diff --git a/Tests/Succeed/Test078.ML b/Tests/Succeed/Test078.ML index 72135ac0..458d2193 100644 --- a/Tests/Succeed/Test078.ML +++ b/Tests/Succeed/Test078.ML @@ -1,13 +1,30 @@ (* Test simple TCP connection. There was a problem with "connect" on Windows. *) val x = INetSock.TCP.socket(): Socket.passive INetSock.stream_sock and y = INetSock.TCP.socket(): Socket.active INetSock.stream_sock; val SOME me = NetHostDB.getByName "localhost"; val localhost = NetHostDB.addr me; Socket.bind(x, INetSock.toAddr(localhost, 0)); Socket.listen(x, 5); let val (_, port) = INetSock.fromAddr(Socket.Ctl.getSockName x) in Socket.connect(y, INetSock.toAddr(localhost, port)) end; -Socket.accept x; +val (cnct, _) = Socket.accept x; + +(* Send the data. Use a separate thread so there's no possibility of blocking. *) +let + fun sendData() = + (Socket.sendVec(y, Word8VectorSlice.full(Byte.stringToBytes "A test")); ()) +in + Thread.Thread.fork(sendData, []) +end; + +if Byte.bytesToString(Socket.recvVec(cnct, 6)) <> "A test" +then raise Fail "failed" +else (); + +Socket.close cnct; +Socket.close x; +Socket.close y; + diff --git a/Tests/Succeed/Test181.ML b/Tests/Succeed/Test181.ML index ff286cad..e5a945d1 100644 --- a/Tests/Succeed/Test181.ML +++ b/Tests/Succeed/Test181.ML @@ -1,33 +1,38 @@ (* Windows tests. *) case #lookupStruct (PolyML.globalNameSpace) "Windows" of SOME _ => () | NONE => raise NotApplicable; val cmd = valOf(Windows.findExecutable "cmd"); val dirExec: (TextIO.instream, TextIO.outstream) Windows.proc = Windows.execute(cmd, "/c dir"); TextIO.closeOut(Windows.textOutstreamOf dirExec); val instr = Windows.textInstreamOf dirExec; TextIO.inputAll instr; TextIO.closeIn instr; (* This is defined to be able to repeatedly return a result. *) val res1 = Windows.reap dirExec; val res2 = Windows.reap dirExec; OS.Process.isSuccess res1; OS.Process.isSuccess res2; val r = Windows.Reg.openKeyEx(Windows.Reg.currentUser, "Software", Windows.Key.read); val a = Windows.Reg.enumKeyEx(r, 0); val b = Windows.Reg.enumValueEx(r, 0); Windows.Reg.closeKey r; val r = Windows.Reg.openKeyEx(Windows.Reg.currentUser, "Environment", Windows.Key.read); val a = Windows.Reg.enumKeyEx(r, 0); val b = Windows.Reg.enumValueEx(r, 0); +case b of + NONE => NONE +| SOME t => Windows.Reg.queryValueEx(r, t); Windows.Reg.closeKey r; Windows.Config.getVersionEx(); Windows.Config.getWindowsDirectory(); Windows.Config.getUserName(); +Windows.Config.getSystemDirectory(); +Windows.Config.getComputerName(); diff --git a/Tests/Succeed/Test185.ML b/Tests/Succeed/Test185.ML new file mode 100644 index 00000000..82bcd612 --- /dev/null +++ b/Tests/Succeed/Test185.ML @@ -0,0 +1,27 @@ +(* UDP Test. *) +val x = INetSock.UDP.socket(): INetSock.dgram_sock; +val y = INetSock.UDP.socket(): INetSock.dgram_sock; + +val SOME me = NetHostDB.getByName "localhost"; +val localhost = NetHostDB.addr me; +(* Bind to an unused port. *) +Socket.bind(x, INetSock.toAddr(localhost, 0)); +(* Get the port so we can connect to it. *) +val socketAddr: INetSock.sock_addr = Socket.Ctl.getSockName x; + +(* Send the data. Use a separate thread so there's no possibility of blocking. *) +let + fun sendData() = + Socket.sendVecTo(y, socketAddr, Word8VectorSlice.full(Byte.stringToBytes "A test")) +in + Thread.Thread.fork(sendData, []) +end; + +val (data, addr: INetSock.sock_addr) = Socket.recvVecFrom(x, 100); + +if Byte.bytesToString data <> "A test" +then raise Fail "failed" +else (); + +Socket.close x; +Socket.close y; diff --git a/Tests/Succeed/Test186.ML b/Tests/Succeed/Test186.ML new file mode 100644 index 00000000..a0bb2a70 --- /dev/null +++ b/Tests/Succeed/Test186.ML @@ -0,0 +1,40 @@ +(* IPv6 test - Test078 converted to IPv6 *) +(* IPv6 may not be configured but it's not clear where the error will occur. *) +val x = INet6Sock.TCP.socket(): Socket.passive INet6Sock.stream_sock + handle OS.SysErr _ => raise NotApplicable; + +val y = INet6Sock.TCP.socket(): Socket.active INet6Sock.stream_sock; + +val me = case Net6HostDB.getByName "localhost" of SOME me => me | NONE => raise NotApplicable; + +val localhost = Net6HostDB.addr me; + +Socket.bind(x, INet6Sock.toAddr(localhost, 0)) + handle exn as OS.SysErr(_, SOME e) => + (case OS.syserror "EADDRNOTAVAIL" of + SOME f => if e = f then raise NotApplicable else raise exn | NONE => raise exn); + +Socket.listen(x, 5); +let +val (_, port) = INet6Sock.fromAddr(Socket.Ctl.getSockName x) +in +Socket.connect(y, INet6Sock.toAddr(localhost, port)) +end; +val (cnct, _) = Socket.accept x; + +(* Send the data. Use a separate thread so there's no possibility of blocking. *) +let + fun sendData() = + (Socket.sendVec(y, Word8VectorSlice.full(Byte.stringToBytes "A test")); ()) +in + Thread.Thread.fork(sendData, []) +end; + +if Byte.bytesToString(Socket.recvVec(cnct, 6)) <> "A test" +then raise Fail "failed" +else (); + +Socket.close cnct; +Socket.close x; +Socket.close y; + diff --git a/Tests/Succeed/Test189.ML b/Tests/Succeed/Test189.ML index 2e1f14cc..5a6983a8 100644 --- a/Tests/Succeed/Test189.ML +++ b/Tests/Succeed/Test189.ML @@ -1,18 +1,19 @@ (* Test Unix.execute. *) case #lookupStruct (PolyML.globalNameSpace) "Unix" of SOME _ => () | NONE => raise NotApplicable; if OS.FileSys.access("/bin/ls", [OS.FileSys.A_EXEC]) then () else raise NotApplicable; val dirExec: (TextIO.instream, TextIO.outstream) Unix.proc = Unix.execute("/bin/ls", ["."]); TextIO.closeOut(Unix.textOutstreamOf dirExec); val instr = Unix.textInstreamOf dirExec; TextIO.inputAll instr; TextIO.closeIn instr; (* This is defined to be able to repeatedly return a result. *) val res1 = Unix.reap dirExec; val res2 = Unix.reap dirExec; OS.Process.isSuccess res1; OS.Process.isSuccess res2; + diff --git a/Tests/Succeed/Test191.ML b/Tests/Succeed/Test191.ML new file mode 100644 index 00000000..89c8ee8c --- /dev/null +++ b/Tests/Succeed/Test191.ML @@ -0,0 +1,34 @@ +(* Unix socket test - Test078 converted to Unix socket *) +case #lookupStruct (PolyML.globalNameSpace) "UnixSock" of + SOME _ => () +| NONE => raise NotApplicable; + +val x = UnixSock.Strm.socket(): Socket.passive UnixSock.stream_sock +and y = UnixSock.Strm.socket(): Socket.active UnixSock.stream_sock; + +val name = OS.FileSys.tmpName(); +OS.FileSys.remove name handle OS.SysErr _ => (); + +Socket.bind(x, UnixSock.toAddr name); +Socket.listen(x, 5); + +Socket.connect(y, UnixSock.toAddr name); + +val (cnct, _) = Socket.accept x; + +(* Send the data. Use a separate thread so there's no possibility of blocking. *) +let + fun sendData() = + (Socket.sendVec(y, Word8VectorSlice.full(Byte.stringToBytes "A test")); ()) +in + Thread.Thread.fork(sendData, []) +end; + +if Byte.bytesToString(Socket.recvVec(cnct, 6)) <> "A test" +then raise Fail "failed" +else (); + +Socket.close cnct; +Socket.close x; +Socket.close y; +OS.FileSys.remove name handle OS.SysErr _ => (); 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/CommandLine.sml b/basis/CommandLine.sml index c7ba2ae8..dca3a72f 100644 --- a/basis/CommandLine.sml +++ b/basis/CommandLine.sml @@ -1,40 +1,31 @@ (* Title: Standard Basis Library: CommandLine Structure and Signature Author: David Matthews - Copyright David Matthews 1999, 2016 + Copyright David Matthews 1999, 2016, 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 COMMAND_LINE = sig val name : unit -> string val arguments : unit -> string list end structure CommandLine : COMMAND_LINE = struct - local - val doCall: int * unit -> string = RunCall.rtsCallFull2 "PolyProcessEnvGeneral" - in - fun name() = doCall(0, ()) - end - - local - val doCall: int * unit -> string list = RunCall.rtsCallFull2 "PolyProcessEnvGeneral" - in - fun arguments() = doCall(1, ()) - end + val name: unit -> string = RunCall.rtsCallFull1 "PolyCommandLineName" + and arguments: unit -> string list = RunCall.rtsCallFull1 "PolyCommandLineArgs" end; diff --git a/basis/Date.sml b/basis/Date.sml index 93b67f55..ec3aa199 100644 --- a/basis/Date.sml +++ b/basis/Date.sml @@ -1,491 +1,492 @@ (* Title: Standard Basis Library: Date structure. Copyright David Matthews 2000, 2016-17 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 Date :> DATE = struct (* There seems to be an assumption, particularly in the "compare" function, that Date.date values are records of year, month, day etc. *) type date = { year: int, (* Signed year. *) month: int, (* Month as 0..11 *) day: int, (* Day as 1..(28, 29, 30, 31) *) hour: int, (* Hour as 0..23 *) minute: int, (* Minute as 0..59 *) second: int, (* Second as 0..59 (maybe 60 or 61 if leap) *) offset: Time.time option (* Offset as Time.time -24hrs raise Date (* Should never happen *) fun isLeapYear(l: int): bool = if l mod 100 = 0 then (l div 100) mod 4 = 0 else l mod 4 = 0 (* Convert the enumerated type to a month number. *) fun monthToMonthNo Jan = 0 | monthToMonthNo Feb = 1 | monthToMonthNo Mar = 2 | monthToMonthNo Apr = 3 | monthToMonthNo May = 4 | monthToMonthNo Jun = 5 | monthToMonthNo Jul = 6 | monthToMonthNo Aug = 7 | monthToMonthNo Sep = 8 | monthToMonthNo Oct = 9 | monthToMonthNo Nov = 10 | monthToMonthNo Dec = 11 - local - val timingGeneralCall = RunCall.rtsCallFull2 "PolyTimingGeneral" - fun timingGeneral(code: int, arg:'a):'b = RunCall.unsafeCast(timingGeneralCall(RunCall.unsafeCast(code, arg))) - in - fun callTiming (code: int) args = timingGeneral (code,args) - end - (* Get the local time offset which applied at the specific time. The time is in seconds since the epoch. The result may be the current time offset if it is outside the range for which we have information. We use seconds as the argument and result here because it avoids having to multiply and divide arbitrary precision values in the RTS. May raise Size if the value is too large (or small). In that case we use the current time offset. *) - fun localOffsetApplying (t: LargeInt.int) : LargeInt.int = - callTiming 4 t - handle General.Size => callTiming 4 (Time.toSeconds(Time.now())) + local + val getLocalOffset: LargeInt.int -> LargeInt.int = RunCall.rtsCallFull1 "PolyTimingLocalOffset" + in + fun localOffsetApplying (t: LargeInt.int) : LargeInt.int = + getLocalOffset t + handle General.Size => getLocalOffset (Time.toSeconds(Time.now())) + end (* Get the current local time offset. *) fun localOffset (): Time.time = Time.fromSeconds(localOffsetApplying(Time.toSeconds(Time.now()))) local (* Time values are since 1st January of this year. *) - val baseYear: int = callTiming 2 0 (* 1601 or 1970 *) - val yearOffset: int = callTiming 3 0 (* The offset of zeroTime within that year. 0 on both Unix and Windows *) + val baseYear: int = RunCall.rtsCallFull0 "PolyTimingBaseYear" () (* 1601 or 1970 *) + val yearOffset: int = RunCall.rtsCallFull0 "PolyTimingYearOffset" () (* The offset of zeroTime within that year. 0 on both Unix and Windows *) (* Get the day in the year. Either of day or year may be unnormalised but that shouldn't affect the result (except if year is negative???) *) fun dayInYear (day, month, year) = if isLeapYear year then Vector.sub(dayInLeapYearVec, month) + day else Vector.sub(dayVec, month) + day (* Compute the number of days since the start. *) fun yearToDays y = let fun ytod dys yr = if yr = baseYear then dys (* If the year is before the base year we subtract the number of days in this year and recurse. *) else if yr < baseYear then if isLeapYear yr then ytod (dys-366) (yr+1) else ytod (dys-365) (yr+1) (* The year we want is after the base year. *) else if yr - baseYear >= 100 (* If it is more than a century apart then we can add in the number of days in a century. There are 24 leap years in most centuries except those which are divisible by 400. Note: We're assuming the Gregorian calendar. *) then if ((yr-1) div 100) mod 4 = 0 then ytod (dys+36525) (yr-100) else ytod (dys+36524) (yr-100) else if isLeapYear(yr-1) then ytod (dys+366) (yr-1) else ytod (dys+365) (yr-1) in ytod 0 y end (* Convert days to number of years plus the day within the year. *) fun daysToYears d = let fun dtoy dys yr = if dys < 0 then (* Before the base year: have to add in days. *) if isLeapYear (yr-1) then dtoy (dys+366) (yr-1) else dtoy (dys+365) (yr-1) (* If we are at least a century away we can subtract the century. *) else if dys >= 36525 then if ((yr+99) div 100) mod 4 = 0 then dtoy (dys-36525) (yr+100) else dtoy (dys-36524) (yr+100) else if isLeapYear yr then if dys >= 366 then dtoy (dys-366) (yr+1) else (yr, dys) else if dys >= 365 then dtoy (dys-365) (yr+1) else (yr, dys) in dtoy d baseYear end (* Convert a number of seconds to a date. *) fun fromSeconds t (tzOffset: Time.time option) : date = let val tsecs = t - LargeInt.fromInt yearOffset val secs = LargeInt.toInt(tsecs mod 60) val mins = LargeInt.toInt((tsecs div 60) mod 60) val hrs = LargeInt.toInt((tsecs div secsPerHour) mod 24) (* Get the day and year. The day is a value between 0 and 364/365. *) val (year, days) = daysToYears(LargeInt.toInt(tsecs div secsPerDay)) (* Convert the day into a month+day *) val isLeap = isLeapYear year fun dayToMonth dy mth = if dy <= Vector.sub(if isLeap then dayInLeapYearVec else dayVec, mth+1) then mth else dayToMonth dy (mth+1) val month = dayToMonth days 0 val dayInMonth = days - Vector.sub(if isLeap then dayInLeapYearVec else dayVec, month) in {year=year, month=month, day=dayInMonth, hour=hrs, minute=mins, second=secs, offset = tzOffset } end in (* Get the day in the year. *) fun yearDay({day, month, year, ...}:date) = dayInYear(day, month, year) (* Convert the date into a UTC time value. *) fun toTime (date as {year, hour, minute, second, offset, ...}) = let (* Compute the seconds. *) val secs = LargeInt.fromInt second + LargeInt.fromInt minute * 60 + LargeInt.fromInt hour * secsPerHour + LargeInt.fromInt(yearDay date + yearToDays year) * secsPerDay + LargeInt.fromInt yearOffset in case offset of SOME t => Time.+(t, Time.fromSeconds secs) | NONE => Time.fromSeconds(secs + localOffsetApplying secs) end (* Convert a UTC time to a UTC date. *) fun fromTimeUniv t = fromSeconds (Time.toSeconds t) (SOME Time.zeroTime) (* Convert a UTC time to a date in the local time zone. *) fun fromTimeLocal t = let val secs = Time.toSeconds t val localOffset = localOffsetApplying secs in fromSeconds (secs-localOffset) NONE end (* Generate a normalised date. *) fun date {year, month, day, hour, minute, second, offset} = let (* Get the time zone information if it is provided. If it is outside +/- 24 hours we get the number of full days. *) val (tzDays, normTz) = case offset of SOME tz => let open Time val excess = LargeInt.quot(Time.toSeconds tz, secsPerDay)*secsPerDay; in (excess, SOME(tz-Time.fromSeconds excess)) end | NONE => (0, NONE) (* Convert it to the number of seconds since the epoch which will normalise it. *) val secs = LargeInt.fromInt second + LargeInt.fromInt minute * 60 + LargeInt.fromInt hour * secsPerHour + LargeInt.fromInt (dayInYear(day, monthToMonthNo month, year) + yearToDays year) * secsPerDay + LargeInt.fromInt yearOffset + tzDays in (* Convert it into a date. *) fromSeconds secs normTz end end val year: date->int = #year and day: date->int = #day and hour: date->int = #hour and minute: date->int = #minute and second: date->int = #second and offset: date->Time.time option = #offset (* Return the month from the enumerated type. *) fun month({month, ...}:date) = monthNoToMonth month (* Get the day of the week as a number - not exported. *) fun dayOfWeek({year, month, day, ...}: date) = let (* From looking at the code of mktime, which is marked as being in the public domain, this formula (Zeller's Congruence?) is used to find the day of the week for the first of any month. I don't know what range this works for but it seems accurate as far as I can test it. *) val m0 = month+1 (* Count months from 1 *) val m1 = (m0 + 9) mod 12 + 1 val yy0 = if m0 <= 2 then year-1 else year val yy1 = yy0 div 100 val yy2 = yy0 mod 100 val dow = ((26*m1 - 2) div 10 + 1 + yy2 + yy2 div 4 + yy1 div 4 - 2*yy1) mod 7 in (* Add on the day within the month. *) (dow + day - 1) mod 7 end (* Get day of week as an enumerated type - exported. *) fun weekDay date = Vector.sub(dayOfWkVec, dayOfWeek date) (* QUESTION: The definition of isDst is very vague. I am assuming that it means that, for a local time, did/will Summer Time apply at that time? *) + val getSummer: LargeInt.int -> int = RunCall.rtsCallFull1 "PolyTimingSummerApplies" + fun isDst (d as {offset=NONE, ...} : date): bool option = - let - val isSummer = - callTiming 5 (Time.toSeconds(toTime d)) handle Size => ~1 - in - if isSummer < 0 then NONE - else SOME (isSummer > 0) - end - | isDst {offset=SOME _, ...} = SOME false (* ?? *) + let + val isSummer = + getSummer (Time.toSeconds(toTime d)) handle Size => ~1 + in + if isSummer < 0 then NONE + else SOME (isSummer > 0) + end + | isDst {offset=SOME _, ...} = SOME false (* ?? *) (* Compare the dates ignoring time zone information. *) fun compare({year=y1, month=m1, day=d1, hour=h1, minute=n1, second=s1, ...}:date, {year=y2, month=m2, day=d2, hour=h2, minute=n2, second=s2, ...}:date) = if y1 < y2 then General.LESS else if y1 > y2 then General.GREATER else if m1 < m2 then General.LESS else if m1 > m2 then General.GREATER else if d1 < d2 then General.LESS else if d1 > d2 then General.GREATER else if h1 < h2 then General.LESS else if h1 > h2 then General.GREATER else if n1 < n2 then General.LESS else if n1 > n2 then General.GREATER else Int.compare(s1, s2) (* Parse a date/time. *) fun scan getc str = let (* Try to extract an n-character string. *) fun getChars n str = let fun getN 0 s str = SOME (String.implode(List.rev s), str) | getN n s str = case getc str of NONE => NONE | SOME(ch, str') => getN (n-1) (ch :: s) str' in getN n [] str end (* Get the day of the week. We don't actually use it but we need to verify it. *) (* QUESTION: What time offset should be used? I presume NONE. *) fun parseDayOfWeek str = case getChars 3 str of NONE => NONE | SOME(s, str') => if Vector.foldr (fn(s', t) => t orelse s=s') false dayNames then SOME(s, str') else NONE fun parseMonth str = case getChars 3 str of NONE => NONE | SOME(s, str') => (* Return the month corresponding to the month name otherwise NONE. *) Vector.foldri (fn(n:int, s':string, t) => if s = s' then SOME(Vector.sub(monthVec, n), str') else t) NONE monthNames (* Get a two digit number. *) fun parse2Digits str = case getc str of NONE => NONE | SOME(ch0, str1) => if ch0 < #"0" orelse ch0 > #"9" then NONE else case getc str1 of NONE => NONE | SOME(ch1, str2) => if ch1 < #"0" orelse ch1 > #"9" then NONE else SOME((Char.ord ch0 - Char.ord #"0")*10 + (Char.ord ch1 - Char.ord #"0"), str2) (* Get two digits as a day of the month. Don't check the range. *) val parseDayOfMonth = parse2Digits (* A time is written as hh:mm:ss *) fun parseTime str = case parse2Digits str of NONE => NONE | SOME(hh, str1) => case getc str1 of NONE => NONE | SOME(ch, str2) => if ch <> #":" then NONE else case parse2Digits str2 of NONE => NONE | SOME(mm, str3) => case getc str3 of NONE => NONE | SOME(ch, str4) => if ch <> #":" then NONE else case parse2Digits str4 of NONE => NONE | SOME(ss, str5) => SOME((hh, mm, ss), str5) (* A year is represented as four digits. *) fun parseYear str = case parse2Digits str of NONE => NONE | SOME(yy0, str1) => case parse2Digits str1 of NONE => NONE | SOME(yy1, str2) => SOME(yy0*100+yy1, str2) fun parseDate str = case parseDayOfWeek str of NONE => NONE | SOME(_, str1) => case getc str1 of (* Get exactly one space. *) NONE => NONE | SOME(ch, str2) => if ch <> #" " then NONE else case parseMonth str2 of (* Name of month. *) NONE => NONE | SOME(mth, str3) => case getc str3 of (* Get exactly one space. *) NONE => NONE | SOME(ch, str4) => if ch <> #" " then NONE else case parseDayOfMonth str4 of NONE => NONE | SOME(day, str5) => case getc str5 of (* Get exactly one space. *) NONE => NONE | SOME(ch, str6) => if ch <> #" " then NONE else case parseTime str6 of NONE => NONE | SOME((hr,min,sec), str7) => case getc str7 of (* Get exactly one space. *) NONE => NONE | SOME(ch, str8) => if ch <> #" " then NONE else case parseYear str8 of NONE => NONE | SOME(year, str9) => SOME(date{year=year, month=mth, day=day, hour=hr, minute=min, second=sec, offset=NONE}, str9) in case getc str of NONE => NONE | SOME (ch, str') => (* Remove initial white space. *) if Char.isSpace ch then scan getc str' else parseDate str end val fromString = StringCvt.scanString scan (* toString generates an English language, American style date. *) fun toString (date as {year, month, day, hour, minute, second, ...}: date) = let (* Pad a number with zeros up to the required width. Doesn't work for negatives which ought to be padded after the minus sign, but that's only a problem for years. *) fun int2str n i = let val str = Int.toString i fun padZeros n = if n <= 0 then "" else "0" ^ padZeros (n-1) in padZeros (n-String.size str) ^ str end in String.concat[ Vector.sub(dayNames, dayOfWeek date), " ", Vector.sub(monthNames, month), " ", int2str 2 day, " ", int2str 2 hour, ":", int2str 2 minute, ":", int2str 2 second, " ", int2str 4 year] end + val convertDate = RunCall.rtsCallFull1 "PolyTimingConvertDateStuct" + fun fmt s (date as {year, month, day, hour, minute, second, offset}) = let (* Edit the string to remove any undefined escape combinations. They shouldn't normally occur. *) fun editString s i l = if i = l then s (* Done *) else if String.sub(s, i) <> #"%" then editString s (i+1) l else (* Found a % sign. *) if i = l-1 then (* This was the last character. QUESTION: This isn't defined assume we should remove it. *) String.substring(s, 0, i) else let val c = String.sub(s, i+1) in if Char.contains "aAbBcdHIjmMpSUwWxXyYZ%" c then (* OK *) editString s (i+2) l else (* Replace %c by c, i.e. remove the %. *) editString (String.substring(s, 0, i) ^ String.substring(s, i+1, l-i-1)) i (l-1) end val newFormat = editString s 0 (String.size s) val summer = case offset of SOME _ => ~1 - | NONE => callTiming 5 (Time.toSeconds(toTime date)) + | NONE => getSummer (Time.toSeconds(toTime date)) handle Size => ~1 in - callTiming 6 (newFormat, year, month, day, hour, minute, second, + convertDate (newFormat, year, month, day, hour, minute, second, dayOfWeek date, yearDay date, summer) handle RunCall.Size => raise Date end end; local (* Install the pretty printer for Date.date. This has to be done outside the structure because of the opaque matching. *) fun pretty _ _ x = PolyML.PrettyString(Date.toString x) in val () = PolyML.addPrettyPrinter pretty end diff --git a/basis/ExnPrinter.sml b/basis/ExnPrinter.sml index 706a2d5f..c04418dc 100644 --- a/basis/ExnPrinter.sml +++ b/basis/ExnPrinter.sml @@ -1,122 +1,122 @@ (* Title: Install a pretty printer for the exn type Author: David Matthews - Copyright David Matthews 2009, 2016 + Copyright David Matthews 2009, 2016, 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 *) local open PolyML (* Print exception packet. Run-time system exceptions have to be processed specially because the IDs don't have printer functions. *) fun exnPrint depth _ exn = let val (exnId, exnName, exnArg, _) = RunCall.unsafeCast exn (* This parenthesis code is used in various places and probably should be centralised. *) fun parenthesise(s as PrettyBlock(_, _, _, [ _ ])) = s | parenthesise(s as PrettyBlock(_, _, _, (PrettyString("(")::_ ))) = s | parenthesise(s as PrettyBlock(_, _, _, (PrettyString("{")::_ ))) = s | parenthesise(s as PrettyBlock(_, _, _, (PrettyString("[")::_ ))) = s | parenthesise(s as PrettyBlock _) = PrettyBlock(3, true, [], [ PrettyString "(", s, PrettyString ")" ]) | parenthesise s = s (* String or Break *) fun nullaryException s = PrettyString s and parameterException(s, param) = PrettyBlock(1, false, [], [ PrettyString s, PrettyBreak(1, 1), parenthesise param ]) (* Use prettyRepresentation because this correctly quotes the string. *) fun stringException(s, arg: string) = parameterException(s, PolyML.prettyRepresentation(arg, depth-1)) in if RunCall.isShort exnId then case exn of RunCall.Conversion s => stringException(exnName, s) | Fail s => stringException(exnName, s) | RunCall.Foreign s => stringException(exnName, s) | RunCall.Thread s => stringException(exnName, s) | RunCall.XWindows s => stringException(exnName, s) - | OS.SysErr param => + | LibrarySupport.SysErr param => parameterException("SysErr", if depth <= 1 then PrettyString "..." else PolyML.prettyRepresentation(param, depth-1)) | _ => (* Anything else is nullary. *) nullaryException exnName else ( (* Exceptions generated within ML contain a printer function. *) case !exnId of NONE => nullaryException exnName | SOME printFn => parameterException(exnName, printFn(exnArg, depth-1)) ) end in val () = addPrettyPrinter exnPrint end; (* Print a ref. Because refs can form circular structures we include a check for a loop here. *) local open PolyML (* If we have an expression as the argument we parenthesise it unless it is a simple string, a tuple, a record or a list. *) fun parenthesise(s as PrettyBlock(_, _, _, [ _ ])) = s | parenthesise(s as PrettyBlock(_, _, _, (PrettyString("(")::_ ))) = s | parenthesise(s as PrettyBlock(_, _, _, (PrettyString("{")::_ ))) = s | parenthesise(s as PrettyBlock(_, _, _, (PrettyString("[")::_ ))) = s | parenthesise(s as PrettyBlock _) = PrettyBlock(3, true, [], [ PrettyString "(", s, PrettyString ")" ]) | parenthesise s = s (* String or Break *) val printLimit: word ref list Universal.tag = Universal.tag() fun print_ref depth doArg (r as ref x) = if depth <= 0 then PrettyString "..." else let (* We keep a list in thread-local storage of refs we're currently printing. This is thread-local to avoid interference between different threads. *) val currentRefs = case Thread.Thread.getLocal printLimit of NONE => [] | SOME limit => limit val thisRef: word ref = RunCall.unsafeCast r in if List.exists(fn x => x = thisRef) currentRefs then PrettyString "..." (* We've already seen this ref. *) else ( (* Add this to the list. *) Thread.Thread.setLocal (printLimit, thisRef :: currentRefs); (* Print it and reset the list*) (PrettyBlock(3, false, [], [ PrettyString "ref", PrettyBreak(1, 0), parenthesise(doArg(x, depth-1)) ])) before (Thread.Thread.setLocal (printLimit, currentRefs)) ) handle exn => ( (* Reset the list if there's been an exception. *) Thread.Thread.setLocal (printLimit, currentRefs); raise exn ) end in val () = addPrettyPrinter print_ref end; diff --git a/basis/Foreign.sml b/basis/Foreign.sml index db72e584..cdc5126f 100644 --- a/basis/Foreign.sml +++ b/basis/Foreign.sml @@ -1,3167 +1,3167 @@ (* 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 * Memory.voidStar -> unit val call: ctype list -> ctype -> symbol -> Memory.voidStar * Memory.voidStar -> unit val cFunctionWithAbi: LibFFI.abi -> ctype list -> ctype -> (Memory.voidStar * Memory.voidStar -> unit) -> Memory.voidStar val cFunction: ctype list -> ctype -> (Memory.voidStar * Memory.voidStar -> unit) -> Memory.voidStar end type 'a conversion val makeConversion: { load: Memory.voidStar -> 'a, (* Load a value from C memory *) store: Memory.voidStar * 'a -> unit -> unit, (* Store value and return free function. *) ctype: LowLevel.ctype } -> 'a conversion val breakConversion: 'a conversion -> { load: Memory.voidStar -> 'a, (* Load a value from C memory *) store: Memory.voidStar * 'a -> unit -> unit, (* Store value and return free function. *) ctype: LowLevel.ctype } val cVoid: unit conversion val cPointer: Memory.voidStar conversion val cInt8: int conversion val cUint8: int conversion val cChar: char conversion val cUchar: Word8.word conversion val cInt16: int conversion val cUint16: int conversion val cInt32: int conversion val cUint32: int conversion val cInt64: int conversion val cUint64: int conversion val cInt32Large: LargeInt.int conversion val cUint32Large: LargeInt.int conversion val cInt64Large: LargeInt.int conversion val cUint64Large: LargeInt.int conversion val cShort: int conversion val cUshort: int conversion val cInt: int conversion val cUint: int conversion val cLong: int conversion val cUlong: int conversion val cIntLarge: LargeInt.int conversion val cUintLarge: LargeInt.int conversion val cLongLarge: LargeInt.int conversion val cUlongLarge: LargeInt.int conversion val cString: string conversion val cByteArray: Word8Vector.vector conversion val cFloat: real conversion val cDouble: real conversion (* When a pointer e.g. a string may be null. *) val cOptionPtr: 'a conversion -> 'a option conversion type 'a closure val cFunction: ('a->'b) closure conversion val buildClosure0withAbi: (unit -> 'a) * LibFFI.abi * unit * 'a conversion -> (unit -> 'a) closure val buildClosure0: (unit -> 'a) * unit * 'a conversion -> (unit -> 'a) closure val buildClosure1withAbi: ('a -> 'b) * LibFFI.abi * 'a conversion * 'b conversion -> ('a -> 'b) closure val buildClosure1: ('a -> 'b) * 'a conversion * 'b conversion -> ('a -> 'b) closure val buildClosure2withAbi: ('a * 'b -> 'c) * LibFFI.abi * ('a conversion * 'b conversion) * 'c conversion -> ('a * 'b -> 'c) closure val buildClosure2: ('a * 'b -> 'c) * ('a conversion * 'b conversion) * 'c conversion -> ('a * 'b -> 'c) closure val buildClosure3withAbi: ('a * 'b *'c -> 'd) * LibFFI.abi * ('a conversion * 'b conversion * 'c conversion) * 'd conversion -> ('a * 'b *'c -> 'd) closure val buildClosure3: ('a * 'b *'c -> 'd) * ('a conversion * 'b conversion * 'c conversion) * 'd conversion -> ('a * 'b *'c -> 'd) closure val buildClosure4withAbi: ('a * 'b * 'c * 'd -> 'e) * LibFFI.abi * ('a conversion * 'b conversion * 'c conversion* 'd conversion) * 'e conversion -> ('a * 'b * 'c * 'd -> 'e) closure val buildClosure4: ('a * 'b * 'c * 'd -> 'e) * ('a conversion * 'b conversion * 'c conversion* 'd conversion) * 'e conversion -> ('a * 'b * 'c * 'd -> 'e) closure val buildClosure5withAbi: ('a * 'b * 'c * 'd * 'e -> 'f) * LibFFI.abi * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion) * 'f conversion -> ('a * 'b * 'c * 'd * 'e -> 'f) closure val buildClosure5: ('a * 'b * 'c * 'd * 'e -> 'f) * ('a conversion * 'b conversion * 'c conversion* 'd conversion * 'e conversion) * 'f conversion -> ('a * 'b * 'c * 'd * 'e -> 'f) closure val buildClosure6withAbi: ('a * 'b * 'c * 'd * 'e * 'f -> 'g) * LibFFI.abi * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion) * 'g conversion -> ('a * 'b * 'c * 'd * 'e * 'f -> 'g) closure val buildClosure6: ('a * 'b * 'c * 'd * 'e * 'f -> 'g) * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion) * 'g conversion -> ('a * 'b * 'c * 'd * 'e * 'f -> 'g) closure (* Remove the "free" from a conversion. Used if extra memory allocated by the argument must not be freed when the function returns. *) val permanent: 'a conversion -> 'a conversion (* Call by reference. *) val cStar: 'a conversion -> 'a ref conversion (* Pass a const pointer *) val cConstStar: 'a conversion -> 'a conversion (* Fixed size vector. It is treated as a struct and passed by value or embedded in a structure. *) val cVectorFixedSize: int * 'a conversion -> 'a vector conversion (* Pass an ML vector as a pointer to a C array. *) and cVectorPointer: 'a conversion -> 'a vector conversion (* Pass an ML array as a pointer to a C array and, on return, update each element of the ML array from the C array. *) and cArrayPointer: 'a conversion -> 'a array conversion (* structs. *) val cStruct2: 'a conversion * 'b conversion -> ('a * 'b) conversion val cStruct3: 'a conversion * 'b conversion * 'c conversion -> ('a*'b*'c)conversion val cStruct4: 'a conversion * 'b conversion * 'c conversion * 'd conversion -> ('a*'b*'c*'d)conversion val cStruct5: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion -> ('a*'b*'c*'d*'e)conversion val cStruct6: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion -> ('a*'b*'c*'d*'e*'f)conversion val cStruct7: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion -> ('a*'b*'c*'d*'e*'f*'g)conversion val cStruct8: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion -> ('a*'b*'c*'d*'e*'f*'g*'h)conversion val cStruct9: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i)conversion val cStruct10: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j)conversion val cStruct11: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k)conversion val cStruct12: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l)conversion val cStruct13: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m)conversion val cStruct14: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n)conversion val cStruct15: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o)conversion val cStruct16: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion * 'p conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p)conversion val cStruct17: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion * 'p conversion * 'q conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q)conversion val cStruct18: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion * 'p conversion * 'q conversion * 'r conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q*'r)conversion val cStruct19: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion * 'p conversion * 'q conversion * 'r conversion * 's conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q*'r*'s)conversion val cStruct20: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion * 'p conversion * 'q conversion * 'r conversion * 's conversion * 't conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q*'r*'s*'t)conversion val buildCall0withAbi: LibFFI.abi * symbol * unit * 'a conversion -> unit -> 'a val buildCall0: symbol * unit * 'a conversion -> unit -> 'a val buildCall1withAbi: LibFFI.abi * symbol * 'a conversion * 'b conversion -> 'a -> 'b val buildCall1: symbol * 'a conversion * 'b conversion -> 'a -> 'b val buildCall2withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion) * 'c conversion -> 'a * 'b -> 'c val buildCall2: symbol * ('a conversion * 'b conversion) * 'c conversion -> 'a * 'b -> 'c val buildCall3withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion) * 'd conversion -> 'a * 'b * 'c -> 'd val buildCall3: symbol * ('a conversion * 'b conversion * 'c conversion) * 'd conversion -> 'a * 'b * 'c -> 'd val buildCall4withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion) * 'e conversion -> 'a * 'b * 'c * 'd -> 'e val buildCall4: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion) * 'e conversion -> 'a * 'b * 'c * 'd -> 'e val buildCall5withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion) * 'f conversion -> 'a * 'b * 'c * 'd * 'e -> 'f val buildCall5: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion) * 'f conversion -> 'a * 'b * 'c * 'd * 'e -> 'f val buildCall6withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion) * 'g conversion -> 'a * 'b * 'c * 'd * 'e * 'f -> 'g val buildCall6: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion) * 'g conversion -> 'a * 'b * 'c * 'd * 'e * 'f -> 'g val buildCall7withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion) * 'h conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g -> 'h val buildCall7: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion) * 'h conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g -> 'h val buildCall8withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion) * 'i conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h -> 'i val buildCall8: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion) * 'i conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h -> 'i val buildCall9withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion) * 'j conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i -> 'j val buildCall9: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion) * 'j conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i -> 'j val buildCall10withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion) * 'k conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j -> 'k val buildCall10: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion) * 'k conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j -> 'k val buildCall11withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion) * 'l conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k -> 'l val buildCall11: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion) * 'l conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k -> 'l val buildCall12withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion) * 'm conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l -> 'm val buildCall12: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion) * 'm conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l -> 'm val buildCall13withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion) * 'n conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm -> 'n val buildCall13: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion) * 'n conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm -> 'n val buildCall14withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion) * 'o conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm * 'n -> 'o val buildCall14: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion) * 'o conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm * 'n -> 'o end; structure Foreign:> FOREIGN = struct fun id x = x exception Foreign = RunCall.Foreign open ForeignConstants structure Memory = ForeignMemory infix 6 ++ -- (* Internal utility function. *) fun alignUp(s, align) = Word.andb(s + align-0w1, ~ align) local val ffiGeneralCall = RunCall.rtsCallFull2 "PolyFFIGeneral" in fun ffiGeneral(code: int, arg: 'a): 'b = RunCall.unsafeCast(ffiGeneralCall(RunCall.unsafeCast(code, arg))) end structure System = struct type voidStar = Memory.voidStar type externalSymbol = voidStar fun loadLibrary(s: string): voidStar = ffiGeneral (2, s) and loadExecutable(): voidStar = ffiGeneral (3, ()) and freeLibrary(s: voidStar): unit = ffiGeneral (4, s) and getSymbol(lib: voidStar, s: string): voidStar = ffiGeneral (5, (lib, s)) (* Create an external symbol object. The first word of this is filled in with the address after the code is exported and linked. On a small number of platforms different relocations are required for functions and for data. *) val externalFunctionSymbol: string -> externalSymbol = RunCall.rtsCallFull1 "PolyFFICreateExtFn" and externalDataSymbol: string -> externalSymbol = RunCall.rtsCallFull1 "PolyFFICreateExtData" (* An external symbol is a memory cell containing the value in the first word followed by the symbol name. Because the first word is the value it can be treated as a Sysword.word value. When it is created the value is zero and the address of the target is only set once the symbol has been exported and the value set by the linker. *) fun addressOfExternal(ext: externalSymbol): voidStar = if Memory.voidStar2Sysword ext = 0w0 then raise Foreign "External symbol has not been set" else ext end structure Error = struct - type syserror = 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 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 * voidStar -> unit = let fun getType ctype = Memory.voidStar2Sysword(#ffiType ctype ()) (* Compile the intermediate function. *) val functionCaller: LargeWord.word * LargeWord.word * LargeWord.word -> unit = RunCall.foreignCall(Word.toInt abi, List.map getType argTypes, getType resType) (* The result function. *) fun callFunction (fnAddr: unit->voidStar) (args, resMem) = functionCaller(voidStar2Sysword(fnAddr()), voidStar2Sysword args, voidStar2Sysword resMem) in callFunction end fun call x = callwithAbi abiDefault x (* Have to make it a fun to avoid value restriction *) (* Build a call-back function. Returns a function to take the actual ML function, create a callback and then return the address. *) fun cFunctionWithAbi (abi: abi) (argTypes: ctype list) (resType: ctype): (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(Memory.null, rMem) val result = resLoad rMem in free rMem; result end handle exn => (free rMem; raise exn) end end fun buildCall0(symbol, argTypes, resType) = buildCall0withAbi (abiDefault, symbol, argTypes, resType) fun buildCall1withAbi (abi: abi, fnAddr, { ctype = argType, store = argStore, updateML = argUpdate, ...}: 'a conversion, { ctype = resType, load= resLoad, ...}: 'b conversion): 'a ->'b = let val callF = callwithAbi abi [argType] resType fnAddr (* Allocate space for argument and result. *) val argOffset = alignUp(#size resType, #align argType) val argSpace = argOffset + #size argType in fn x => let val rMem = malloc argSpace val argAddr = rMem ++ argOffset val freea = argStore (argAddr, x) fun freeAll () = (freea(); free rMem) in let val () = callF(argAddr, rMem) val result = resLoad rMem in argUpdate (argAddr, x); freeAll (); result end handle exn => (freeAll (); raise exn) end end fun buildCall1(symbol, argTypes, resType) = buildCall1withAbi (abiDefault, symbol, argTypes, resType) fun buildCall2withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion), resConv: 'c conversion): 'a * 'b -> 'c = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct2(arg1Conv, arg2Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall2(symbol, argTypes, resType) = buildCall2withAbi (abiDefault, symbol, argTypes, resType) fun buildCall3withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion), resConv: 'd conversion): 'a * 'b *'c -> 'd = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct3(arg1Conv, arg2Conv, arg3Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall3(symbol, argTypes, resType) = buildCall3withAbi (abiDefault, symbol, argTypes, resType) fun buildCall4withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion), resConv: 'e conversion): 'a * 'b *'c * 'd -> 'e = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct4(arg1Conv, arg2Conv, arg3Conv, arg4Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall4(symbol, argTypes, resType) = buildCall4withAbi (abiDefault, symbol, argTypes, resType) fun buildCall5withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion), resConv: 'f conversion): 'a * 'b *'c * 'd * 'e -> 'f = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct5(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall5(symbol, argTypes, resType) = buildCall5withAbi (abiDefault, symbol, argTypes, resType) fun buildCall6withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion), resConv: 'g conversion): 'a * 'b *'c * 'd * 'e * 'f -> 'g = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct6(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall6(symbol, argTypes, resType) = buildCall6withAbi (abiDefault, symbol, argTypes, resType) fun buildCall7withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion, arg7Conv: 'g conversion), resConv: 'h conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g -> 'h = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct7(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall7(symbol, argTypes, resType) = buildCall7withAbi (abiDefault, symbol, argTypes, resType) fun buildCall8withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion, arg7Conv: 'g conversion, arg8Conv: 'h conversion), resConv: 'i conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h -> 'i = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv, #ctype arg8Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct8(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall8(symbol, argTypes, resType) = buildCall8withAbi (abiDefault, symbol, argTypes, resType) fun buildCall9withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion, arg7Conv: 'g conversion, arg8Conv: 'h conversion, arg9Conv: 'i conversion), resConv: 'j conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i -> 'j = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv, #ctype arg8Conv, #ctype arg9Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct9(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall9(symbol, argTypes, resType) = buildCall9withAbi (abiDefault, symbol, argTypes, resType) fun buildCall10withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion, arg7Conv: 'g conversion, arg8Conv: 'h conversion, arg9Conv: 'i conversion, arg10Conv: 'j conversion), resConv: 'k conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j -> 'k = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv, #ctype arg8Conv, #ctype arg9Conv, #ctype arg10Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct10(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv, arg10Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall10(symbol, argTypes, resType) = buildCall10withAbi (abiDefault, symbol, argTypes, resType) fun buildCall11withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion, arg7Conv: 'g conversion, arg8Conv: 'h conversion, arg9Conv: 'i conversion, arg10Conv: 'j conversion, arg11Conv: 'k conversion), resConv: 'l conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k -> 'l = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv, #ctype arg8Conv, #ctype arg9Conv, #ctype arg10Conv, #ctype arg11Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct11(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv, arg10Conv, arg11Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall11(symbol, argTypes, resType) = buildCall11withAbi (abiDefault, symbol, argTypes, resType) fun buildCall12withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion, arg7Conv: 'g conversion, arg8Conv: 'h conversion, arg9Conv: 'i conversion, arg10Conv: 'j conversion, arg11Conv: 'k conversion, arg12Conv: 'l conversion), resConv: 'm conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l -> 'm = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv, #ctype arg8Conv, #ctype arg9Conv, #ctype arg10Conv, #ctype arg11Conv, #ctype arg12Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct12(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv, arg10Conv, arg11Conv, arg12Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall12(symbol, argTypes, resType) = buildCall12withAbi (abiDefault, symbol, argTypes, resType) fun buildCall13withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion, arg7Conv: 'g conversion, arg8Conv: 'h conversion, arg9Conv: 'i conversion, arg10Conv: 'j conversion, arg11Conv: 'k conversion, arg12Conv: 'l conversion, arg13Conv: 'm conversion), resConv: 'n conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm -> 'n = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv, #ctype arg8Conv, #ctype arg9Conv, #ctype arg10Conv, #ctype arg11Conv, #ctype arg12Conv, #ctype arg13Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct13(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv, arg10Conv, arg11Conv, arg12Conv, arg13Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall13(symbol, argTypes, resType) = buildCall13withAbi (abiDefault, symbol, argTypes, resType) fun buildCall14withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion, arg7Conv: 'g conversion, arg8Conv: 'h conversion, arg9Conv: 'i conversion, arg10Conv: 'j conversion, arg11Conv: 'k conversion, arg12Conv: 'l conversion, arg13Conv: 'm conversion, arg14Conv: 'n conversion), resConv: 'o conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm * 'n -> 'o = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv, #ctype arg8Conv, #ctype arg9Conv, #ctype arg10Conv, #ctype arg11Conv, #ctype arg12Conv, #ctype arg13Conv, #ctype arg14Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct14(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv, arg10Conv, arg11Conv, arg12Conv, arg13Conv, arg14Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall14(symbol, argTypes, resType) = buildCall14withAbi (abiDefault, symbol, argTypes, resType) end (* A closure is a memoised address. *) type 'a closure = unit -> Memory.voidStar 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/GenericSock.sml b/basis/GenericSock.sml index 6920abac..db7a1c39 100644 --- a/basis/GenericSock.sml +++ b/basis/GenericSock.sml @@ -1,55 +1,64 @@ (* Title: Standard Basis Library: Generic socket structure and signature. Author: David Matthews - Copyright David Matthews 2000, 2016 + Copyright David Matthews 2000, 2016, 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 GENERIC_SOCK = sig val socket : Socket.AF.addr_family * Socket.SOCK.sock_type -> ('af, 'sock_type) Socket.sock val socketPair : Socket.AF.addr_family * Socket.SOCK.sock_type -> ('af, 'sock_type) Socket.sock * ('af, 'sock_type) Socket.sock val socket' : Socket.AF.addr_family * Socket.SOCK.sock_type * int -> ('af, 'sock_type) Socket.sock val socketPair' : Socket.AF.addr_family * Socket.SOCK.sock_type * int -> ('af, 'sock_type) Socket.sock * ('af, 'sock_type) Socket.sock end; structure GenericSock : GENERIC_SOCK = struct local - val doCall = RunCall.rtsCallFull2 "PolyNetworkGeneral" + val doCreateSocket: Socket.AF.addr_family * Socket.SOCK.sock_type * int -> OS.IO.iodesc = + RunCall.rtsCallFull3 "PolyNetworkCreateSocket" in - fun socket' (af, st, p: int) = RunCall.unsafeCast(doCall(14, (af, st, p))) + fun socket' (af, st, p) = LibraryIOSupport.SOCK(doCreateSocket(af, st, p)) end + local - val doCall = RunCall.rtsCallFull2 "PolyNetworkGeneral" + val doCreateSocketPair: + Socket.AF.addr_family * Socket.SOCK.sock_type * int -> OS.IO.iodesc * OS.IO.iodesc = + RunCall.rtsCallFull3 "PolyNetworkCreateSocketPair" in - fun socketPair' (af, st, p: int) = RunCall.unsafeCast(doCall(55, (af, st, p))) + fun socketPair' (af, st, p: int) = + let + val (a, b) = doCreateSocketPair (af, st, p) + in + (LibraryIOSupport.SOCK a, LibraryIOSupport.SOCK b) + end end (* We assume that the default protocol is always zero. *) fun socket(af, st) = socket'(af, st, 0) fun socketPair(af, st) = socketPair'(af, st, 0) end; diff --git a/basis/INet6Sock.sml b/basis/INet6Sock.sml new file mode 100644 index 00000000..2b28388e --- /dev/null +++ b/basis/INet6Sock.sml @@ -0,0 +1,221 @@ +(* + Title: Standard Basis Library: IPV6 Sockets + Author: David Matthews + Copyright David Matthews 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 +*) + +(* Based on INetSock and NetHostDB. They're sufficiently similar that + we could use a common functor. *) +local + structure INet6Addr :> + sig + eqtype in_addr + type inet + type sock_addr = inet Socket.sock_addr + val inetAF : Socket.AF.addr_family + + val scan : (char, 'a) StringCvt.reader + -> (in_addr, 'a) StringCvt.reader + val fromString : string -> in_addr option + val toString : in_addr -> string + + val toAddr : in_addr * int -> sock_addr + val fromAddr : sock_addr -> in_addr * int + val any : int -> sock_addr + end + = + struct + type in_addr = Word8Vector.vector + + abstype inet = ABSTRACT with end; + + type sock_addr = inet Socket.sock_addr + + val inetAF = + case Socket.AF.fromString "INET6" of + NONE => raise OS.SysErr("Missing address family", NONE) + | SOME s => s + + + (* Scan an IPv6 address. Strictly, we should try to recognise sufficient + of the input stream to produce a single IPv6 address and no more. + Instead we read the input stream so long as it contains characters + that could form part of an address i.e. hex characters, colon and + full-stop (because of the special IPv4 compatibility format) + then pass the result to inet_pton to try to convert it. *) + local + val convert: string -> in_addr = RunCall.rtsCallFull1 "PolyNetworkStringToIP6Address" + in + fun scan getc src = + let + fun isValid #":" = true + | isValid #"." = true + | isValid ch = + Char.isDigit ch orelse ch >= #"A" andalso ch <= #"F" orelse ch >= #"a" andalso ch <= #"f" + + fun whileValid l src = + case getc src of + NONE => (l, src) + | SOME(ch, src') => + if isValid ch then whileValid(ch :: l) src' else (l, src) + + val (input, src') = whileValid [] src + in + SOME(convert(String.implode(List.rev input)), src') + handle Fail _ => NONE + end + end + + val fromString = StringCvt.scanString scan + (* This conversion could be done in ML but the rules for producing the canonical + version are complicated when there are zeros. *) + and toString: in_addr -> string = RunCall.rtsCallFull1 "PolyNetworkIP6AddressToString" + + val toAddr: in_addr * int -> sock_addr = RunCall.rtsCallFull2 "PolyNetworkCreateIP6Address" + and fromAddr: sock_addr -> in_addr * int = RunCall.rtsCallFull1 "PolyNetworkGetAddressAndPortFromIP6" + + local + val getAddrAny: unit -> in_addr = RunCall.rtsCallFull0 "PolyNetworkReturnIP6AddressAny" + val iAddrAny: in_addr = getAddrAny() + in + fun any (p: int) : sock_addr = toAddr(iAddrAny, p) + end + + end + +in + structure Net6HostDB :> NET_HOST_DB where type in_addr = INet6Addr.in_addr where type addr_family = Socket.AF.addr_family = + struct + open INet6Addr + type addr_family = Socket.AF.addr_family + type entry = string * string list * addr_family * in_addr list + val name: entry -> string = #1 + (* aliases now always returns the empty list. *) + val aliases : entry -> string list = #2 + val addrType : entry -> addr_family = #3 + val addrs : entry -> in_addr list = #4 + + (* Addr returns the first address in the list. There should always + be at least one entry. *) + fun addr e = + case addrs e of + a :: _ => a + | [] => raise OS.SysErr("No address returned", NONE) + + val getHostName: unit -> string = RunCall.rtsCallFull0 "PolyNetworkGetHostName" + + local + type addrInfo = int * Socket.AF.addr_family * int * int * sock_addr * string + val getAddrInfo: string * addr_family -> addrInfo list = + RunCall.rtsCallFull2 "PolyNetworkGetAddrInfo" + in + fun getByName s = + ( + case getAddrInfo(s, inetAF) of + [] => NONE + | l as ((_, family, _, _, _, name) :: _) => + SOME (name, [], family, map (#1 o fromAddr o #5) l) + ) handle OS.SysErr _ => NONE + end + + local + (* This does a reverse lookup of the address to return the name. *) + val doCall: sock_addr -> string = RunCall.rtsCallFull1 "PolyNetworkGetNameInfo" + in + fun getByAddr n = + ( + (* Create an entry out of this. We could do a forward look-up + of the resulting address but there doesn't seem to be any point. *) + SOME(doCall(toAddr(n, 0)), [], inetAF, [n]) + ) handle OS.SysErr _ => NONE + end + end + + and INet6Sock = + struct + open INet6Addr + + type 'sock_type sock = (inet, 'sock_type) Socket.sock + type 'mode stream_sock = 'mode Socket.stream sock + + type dgram_sock = Socket.dgram sock + + local + val doSetOpt: int * OS.IO.iodesc * int -> unit = + RunCall.rtsCallFull3 "PolyNetworkSetOption" + val doGetOpt: int * OS.IO.iodesc -> int = + RunCall.rtsCallFull2 "PolyNetworkGetOption" + in + structure UDP = + struct + fun socket () = GenericSock.socket(inetAF, Socket.SOCK.dgram) + fun socket' p = GenericSock.socket'(inetAF, Socket.SOCK.dgram, p) + end + + structure TCP = + struct + fun socket () = GenericSock.socket(inetAF, Socket.SOCK.stream) + fun socket' p = GenericSock.socket'(inetAF, Socket.SOCK.stream, p) + + fun getNODELAY(LibraryIOSupport.SOCK s: 'mode stream_sock): bool = doGetOpt(16, s) <> 0 + + fun setNODELAY (LibraryIOSupport.SOCK s: 'mode stream_sock, b: bool): unit = + doSetOpt(15, s, if b then 1 else 0) + end + end + + end; +end; + +(* We can't use the INET_SOCK signature because that binds in NetHostDB. *) +signature INET6_SOCK = +sig + type inet + + type 'sock_type sock = (inet, 'sock_type) Socket.sock + type 'mode stream_sock = 'mode Socket.stream sock + + type dgram_sock = Socket.dgram sock + type sock_addr = inet Socket.sock_addr + + val inetAF : Socket.AF.addr_family + val toAddr : Net6HostDB.in_addr * int -> sock_addr + val fromAddr : sock_addr -> Net6HostDB.in_addr * int + val any : int -> sock_addr + structure UDP : + sig + val socket : unit -> dgram_sock + val socket' : int -> dgram_sock + end + structure TCP : + sig + val socket : unit -> 'mode stream_sock + val socket' : int -> 'mode stream_sock + val getNODELAY : 'mode stream_sock -> bool + val setNODELAY : 'mode stream_sock * bool -> unit + end +end; + +structure INet6Sock :> INET6_SOCK = INet6Sock; + +local + (* Install the pretty printer for NetHostDB.in_addr. + This must be done outside + the structure if we use opaque matching. *) + fun printAddr _ _ x = PolyML.PrettyString(Net6HostDB.toString x) +in + val () = PolyML.addPrettyPrinter printAddr +end; diff --git a/basis/INetSock.sml b/basis/INetSock.sml index d7102ca6..d7c24f2e 100644 --- a/basis/INetSock.sml +++ b/basis/INetSock.sml @@ -1,110 +1,310 @@ (* Title: Standard Basis Library: Internet Sockets Author: David Matthews - Copyright David Matthews 2000, 2016 + Copyright David Matthews 2000, 2016, 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 NET_HOST_DB = +sig + eqtype in_addr + eqtype addr_family + type entry + val name : entry -> string + val aliases : entry -> string list + val addrType : entry -> addr_family + val addr : entry -> in_addr + val addrs : entry -> in_addr list + + val getByName : string -> entry option + val getByAddr : in_addr -> entry option + val getHostName : unit -> string + val scan : (char, 'a) StringCvt.reader + -> (in_addr, 'a) StringCvt.reader + val fromString : string -> in_addr option + val toString : in_addr -> string +end; + +local + fun power2 0 = 1: LargeInt.int + | power2 n = 2 * power2(n-1) + val p32 = power2 32 + val p24 = power2 24 + + fun scan getc src = + let + (* Read a number as either decimal, hex or octal up to the + given limit. Stops when it reaches the limit or finds a + character it doesn't recognise. *) + fun readNum base acc limit src = + let + fun addDigit d src = + let + val n = case acc of SOME(n, _) => n | NONE => 0 + val next = n * LargeInt.fromInt base + LargeInt.fromInt d + in + (* If we are below the limit we can continue. *) + if next < limit + then readNum base (SOME(next, src)) limit src + else acc + end + in + case getc src of + NONE => acc + | SOME(ch, src') => + if Char.isDigit ch andalso + ch < Char.chr(Char.ord #"0" + base) + then addDigit (Char.ord ch - Char.ord #"0") src' + else if base = 16 andalso (ch >= #"A" andalso ch <= #"F") + then addDigit (Char.ord ch - Char.ord #"A" + 10) src' + else if base = 16 andalso (ch >= #"a" andalso ch <= #"f") + then addDigit (Char.ord ch - Char.ord #"a" + 10) src' + else acc + end + + (* Read a number. If it starts with 0x or 0X treat it + as hex, otherwise if it starts with 0 treat as octal + otherwise decimal. *) + fun scanNum limit src = + case getc src of + NONE => NONE + | SOME (#"0", src') => + ( + case getc src' of + SOME(ch, src'') => + if ch = #"x" orelse ch = #"X" + then + ( + (* If it is invalid we have still read a + zero so return that. *) + case readNum 16 NONE limit src'' of + NONE => SOME(0, src') + | res => res + ) + else (* Octal - include the zero. *) + readNum 8 NONE limit src + | NONE => SOME(0, src') (* Just the zero. *) + ) + | SOME (_, _) => (* Treat it as a decimal number. *) + readNum 10 NONE limit src + + fun scanAddr src limit i acc = + case scanNum limit src of + NONE => NONE + | SOME(n, src') => + let + val res = acc*256 + n (* This is the accumulated result. *) + in + (* If the result is more than 24 bits or we've read + all the sections we're finished. *) + if res >= p24 orelse i = 1 then SOME(res, src') + else + case getc src' of + SOME (#".", src'') => + ( + (* The limit for sections other than the + first is 256. *) + case scanAddr src'' 256 (i-1) res of + NONE => SOME(res, src') (* Return what we had. *) + | r => r + ) + | _ => SOME(res, src') (* Return what we've got. *) + end + in + scanAddr src p32 4 (* Four sections in all. *) 0 + end (* scan *) + + structure INet4Addr :> + sig + eqtype in_addr + type inet + type sock_addr = inet Socket.sock_addr + val inetAF : Socket.AF.addr_family + + val scan : (char, 'a) StringCvt.reader + -> (in_addr, 'a) StringCvt.reader + val fromString : string -> in_addr option + val toString : in_addr -> string + + val toAddr : in_addr * int -> sock_addr + val fromAddr : sock_addr -> in_addr * int + val any : int -> sock_addr + end + = + struct + type in_addr = LargeInt.int + + abstype inet = ABSTRACT with end; + + type sock_addr = inet Socket.sock_addr + + val inetAF = + case Socket.AF.fromString "INET" of + NONE => raise OS.SysErr("Missing address family", NONE) + | SOME s => s + + val scan = scan + and fromString = StringCvt.scanString scan + + fun toString (n: in_addr) = + let + fun pr n i = + (if i > 0 then pr (n div 256) (i-1) ^ "." else "") ^ + LargeInt.toString (n mod 256) + + in + pr n 3 (* Always generate 4 numbers. *) + end + + val toAddr: in_addr * int -> sock_addr = RunCall.rtsCallFull2 "PolyNetworkCreateIP4Address" + and fromAddr: sock_addr -> in_addr * int = RunCall.rtsCallFull1 "PolyNetworkGetAddressAndPortFromIP4" + + local + val getAddrAny: unit -> in_addr = RunCall.rtsCallFull0 "PolyNetworkReturnIP4AddressAny" + val iAddrAny: in_addr = getAddrAny() + in + fun any (p: int) : sock_addr = toAddr(iAddrAny, p) + end + + end + +in + structure NetHostDB :> NET_HOST_DB where type in_addr = INet4Addr.in_addr where type addr_family = Socket.AF.addr_family = + struct + open INet4Addr + type addr_family = Socket.AF.addr_family + type entry = string * string list * addr_family * in_addr list + val name: entry -> string = #1 + (* aliases now always returns the empty list. *) + val aliases : entry -> string list = #2 + val addrType : entry -> addr_family = #3 + val addrs : entry -> in_addr list = #4 + + (* Addr returns the first address in the list. There should always + be at least one entry. *) + fun addr e = + case addrs e of + a :: _ => a + | [] => raise OS.SysErr("No address returned", NONE) + + val getHostName: unit -> string = RunCall.rtsCallFull0 "PolyNetworkGetHostName" + + local + type addrInfo = int * Socket.AF.addr_family * int * int * sock_addr * string + val getAddrInfo: string * addr_family -> addrInfo list = + RunCall.rtsCallFull2 "PolyNetworkGetAddrInfo" + in + fun getByName s = + ( + case getAddrInfo(s, inetAF) of + [] => NONE + | l as ((_, family, _, _, _, name) :: _) => + SOME (name, [], family, map (#1 o fromAddr o #5) l) + ) handle OS.SysErr _ => NONE + end + + local + (* This does a reverse lookup of the address to return the name. *) + val doCall: sock_addr -> string = RunCall.rtsCallFull1 "PolyNetworkGetNameInfo" + in + fun getByAddr n = + ( + (* Create an entry out of this. We could do a forward look-up + of the resulting address but there doesn't seem to be any point. *) + SOME(doCall(toAddr(n, 0)), [], inetAF, [n]) + ) handle OS.SysErr _ => NONE + end + end + + and INetSock = + struct + open INet4Addr + + type 'sock_type sock = (inet, 'sock_type) Socket.sock + type 'mode stream_sock = 'mode Socket.stream sock + + type dgram_sock = Socket.dgram sock + + local + val doSetOpt: int * OS.IO.iodesc * int -> unit = + RunCall.rtsCallFull3 "PolyNetworkSetOption" + val doGetOpt: int * OS.IO.iodesc -> int = + RunCall.rtsCallFull2 "PolyNetworkGetOption" + in + structure UDP = + struct + fun socket () = GenericSock.socket(inetAF, Socket.SOCK.dgram) + fun socket' p = GenericSock.socket'(inetAF, Socket.SOCK.dgram, p) + end + + structure TCP = + struct + fun socket () = GenericSock.socket(inetAF, Socket.SOCK.stream) + fun socket' p = GenericSock.socket'(inetAF, Socket.SOCK.stream, p) + + fun getNODELAY(LibraryIOSupport.SOCK s: 'mode stream_sock): bool = doGetOpt(16, s) <> 0 + + fun setNODELAY (LibraryIOSupport.SOCK s: 'mode stream_sock, b: bool): unit = + doSetOpt(15, s, if b then 1 else 0) + end + end + + end; +end; + + +(* These use NetHostDB in the signature which is a bit of a mess. *) + +(* Apply type realisation. *) +signature SOCKET = sig include SOCKET end where type AF.addr_family = NetHostDB.addr_family; + signature INET_SOCK = sig type inet type 'sock_type sock = (inet, 'sock_type) Socket.sock type 'mode stream_sock = 'mode Socket.stream sock type dgram_sock = Socket.dgram sock type sock_addr = inet Socket.sock_addr val inetAF : Socket.AF.addr_family val toAddr : NetHostDB.in_addr * int -> sock_addr val fromAddr : sock_addr -> NetHostDB.in_addr * int val any : int -> sock_addr structure UDP : sig val socket : unit -> dgram_sock val socket' : int -> dgram_sock end structure TCP : sig val socket : unit -> 'mode stream_sock val socket' : int -> 'mode stream_sock val getNODELAY : 'mode stream_sock -> bool val setNODELAY : 'mode stream_sock * bool -> unit end end; -structure INetSock :> INET_SOCK = -struct - abstype inet = ABSTRACT with end; - - type 'sock_type sock = (inet, 'sock_type) Socket.sock - type 'mode stream_sock = 'mode Socket.stream sock - - type dgram_sock = Socket.dgram sock - type sock_addr = inet Socket.sock_addr - - val inetAF : Socket.AF.addr_family = - case Socket.AF.fromString "INET" of - NONE => raise OS.SysErr("Missing address family", NONE) - | SOME s => s - - local - val doCall = RunCall.rtsCallFull2 "PolyNetworkGeneral" - in - fun toAddr(iaddr: NetHostDB.in_addr, port: int) : sock_addr = - doCall(40, (port, iaddr)) - end - - local - val doCall1 = RunCall.rtsCallFull2 "PolyNetworkGeneral" - and doCall2 = RunCall.rtsCallFull2 "PolyNetworkGeneral" - in - fun fromAddr (s: sock_addr) : NetHostDB.in_addr * int = - if Socket.familyOfAddr s <> inetAF - then raise Match - else (doCall1(42, s), doCall2(41, s)) - end - - local - val doCall = RunCall.rtsCallFull2 "PolyNetworkGeneral" - val iAddrAny: NetHostDB.in_addr = doCall(13, ()) - in - fun any (p: int) : sock_addr = toAddr(iAddrAny, p) - end - - local - val doCall1 = RunCall.rtsCallFull2 "PolyNetworkGeneral" - val doCall2 = RunCall.rtsCallFull2 "PolyNetworkGeneral" - in - structure UDP = - struct - fun socket () = GenericSock.socket(inetAF, Socket.SOCK.dgram) - fun socket' p = GenericSock.socket'(inetAF, Socket.SOCK.dgram, p) - end - - structure TCP = - struct - fun socket () = GenericSock.socket(inetAF, Socket.SOCK.stream) - fun socket' p = GenericSock.socket'(inetAF, Socket.SOCK.stream, p) - - fun getNODELAY(s: 'mode stream_sock): bool = - doCall1(16, RunCall.unsafeCast s) - - fun setNODELAY (s: 'mode stream_sock, b: bool): unit = - doCall2(15, (RunCall.unsafeCast s, b)) - end - end +structure INetSock :> INET_SOCK = INetSock; +local + (* Install the pretty printer for NetHostDB.in_addr. + This must be done outside + the structure if we use opaque matching. *) + fun printAddr _ _ x = PolyML.PrettyString(NetHostDB.toString x) +in + val () = PolyML.addPrettyPrinter printAddr 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/LibraryIOSupport.sml b/basis/LibraryIOSupport.sml index ca760fb3..01193e16 100644 --- a/basis/LibraryIOSupport.sml +++ b/basis/LibraryIOSupport.sml @@ -1,463 +1,472 @@ (* Title: Standard Basis Library: IO Support functions Copyright David C.J. Matthews 2000, 2015-16 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 *) (* This function provides wrappers for the RTS file descriptors to construct TextPrimIO and BinPrimIO readers and writers. It is used both from the TextIO and BinIO structures and also from the Windows and Unix structures to wrap up pipes. *) structure LibraryIOSupport:> sig structure BinPrimIO: PRIM_IO where type vector = Word8Vector.vector where type elem = Word8.word where type array = Word8Array.array (* BinPrimIO.pos is defined to be Position.int. Is it? Can't find that in G&R 2004. *) where type pos = Position.int where type vector_slice = Word8VectorSlice.slice where type array_slice = Word8ArraySlice.slice and TextPrimIO: sig include PRIM_IO where type vector = CharVector.vector where type elem = Char.char where type array = CharArray.array (* TextPrimIO.pos is abstract. In particular it could be a problem in Windows with CRNL <-> NL conversion. *) where type vector_slice = CharVectorSlice.slice where type array_slice = CharArraySlice.slice end val wrapInFileDescr : { fd : OS.IO.iodesc, name : string, initBlkMode : bool } -> TextPrimIO.reader val wrapOutFileDescr : { fd : OS.IO.iodesc, name : string, appendMode : bool, initBlkMode : bool, chunkSize : int } -> TextPrimIO.writer val wrapBinInFileDescr : { fd : OS.IO.iodesc, name : string, initBlkMode : bool } -> BinPrimIO.reader val wrapBinOutFileDescr : { fd : OS.IO.iodesc, name : string, appendMode : bool, initBlkMode : bool, chunkSize : int } -> BinPrimIO.writer val readBinVector: OS.IO.iodesc * int -> Word8Vector.vector val readBinArray: OS.IO.iodesc * Word8ArraySlice.slice -> int val writeBinVec: OS.IO.iodesc * Word8VectorSlice.slice -> int val writeBinArray: OS.IO.iodesc * Word8ArraySlice.slice -> int val nonBlocking : ('a->'b) -> 'a ->'b option val protect: Thread.Mutex.mutex -> ('a -> 'b) -> 'a -> 'b + + datatype ('af,'sock_type) sock = SOCK of OS.IO.iodesc + (* Socket addresses are implemented as strings. *) + datatype 'af sock_addr = SOCKADDR of Word8Vector.vector end = struct structure BinPrimIO = PrimIO ( structure Array : MONO_ARRAY = Word8Array structure Vector : MONO_VECTOR = Word8Vector structure VectorSlice = Word8VectorSlice structure ArraySlice = Word8ArraySlice val someElem : Vector.elem = 0wx00 (* Initialise to zero. *) type pos = Position.int (* Position should always be LargeInt. *) val compare = Position.compare ) structure TextPrimIO = PrimIO ( structure Array = CharArray structure Vector = CharVector structure ArraySlice = CharArraySlice structure VectorSlice = CharVectorSlice val someElem : Array.elem = #" " (* Initialise to spaces. *) type pos = Position.int val compare = Position.compare ); (* open IO *) type address = LibrarySupport.address type fileDescr = OS.IO.iodesc (* Called after any exception in the lower level reader or writer to map any exception other than Io into Io. *) local val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun sys_close (strm: fileDescr): unit = doIo(7, strm, 0) and sys_block_in(strm: fileDescr): unit = doIo(27, strm, 0) and sys_block_out(strm: fileDescr): unit = doIo(29, strm, 0) end local val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun sys_read_text (strm: fileDescr, vil: address*word*word): int = doIo(8, strm, vil) fun sys_write_text (strm: fileDescr, vil: address*word*word): int = doIo(11, strm, vil) fun sys_read_bin (strm: fileDescr, vil: address*word*word): int = doIo(9, strm, vil) fun sys_write_bin (strm: fileDescr, vil: address*word*word): int = doIo(12, strm, vil) end local val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun sys_read_string (strm: fileDescr, len: int): string = doIo(10, strm, len) end local val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun readBinVector (strm: fileDescr, len: int): Word8Vector.vector = doIo(26, strm, len) end local val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun sys_get_buffsize (strm: fileDescr): int = doIo(15, strm, 0) and sys_can_input(strm: fileDescr): int = doIo(16, strm, 0) and sys_can_output(strm: fileDescr): int = doIo(28, strm, 0) and sys_avail(strm: fileDescr): int = doIo(17, strm, 0) end local val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun sys_get_pos(strm: fileDescr): Position.int = doIo(18, strm, 0) (* N.B. large int *) end local val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun sys_end_pos(strm: fileDescr): Position.int = doIo(20, strm, 0) (* N.B. large int *) end local val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun sys_set_pos(strm: fileDescr, p: Position.int): unit = (doIo(19, strm, p); ()) (* N.B. large int *) end local (* Find out the error which will be generated if a stream in non-blocking mode would block. *) val eAgain = OS.syserror "EAGAIN" and eWouldBlock = OS.syserror "EWOULDBLOCK" and eInProgress = OS.syserror "EINPROGRESS" and wsaWouldBlock = OS.syserror "WSAEWOULDBLOCK" and wsaInProgress = OS.syserror "WSAEINPROGRESS" in (* If evaluating the function raises EAGAIN or EWOULDBLOCK we return NONE otherwise if it succeeds return SOME result. Pass other exceptions back to the caller. *) fun nonBlocking f arg = SOME(f arg) handle exn as OS.SysErr(_, SOME e) => if (case eAgain of SOME again => e = again | NONE => false) then NONE else if (case eWouldBlock of SOME wouldBlock => e = wouldBlock | NONE => false) then NONE else if (case eInProgress of SOME inProgress => e = inProgress | NONE => false) then NONE else if (case wsaWouldBlock of SOME wouldBlock => e = wouldBlock | NONE => false) then NONE else if (case wsaInProgress of SOME inProgress => e = inProgress | NONE => false) then NONE - else raise exn + else PolyML.Exception.reraise exn end val wordSize : word = LibrarySupport.wordSize; (* Find out if random access is permitted and return the appropriate values. *) fun getRandAccessFns n = let val isRandomAccess = ((sys_get_pos n; true) handle OS.SysErr _ => false) val getPos = if isRandomAccess then SOME(fn () => sys_get_pos n) else NONE val setPos = if isRandomAccess then SOME(fn p => sys_set_pos(n, p)) else NONE val endPos = if isRandomAccess then SOME(fn () => sys_end_pos n) else NONE in (getPos, setPos, endPos) end fun writeBinArray (n: fileDescr, slice: Word8ArraySlice.slice): int = let val (buf, i, len) = Word8ArraySlice.base slice val LibrarySupport.Word8Array.Array(_, v) = buf val iW = LibrarySupport.unsignedShortOrRaiseSubscript i val lenW = LibrarySupport.unsignedShortOrRaiseSubscript len in sys_write_bin(n, (v, iW, lenW)) end fun readBinArray (n: fileDescr, slice: Word8ArraySlice.slice): int = let val (buf, i, len) = Word8ArraySlice.base slice val LibrarySupport.Word8Array.Array(_, v) = buf val lenW = LibrarySupport.unsignedShortOrRaiseSubscript len val iW = LibrarySupport.unsignedShortOrRaiseSubscript i in sys_read_bin(n, (v, iW, lenW)) end (* Write out a string using the underlying call. Note that we have to add the size of a word to the offsets to skip the length word. The underlying call deals with the special case of a single character string where the "string" is actually the character itself. *) fun writeBinVec (n: fileDescr, slice: Word8VectorSlice.slice): int = let val (buf, i, len) = Word8VectorSlice.base slice val iW = LibrarySupport.unsignedShortOrRaiseSubscript i val lenW = LibrarySupport.unsignedShortOrRaiseSubscript len in sys_write_bin(n, (LibrarySupport.w8vectorAsAddress buf, iW+wordSize, lenW)) end (* Create the primitive IO functions and add the higher layers. For all file descriptors other than standard input we look at the stream to see if we can do non-blocking input and/or random access. Standard input, though is persistent and so we have to take a more restrictive view. *) fun wrapInFileDescr{ fd, name, initBlkMode } = let fun readArray (slice: CharArraySlice.slice): int = let val (buf, i, len) = CharArraySlice.base slice val LibrarySupport.CharArray.Array(_, v) = buf val iW = LibrarySupport.unsignedShortOrRaiseSubscript i val lenW = LibrarySupport.unsignedShortOrRaiseSubscript len in sys_read_text(fd, (v, iW, lenW)) end fun readVector l = sys_read_string(fd, l) (* If we have opened the stream in non-blocking mode readVec and readArray will raise an exception if they would block. We have to handle that. The blocking functions can be constructed using block_in but that should be done by augmentReader. *) val (readVec, readArr, readVecNB, readArrNB) = if initBlkMode then (SOME readVector, SOME readArray, NONE, NONE) else (NONE, NONE, SOME(nonBlocking readVector), SOME(nonBlocking readArray)) val (getPos, setPos, endPos) = getRandAccessFns fd (* Unlike the other functions "avail" is a function returning an option, not an optional function. *) fun avail () = let (* If we get an exception or a negative number return NONE. *) val v = sys_avail fd handle OS.SysErr _ => ~1 in if v >= 0 then SOME v else NONE end val textPrimRd = TextPrimIO.RD { name = name, chunkSize = sys_get_buffsize fd, readVec = readVec, readArr = readArr, readVecNB = readVecNB, readArrNB = readArrNB, block = SOME(fn () => sys_block_in fd), canInput = SOME (fn () => sys_can_input fd > 0), avail = avail, getPos = getPos, setPos = setPos, endPos = endPos, verifyPos = getPos, close = fn () => sys_close fd, ioDesc = (SOME fd) : OS.IO.iodesc option } in TextPrimIO.augmentReader textPrimRd end fun wrapOutFileDescr {fd, name, appendMode, initBlkMode, chunkSize} = let fun writeArray (slice: CharArraySlice.slice): int = let val (buf, i, len) = CharArraySlice.base slice val LibrarySupport.CharArray.Array(_, v) = buf val iW = LibrarySupport.unsignedShortOrRaiseSubscript i val lenW = LibrarySupport.unsignedShortOrRaiseSubscript len in sys_write_text(fd, (v, iW, lenW)) end (* Write out a string using the underlying call. Note that we have to add the size of a word to the offsets to skip the length word. The underlying call deals with the special case of a single character string where the "string" is actually the character itself. *) fun writeVector (slice: CharVectorSlice.slice): int = let val (buf, i, len) = CharVectorSlice.base slice val v = LibrarySupport.stringAsAddress buf val iW = LibrarySupport.unsignedShortOrRaiseSubscript i val lenW = LibrarySupport.unsignedShortOrRaiseSubscript len in sys_write_text(fd, (v, iW+wordSize, lenW)) end (* Set up the writers depending on whether the stream is in non-blocking mode or not. *) val (writeVec, writeArr, writeVecNB, writeArrNB) = if initBlkMode then (SOME writeVector, SOME writeArray, NONE, NONE) else (NONE, NONE, SOME(nonBlocking writeVector), SOME(nonBlocking writeArray)) (* Random access is provided if getPos works. *) val (getPos, setPos, endPos) = getRandAccessFns fd (* If we have opened the stream for append we will always write to the end of the stream so setPos won't work. *) val setPos = if appendMode then NONE else setPos val textPrimWr = TextPrimIO.WR { name = name, chunkSize = chunkSize, writeVec = writeVec, writeArr = writeArr, writeVecNB = writeVecNB, writeArrNB = writeArrNB, block = SOME(fn () => sys_block_out fd), canOutput = SOME(fn () => sys_can_output fd > 0), getPos = getPos, setPos = setPos, endPos = endPos, verifyPos = getPos, close = fn () => sys_close fd, ioDesc = (SOME fd) : OS.IO.iodesc option } in TextPrimIO.augmentWriter textPrimWr end fun wrapBinInFileDescr{fd, name, initBlkMode} = let fun readVector l = readBinVector(fd, l) and readArray b = readBinArray(fd, b) (* If we have opened the stream in non-blocking mode readVec and readArray will raise an exception if they would block. We have to handle that. The blocking functions can be constructed using block_in but that should be done by augmentReader. *) val (readVec, readArr, readVecNB, readArrNB) = if initBlkMode then (SOME readVector, SOME readArray, NONE, NONE) else (NONE, NONE, SOME(nonBlocking readVector), SOME(nonBlocking readArray)) (* Random access is provided if getPos works. *) val (getPos, setPos, endPos) = getRandAccessFns fd (* Unlike the other functions "avail" is a function returning an option, not an optional function. *) fun avail () = let (* If we get an exception or a negative number return NONE. *) val v = sys_avail fd handle OS.SysErr _ => ~1 in if v >= 0 then SOME v else NONE end val binPrimRd = BinPrimIO.RD { name = name, chunkSize = sys_get_buffsize fd, readVec = readVec, readArr = readArr, readVecNB = readVecNB, readArrNB = readArrNB, block = SOME(fn () => sys_block_in fd), canInput = SOME(fn() =>sys_can_input fd > 0), avail = avail, getPos = getPos, setPos = setPos, endPos = endPos, verifyPos = getPos, close = fn() => sys_close fd, ioDesc = SOME fd } in BinPrimIO.augmentReader binPrimRd end fun wrapBinOutFileDescr{fd, name, appendMode, initBlkMode, chunkSize} = let fun writeArray b = writeBinArray(fd, b) and writeVector b = writeBinVec(fd, b) (* Set up the writers depending on whether the stream is in non-blocking mode or not. *) val (writeVec, writeArr, writeVecNB, writeArrNB) = if initBlkMode then (SOME writeVector, SOME writeArray, NONE, NONE) else (NONE, NONE, SOME(nonBlocking writeVector), SOME(nonBlocking writeArray)) (* Random access is provided if getPos works. *) val (getPos, setPos, endPos) = getRandAccessFns fd (* If we have opened the stream for append we will always write to the end of the stream so setPos won't work. *) val setPos = if appendMode then NONE else setPos val binPrimWr = BinPrimIO.WR { name = name, chunkSize = chunkSize, writeVec = writeVec, writeArr = writeArr, writeVecNB = writeVecNB, writeArrNB = writeArrNB, block = SOME(fn () => sys_block_out fd), canOutput = SOME(fn () => sys_can_output fd > 0), getPos = getPos, setPos = setPos, endPos = endPos, verifyPos = getPos, close = fn () => sys_close fd, ioDesc = SOME fd } in BinPrimIO.augmentWriter binPrimWr end (* Many of the IO functions need a mutex so we include this here. This applies a function while a mutex is being held. *) val protect = ThreadLib.protect + + (* These are abstract in Socket but it's convenient to be able to convert in + the other socket structures. *) + datatype ('af,'sock_type) sock = SOCK of OS.IO.iodesc + datatype 'af sock_addr = SOCKADDR of Word8Vector.vector end; structure BinPrimIO = LibraryIOSupport.BinPrimIO and TextPrimIO = LibraryIOSupport.TextPrimIO; diff --git a/basis/LibrarySupport.sml b/basis/LibrarySupport.sml index 915d56b1..cc24d8b5 100644 --- a/basis/LibrarySupport.sml +++ b/basis/LibrarySupport.sml @@ -1,200 +1,217 @@ (* Title: Standard Basis Library: Support functions - Copyright David C.J. Matthews 2000, 2015-18 + 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/NetHostDB.sml b/basis/NetHostDB.sml deleted file mode 100644 index ad071837..00000000 --- a/basis/NetHostDB.sml +++ /dev/null @@ -1,193 +0,0 @@ -(* - Title: Standard Basis Library: NetHostDB and NetDB Structures and Signatures - Author: David Matthews - Copyright David Matthews 2000, 2016 - - 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 NET_HOST_DB = -sig - eqtype in_addr - eqtype addr_family - type entry - val name : entry -> string - val aliases : entry -> string list - val addrType : entry -> addr_family - val addr : entry -> in_addr - val addrs : entry -> in_addr list - - val getByName : string -> entry option - val getByAddr : in_addr -> entry option - val getHostName : unit -> string - val scan : (char, 'a) StringCvt.reader - -> (in_addr, 'a) StringCvt.reader - val fromString : string -> in_addr option - val toString : in_addr -> string -end; - -local - fun power2 0 = 1: LargeInt.int - | power2 n = 2 * power2(n-1) - val p32 = power2 32 - val p24 = power2 24 - - fun scan getc src = - let - (* Read a number as either decimal, hex or octal up to the - given limit. Stops when it reaches the limit or finds a - character it doesn't recognise. *) - fun readNum base acc limit src = - let - fun addDigit d src = - let - val n = case acc of SOME(n, _) => n | NONE => 0 - val next = n * LargeInt.fromInt base + LargeInt.fromInt d - in - (* If we are below the limit we can continue. *) - if next < limit - then readNum base (SOME(next, src)) limit src - else acc - end - in - case getc src of - NONE => acc - | SOME(ch, src') => - if Char.isDigit ch andalso - ch < Char.chr(Char.ord #"0" + base) - then addDigit (Char.ord ch - Char.ord #"0") src' - else if base = 16 andalso (ch >= #"A" andalso ch <= #"F") - then addDigit (Char.ord ch - Char.ord #"A" + 10) src' - else if base = 16 andalso (ch >= #"a" andalso ch <= #"f") - then addDigit (Char.ord ch - Char.ord #"a" + 10) src' - else acc - end - - (* Read a number. If it starts with 0x or 0X treat it - as hex, otherwise if it starts with 0 treat as octal - otherwise decimal. *) - fun scanNum limit src = - case getc src of - NONE => NONE - | SOME (#"0", src') => - ( - case getc src' of - SOME(ch, src'') => - if ch = #"x" orelse ch = #"X" - then - ( - (* If it is invalid we have still read a - zero so return that. *) - case readNum 16 NONE limit src'' of - NONE => SOME(0, src') - | res => res - ) - else (* Octal - include the zero. *) - readNum 8 NONE limit src - | NONE => SOME(0, src') (* Just the zero. *) - ) - | SOME (_, _) => (* Treat it as a decimal number. *) - readNum 10 NONE limit src - - fun scanAddr src limit i acc = - case scanNum limit src of - NONE => NONE - | SOME(n, src') => - let - val res = acc*256 + n (* This is the accumulated result. *) - in - (* If the result is more than 24 bits or we've read - all the sections we're finished. *) - if res >= p24 orelse i = 1 then SOME(res, src') - else - case getc src' of - SOME (#".", src'') => - ( - (* The limit for sections other than the - first is 256. *) - case scanAddr src'' 256 (i-1) res of - NONE => SOME(res, src') (* Return what we had. *) - | r => r - ) - | _ => SOME(res, src') (* Return what we've got. *) - end - in - scanAddr src p32 4 (* Four sections in all. *) 0 - end (* scan *) - -in - structure NetHostDB :> NET_HOST_DB = - struct - type in_addr = LargeInt.int - and addr_family = int - type entry = string * string list * addr_family * in_addr list - val name: entry -> string = #1 - val aliases : entry -> string list = #2 - val addrType : entry -> addr_family = #3 - val addrs : entry -> in_addr list = #4 - - (* Addr returns the first address in the list. There should always - be at least one entry. *) - fun addr e = - case addrs e of - a :: _ => a - | [] => raise OS.SysErr("No address returned", NONE) - - val getHostName: unit -> string = RunCall.rtsCallFull0 "PolyNetworkGetHostName" - - (* The RTS calls return either zero or the address of the entry. *) - datatype result = AResult of entry | NoResult - - local - val doCall: string -> result - = RunCall.rtsCallFull1 "PolyNetworkGetHostByName" - in - fun getByName s = - case doCall s of AResult r => SOME r | NoResult => NONE - end - - local - val doCall: LargeInt.int -> result - = RunCall.rtsCallFull1 "PolyNetworkGetHostByAddr" - in - fun getByAddr n = - case doCall n of AResult r => SOME r | NoResult => NONE - end - - val scan = scan - and fromString = StringCvt.scanString scan - - fun toString (n: in_addr) = - let - fun pr n i = - (if i > 0 then pr (n div 256) (i-1) ^ "." else "") ^ - LargeInt.toString (n mod 256) - - in - pr n 3 (* Always generate 4 numbers. *) - end - end; - -end; - - -local - (* Install the pretty printer for NetHostDB.in_addr. - This must be done outside - the structure if we use opaque matching. *) - fun printAddr _ _ x = PolyML.PrettyString(NetHostDB.toString x) -in - val () = PolyML.addPrettyPrinter printAddr -end - diff --git a/basis/OS.sml b/basis/OS.sml index 16ea0db1..039dee2a 100644 --- a/basis/OS.sml +++ b/basis/OS.sml @@ -1,1212 +1,1189 @@ (* Title: Standard Basis Library: OS Structures and Signatures Author: David Matthews - Copyright David Matthews 2000, 2005, 2015-16 + Copyright David Matthews 2000, 2005, 2015-16, 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 OS_FILE_SYS = sig type dirstream val openDir : string -> dirstream val readDir : dirstream -> string option val rewindDir : dirstream -> unit val closeDir : dirstream -> unit val chDir : string -> unit val getDir : unit -> string val mkDir : string -> unit val rmDir : string -> unit val isDir : string -> bool val isLink : string -> bool val readLink : string -> string val fullPath : string -> string val realPath : string -> string val modTime : string -> Time.time val fileSize : string -> Position.int val setTime : (string * Time.time Option.option) -> unit val remove : string -> unit val rename : {old : string, new : string} -> unit datatype access_mode = A_READ | A_WRITE | A_EXEC val access : (string * access_mode list) -> bool val tmpName : unit -> string eqtype file_id val fileId : string -> file_id val hash : file_id -> word val compare : (file_id * file_id) -> General.order end (* OS_FILE_SYS *); signature OS_PATH = sig exception Path exception InvalidArc val parentArc : string val currentArc : string val fromString : string -> { isAbs : bool, vol : string, arcs : string list } val toString : { isAbs : bool, vol : string, arcs : string list } -> string val validVolume : {isAbs : bool, vol : string} -> bool val getVolume : string -> string val getParent : string -> string val splitDirFile : string -> {dir : string, file : string} val joinDirFile : {dir : string, file : string} -> string val dir : string -> string val file : string -> string val splitBaseExt : string -> {base : string, ext : string option } val joinBaseExt : {base : string, ext : string option} -> string val base : string -> string val ext : string -> string option val mkCanonical : string -> string val isCanonical : string -> bool val mkAbsolute : {path : string, relativeTo : string} -> string val mkRelative : {path : string, relativeTo : string} -> string val isAbsolute : string -> bool val isRelative : string -> bool val isRoot : string -> bool val concat : string * string -> string val toUnixPath : string -> string val fromUnixPath : string -> string end (* OS_PATH *); signature OS_PROCESS = sig type status val success : status val failure : status val isSuccess : status -> bool val system : string -> status val atExit : (unit -> unit) -> unit val exit : status -> 'a val terminate : status -> 'a val getEnv : string -> string Option.option val sleep: Time.time -> unit end (* OS_PROCESS *); signature OS_IO = sig eqtype iodesc val hash : iodesc -> word val compare : (iodesc * iodesc) -> General.order eqtype iodesc_kind val kind : iodesc -> iodesc_kind structure Kind: sig val file : iodesc_kind val dir : iodesc_kind val symlink : iodesc_kind val tty : iodesc_kind val pipe : iodesc_kind val socket : iodesc_kind val device : iodesc_kind end eqtype poll_desc type poll_info val pollDesc : iodesc -> poll_desc Option.option val pollToIODesc : poll_desc -> iodesc exception Poll val pollIn : poll_desc -> poll_desc val pollOut : poll_desc -> poll_desc val pollPri : poll_desc -> poll_desc val poll : (poll_desc list * Time.time Option.option) -> poll_info list val isIn : poll_info -> bool val isOut : poll_info -> bool val isPri : poll_info -> bool val infoToPollDesc : poll_info -> poll_desc end (* OS_IO *); signature OS = sig - eqtype syserror + eqtype syserror exception SysErr of (string * syserror Option.option) val errorMsg : syserror -> string val errorName : syserror -> string val syserror : string -> syserror Option.option structure FileSys : OS_FILE_SYS structure Path : OS_PATH structure Process : OS_PROCESS structure IO : OS_IO end (* OS *); -structure OS:> OS = +structure OS:> OS where type syserror = LibrarySupport.syserror (* Don't make it abstract a second time *) = struct - type syserror = SysWord.word (* Implemented as a SysWord.word value. *) + type syserror = LibrarySupport.syserror (* Implemented as a SysWord.word value. *) (* The calls themselves raise the SysCall exception. That has to be turned into a SysError exception. *) - exception SysErr = RunCall.SysErr + exception SysErr = LibrarySupport.SysErr (* Convert a numeric system error to a string. Note: unlike Posix.Error.errorName and Posix.Error.sysError the results are not defined other than that SOME e = syserror(errorName e) nor is this defined to be the same as the Posix.Error functions. Those are defined to return e.g. "etoobig". Here we return "E2BIG". *) val errorName: syserror -> string = RunCall.rtsCallFull1 "PolyProcessEnvErrorName" and errorMsg: syserror -> string = RunCall.rtsCallFull1 "PolyProcessEnvErrorMessage" local val doCall: string -> syserror = RunCall.rtsCallFull1 "PolyProcessEnvErrorFromString" in (* Convert a string to an error message if possible. *) fun syserror (s: string) : syserror option = let val n = doCall s in - if n = 0w0 then NONE else SOME n + if LibrarySupport.syserrorToWord n = 0w0 then NONE else SOME n end end structure Path:> OS_PATH = struct (* Note: The definition of relative and absolute paths are somewhat unclear and some of the examples seem contradictory. The definition I would prefer to use is that an absolute path is one which identifies a given file independent of any setting of the current directory. Hence the examples of "\" and "\A\B" as being absolute paths in DOS is in my opinion wrong. These are relative since they depend on the setting of the current volume. However this is a mess when it comes to fromString since if we don't treat "\A" as an absolute path it looks just like an absolute path with an empty arc. *) exception Path exception InvalidArc local val getOSCall: unit -> int = RunCall.rtsCallFast0 "PolyGetOSType" val getOS: int = getOSCall() in val isWindows = case getOS of 0 => false (* Posix *) | 1 => true | _ => raise Fail "Unknown operating system" end val isCaseSensitive = not isWindows val isSeparator = if isWindows then fn #"/" => true | #"\\" => true | _ => false else fn #"/" => true | _ => false val separator = if isWindows then "\\" else "/" val parentArc = ".." and currentArc = "." val isValidArc = if isWindows then let fun invalidChars #"\000" = true | invalidChars #"<" = true | invalidChars #">" = true | invalidChars #":" = true | invalidChars #"\"" = true | invalidChars #"\\" = true | invalidChars #"/" = true | invalidChars #"|" = true | invalidChars #"?" = true | invalidChars #"*" = true | invalidChars _ = false in not o (CharVector.exists invalidChars) end else let (* Posix - only null and / are invalid. *) fun invalidChars #"\000" = true | invalidChars #"/" = true | invalidChars _ = false in not o (CharVector.exists invalidChars) end local (* Given a string it examines the prefix and extracts the volume name if there is one. It returns the volume and also whether the name is absolute. It also returns the number of characters which matched so that this can be removed before treating the rest as a relative path. *) fun matchVolumePrefixPosix s = if String.size s > 0 andalso String.sub(s, 0) = #"/" then {volLen = 1, vol = "", abs = true, root = true } else {volLen = 0, vol = "", abs = false, root = false } fun matchVolumePrefixWindows s = let val slen = String.size s in if slen = 0 then { volLen = 0, vol = "", abs = false, root = false } else if slen >= 2 andalso String.sub(s, 1) = #":" andalso Char.isAlpha(String.sub(s, 0)) then if slen > 2 andalso isSeparator(String.sub(s, 2)) then { volLen = 3, vol = String.substring(s, 0, 2), abs = true, root = true } (* e.g. C:\ or C:\fred *) else { volLen = 2, vol = String.substring(s, 0, 2), abs = false, root = false } (* e.g. C: or C:fred *) else if slen > 2 andalso isSeparator(String.sub(s, 0)) andalso isSeparator(String.sub(s, 1)) then (* Looks like a UNC server name. See how big it is. *) let val (server, rest) = Substring.splitl(fn c => not (isSeparator c)) (Substring.extract(s, 2, NONE)) (* TODO: Is the server name actually valid? Assume yes. *) in if Substring.size rest = 0 then { volLen = 0, vol = "", abs = false, root = false } else (* Must be room for a share name as well. *) let val shareName = Substring.takel(fn c => not (isSeparator c)) (Substring.triml 1 rest) in { volLen = Substring.size server + Substring.size shareName + 4, vol = separator ^ separator ^ Substring.string server ^ separator ^ Substring.string shareName, abs = true, root = true } end end (* Leading \ in Windows means the "root" directory on the current drive. *) else if isSeparator(String.sub(s, 0)) then { volLen = 1, vol = "", abs = false, root = true } else { volLen = 0, vol = "", abs = false, root = false } end in val matchVolumePrefix = if isWindows then matchVolumePrefixWindows else matchVolumePrefixPosix end (* Internal - map the strings to the canonical case if they are not case sensitive. *) val toCanonicalCase = if isCaseSensitive then fn s => s else String.map Char.toLower (* Internal - are the arcs equivalent? *) fun equivalent (s, t) = toCanonicalCase s = toCanonicalCase t (* See if the volume name is valid for either an absolute or relative path. Windows relative paths may or may not have a volume but if they have the volume must look right. On Unix relative paths may not specify a volume and the only volume for absolute paths is the empty string. *) val validVolume = if isWindows then fn {isAbs, vol = ""} => not isAbs (* Empty volume is only valid for relative paths. *) | {vol, ...} => if size vol = 2 andalso String.sub(vol, 1) = #":" andalso Char.isAlpha(String.sub(vol, 0)) then true (* Drive letter e.g. C: *) else if size vol > 2 andalso isSeparator(String.sub(vol, 0)) then (* UNC name? \\server\share *) case String.fields isSeparator vol of ["", "", server, share] => server <> "" andalso share <> "" | _ => false else false else (* Posix. The volume must always be empty. *) fn {vol = "", ...} => true | _ => false (* We only return an empty arcs list if the argument is the empty string. *) fun fromString "" = {isAbs = false, vol = "", arcs=[]} | fromString (s: string) = let (* Do we have a volume name? *) val {volLen, vol, abs, root, ...} = matchVolumePrefix s (* The remainder forms a set of arcs. *) val rest = String.extract(s, volLen, NONE) val arcs = String.fields isSeparator rest (* If it begins with the Windows \ without a drive we need to add an extra empty arc. Otherwise we can't distinguish \a from a. *) val allArcs = if root andalso not abs then "" :: arcs else arcs in {isAbs = abs, vol = vol, arcs=allArcs} end (* Note: This is a mess as well. For example it says that it should raise Path if there is a relative path which begins with an empty arc. That's only true in Unix. What it should say is that it if isAbs is false then it should raise Path if the resulting path has the form of an absolute path. In Windows we should raise path if given (e.g.) {isAbs=false, vol="", arcs=["", "", "a", "b"]} because that looks like a UNC name. *) fun toString {isAbs : bool, vol : string, arcs : string list} = (* Check we have a valid volume. *) if not (validVolume{isAbs=isAbs, vol=vol}) then raise Path (* Check that each arc is valid. *) else if List.exists (fn s => not (isValidArc s)) arcs then raise InvalidArc else let (* Place separators between each arc. *) fun arcsToLinks [] = [] | arcsToLinks [a] = [a] | arcsToLinks (a::b) = a :: separator :: arcsToLinks b fun makePrefix(vol, false) = vol | makePrefix(vol, true) = vol ^ separator val r = String.concat(makePrefix(vol, isAbs) :: arcsToLinks arcs) (* Check to see whether we have turned a relative path into an absolute one by including empty arcs in the wrong places. *) val {abs = nowAbs, ...} = matchVolumePrefix r in if nowAbs <> isAbs then raise Path else r end (* Note: this is just defined to "return the volume portion" but doesn't say what to do if there isn't a volume. Seems simplest to define it as below. *) fun getVolume s = #vol(fromString s) (* Note: Once again this has very much a Unix view of the world, most of which almost works in Windows. I think the idea is that if possible it replaces the path with the path to the containing directory. If we're in the root directory we get the root directory. If we're in a path that ends with a component *) fun getParent "" = parentArc | getParent s = let val len = String.size s val {volLen, ...} = matchVolumePrefix s (* Split it at the last separator. *) val (prefix, suffix) = Substring.splitr (fn c => not (isSeparator c)) (Substring.full s) in if volLen = len then s (* We have a root. *) else if Substring.size suffix = 0 then (* If the last character is a separator just add on the parent arc (..) to refer to the parent directory. I don't know why we can't just remove the last component in this case but the examples don't do that. The only special case is where we have reached the root when we just return the root. *) s ^ parentArc else if Substring.size prefix = 0 then (* No separator at all *) ( if s = parentArc (* .. => ../.. *) then parentArc ^ (separator) ^ parentArc else if s = currentArc then parentArc (* . => .. *) else currentArc (* abc => . *) ) else if Substring.size prefix = volLen (* ??? If the prefix matches the volume then return the whole of prefix including the separator. *) then Substring.string prefix else (* Return the prefix with the separator removed. *) Substring.string(Substring.trimr 1 prefix) end (* Another mess defined in terms of examples for Unix from which one is expected to infer a general rule. It seems to split the string at the last separator and return the two halves without the separator except in the case where the directory is a root directory when a full volume name and separator are given. *) fun splitDirFile s = let (* Split it at the last separator. *) val (prefix, suffix) = Substring.splitr (fn c => not (isSeparator c)) (Substring.full s) val {volLen, vol, ...} = matchVolumePrefix s val dirName = case Substring.size prefix of 0 => "" | 1 => Substring.string prefix (* Special case of Windows \a. *) | _ => Substring.string(Substring.trimr 1 prefix) and fileName = Substring.string suffix in if volLen <> 0 andalso vol = dirName then {dir = vol ^ separator, file = fileName} else {dir = dirName, file = fileName} end fun dir s = #dir(splitDirFile s) and file s = #file(splitDirFile s) (* Question: It seems from the definition of toString that the arcs list can include separators. Is that true here? Assume yes. *) (* If the last character is already a separator we don't add one, e.g. if the directory is "/". *) fun joinDirFile{dir, file} = if not (isValidArc file) then raise InvalidArc else if dir = "" then file (* Return the file name unchanged *) else if isSeparator(String.sub(dir, size dir - 1)) then dir ^ file else dir ^ separator ^ file fun splitBaseExt s = let val slen = String.size s fun getExt n = if n <= 0 then NONE (* If it's at the start ignore it. *) else if isSeparator(String.sub(s, n)) then NONE else if String.sub(s, n) = #"." then (* Found a dot. *) ( if n = slen-1 then NONE (* Dot in last position. *) else if isSeparator(String.sub(s, n-1)) then NONE (* Dot immediately after separator. *) else SOME n ) else getExt (n-1) val extPos = getExt(slen - 1) in case extPos of NONE => {base=s, ext=NONE} | SOME n => {base=String.substring(s, 0, n), ext=SOME(String.substring(s, n+1, slen-n-1))} end fun joinBaseExt {base : string, ext = NONE} = base | joinBaseExt {base : string, ext = SOME ""} = base | joinBaseExt {base : string, ext = SOME ext} = base ^ "." ^ ext fun base s = #base(splitBaseExt s) and ext s = #ext(splitBaseExt s) val emptyArcIsRedundant = true fun mkCanonical s = let val {isAbs, vol, arcs} = fromString s fun collapse [] = [] | collapse (a :: b) = (* Work down the list removing currentArc entries and null entries (if the OS treats them as redundant).. *) if a = currentArc orelse (emptyArcIsRedundant andalso a = "") then collapse b (* Then work back up it removing parentArc entries. *) else case collapse b of [] => [a] | b' as (x :: y) => if x = parentArc andalso not (a = parentArc) then (* Remove "a" and "x". *) y else a :: b' val collapsed = collapse arcs (* If this is the root we can remove leading occurrences of the parent arc since the parent of the root is the root. *) fun removeLeadingParent [] = [] | removeLeadingParent (a::b) = if a = parentArc then removeLeadingParent b else a::b val newArcs = if isAbs then removeLeadingParent collapsed else collapsed val res = toString{isAbs=isAbs, vol=vol, arcs=newArcs} in (* Finally replace the empty string with "." and map to lower case if it's not case sensitive. *) if res = "" then currentArc else toCanonicalCase res end fun isCanonical s = mkCanonical s = s handle Path => false fun isAbsolute s = #isAbs(fromString s) and isRelative s = not(#isAbs(fromString s)) (* Concatenate two paths. The second must be relative and, if it contains a volume name, refer to the same volume as the first. *) fun concat(s, t) = let val {isAbs=absS, vol=volS, arcs=ArcsS} = fromString s val {isAbs=absT, vol=volT, arcs=ArcsT} = fromString t (* Concatenate the two lists of arcs except that a trailing empty arc on the first path is removed (i.e. concat("a/", "b") is the same as concat("a", "b") *) fun concatArcs [] p = p | concatArcs [a] p = if a = "" then p else a :: p | concatArcs (a::b) p = a :: concatArcs b p in if absT then raise Path else if volT <> "" andalso not(equivalent(volS, volT)) then raise Path else if #root(matchVolumePrefix t) (* Special case for Windows. concat("c:\\abc\\def", "\\xyz") is "c:\\xyz". *) then let (* Because this a relative path we have an extra empty arc here. *) val ArcsT' = case ArcsT of "" :: a => a | a => a in toString{isAbs=absS, vol=volS, arcs=ArcsT'} end else toString{isAbs=absS, vol=volS, arcs=concatArcs ArcsS ArcsT} end (* Make an absolute path by treating a relative path as relative to a given path. *) fun mkAbsolute {path, relativeTo} = let val {isAbs=absP, vol=volP, ...} = fromString path val {isAbs=absRT, vol=volRT, ...} = fromString relativeTo in if absP then path else if not absRT then raise Path (* If the path contained a volume it must be the same as the absolute path. *) else if volP <> "" andalso not(equivalent(volP, volRT)) then raise Path else mkCanonical(concat(relativeTo, path)) end (* Make a relative path by treating an absolute path as derived from a given other absolute path. *) fun mkRelative {path, relativeTo} = case fromString path of {isAbs=false, ...} => path (* Already relative *) | {vol=volP, arcs=arcsP, ...} => let val {isAbs=absRT, vol=volRT, arcs=arcsRT} = fromString (mkCanonical relativeTo) (* Add as many parent arcs as there are arcs in the path. *) fun addParents [] p = p | addParents (_::b) p = parentArc :: addParents b p fun matchPaths [] [] = [currentArc] (* Both equal *) | matchPaths p [] = (* Absolute path is finished - return p *) p | matchPaths [] r = (* Relative paths finished - add parent arcs *) addParents r [] | matchPaths (p :: p') (r :: r') = (* Are they the same arc? Note: When arcs are case insensitive I'm doing a case insensitive match here. *) if equivalent(p, r) then matchPaths p' r' else addParents (r :: r') (p :: p') (* We have a special case with the root directory (/ on Unix or c:\\ on Windows). In that case fromString returns a single empty arc and we want to remove it here otherwise we can end up with an empty arc in addParents. *) val arcsP' = case arcsP of [""] => [] | _ => arcsP val arcsRT' = case arcsRT of [""] => [] | _ => arcsRT in if not absRT then raise Path (* If the path contained a volume it must be the same as the absolute path. *) else if volP <> "" andalso not(equivalent(volP, volRT)) then raise Path else toString{isAbs=false, vol="", arcs=matchPaths arcsP' arcsRT'} end (* Another badly defined function. What is a root? Does it have to specify a volume or is \ a root in Windows? Assume that it must be absolute. *) fun isRoot s = let val {volLen, abs, ...} = matchVolumePrefix s in abs andalso volLen = String.size s andalso isCanonical s end (* Question: there's no definition of what these functions mean. The crucial questions are how to deal with volume names and also how to deal with symbols in the paths which may be invalid (e.g. path separators) in one or other system. For instance "a\b" is a valid file name in Unix and 31/3/2000 is valid in MacOS. Are they supposed to represent the original file system in some way? *) fun toUnixPath s = let (* We may have occurrences of "/" in the arcs if that is not a separator on this OS. Replace them by this machine's separator. *) fun mapArc a = if a = currentArc then "." else if a = parentArc then ".." else a fun mapArcs [] = [] | mapArcs [a] = [mapArc a] | mapArcs (a::b) = mapArc a :: "/" :: mapArcs b val {isAbs, vol, arcs} = fromString s val volArc = if vol <> "" then vol :: arcs else arcs val sl = String.concat(mapArcs volArc) in if String.size sl = 0 then "" else if isAbs then if String.sub(sl, 0) <> #"/" then "/" ^ sl else sl else (* not abs *) if String.sub(sl, 0) = #"/" then "." ^ sl else sl end fun fromUnixPath s = let val arcs = String.fields (fn ch => ch = #"/") s (* Turn any occurrences of this OS's separator into / since that can't occur within an arc. *) val convArc = String.translate ( fn ch => if isSeparator ch then "/" else String.str ch) val convArcs = List.map convArc arcs in case convArcs of [] => "" | ("" :: a :: rest) => let (* We had a leading / : is the first arc a volume name? *) val {volLen = n, vol, ...} = matchVolumePrefix a in if n = String.size a then (* We have a volume name. *) toString{isAbs=true, vol=vol, arcs=rest} else toString{isAbs=true, vol="", arcs=convArcs} end | (a :: rest) => let (* May be a relative volume name. *) val {volLen = n, vol, ...} = matchVolumePrefix a in if n = String.size a then toString{isAbs=false, vol=vol, arcs=rest} else toString{isAbs=false, vol="", arcs=convArcs} end end end (* Path *) structure FileSys:> OS_FILE_SYS = struct type dirFd = int (* The directory stream consists of the stream identifier returned by openDir together with the original directory name. We need that for rewind in Windows. *) datatype dirstream = DIR of dirFd * string local val doIo: int*unit*string -> dirFd = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun openDir (s : string): dirstream = DIR(doIo(50, (), s), s) end local val doIo: int*dirFd*unit -> string = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun readDir (DIR(d, _)): string option = let (* This returns the empty string at end-of-stream. *) val s = doIo(51, d, ()) in if s = "" then NONE else SOME s end end local val doIo: int*dirFd*unit -> unit = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun closeDir(DIR(d, _)) = doIo(52, d, ()) end local val doIo: int*dirFd*string -> unit = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in (* We need to pass in the string because Windows has to reopen the stream. *) fun rewindDir(DIR(d, s)) = doIo(53, d, s) end val chDir: string -> unit = RunCall.rtsCallFull1 "PolyChDir" local val doIo: int*unit*unit -> string = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in (* Return current directory. *) fun getDir() = doIo(54, (), ()) (* Get a temporary file name. *) fun tmpName() = doIo(67, (), ()) end local val doIo: int*unit*string -> unit = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in (* Create and delete directories and remove a file. *) fun mkDir s = doIo(55, (), s) and rmDir s = doIo(56, (), s) and remove s = doIo(64, (), s) end local val doIo: int*unit*string -> bool = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in (* Test for directory and symbolic link. *) fun isDir s = doIo(57, (), s) and isLink s = doIo(58, (), s) end local val doIo: int*unit*string -> string = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in (* Read a symbolic link. *) fun readLink s = doIo(59, (), s) (* Get a full canonical path name. *) and fullPath s = doIo(60, (), s) end local val doIo: int*unit*string -> Time.time = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in (* Get file modification time. *) fun modTime s = doIo(61, (), s) end local val doIo: int*unit*string -> Position.int (* This can be larger than 32-bits. *) = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in (* Get file size. *) fun fileSize s = doIo(62, (), s) end local val doIo: int*string*Time.time -> unit = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in (* Get file size. *) fun setTime(s, NONE) = doIo(63, s, Time.now()) | setTime(s, SOME t) = doIo(63, s, t) end local val doIo: int*string*string -> unit = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in (* Rename a file. *) fun rename {old, new} = doIo(65, old, new) end datatype access_mode = A_READ | A_WRITE | A_EXEC local val doIo: int*string*word -> bool = RunCall.rtsCallFull3 "PolyBasicIOGeneral" fun mapAccess (A_READ, m) = Word.orb(m, 0w1) | mapAccess (A_WRITE, m) = Word.orb(m, 0w2) | mapAccess (A_EXEC, m) = Word.orb(m, 0w4) in (* Get access rights. *) fun access (s, m) = doIo(66, s, List.foldl mapAccess 0w0 m) end (* file_id seems to be intended to reflect the semantics of a Unix inode. That concept doesn't exist in Windows so we use a canonical file name instead. *) datatype file_id = INODE of LargeInt.int | FILENAME of string fun compare(INODE i, INODE j) = LargeInt.compare(i, j) | compare(FILENAME s, FILENAME t) = String.compare(s, t) | (* These cases shouldn't happen but we'll define them anyway. *) compare(INODE _, FILENAME _) = General.GREATER | compare(FILENAME _, INODE _) = General.LESS (* TODO: The hash function is supposed to well distribute the the values when taken modulo 2^n for any n. I'm sure we can come up with something better than this. *) fun hash(INODE i) = let open Word infix xorb << val w = Word.fromLargeInt i in w xorb (w << 0w8) xorb (w << 0w16) xorb (w << 0w24) end | hash(FILENAME s) = (* Simple hash function which multiplies the accumulator by 7 and adds in the next character. *) CharVector.foldl (fn(c, a) => a * 0w7 + Word.fromInt(Char.ord c)) 0w0 s local val doIo: int*unit*string -> LargeInt.int = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in (* Get file id (inode). Returns negative value if inodes aren't supported. *) fun fileId s = let val i = doIo(68, (), s) in if i < 0 then FILENAME(fullPath s) else INODE i end end fun realPath p = if Path.isAbsolute p then fullPath p else Path.mkRelative{path=fullPath p, relativeTo=fullPath(getDir())} end (* FileSys *) structure IO :> OS_IO = struct datatype iodesc = IODESC of int (* Actually abstract. This isn't the file descriptor itself, rather a pointer into the io table. *) local val doIo: int*iodesc*unit -> int = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in (* Get underlying index. *) fun getIndex f = doIo(69, f, ()) end (* TODO: The hash function is supposed to well distribute the the values when taken modulo 2^n for any n. I'm sure we can come up with something better than this. *) fun hash (i: iodesc) : word = let open Word infix xorb << val w = Word.fromInt(getIndex i) in w xorb (w << 0w8) xorb (w << 0w16) xorb (w << 0w24) end fun compare(i, j) = Int.compare(getIndex i, getIndex j) (* eq *)type iodesc_kind = int structure Kind = struct val file : iodesc_kind = 0 val dir : iodesc_kind = 1 val symlink : iodesc_kind = 2 val tty : iodesc_kind = 3 val pipe : iodesc_kind = 4 val socket : iodesc_kind = 5 val device : iodesc_kind = 6 end local val doIo: int*iodesc*int -> int = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun kind (i: iodesc): iodesc_kind = let val k = doIo(21, i, 0) in (* Returns a negative number if the call fails, otherwise one of the above numbers. Returns 7 on unknown or something else. *) if k < 0 orelse k > 6 then raise SysErr("Invalid result", NONE) else k end end (* The poll descriptor and the result of polling is a bit map together with the io descriptor. *) val inBit = 0w1 and outBit = 0w2 and priBit = 0w4 (* N.B. The implementation of poll_desc is hard-wired into Socket.pollDesc. *) type poll_desc = word*iodesc datatype poll_info = PI of word*poll_desc local val doIo: int*iodesc*int -> word = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun sys_poll_test(i: iodesc) = doIo(22, i, 0) end - local - val doIo: int*int* - (iodesc Vector.vector * word Vector.vector * Time.time) -> - word Vector.vector - = RunCall.rtsCallFull3 "PolyBasicIOGeneral" - in - fun sys_poll_block(iov, wv) = doIo(23, 0, (iov, wv, Time.zeroTime)) - fun sys_poll_poll(iov, wv) = doIo(25, 0, (iov, wv, Time.zeroTime)) - and sys_poll_wait (iov, wv, t) = doIo(24, 0, (iov, wv, t)) - end + val sysPoll:iodesc Vector.vector * word Vector.vector * int -> word Vector.vector = + RunCall.rtsCallFull3 "PolyPollIODescriptors" fun pollDesc (i: iodesc): poll_desc option = (* If the poll test returns zero then polling is not allowed for any mode. *) if sys_poll_test i = 0w0 then NONE else SOME(0w0, i) fun pollToIODesc(_, i): iodesc = i exception Poll (* Add the appropriate bit to the set if it is allowed. *) local fun addBit b ((bm, i)) = if Word.andb(sys_poll_test i, b) = 0w0 then raise Poll else (Word.orb(bm, b), i) in val pollIn = addBit inBit and pollOut = addBit outBit and pollPri = addBit priBit end - fun poll (l : poll_desc list, t: Time.time Option.option) : - poll_info list = + fun poll (l : poll_desc list, t: Time.time Option.option) : poll_info list = let (* The original poll descriptor list may contain multiple occurrences of the same IO descriptor with the same or different flags. On Cygwin, at least, passing this directly produces funny results so we transform the request so that we make at most one request for each descriptor. *) local fun quickSort _ ([]:'a list) = [] | quickSort _ ([h]:'a list) = [h] | quickSort (leq:'a -> 'a -> bool) ((h::t) :'a list) = let val (after, befor) = List.partition (leq h) t in quickSort leq befor @ (h :: quickSort leq after) end; fun leqPoll((p1, f1): poll_desc) ((p2, f2): poll_desc) = case compare(f1, f2) of EQUAL => p1 <= p2 | LESS => true | GREATER => false fun merge ((p1, f1) :: (p2, f2) :: rest) = if compare(f1, f2) = EQUAL then merge((Word.orb(p1, p2), f1) :: rest) else (p1, f1) :: merge((p2, f2) :: rest) | merge c = c val sortedDescs = quickSort leqPoll l in val mergedDescs = merge sortedDescs end (* Turn the list into vectors of io descriptors and request bits - easier for the RTS to manage. N.B. This assumes that Vector.vector creates a simple memory vector and does not wrap it in any way. *) local val (bits, ioDescs) = ListPair.unzip mergedDescs in val bitVector: word Vector.vector = Vector.fromList bits and ioVector: iodesc Vector.vector = Vector.fromList ioDescs end - (* Do the actual polling. Returns a vector with bits - set for the results. *) - val resV: word Vector.vector = - case t of - NONE => sys_poll_block(ioVector, bitVector) - | SOME tt => - let - open Time - in - if tt = Time.zeroTime - then sys_poll_poll(ioVector, bitVector) - else if tt < Time.zeroTime - (* Must check for negative times since these can be - interpreted as infinity. *) - then raise SysErr("Invalid time", NONE) - (* For non-zero times we convert this to a number of - milliseconds since the current time. We have to - pass in an absolute time rather than a relative - time because the RTS may retry this call if the - polled events haven't happened. *) - else sys_poll_wait(ioVector, bitVector, tt + Time.now()) - end + (* Do the actual polling. Returns a vector with bits set for the results. *) + val finishTime = case t of NONE => NONE | SOME t => SOME(t + Time.now()) + + val pollMillSeconds = 1000 (* 1 second *) + fun doPoll() = + let + val timeToGo = + case finishTime of + NONE => pollMillSeconds + | SOME finish => LargeInt.toInt(LargeInt.min(LargeInt.max(0, Time.toMilliseconds(finish-Time.now())), LargeInt.fromInt pollMillSeconds)) + + (* Poll the descriptors. Returns after the timeout whether or not they are ready. *) + val resV = sysPoll(ioVector, bitVector, timeToGo) + in + if timeToGo < pollMillSeconds orelse Vector.exists(fn w => w <> 0w0) resV + then resV + else doPoll() + end + + val resV : word Vector.vector = doPoll() + (* Process the original list to see which items are present, retaining the original order. *) fun testResults(request as (bits, iod), tl) = let val (index, _) = (* Find the IO descriptor. It must be there somewhere. *) valOf(Vector.findi (fn (_, iod1) => compare(iod, iod1) = EQUAL) ioVector) (* The result is in the corresponding index position. We need to AND this with the request because we could have separate requests asking for different bits for the same file descriptor. *) val result = Word.andb(bits, Vector.sub(resV, index)) in if result = 0w0 then tl else PI(result, request) :: tl end in List.foldl testResults [] l end fun isIn(PI(b, _)) = Word.andb(b, inBit) <> 0w0 and isOut(PI(b, _)) = Word.andb(b, outBit) <> 0w0 and isPri(PI(b, _)) = Word.andb(b, priBit) <> 0w0 fun infoToPollDesc (PI(_, pd)) = pd end (* IO *) structure Process:> OS_PROCESS = struct type status = int - local - val doCall: int*unit -> int - = RunCall.rtsCallFull2 "PolyProcessEnvGeneral" - in - val success = doCall(15, ()) - and failure = doCall(16, ()) - end + val success = RunCall.rtsCallFull0 "PolyProcessEnvSuccessValue" () + and failure = RunCall.rtsCallFull0 "PolyProcessEnvFailureValue" () fun isSuccess i = i = success - local - val doCall: int*string -> status - = RunCall.rtsCallFull2 "PolyProcessEnvGeneral" - in - (* Run a process and wait for the result. *) - fun system s = doCall(17, s) - end + (* Run a process and wait for the result. *) + val system: string -> status = RunCall.rtsCallFull1 "PolyProcessEnvSystem" local - val doCall: int*(unit->unit) -> unit - = RunCall.rtsCallFull2 "PolyProcessEnvGeneral" - in - (* Register a function to be run at exit. *) - fun atExit f = doCall(18, f) - end - - local + val locker = Thread.Mutex.mutex() + val exitFns: (unit -> unit) list ref = ref [] (* exit - supply result code and close down all threads. *) - val doExit: int -> unit = RunCall.rtsCallFull1 "PolyFinish" - val doCall: int*unit -> (unit->unit) = - RunCall.rtsCallFull2 "PolyProcessEnvGeneral" + val reallyExit: int -> unit = RunCall.rtsCallFull1 "PolyFinish" + (* The definition says that if any of the exit functions call + "exit" then they do not return but subsequent atExit functions + are executed. A call to exit takes a single function off the + atExit list so any exit calls within an atExit "take over" + the exit process. *) + fun nextExit n = + case !exitFns of + [] => (fn () => reallyExit n) + | (hd :: tl) => (exitFns := tl; hd) in fun exit (n: int) = - let - (* Get a function from the atExit list. If that list - is empty it will raise an exception and we've finished. *) - val exitFun = - doCall(19, ()) handle _ => (doExit n; fn () => ()) - in - (* Run the function and then repeat. *) - exitFun() handle _ => (); (* Ignore exceptions in the function. *) - exit(n) - end + ( + ThreadLib.protect locker nextExit n () handle _ => (); + exit n + ) + + (* Add an exit function to the list. Functions are executed in reverse + order of registration. *) + val atExit = ThreadLib.protect locker (fn f => exitFns := f :: !exitFns) end (* Terminate without running the atExit list or flushing the buffers. We raise an exception to get the type right. *) local val doCall: int -> unit = RunCall.rtsCallFull1 "PolyTerminate" in fun terminate n = (doCall n; raise Fail "never") end local - val doCall: int*string -> string - = RunCall.rtsCallFull2 "PolyProcessEnvGeneral" + val doCall: string -> string = RunCall.rtsCallFull1 "PolyGetEnv" in (* Get an environment string. The underlying call raises an exception if the string isn't there. *) - fun getEnv s = - SOME(doCall(14, s)) handle RunCall.SysErr _ => NONE + fun getEnv s = SOME(doCall s) handle RunCall.SysErr _ => NONE end (* poll is implemented so that an empty list simply waits for the time. *) fun sleep t = (IO.poll([], SOME t); ()) end (* Process. *) end; local (* Install the pretty printer for OS.IO.Kind and OS.syserror. *) fun kind_string k = if k = OS.IO.Kind.file then "file" else if k = OS.IO.Kind.dir then "dir" else if k = OS.IO.Kind.symlink then "symlink" else if k = OS.IO.Kind.tty then "tty" else if k = OS.IO.Kind.pipe then "pipe" else if k = OS.IO.Kind.socket then "socket" else if k = OS.IO.Kind.device then "device" else "unknown" fun printKind _ _ x = PolyML.PrettyString(kind_string x) fun printSysError _ _ x = PolyML.PrettyString(OS.errorName x) (* For the moment just make these opaque. *) fun printPollDesc _ _ (_: OS.IO.poll_desc) = PolyML.PrettyString "?" and printPollInfo _ _ (_: OS.IO.poll_info) = PolyML.PrettyString "?" in val () = PolyML.addPrettyPrinter printKind val () = PolyML.addPrettyPrinter printSysError val () = PolyML.addPrettyPrinter printPollDesc val () = PolyML.addPrettyPrinter printPollInfo end diff --git a/basis/Posix.sml b/basis/Posix.sml index d2615388..b016e2f8 100644 --- a/basis/Posix.sml +++ b/basis/Posix.sml @@ -1,1710 +1,1710 @@ (* Title: Standard Basis Library: Posix structure and signature. Copyright David Matthews 2000, 2016-17, 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 POSIX_ERROR = sig type syserror = OS.syserror (* G&R 2004 has an error *) val toWord : syserror -> SysWord.word val fromWord : SysWord.word -> syserror val errorMsg : syserror -> string val errorName : syserror -> string val syserror : string -> syserror option val acces : syserror val again : syserror val badf : syserror val badmsg : syserror val busy : syserror val canceled (* sic *) : syserror val child : syserror val deadlk : syserror val dom : syserror val exist : syserror val fault : syserror val fbig : syserror val inprogress : syserror val intr : syserror val inval : syserror val io : syserror val isdir : syserror val loop : syserror val mfile : syserror val mlink : syserror val msgsize : syserror val nametoolong : syserror val nfile : syserror val nodev : syserror val noent : syserror val noexec : syserror val nolck : syserror val nomem : syserror val nospc : syserror val nosys : syserror val notdir : syserror val notempty : syserror val notsup : syserror val notty : syserror val nxio : syserror val perm : syserror val pipe : syserror val range : syserror val rofs : syserror val spipe : syserror val srch : syserror val toobig : syserror val xdev : syserror end; signature POSIX_SIGNAL = sig eqtype signal val toWord : signal -> SysWord.word val fromWord : SysWord.word -> signal val abrt : signal val alrm : signal val bus : signal val fpe : signal val hup : signal val ill : signal val int : signal val kill : signal val pipe : signal val quit : signal val segv : signal val term : signal val usr1 : signal val usr2 : signal val chld : signal val cont : signal val stop : signal val tstp : signal val ttin : signal val ttou : signal end; signature POSIX_PROCESS = sig eqtype signal eqtype pid val wordToPid : SysWord.word -> pid val pidToWord : pid -> SysWord.word val fork : unit -> pid option val exec : string * string list -> 'a val exece : string * string list * string list -> 'a val execp : string * string list -> 'a datatype waitpid_arg = W_ANY_CHILD | W_CHILD of pid | W_SAME_GROUP | W_GROUP of pid datatype exit_status = W_EXITED | W_EXITSTATUS of Word8.word | W_SIGNALED (* sic *) of signal | W_STOPPED of signal val fromStatus : OS.Process.status -> exit_status structure W: sig include BIT_FLAGS val untraced : flags end val wait : unit -> pid * exit_status val waitpid : waitpid_arg * W.flags list -> pid * exit_status val waitpid_nh : waitpid_arg * W.flags list -> (pid * exit_status) option val exit : Word8.word -> 'a datatype killpid_arg = K_PROC of pid | K_SAME_GROUP | K_GROUP of pid val kill : killpid_arg * signal -> unit val alarm : Time.time -> Time.time val pause : unit -> unit - (* QUESTION: Why does sleep return a Time.time ? Is it intended to be the - time remaining? Assume so. *) val sleep : Time.time -> Time.time end; signature POSIX_PROC_ENV = sig eqtype pid eqtype uid eqtype gid eqtype file_desc val uidToWord : uid -> SysWord.word val wordToUid : SysWord.word -> uid val gidToWord : gid -> SysWord.word val wordToGid : SysWord.word -> gid val getpid : unit -> pid val getppid : unit -> pid val getuid : unit -> uid val geteuid : unit -> uid val getgid : unit -> gid val getegid : unit -> gid val setuid : uid -> unit val setgid : gid -> unit val getgroups : unit -> gid list val getlogin : unit -> string val getpgrp : unit -> pid val setsid : unit -> pid val setpgid : {pid : pid option, pgid : pid option} -> unit val uname : unit -> (string * string) list val time : unit -> Time.time val times : unit -> { elapsed : Time.time, utime : Time.time, stime : Time.time, cutime : Time.time, cstime : Time.time } val getenv : string -> string option val environ : unit -> string list val ctermid : unit -> string val ttyname : file_desc -> string val isatty : file_desc -> bool val sysconf : string -> SysWord.word end; signature POSIX_FILE_SYS = sig eqtype uid eqtype gid eqtype file_desc val fdToWord : file_desc -> SysWord.word val wordToFD : SysWord.word -> file_desc val fdToIOD : file_desc -> OS.IO.iodesc val iodToFD : OS.IO.iodesc -> file_desc option type dirstream val opendir : string -> dirstream val readdir : dirstream -> string option val rewinddir : dirstream -> unit val closedir : dirstream -> unit val chdir : string -> unit val getcwd : unit -> string val stdin : file_desc val stdout : file_desc val stderr : file_desc structure S : sig eqtype mode include BIT_FLAGS where type flags = mode val irwxu : mode val irusr : mode val iwusr : mode val ixusr : mode val irwxg : mode val irgrp : mode val iwgrp : mode val ixgrp : mode val irwxo : mode val iroth : mode val iwoth : mode val ixoth : mode val isuid : mode val isgid : mode end structure O: sig include BIT_FLAGS val append : flags val excl : flags val noctty : flags val nonblock : flags val sync : flags val trunc : flags end datatype open_mode = O_RDONLY | O_WRONLY | O_RDWR val openf : string * open_mode * O.flags -> file_desc val createf : string * open_mode * O.flags * S.mode -> file_desc val creat : string * S.mode -> file_desc val umask : S.mode -> S.mode val link : {old : string, new : string} -> unit val mkdir : string * S.mode -> unit val mkfifo : string * S.mode -> unit val unlink : string -> unit val rmdir : string -> unit val rename : {old : string, new : string} -> unit val symlink : {old : string, new : string} -> unit val readlink : string -> string eqtype dev val wordToDev : SysWord.word -> dev val devToWord : dev -> SysWord.word eqtype ino val wordToIno : SysWord.word -> ino val inoToWord : ino -> SysWord.word structure ST: sig type stat val isDir : stat -> bool val isChr : stat -> bool val isBlk : stat -> bool val isReg : stat -> bool val isFIFO : stat -> bool val isLink : stat -> bool val isSock : stat -> bool val mode : stat -> S.mode val ino : stat -> ino val dev : stat -> dev val nlink : stat -> int val uid : stat -> uid val gid : stat -> gid val size : stat -> Position.int val atime : stat -> Time.time val mtime : stat -> Time.time val ctime : stat -> Time.time end val stat : string -> ST.stat val lstat : string -> ST.stat val fstat : file_desc -> ST.stat datatype access_mode = A_READ | A_WRITE | A_EXEC val access : string * access_mode list -> bool val chmod : string * S.mode -> unit val fchmod : file_desc * S.mode -> unit val chown : string * uid * gid -> unit val fchown : file_desc * uid * gid -> unit val utime : string * {actime : Time.time, modtime : Time.time} option -> unit val ftruncate : file_desc * Position.int -> unit val pathconf : string * string -> SysWord.word option val fpathconf : file_desc * string -> SysWord.word option end; signature POSIX_IO = sig eqtype file_desc eqtype pid val pipe: unit -> {infd : file_desc, outfd : file_desc} val dup: file_desc -> file_desc val dup2: {old : file_desc, new : file_desc} -> unit val close: file_desc -> unit val readVec : file_desc * int -> Word8Vector.vector val readArr: file_desc * Word8ArraySlice.slice -> int val writeVec: file_desc * Word8VectorSlice.slice -> int val writeArr: file_desc * Word8ArraySlice.slice -> int datatype whence = SEEK_SET | SEEK_CUR | SEEK_END structure FD: sig include BIT_FLAGS val cloexec: flags end structure O: sig include BIT_FLAGS val append : flags val nonblock : flags val sync : flags end datatype open_mode = O_RDONLY | O_WRONLY | O_RDWR val dupfd : {old : file_desc, base : file_desc} -> file_desc val getfd : file_desc -> FD.flags val setfd : file_desc * FD.flags -> unit val getfl : file_desc -> O.flags * open_mode val setfl : file_desc * O.flags -> unit val lseek : file_desc * Position.int * whence -> Position.int val fsync : file_desc -> unit datatype lock_type = F_RDLCK | F_WRLCK | F_UNLCK structure FLock: sig type flock val flock : { ltype : lock_type, whence : whence, start : Position.int, len : Position.int, pid : pid option } -> flock val ltype : flock -> lock_type val whence : flock -> whence val start : flock -> Position.int val len : flock -> Position.int val pid : flock -> pid option end val getlk : file_desc * FLock.flock -> FLock.flock val setlk : file_desc * FLock.flock -> FLock.flock val setlkw : file_desc * FLock.flock -> FLock.flock val mkBinReader: { fd : file_desc, name : string, initBlkMode : bool } -> BinPrimIO.reader val mkTextReader: { fd : file_desc, name : string, initBlkMode : bool } -> TextPrimIO.reader val mkBinWriter: { fd : file_desc, name : string, appendMode : bool, initBlkMode : bool, chunkSize : int } -> BinPrimIO.writer val mkTextWriter: { fd : file_desc, name : string, appendMode : bool, initBlkMode : bool, chunkSize : int } -> TextPrimIO.writer end; signature POSIX_SYS_DB = sig eqtype uid eqtype gid structure Passwd : sig type passwd val name : passwd -> string val uid : passwd -> uid val gid : passwd -> gid val home : passwd -> string val shell : passwd -> string end structure Group : sig type group val name : group -> string val gid : group -> gid val members : group -> string list end val getgrgid : gid -> Group.group val getgrnam : string -> Group.group val getpwuid : uid -> Passwd.passwd val getpwnam : string -> Passwd.passwd end; signature POSIX_TTY = sig eqtype pid eqtype file_desc structure V : sig val eof : int val eol : int val erase : int val intr : int val kill : int val min : int val quit : int val susp : int val time : int val start : int val stop : int val nccs : int type cc val cc : (int * char) list -> cc val update : cc * (int * char) list -> cc val sub : cc * int -> char end structure I : sig include BIT_FLAGS val brkint : flags val icrnl : flags val ignbrk : flags val igncr : flags val ignpar : flags val inlcr : flags val inpck : flags val istrip : flags val ixoff : flags val ixon : flags val parmrk : flags end structure O : sig include BIT_FLAGS val opost : flags end structure C : sig include BIT_FLAGS val clocal : flags val cread : flags val cs5 : flags val cs6 : flags val cs7 : flags val cs8 : flags val csize : flags val cstopb : flags val hupcl : flags val parenb : flags val parodd : flags end structure L : sig include BIT_FLAGS val echo : flags val echoe : flags val echok : flags val echonl : flags val icanon : flags val iexten : flags val isig : flags val noflsh : flags val tostop : flags end eqtype speed val compareSpeed : speed * speed -> order val speedToWord : speed -> SysWord.word val wordToSpeed : SysWord.word -> speed val b0 : speed val b50 : speed val b75 : speed val b110 : speed val b134 : speed val b150 : speed val b200 : speed val b300 : speed val b600 : speed val b1200 : speed val b1800 : speed val b2400 : speed val b4800 : speed val b9600 : speed val b19200 : speed val b38400 : speed type termios val termios : { iflag : I.flags, oflag : O.flags, cflag : C.flags, lflag : L.flags, cc : V.cc, ispeed : speed, ospeed : speed } -> termios val fieldsOf : termios -> { iflag : I.flags, oflag : O.flags, cflag : C.flags, lflag : L.flags, cc : V.cc, ispeed : speed, ospeed : speed } val getiflag : termios -> I.flags val getoflag : termios -> O.flags val getcflag : termios -> C.flags val getlflag : termios -> L.flags val getcc : termios -> V.cc structure CF : sig val getospeed : termios -> speed val setospeed : termios * speed -> termios val getispeed : termios -> speed val setispeed : termios * speed -> termios end structure TC : sig eqtype set_action val sanow : set_action val sadrain : set_action val saflush : set_action eqtype flow_action val ooff : flow_action val oon : flow_action val ioff : flow_action val ion : flow_action eqtype queue_sel val iflush : queue_sel val oflush : queue_sel val ioflush : queue_sel val getattr : file_desc -> termios val setattr : file_desc * set_action * termios -> unit val sendbreak : file_desc * int -> unit val drain : file_desc -> unit val flush : file_desc * queue_sel -> unit val flow : file_desc * flow_action -> unit end val getpgrp : file_desc -> pid val setpgrp : file_desc * pid -> unit end; signature POSIX = sig structure Error : POSIX_ERROR structure Signal : POSIX_SIGNAL structure Process : POSIX_PROCESS where type signal = Signal.signal structure ProcEnv : POSIX_PROC_ENV where type pid = Process.pid structure FileSys : POSIX_FILE_SYS where type file_desc = ProcEnv.file_desc where type uid = ProcEnv.uid where type gid = ProcEnv.gid structure IO : POSIX_IO where type pid = Process.pid where type file_desc = ProcEnv.file_desc where type open_mode = FileSys.open_mode structure SysDB : POSIX_SYS_DB where type uid = ProcEnv.uid where type gid = ProcEnv.gid structure TTY : POSIX_TTY where type pid = Process.pid where type file_desc = ProcEnv.file_desc end; structure Posix :> sig include POSIX (* I'm not sure if it's legal to use where type with a datatype. The alternative is to copy the whole of the signature and use datatype replication. *) where type FileSys.access_mode = OS.FileSys.access_mode sharing type Process.pid = ProcEnv.pid = IO.pid = TTY.pid sharing type ProcEnv.uid = FileSys.uid = SysDB.uid sharing type ProcEnv.gid = FileSys.gid = SysDB.gid sharing type ProcEnv.file_desc = FileSys.file_desc = IO.file_desc = TTY.file_desc end (* Posix.Signal.signal is made the same as int so that we can pass the values directly to our (non-standard) Signal.signal function. Since there isn't a standard way of handling signals this is the best we can do. *) where type Signal.signal = int where type FileSys.dirstream = OS.FileSys.dirstream = struct local - val processEnvGeneralCall = RunCall.rtsCallFull2 "PolyProcessEnvGeneral" - and osSpecificGeneralCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" - and timingGeneralCall = RunCall.rtsCallFull2 "PolyTimingGeneral" + val osSpecificGeneralCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" in - fun processEnvGeneral(code: int, arg:'a):'b = RunCall.unsafeCast(processEnvGeneralCall(RunCall.unsafeCast(code, arg))) - and osSpecificGeneral(code: int, arg:'a):'b = RunCall.unsafeCast(osSpecificGeneralCall(RunCall.unsafeCast(code, arg))) - and timingGeneral(code: int, arg:'a):'b = RunCall.unsafeCast(timingGeneralCall(RunCall.unsafeCast(code, arg))) + fun osSpecificGeneral(code: int, arg:'a):'b = RunCall.unsafeCast(osSpecificGeneralCall(RunCall.unsafeCast(code, arg))) end fun getConst i : SysWord.word = osSpecificGeneral (4, i) structure BitFlags = (* This structure is used as the basis of all the BIT_FLAGS structures. *) struct type flags = SysWord.word fun toWord f = f fun fromWord f = f val flags = List.foldl (fn (a, b) => SysWord.orb(a,b)) 0w0 fun allSet (fl1, fl2) = SysWord.andb(fl1, fl2) = fl1 fun anySet (fl1, fl2) = SysWord.andb(fl1, fl2) <> 0w0 fun clear (fl1, fl2) = SysWord.andb(SysWord.notb fl1, fl2) end structure Error = struct type syserror = OS.syserror (* Implemented as a SysWord.word value. *) val errorMsg = OS.errorMsg - fun toWord (s: syserror): SysWord.word = RunCall.unsafeCast s - and fromWord (w: SysWord.word) : syserror = RunCall.unsafeCast w + + val toWord = LibrarySupport.syserrorToWord + and fromWord = LibrarySupport.syserrorFromWord val toobig = fromWord(getConst 0) and acces = fromWord(getConst 1) and again = fromWord(getConst 2) and badf = fromWord(getConst 3) and badmsg = fromWord(getConst 4) and busy = fromWord(getConst 5) and canceled (* sic *) = fromWord(getConst 6) and child = fromWord(getConst 7) and deadlk = fromWord(getConst 8) and dom = fromWord(getConst 9) and exist = fromWord(getConst 10) and fault = fromWord(getConst 11) and fbig = fromWord(getConst 12) and inprogress = fromWord(getConst 13) and intr = fromWord(getConst 14) and inval = fromWord(getConst 15) and io = fromWord(getConst 16) and isdir = fromWord(getConst 17) and loop = fromWord(getConst 18) and mfile = fromWord(getConst 19) and mlink = fromWord(getConst 20) and msgsize = fromWord(getConst 21) and nametoolong = fromWord(getConst 22) and nfile = fromWord(getConst 23) and nodev = fromWord(getConst 24) and noent = fromWord(getConst 25) and noexec = fromWord(getConst 26) and nolck = fromWord(getConst 27) and nomem = fromWord(getConst 28) and nospc = fromWord(getConst 29) and nosys = fromWord(getConst 30) and notdir = fromWord(getConst 31) and notempty = fromWord(getConst 32) and notsup = fromWord(getConst 33) and notty = fromWord(getConst 34) and nxio = fromWord(getConst 35) and perm = fromWord(getConst 36) and pipe = fromWord(getConst 37) and range = fromWord(getConst 38) and rofs = fromWord(getConst 39) and spipe = fromWord(getConst 40) and srch = fromWord(getConst 41) and xdev = fromWord(getConst 42) val errNames = [ (acces, "acces"), (again, "again"), (badf, "badf"), (badmsg, "badmsg"), (busy, "busy"), (canceled, "canceled"), (child, "child"), (deadlk, "deadlk"), (dom, "dom"), (exist, "exist"), (fault, "fault"), (fbig, "fbig"), (inprogress, "inprogress"), (intr, "intr"), (inval, "inval"), (io, "io"), (isdir, "isdir"), (loop, "loop"), (mfile, "mfile"), (mlink, "mlink"), (msgsize, "msgsize"), (nametoolong, "nametoolong"), (nfile, "nfile"), (nodev, "nodev"), (noent, "noent"), (noexec, "noexec"), (nolck, "nolck"), (nomem, "nomem"), (nospc, "nospc"), (nosys, "nosys"), (notdir, "notdir"), (notempty, "notempty"), (notsup, "notsup"), (notty, "notty"), (nxio, "nxio"), (perm, "perm"), (pipe, "pipe"), (range, "range"), (rofs, "rofs"), (spipe, "spipe"), (srch, "srch"), (toobig, "toobig"), (xdev, "xdev") ] (* These are defined to return the names above. *) fun errorName n = case List.find (fn (e, _) => e = n) errNames of SOME(_, s) => s | NONE => OS.errorName n fun syserror s = case List.find (fn (_, t) => s = t) errNames of SOME(e, _) => SOME e | NONE => OS.syserror s end; structure Signal = struct type signal = int val toWord = SysWord.fromInt and fromWord = SysWord.toInt (* These signal values are probably defined to correspond to particular numbers but there's no harm in getting them from the RTS. *) val abrt = fromWord(getConst 43) and alrm = fromWord(getConst 44) and bus = fromWord(getConst 45) and fpe = fromWord(getConst 46) and hup = fromWord(getConst 47) and ill = fromWord(getConst 48) and int = fromWord(getConst 49) and kill = fromWord(getConst 50) and pipe = fromWord(getConst 51) and quit = fromWord(getConst 52) and segv = fromWord(getConst 53) and term = fromWord(getConst 54) and usr1 = fromWord(getConst 55) and usr2 = fromWord(getConst 56) and chld = fromWord(getConst 57) and cont = fromWord(getConst 58) and stop = fromWord(getConst 59) and tstp = fromWord(getConst 60) and ttin = fromWord(getConst 61) and ttou = fromWord(getConst 62) end; structure Process = struct type signal = Signal.signal type pid = int val pidToWord = SysWord.fromInt and wordToPid = SysWord.toInt datatype waitpid_arg = W_ANY_CHILD | W_CHILD of pid | W_SAME_GROUP | W_GROUP of pid datatype exit_status = W_EXITED | W_EXITSTATUS of Word8.word | W_SIGNALED of signal | W_STOPPED of signal datatype killpid_arg = K_PROC of pid | K_SAME_GROUP | K_GROUP of pid structure W = struct open BitFlags val untraced = getConst 133 val nohang = getConst 134 (* Not exported. *) val all = flags [ untraced, nohang] val intersect = List.foldl (fn (a, b) => SysWord.andb(a, b)) all end local val doCall = osSpecificGeneral in fun fork () = case doCall(5, ()) of 0 => NONE (* Parent *) | n => SOME n (* Child *) end local val doCall = osSpecificGeneral in (* Map the pid argument to positive, zero or negative. *) fun kill (K_PROC pid, si) = doCall(6,(pid, si)) | kill (K_SAME_GROUP, si) = doCall(6, (0, si)) | kill (K_GROUP pid, si) = doCall(6, (~pid, si)) end local val doCall = osSpecificGeneral in (* The format of a result may well be sufficiently fixed that we could decode it without calling the RTS. It's probably worth the small cost to make maintenance easier. *) fun fromStatus (stat: OS.Process.status): exit_status = case (doCall(15, stat)) of (1, 0) => W_EXITED | (1, n) => W_EXITSTATUS(Word8.fromInt n) | (2, n) => W_SIGNALED n | (3, n) => W_STOPPED n | _ => raise Fail "Unknown result status" end local val doCall = osSpecificGeneral fun doWait(kind: int, pid: pid, flags: W.flags list) = let val (pid, status) = doCall(14, (kind, pid, SysWord.toInt(W.flags flags))) in (pid, fromStatus status) end in fun waitpid(W_ANY_CHILD, flags) = doWait(0, 0, flags) | waitpid(W_CHILD pid, flags) = doWait(1, pid, flags) | waitpid(W_SAME_GROUP, flags) = doWait(2, 0, flags) | waitpid(W_GROUP pid, flags) = doWait(3, pid, flags) fun wait() = waitpid(W_ANY_CHILD, []) fun waitpid_nh(wpa, flags) = let val (pid, status) = waitpid(wpa, W.nohang :: flags) in if pid = 0 then NONE else SOME(pid, status) end end fun exec(p, args) = osSpecificGeneral(17, (p, args)) and exece(p, args, env) = osSpecificGeneral(18, (p, args, env)) and execp(p, args) = osSpecificGeneral(19, (p, args)) (* The definition of "exit" is obviously designed to allow OS.Process.exit to be defined in terms of it. In particular it doesn't execute the functions registered with atExit. *) local val doExit: Word8.word -> unit = RunCall.rtsCallFull1 "PolyFinish" in fun exit w = ( doExit w; raise Bind (* Never executed but gives the correct result type.*) ) end local val doCall = osSpecificGeneral - fun toAbsolute t = - if t < Time.zeroTime - then raise OS.SysErr("Invalid time", NONE) - else t + Time.now() - (* Because of rounding we may get a negative time. In that - case we return zero. *) - fun endTime t = - let - val now = Time.now() - in - if t > now then t-now else Time.zeroTime - end in (* This previously used absolute times. Now uses relative. *) fun alarm t = doCall(20, t) + end - fun sleep t = + local + (* The underlying call waits for up to a second. It takes the count of signals that + have been received and returns the last count. This is necessary in case + a signal is received while we are in ML between calls to the RTS. *) + val doCall: int * int -> int = RunCall.rtsCallFull2 "PolyPosixSleep" + in + (* Sleep for a period. Returns the unused wait time. *) + fun sleep sleepTime = let - val finish = toAbsolute t + val endTime = sleepTime + Time.now() + val maxWait = 1000 (* Wait for up to a second *) + val initialCount = doCall (0, 0) + fun doWait () = + let + val timeToGo = + LargeInt.min(Time.toMilliseconds(endTime-Time.now()), LargeInt.fromInt maxWait) + in + if timeToGo <= 0 orelse doCall(LargeInt.toInt timeToGo, initialCount) <> initialCount + then (* Time has expired or we were interrupted. *) + let + val now = Time.now() + in + if endTime > now + then endTime-now + else Time.fromSeconds 0 + end + else doWait() (* Resume the wait *) + end in - (* We need to pass in the absolute time here. That's - because the process scheduler retries the - function until a signal occurs or the time expires. *) - (* The result is zero if it returns successfully. If - an exception is raised we return the remaining - time. We assume that this only happens because - the process is interrupted. We don't handle the - Interrupt exception, though. *) - (doCall(22, finish); Time.zeroTime) handle OS.SysErr _ => - endTime finish + doWait() end - end - local - val doCall = osSpecificGeneral - in - fun pause() = doCall(21, ()) + and pause() = + let + val initialCount = doCall(0, 0) + fun doPause() = if doCall(1000, initialCount) <> initialCount then () else doPause() + in + doPause() + end end end; structure ProcEnv = struct type pid = Process.pid and file_desc = OS.IO.iodesc type uid = int and gid = int val uidToWord = SysWord.fromInt and wordToUid = SysWord.toInt and gidToWord = SysWord.fromInt and wordToGid = SysWord.toInt local val doCall = osSpecificGeneral in fun getpid () = doCall(7, ()) and getppid () = doCall(8, ()) and getuid () = doCall(9, ()) and geteuid () = doCall(10, ()) and getgid () = doCall(11, ()) and getegid () = doCall(12, ()) and getpgrp () = doCall(13, ()) and setsid () = doCall(27, ()) end val getenv = OS.Process.getEnv - fun environ() = processEnvGeneral(21, ()) + val environ = RunCall.rtsCallFull0 "PolyGetEnvironment" local val doCall = osSpecificGeneral in fun setuid(u: uid) = doCall(23, u) and setgid(g: gid) = doCall(24, g) end local val doCall = osSpecificGeneral in fun getgroups() = doCall(25, ()) end local val doCall = osSpecificGeneral in fun getlogin() = doCall(26, ()) and ctermid() = doCall(30, ()) end local val doCall = osSpecificGeneral in (* In each case NONE as an argument is taken as 0. *) fun setpgid{pid, pgid} = doCall(28, (getOpt(pid, 0), getOpt(pgid, 0))) end local val doCall = osSpecificGeneral in fun uname() = doCall(29, ()) end val time = Time.now - fun times() = - let - (* Apart from the child times all these could be obtained - by calling the Timer functions. *) - val doCall: int*unit -> Time.time = timingGeneral - fun getUserTime() = doCall(7, ()) - and getSysTime() = doCall(8, ()) - and getRealTime() = doCall(10, ()) - and getChildUserTime() = doCall(11, ()) - and getChildSysTime() = doCall(12, ()) + local + (* Apart from the child times all these could be obtained by calling the Timer functions. *) + val getUserTime: unit -> Time.time = RunCall.rtsCallFull0 "PolyTimingGetUser" + and getSysTime: unit -> Time.time = RunCall.rtsCallFull0 "PolyTimingGetSystem" + and getRealTime: unit -> Time.time = RunCall.rtsCallFull0 "PolyTimingGetReal" + and getChildUserTime: unit -> Time.time = RunCall.rtsCallFull0 "PolyTimingGetChildUser" + and getChildSysTime: unit -> Time.time = RunCall.rtsCallFull0 "PolyTimingGetChildSystem" in - { elapsed=getRealTime(), utime=getUserTime(), stime=getSysTime(), - cutime=getChildUserTime(), cstime=getChildSysTime()} + fun times() = + { elapsed=getRealTime(), utime=getUserTime(), stime=getSysTime(), + cutime=getChildUserTime(), cstime=getChildSysTime()} end local val doCall = osSpecificGeneral in fun ttyname(f: file_desc) = doCall(31, f) end local val doCall = osSpecificGeneral in fun isatty(f: file_desc) = doCall(32, f) end local val doCall = osSpecificGeneral in fun sysconf(s: string) = SysWord.fromInt(doCall(33, s)) end end; structure FileSys = struct type uid = ProcEnv.uid and gid = ProcEnv.gid type file_desc = OS.IO.iodesc type dirstream = OS.FileSys.dirstream datatype open_mode = O_RDONLY | O_WRONLY | O_RDWR structure O = struct open BitFlags val append = getConst 66 and excl = getConst 67 and noctty = getConst 68 and nonblock = getConst 69 and sync = getConst 70 and trunc = getConst 71 val all = flags [append, excl, noctty, nonblock, sync, trunc] val intersect = List.foldl (fn (a, b) => SysWord.andb(a, b)) all end local val doIo: int*file_desc*unit -> int = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun fdToWord (f: file_desc) = SysWord.fromInt(doIo(30, f, ())) end local val doIo: int*unit*int -> file_desc = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun wordToFD(s: SysWord.word): file_desc = doIo(31, (), SysWord.toInt s) end (* file_desc and OS.IO.iodesc are the same. *) fun fdToIOD i = i and iodToFD i = SOME i val opendir = OS.FileSys.openDir and readdir = OS.FileSys.readDir and rewinddir = OS.FileSys.rewindDir and closedir = OS.FileSys.closeDir and chdir = OS.FileSys.chDir and getcwd = OS.FileSys.getDir and unlink = OS.FileSys.remove and rmdir = OS.FileSys.rmDir and rename = OS.FileSys.rename and readlink = OS.FileSys.readLink local val persistentFD: int -> file_desc = RunCall.rtsCallFull1 "PolyPosixCreatePersistentFD" in val stdin : file_desc = persistentFD 0 and stdout : file_desc = persistentFD 1 and stderr : file_desc = persistentFD 2 end structure S = struct open BitFlags type mode = flags val irusr : mode = getConst 145 and iwusr : mode = getConst 146 and ixusr : mode = getConst 147 val irwxu : mode = flags[irusr, iwusr, ixusr] val irgrp : mode = getConst 148 and iwgrp : mode = getConst 149 and ixgrp : mode = getConst 150 val irwxg : mode = flags[irgrp, iwgrp, ixgrp] val iroth : mode = getConst 151 and iwoth : mode = getConst 152 and ixoth : mode = getConst 153 val irwxo : mode = flags[iroth, iwoth, ixoth] val isuid : mode = getConst 154 val isgid : mode = getConst 155 val all = flags [irwxu, irwxg, irwxo, isuid, isgid] val intersect = List.foldl (fn (a, b) => SysWord.andb(a, b)) all end local val o_rdonly = getConst 63 and o_wronly = getConst 64 and o_rdwr = getConst 65 fun toBits O_RDONLY = o_rdonly | toBits O_WRONLY = o_wronly | toBits O_RDWR = o_rdwr val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun openf(name, mode, flags) = let val bits = SysWord.orb(flags, toBits mode) in doIo(70, 0, (name, SysWord.toInt bits, 0)) end and createf(name, mode, flags, smode) = let val bits = SysWord.orb(flags, toBits mode) in doIo(71, 0, (name, SysWord.toInt bits, SysWord.toInt smode)) end end fun creat(s, m) = createf(s, O_WRONLY, O.trunc, m) local val doCall = osSpecificGeneral in fun umask m = SysWord.fromInt(doCall(50, SysWord.toInt m)) end local val doCall = osSpecificGeneral in fun link{old, new} = doCall(51, (old, new)) and symlink{old, new} = doCall(54, (old, new)) end local val doCall = osSpecificGeneral in fun mkdir(name, mode) = doCall(52, (name, SysWord.toInt mode)) and mkfifo(name, mode) = doCall(53, (name, SysWord.toInt mode)) and chmod(name, mode) = doCall(59, (name, SysWord.toInt mode)) end type dev = LargeInt.int and ino = LargeInt.int val wordToDev = SysWord.toLargeInt and devToWord = SysWord.fromLargeInt and wordToIno = SysWord.toLargeInt and inoToWord = SysWord.fromLargeInt structure ST = struct type stat = { mode: S.mode, kind: int, ino: ino, dev: dev, nlink: int, uid: uid, gid: gid, size: Position.int, atime: Time.time, mtime: Time.time, ctime: Time.time } (* The "kind" information is encoded by "stat" *) fun isDir({ kind, ...} : stat) = kind = 1 and isChr({ kind, ...} : stat) = kind = 2 and isBlk({ kind, ...} : stat) = kind = 3 and isReg({ kind, ...} : stat) = kind = 0 and isFIFO({ kind, ...} : stat) = kind = 4 and isLink({ kind, ...} : stat) = kind = 5 and isSock({ kind, ...} : stat) = kind = 6 val mode : stat -> S.mode = #mode and ino : stat -> ino = #ino val dev : stat -> dev = #dev val nlink : stat -> int = #nlink val uid : stat -> uid = #uid val gid : stat -> gid = #gid val size : stat -> Position.int = #size val atime : stat -> Time.time = #atime val mtime : stat -> Time.time = #mtime val ctime : stat -> Time.time = #ctime end local val doCall1 = osSpecificGeneral val doCall2 = osSpecificGeneral fun convStat(mode, kind, ino, dev, nlink, uid, gid, size, atime, mtime, ctime) = { mode = SysWord.fromInt mode, kind = kind, ino = ino, dev = dev, nlink = nlink, uid = uid, gid = gid, size = size, atime = atime, mtime = mtime, ctime = ctime } in fun stat name = convStat(doCall1(55, name)) and lstat name = convStat(doCall1(56, name)) and fstat f = convStat(doCall2(57, f)) end datatype access_mode = datatype OS.FileSys.access_mode local val doCall = osSpecificGeneral val rOK = getConst 156 and wOK = getConst 157 and eOK = getConst 158 and fOK = getConst 159 fun abit A_READ = rOK | abit A_WRITE = wOK | abit A_EXEC = eOK val abits = List.foldl (fn (a, b) => SysWord.orb(abit a,b)) 0w0 in (* If the bits are nil it tests for existence of the file. *) fun access(name, []) = doCall(58, (name, SysWord.toInt(fOK))) | access(name, al) = doCall(58, (name, SysWord.toInt(abits al))) end local val doCall = osSpecificGeneral in fun fchmod(fd, mode) = doCall(60, (fd, SysWord.toInt mode)) end local val doCall = osSpecificGeneral in fun chown(name, uid, gid) = doCall(61, (name, uid, gid)) end local val doCall = osSpecificGeneral in fun fchown(fd, uid, gid) = doCall(62, (fd, uid, gid)) end local val doCall1 = osSpecificGeneral and doCall2 = osSpecificGeneral in fun utime (name, NONE) = doCall1(64, name) | utime (name, SOME{actime, modtime}) = doCall2(63, (name, actime, modtime)) end local val doCall = osSpecificGeneral in fun ftruncate(fd, size) = doCall(65, (fd, size)) end local val doCall = osSpecificGeneral in fun pathconf(name, var) = let val res = doCall(66, (name, var)) in if res < 0 then NONE else SOME(SysWord.fromInt res) end end local val doCall = osSpecificGeneral in fun fpathconf(fd, var) = let val res = doCall(67, (fd, var)) in if res < 0 then NONE else SOME(SysWord.fromInt res) end end end; structure IO = struct type file_desc = OS.IO.iodesc and pid = Process.pid structure FD = struct open BitFlags val cloexec: flags = getConst 132 val all = flags [cloexec] val intersect = List.foldl (fn (a, b) => SysWord.andb(a, b)) all end (* Posix.IO.O seems to be a cut-down version of Posix.FileSys.O. It seems to me that one structure would suffice. *) structure O = FileSys.O datatype open_mode = datatype FileSys.open_mode local val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun close (strm: file_desc): unit = doIo(7, strm, 0) end local val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun readVec (strm: file_desc, len: int): Word8Vector.vector = doIo(26, strm, len) end local val doCall = osSpecificGeneral in fun pipe() = let val (inf, outf) = doCall(110, ()) in { infd=inf, outfd=outf } end end local val doCall = osSpecificGeneral in fun dup fd = doCall(111, fd) end local val doCall = osSpecificGeneral in fun dup2{old, new} = doCall(112, (old, new)) end local val doCall = osSpecificGeneral in fun dupfd{old, base} = doCall(113, (old, base)) end local val doCall = osSpecificGeneral val o_rdonly = getConst 63 and o_wronly = getConst 64 and o_accmode = getConst 166 (* Access mode mask. *) in fun getfd fd = SysWord.fromInt(doCall(114, fd)) and getfl fd = let val res = SysWord.fromInt(doCall(116, fd)) (* Separate out the mode bits. *) val flgs = SysWord.andb(res, SysWord.notb o_accmode) val mode = SysWord.andb(res, o_accmode) val omode = if mode = o_rdonly then O_RDONLY else if mode = o_wronly then O_WRONLY else O_RDWR in (flgs, omode) end end local val doCall = osSpecificGeneral in fun setfd(fd, flags) = doCall(115, (fd, SysWord.toInt flags)) and setfl(fd, flags) = doCall(117, (fd, SysWord.toInt flags)) end datatype whence = SEEK_SET | SEEK_CUR | SEEK_END local val seekSet = SysWord.toInt(getConst 160) and seekCur = SysWord.toInt(getConst 161) and seekEnd = SysWord.toInt(getConst 162) in (* Convert the datatype to the corresponding int. *) fun seekWhence SEEK_SET = seekSet | seekWhence SEEK_CUR = seekCur | seekWhence SEEK_END = seekEnd fun whenceSeek s = if s = seekSet then SEEK_SET else if s = seekCur then SEEK_CUR else SEEK_END end local val doCall = osSpecificGeneral in fun lseek(fd, pos, whence) = doCall(118, (fd, pos, seekWhence whence)) end local val doCall = osSpecificGeneral in fun fsync fd = doCall(119, fd) end datatype lock_type = F_RDLCK | F_WRLCK | F_UNLCK structure FLock = struct val fRdlck = SysWord.toInt(getConst 163) and fWrlck = SysWord.toInt(getConst 164) and fUnlck = SysWord.toInt(getConst 165) type flock = int (* lock type *) * int (* whence *) * Position.int (* start *) * Position.int (* len *) * pid fun flock{ltype, whence, start, len, pid} = let val lt = case ltype of F_RDLCK => fRdlck | F_WRLCK => fWrlck | F_UNLCK => fUnlck in (lt, seekWhence whence, start, len, getOpt(pid, ~1)) end fun ltype (lt, _, _, _, _) = if lt = fRdlck then F_RDLCK else if lt = fWrlck then F_WRLCK else F_UNLCK fun whence (fl: flock) = whenceSeek(#2 fl) val start : flock -> Position.int = #3 val len : flock -> Position.int = #4 fun pid (_, _, _, _, pid) = if pid < 0 then NONE else SOME pid end local val doCall = osSpecificGeneral in fun getlk(fd, (t, w, s, l, p)) = doCall(120, (fd, t, w, s, l, p)) (* Note: the return type of setlk and setlkw is Flock.lock not unit. I assume they simply return their argument. *) and setlk(fd, (t, w, s, l, p)) = doCall(121, (fd, t, w, s, l, p)) and setlkw(fd, (t, w, s, l, p)) = doCall(122, (fd, t, w, s, l, p)) end val readArr = LibraryIOSupport.readBinArray and writeVec = LibraryIOSupport.writeBinVec and writeArr = LibraryIOSupport.writeBinArray val mkTextReader = LibraryIOSupport.wrapInFileDescr and mkTextWriter = LibraryIOSupport.wrapOutFileDescr val mkBinReader = LibraryIOSupport.wrapBinInFileDescr and mkBinWriter = LibraryIOSupport.wrapBinOutFileDescr end; structure SysDB = struct type uid = ProcEnv.uid and gid = ProcEnv.gid structure Passwd = struct type passwd = string * uid * gid * string * string val name: passwd->string = #1 and uid: passwd->uid = #2 and gid: passwd->gid = #3 and home: passwd->string = #4 and shell: passwd->string = #5 end structure Group = struct type group = string * gid * string list val name: group->string = #1 and gid: group->gid = #2 and members: group->string list = #3 end local val doCall = osSpecificGeneral in fun getpwnam (s: string): Passwd.passwd = doCall(100, s) end local val doCall = osSpecificGeneral in fun getpwuid (u: uid): Passwd.passwd = doCall(101, u) end local val doCall = osSpecificGeneral in fun getgrnam (s: string): Group.group = doCall(102, s) end local val doCall = osSpecificGeneral in fun getgrgid (g: gid): Group.group = doCall(103, g) end end; structure TTY = struct type pid = Process.pid and file_desc = OS.IO.iodesc structure V = struct val eof = SysWord.toInt(getConst 72) and eol = SysWord.toInt(getConst 73) and erase = SysWord.toInt(getConst 74) and intr = SysWord.toInt(getConst 75) and kill = SysWord.toInt(getConst 76) and min = SysWord.toInt(getConst 77) and quit = SysWord.toInt(getConst 78) and susp = SysWord.toInt(getConst 79) and time = SysWord.toInt(getConst 80) and start = SysWord.toInt(getConst 81) and stop = SysWord.toInt(getConst 82) and nccs = SysWord.toInt(getConst 83) type cc = string fun cc l = (* Generate a string using the values given and defaulting the rest to NULL. *) let fun find [] _ = #"\000" | find ((n, c)::l) i = if i = n then c else find l i in CharVector.tabulate(nccs, find l) end (* Question: What order does this take? E.g. What is the result of update(cc, [(eof, #"a"), (eof, #"b")]) ? Assume that earlier entries take precedence. That also affects the processing of exceptions. *) fun update(cc, l) = let fun find [] i = String.sub(cc, i) | find ((n, c)::l) i = if i = n then c else find l i in CharVector.tabulate(nccs, find l) end val sub = String.sub end structure I = struct open BitFlags val brkint = getConst 84 and icrnl = getConst 85 and ignbrk = getConst 86 and igncr = getConst 87 and ignpar = getConst 88 and inlcr = getConst 89 and inpck = getConst 90 and istrip = getConst 91 and ixoff = getConst 92 and ixon = getConst 93 and parmrk = getConst 94 val all = flags [brkint, icrnl, ignbrk, igncr, ignpar, inlcr, inpck, istrip, ixoff, ixon, parmrk] val intersect = List.foldl (fn (a, b) => SysWord.andb(a, b)) all end structure O = struct open BitFlags val opost = getConst 95 val all = flags [opost] val intersect = List.foldl (fn (a, b) => SysWord.andb(a, b)) all end structure C = struct open BitFlags val clocal = getConst 96 and cread = getConst 97 and cs5 = getConst 98 and cs6 = getConst 99 and cs7 = getConst 100 and cs8 = getConst 101 and csize = getConst 102 and cstopb = getConst 103 and hupcl = getConst 104 and parenb = getConst 105 and parodd = getConst 106 val all = flags [clocal, cread, cs5, cs6, cs7, cs8, csize, cstopb, hupcl, parenb, parodd] val intersect = List.foldl (fn (a, b) => SysWord.andb(a, b)) all end structure L = struct open BitFlags val echo = getConst 107 and echoe = getConst 108 and echok = getConst 109 and echonl = getConst 110 and icanon = getConst 111 and iexten = getConst 112 and isig = getConst 113 and noflsh = getConst 114 and tostop = getConst 115 val all = flags [echo, echoe, echok, echonl, icanon, iexten, isig, noflsh, tostop] val intersect = List.foldl (fn (a, b) => SysWord.andb(a, b)) all end type speed = int (* compareSpeed is supposed to compare by the baud rate, not by the encoding. Provided the encoding maintains the ordering then that's fine. Maybe we should have an RTS call. *) val compareSpeed : speed * speed -> order = Int.compare and speedToWord : speed -> SysWord.word = SysWord.fromInt and wordToSpeed : SysWord.word -> speed = SysWord.toInt val b0 : speed = SysWord.toInt(getConst 116) and b50 : speed = SysWord.toInt(getConst 117) and b75 : speed = SysWord.toInt(getConst 118) and b110 : speed = SysWord.toInt(getConst 119) and b134 : speed = SysWord.toInt(getConst 120) and b150 : speed = SysWord.toInt(getConst 121) and b200 : speed = SysWord.toInt(getConst 122) and b300 : speed = SysWord.toInt(getConst 123) and b600 : speed = SysWord.toInt(getConst 124) and b1200 : speed = SysWord.toInt(getConst 125) and b1800 : speed = SysWord.toInt(getConst 126) and b2400 : speed = SysWord.toInt(getConst 127) and b4800 : speed = SysWord.toInt(getConst 128) and b9600 : speed = SysWord.toInt(getConst 129) and b19200 : speed = SysWord.toInt(getConst 130) and b38400 : speed = SysWord.toInt(getConst 131) type termios = { iflag : I.flags, oflag : O.flags, cflag : C.flags, lflag : L.flags, cc : V.cc, ispeed : speed, ospeed : speed } fun termios t = t and fieldsOf t = t val getiflag : termios -> I.flags = #iflag and getoflag : termios -> O.flags = #oflag and getcflag : termios -> C.flags = #cflag and getlflag : termios -> L.flags = #lflag and getcc : termios -> V.cc = #cc structure CF = struct val getospeed : termios -> speed = #ospeed and getispeed : termios -> speed = #ispeed fun setospeed ({ iflag, oflag, cflag, lflag, cc, ispeed, ... }, speed) = { iflag=iflag, oflag=oflag, cflag=cflag, lflag=lflag, cc=cc, ispeed = ispeed, ospeed = speed } fun setispeed ({ iflag, oflag, cflag, lflag, cc, ospeed, ... }, speed) = { iflag=iflag, oflag=oflag, cflag=cflag, lflag=lflag, cc=cc, ispeed = speed, ospeed = ospeed } end structure TC = struct type set_action = int val sanow : set_action = SysWord.toInt(getConst 135) val sadrain : set_action = SysWord.toInt(getConst 136) val saflush : set_action = SysWord.toInt(getConst 137) type flow_action = int val ooff : flow_action = SysWord.toInt(getConst 138) val oon : flow_action = SysWord.toInt(getConst 139) val ioff : flow_action = SysWord.toInt(getConst 140) val ion : flow_action = SysWord.toInt(getConst 141) type queue_sel = int val iflush : queue_sel = SysWord.toInt(getConst 142) val oflush : queue_sel = SysWord.toInt(getConst 143) val ioflush : queue_sel = SysWord.toInt(getConst 144) local val doCall = osSpecificGeneral in fun getattr f = let val (iflag, oflag, cflag, lflag, cc, ispeed, ospeed) = doCall(150, f) in { iflag=SysWord.fromInt iflag, oflag=SysWord.fromInt oflag, cflag=SysWord.fromInt cflag, lflag=SysWord.fromInt lflag, cc=cc, ispeed = ispeed, ospeed = ospeed } end end local val doCall = osSpecificGeneral in fun setattr (f, sa, {iflag, oflag, cflag, lflag, cc, ispeed, ospeed}) = doCall(151, (f, sa, SysWord.toInt iflag, SysWord.toInt oflag, SysWord.toInt cflag, SysWord.toInt lflag, cc, ispeed, ospeed)) end local val doCall = osSpecificGeneral in fun sendbreak (f, d) = doCall(152, (f, d)) end local val doCall = osSpecificGeneral in fun drain f = doCall(153, f) end local val doCall = osSpecificGeneral in fun flush (f, qs) = doCall(154, (f, qs)) end local val doCall = osSpecificGeneral in fun flow (f, fa) = doCall(155, (f, fa)) end end local val doCall = osSpecificGeneral in fun getpgrp (f: file_desc): pid = doCall(156, f) end local val doCall = osSpecificGeneral in fun setpgrp (f: file_desc, p: pid): unit = doCall(157, (f,p)) end end end; local (* Install the pretty printers for pid, uid, gid. Don't install one for signal because it's now the same as int. *) fun ppid _ _ x = PolyML.PrettyString(Int.toString(SysWord.toInt(Posix.Process.pidToWord x))) and puid _ _ x = PolyML.PrettyString(Int.toString(SysWord.toInt(Posix.ProcEnv.uidToWord x))) and pgid _ _ x = PolyML.PrettyString(Int.toString(SysWord.toInt(Posix.ProcEnv.gidToWord x))) in val () = PolyML.addPrettyPrinter ppid val () = PolyML.addPrettyPrinter puid val () = PolyML.addPrettyPrinter pgid 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/Socket.sml b/basis/Socket.sml index 953f7689..949367c2 100644 --- a/basis/Socket.sml +++ b/basis/Socket.sml @@ -1,678 +1,729 @@ (* Title: Standard Basis Library: Generic Sockets Author: David Matthews - Copyright David Matthews 2000, 2005, 2015-16 + Copyright David Matthews 2000, 2005, 2015-16, 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 SOCKET = sig type ('af,'sock_type) sock type 'af sock_addr type dgram type 'mode stream type passive type active structure AF : sig - type addr_family = NetHostDB.addr_family + eqtype addr_family (* = NetHostDB.addr_family *) (* This is a mess: NetHostDB depends on Socket. *) val list : unit -> (string * addr_family) list val toString : addr_family -> string val fromString : string -> addr_family option end structure SOCK : sig eqtype sock_type val stream : sock_type val dgram : sock_type val list : unit -> (string * sock_type) list val toString : sock_type -> string val fromString : string -> sock_type option end structure Ctl : sig val getDEBUG : ('af, 'sock_type) sock -> bool val setDEBUG : ('af, 'sock_type) sock * bool -> unit val getREUSEADDR : ('af, 'sock_type) sock -> bool val setREUSEADDR : ('af, 'sock_type) sock * bool -> unit val getKEEPALIVE : ('af, 'sock_type) sock -> bool val setKEEPALIVE : ('af, 'sock_type) sock * bool -> unit val getDONTROUTE : ('af, 'sock_type) sock -> bool val setDONTROUTE : ('af, 'sock_type) sock * bool -> unit val getLINGER : ('af, 'sock_type) sock -> Time.time option val setLINGER : ('af, 'sock_type) sock * Time.time option -> unit val getBROADCAST : ('af, 'sock_type) sock -> bool val setBROADCAST : ('af, 'sock_type) sock * bool -> unit val getOOBINLINE : ('af, 'sock_type) sock -> bool val setOOBINLINE : ('af, 'sock_type) sock * bool -> unit val getSNDBUF : ('af, 'sock_type) sock -> int val setSNDBUF : ('af, 'sock_type) sock * int -> unit val getRCVBUF : ('af, 'sock_type) sock -> int val setRCVBUF : ('af, 'sock_type) sock * int -> unit val getTYPE : ('af, 'sock_type) sock -> SOCK.sock_type val getERROR : ('af, 'sock_type) sock -> bool val getPeerName : ('af, 'sock_type) sock -> 'af sock_addr val getSockName : ('af, 'sock_type) sock -> 'af sock_addr val getNREAD : ('af, 'sock_type) sock -> int val getATMARK : ('af, active stream) sock -> bool end val sameAddr : 'af sock_addr * 'af sock_addr -> bool val familyOfAddr : 'af sock_addr -> AF.addr_family val bind : ('af, 'sock_type) sock * 'af sock_addr -> unit val listen : ('af, passive stream) sock * int -> unit val accept : ('af, passive stream) sock -> ('af, active stream) sock * 'af sock_addr val acceptNB : ('af, passive stream) sock -> (('af, active stream) sock * 'af sock_addr) option val connect : ('af, 'sock_type) sock * 'af sock_addr -> unit val connectNB : ('af, 'sock_type) sock * 'af sock_addr -> bool val close : ('af, 'sock_type) sock -> unit datatype shutdown_mode = NO_RECVS | NO_SENDS | NO_RECVS_OR_SENDS val shutdown : ('af, 'sock_type stream) sock * shutdown_mode -> unit type sock_desc val sockDesc : ('af, 'sock_type) sock -> sock_desc val sameDesc: sock_desc * sock_desc -> bool val select: { rds: sock_desc list, wrs : sock_desc list, exs : sock_desc list, timeout: Time.time option } -> { rds: sock_desc list, wrs : sock_desc list, exs : sock_desc list } val ioDesc : ('af, 'sock_type) sock -> OS.IO.iodesc type out_flags = {don't_route : bool, oob : bool} type in_flags = {peek : bool, oob : bool} val sendVec : ('af, active stream) sock * Word8VectorSlice.slice -> int val sendArr : ('af, active stream) sock * Word8ArraySlice.slice -> int val sendVec' : ('af, active stream) sock * Word8VectorSlice.slice * out_flags -> int val sendArr' : ('af, active stream) sock * Word8ArraySlice.slice * out_flags -> int val sendVecNB : ('af, active stream) sock * Word8VectorSlice.slice -> int option val sendArrNB : ('af, active stream) sock * Word8ArraySlice.slice -> int option val sendVecNB' : ('af, active stream) sock * Word8VectorSlice.slice * out_flags -> int option val sendArrNB' : ('af, active stream) sock * Word8ArraySlice.slice * out_flags -> int option val recvVec : ('af, active stream) sock * int -> Word8Vector.vector val recvArr : ('af, active stream) sock * Word8ArraySlice.slice -> int val recvVec' : ('af, active stream) sock * int * in_flags -> Word8Vector.vector val recvArr' : ('af, active stream) sock * Word8ArraySlice.slice * in_flags -> int val recvVecNB : ('af, active stream) sock * int -> Word8Vector.vector option val recvArrNB : ('af, active stream) sock * Word8ArraySlice.slice -> int option val recvVecNB' : ('af, active stream) sock * int * in_flags -> Word8Vector.vector option val recvArrNB' : ('af, active stream) sock * Word8ArraySlice.slice * in_flags -> int option val sendVecTo : ('af, dgram) sock * 'af sock_addr * Word8VectorSlice.slice -> unit val sendArrTo : ('af, dgram) sock * 'af sock_addr * Word8ArraySlice.slice -> unit val sendVecTo' : ('af, dgram) sock * 'af sock_addr * Word8VectorSlice.slice * out_flags -> unit val sendArrTo' : ('af, dgram) sock * 'af sock_addr * Word8ArraySlice.slice * out_flags -> unit val sendVecToNB : ('af, dgram) sock * 'af sock_addr * Word8VectorSlice.slice -> bool val sendArrToNB : ('af, dgram) sock * 'af sock_addr * Word8ArraySlice.slice -> bool val sendVecToNB' : ('af, dgram) sock * 'af sock_addr * Word8VectorSlice.slice * out_flags -> bool val sendArrToNB' : ('af, dgram) sock * 'af sock_addr * Word8ArraySlice.slice * out_flags -> bool val recvVecFrom : ('af, dgram) sock * int -> Word8Vector.vector * 'sock_type sock_addr val recvArrFrom : ('af, dgram) sock * Word8ArraySlice.slice -> int * 'af sock_addr val recvVecFrom' : ('af, dgram) sock * int * in_flags -> Word8Vector.vector * 'sock_type sock_addr val recvArrFrom' : ('af, dgram) sock * Word8ArraySlice.slice * in_flags -> int * 'af sock_addr val recvVecFromNB : ('af, dgram) sock * int -> (Word8Vector.vector * 'sock_type sock_addr) option val recvArrFromNB : ('af, dgram) sock * Word8ArraySlice.slice -> (int * 'af sock_addr) option val recvVecFromNB' : ('af, dgram) sock * int * in_flags -> (Word8Vector.vector * 'sock_type sock_addr) option val recvArrFromNB' : ('af, dgram) sock * Word8ArraySlice.slice * in_flags -> (int * 'af sock_addr) option end; -structure Socket :> SOCKET = +structure Socket :> SOCKET + where type ('af,'sock_type) sock = ('af,'sock_type) LibraryIOSupport.sock (* So we can use it elsewhere *) = struct (* We don't really need an implementation for these. *) - (* TODO: We should really pull the definition of the sock type into a common structure so - it can be shared by the various socket structures. In fact it doesn't matter since the - unary constructor here is compiled as an identity so the underlying representation of - "SOCK x" will be the same as "x". *) - datatype ('af,'sock_type) sock = SOCK of OS.IO.iodesc - and dgram = DGRAM + datatype sock = datatype LibraryIOSupport.sock + + datatype dgram = DGRAM and 'mode stream = STREAM and passive = PASSIVE and active = ACTIVE - local - val netCall: int * word -> word = RunCall.rtsCallFull2 "PolyNetworkGeneral" - in - fun doNetCall(i: int, arg:'a):'b = - RunCall.unsafeCast(netCall(i, RunCall.unsafeCast arg)) - end - structure AF = struct - type addr_family = NetHostDB.addr_family + type addr_family = int - local - val doCall: int*unit -> (string * addr_family) list - = doNetCall - in - fun list () = doCall(11, ()) - end + val list: unit -> (string * addr_family) list = RunCall.rtsCallFull0 "PolyNetworkGetAddrList" fun toString (af: addr_family) = let val afs = list() in (* Do a linear search on the list - it's small. *) case List.find (fn (_, af') => af=af') afs of NONE => raise OS.SysErr("Missing address family", NONE) | SOME (s, _) => s end fun fromString s = let val afs = list() in (* Do a linear search on the list - it's small. *) case List.find (fn (s', _) => s=s') afs of NONE => NONE | SOME (_, af) => SOME af end end structure SOCK = struct datatype sock_type = SOCKTYPE of int - local - val doCall: int*unit -> (string * sock_type) list - = doNetCall - in - fun list () = doCall(12, ()) - end + val list:unit -> (string * sock_type) list = RunCall.rtsCallFull0 "PolyNetworkGetSockTypeList" fun toString (sk: sock_type) = let val sks = list() in (* Do a linear search on the list - it's small. *) case List.find (fn (_, sk') => sk=sk') sks of NONE => raise OS.SysErr("Missing socket type", NONE) | SOME (s, _) => s end fun fromString s = let val sks = list() in (* Do a linear search on the list - it's small. *) case List.find (fn (s', _) => s=s') sks of NONE => NONE | SOME (_, sk) => SOME sk end (* We assume that both of these at least are in the table. *) val stream = case fromString "STREAM" of NONE => raise OS.SysErr("Missing socket type", NONE) | SOME s => s val dgram = case fromString "DGRAM" of NONE => raise OS.SysErr("Missing socket type", NONE) | SOME s => s end (* Socket addresses are implemented as strings. *) - datatype 'af sock_addr = SOCKADDR of Word8Vector.vector + datatype sock_addr = datatype LibraryIOSupport.sock_addr (* Note: The definition did not make these equality type variables. The assumption is probably that it works much like equality on references. *) fun sameAddr (SOCKADDR a, SOCKADDR b) = a = b - (* Many of these calls involve type variables. We have to use a cast to - get the types right. *) local - val doCall = doNetCall + (* Because this involves a type variable we need an extra function. *) + val doCall = RunCall.rtsCallFast1 "PolyNetworkGetFamilyFromAddress" in - fun familyOfAddr (sa: 'af sock_addr) = doCall(39, RunCall.unsafeCast sa) + fun familyOfAddr (SOCKADDR sa) = doCall sa + end + + + (* Get the error state as an OS.syserror value. This is a SysWord.word value. *) + local + val sysGetError: OS.IO.iodesc -> SysWord.word = + RunCall.rtsCallFull1 "PolyNetworkGetSocketError" + in + fun getAndClearError(SOCK s): SysWord.word = sysGetError s end structure Ctl = struct local - val doCall1 = doNetCall - val doCall2 = doNetCall + val doGetOpt: int * OS.IO.iodesc -> int = RunCall.rtsCallFull2 "PolyNetworkGetOption" + val doSetOpt: int * OS.IO.iodesc * int -> unit = RunCall.rtsCallFull3 "PolyNetworkSetOption" in - fun getOpt (i:int) (SOCK s) = doCall1(i, s) - fun setOpt (i: int) (SOCK s, b: bool) = doCall2(i, (s, b)) - end - - fun getDEBUG s = getOpt 18 s - and setDEBUG s = setOpt 17 s - and getREUSEADDR s = getOpt 20 s - and setREUSEADDR s = setOpt 19 s - and getKEEPALIVE s = getOpt 22 s - and setKEEPALIVE s = setOpt 21 s - and getDONTROUTE s = getOpt 24 s - and setDONTROUTE s = setOpt 23 s - and getBROADCAST s = getOpt 26 s - and setBROADCAST s = setOpt 25 s - and getOOBINLINE s = getOpt 28 s - and setOOBINLINE s = setOpt 27 s - and getERROR s = getOpt 34 s - and getATMARK s = getOpt 45 s + fun getOpt (i:int) (SOCK s) : int = doGetOpt(i, s) + fun setOpt (i: int) (SOCK s, v: int) = doSetOpt(i, s, v) + fun bv true = 1 | bv false = 0 + end + + fun getDEBUG s = getOpt 18 s <> 0 + and setDEBUG(s, b) = setOpt 17 (s, bv b) + and getREUSEADDR s = getOpt 20 s <> 0 + and setREUSEADDR(s, b) = setOpt 19 (s, bv b) + and getKEEPALIVE s = getOpt 22 s <> 0 + and setKEEPALIVE(s, b) = setOpt 21 (s, bv b) + and getDONTROUTE s = getOpt 24 s <> 0 + and setDONTROUTE(s, b) = setOpt 23 (s, bv b) + and getBROADCAST s = getOpt 26 s <> 0 + and setBROADCAST(s, b) = setOpt 25 (s, bv b) + and getOOBINLINE s = getOpt 28 s <> 0 + and setOOBINLINE(s, b) = setOpt 27 (s, bv b) + and getERROR s = getAndClearError s <> 0w0 + and setSNDBUF(s, i: int) = setOpt 29 (s, i) + and getSNDBUF s = getOpt 30 s + and setRCVBUF(s, i: int) = setOpt 31 (s, i) + and getRCVBUF s = getOpt 32 s + and getTYPE s = SOCK.SOCKTYPE(getOpt 33 s) local - val doCall1 = doNetCall - val doCall2 = doNetCall + val doGetOpt: OS.IO.iodesc -> bool = RunCall.rtsCallFull1 "PolyNetworkGetAtMark" + in + fun getATMARK (SOCK s) = doGetOpt s + end + + local + val doGetNRead: OS.IO.iodesc -> int = RunCall.rtsCallFull1 "PolyNetworkBytesAvailable" in - fun getSNDBUF (SOCK s) = doCall1(30, s) - fun setSNDBUF (SOCK s, i: int) = doCall2(29, (s, i)) - fun getRCVBUF (SOCK s) = doCall1(32, s) - fun setRCVBUF (SOCK s, i: int) = doCall2(31, (s, i)) - fun getTYPE (SOCK s) = SOCK.SOCKTYPE(doCall1(33, s)) - - fun getNREAD (SOCK s) = doCall1(44, s) + fun getNREAD (SOCK s) = doGetNRead s + end + local + val doSetLinger: OS.IO.iodesc * LargeInt.int -> unit = RunCall.rtsCallFull2 "PolyNetworkSetLinger" + val doGetLinger: OS.IO.iodesc -> LargeInt.int = RunCall.rtsCallFull1 "PolyNetworkGetLinger" + in fun getLINGER (SOCK s): Time.time option = let - val lTime = doCall1(36, s) + val lTime = doGetLinger s (* Returns LargeInt.int *) in - if lTime < 0 then NONE else SOME(Time.fromSeconds(LargeInt.fromInt lTime)) + if lTime < 0 then NONE else SOME(Time.fromSeconds lTime) end fun setLINGER (SOCK s, NONE) = ( - doCall2(35, (s, ~1)) + doSetLinger(s, ~1) ) | setLINGER (SOCK s, SOME t) = let - val lTime = LargeInt.toInt(Time.toSeconds t) + val lTime = Time.toSeconds t in if lTime < 0 then raise OS.SysErr("Invalid time", NONE) - else doCall2(35, (s, lTime)) + else doSetLinger(s, lTime) end end local - val doCall = doNetCall + val getPeer: OS.IO.iodesc -> Word8Vector.vector = RunCall.rtsCallFull1 "PolyNetworkGetPeerName" in - fun getPeerName (SOCK s): 'af sock_addr = RunCall.unsafeCast(doCall(37, s)) + fun getPeerName (SOCK s): 'af sock_addr = SOCKADDR(getPeer s) + end - fun getSockName (SOCK s): 'af sock_addr = RunCall.unsafeCast(doCall(38, s)) + local + val getSock: OS.IO.iodesc -> Word8Vector.vector = RunCall.rtsCallFull1 "PolyNetworkGetSockName" + in + fun getSockName (SOCK s): 'af sock_addr = SOCKADDR(getSock s) end end (* Ctl *) - (* Run an operation in non-blocking mode. This catches EWOULDBLOCK and returns NONE, - otherwise returns SOME result. Other exceptions are passed back as normal. *) - val nonBlockingCall = LibraryIOSupport.nonBlocking + (* "select" call. *) + datatype sock_desc = SOCKDESC of OS.IO.iodesc + fun sockDesc (SOCK sock) = SOCKDESC sock (* Create a socket descriptor from a socket. *) + fun sameDesc (SOCKDESC a, SOCKDESC b) = a = b - local - val doCall = doNetCall + (* The underlying call takes three arrays and updates them with the sockets that are + in the appropriate state. It sets inactive elements to ~1. *) + val sysSelect: (OS.IO.iodesc Vector.vector * OS.IO.iodesc Vector.vector * OS.IO.iodesc Vector.vector) * int -> + OS.IO.iodesc Vector.vector * OS.IO.iodesc Vector.vector * OS.IO.iodesc Vector.vector + = RunCall.rtsCallFull2 "PolyNetworkSelect" + + fun select { rds: sock_desc list, wrs : sock_desc list, exs : sock_desc list, timeout: Time.time option } : + { rds: sock_desc list, wrs : sock_desc list, exs : sock_desc list } = + let + fun sockDescToDesc(SOCKDESC sock) = sock + (* Create the initial vectors. *) + val rdVec: OS.IO.iodesc Vector.vector = Vector.fromList(map sockDescToDesc rds) + val wrVec: OS.IO.iodesc Vector.vector = Vector.fromList(map sockDescToDesc wrs) + val exVec: OS.IO.iodesc Vector.vector = Vector.fromList(map sockDescToDesc exs) + + (* As with OS.FileSys.poll we call the RTS to check the sockets for up to a second + and repeat until the time expires. *) + val finishTime = case timeout of NONE => NONE | SOME t => SOME(t + Time.now()) + + val maxMilliSeconds = 1000 (* 1 second *) + + fun doSelect() = + let + val timeToGo = + case finishTime of + NONE => maxMilliSeconds + | SOME finish => LargeInt.toInt(LargeInt.min(LargeInt.max(0, Time.toMilliseconds(finish-Time.now())), + LargeInt.fromInt maxMilliSeconds)) + + val results as (rdResult, wrResult, exResult) = + sysSelect((rdVec, wrVec, exVec), timeToGo) + in + if timeToGo < maxMilliSeconds orelse Vector.length rdResult <> 0 + orelse Vector.length wrResult <> 0 orelse Vector.length exResult <> 0 + then results + else doSelect() + end + + val (rdResult, wrResult, exResult) = doSelect() + + (* Function to create the results. *) + fun getResults v = Vector.foldr (fn (sd, l) => SOCKDESC sd :: l) [] v in - fun accept (SOCK s) = RunCall.unsafeCast(doCall (46, s)) + (* Convert the results. *) + { rds = getResults rdResult, wrs = getResults wrResult, exs = getResults exResult } end + (* Run an operation in non-blocking mode. This catches EWOULDBLOCK and returns NONE, + otherwise returns SOME result. Other exceptions are passed back as normal. *) + val nonBlockingCall = LibraryIOSupport.nonBlocking + local - val doCall = doNetCall - fun acc sock = doCall (58, RunCall.unsafeCast sock) + val accpt: OS.IO.iodesc -> OS.IO.iodesc * Word8Vector.vector = RunCall.rtsCallFull1 "PolyNetworkAccept" in - fun acceptNB sock = RunCall.unsafeCast(nonBlockingCall acc sock) + fun acceptNB (SOCK sk) = + case nonBlockingCall accpt sk of + SOME (resSkt, resAddr) => SOME (SOCK resSkt, SOCKADDR resAddr) + | NONE => NONE end + + (* Blocking accept - keep trying until we get a result. *) + fun accept skt = + case acceptNB skt of + SOME result => result + | NONE => + ( + select{wrs=[], rds=[sockDesc skt], exs=[sockDesc skt], timeout=NONE}; + accept skt + ) local - val doCall = doNetCall + val doBindCall: OS.IO.iodesc * Word8Vector.vector -> unit = RunCall.rtsCallFull2 "PolyNetworkBind" in - fun bind (SOCK s, a) = doCall (47, RunCall.unsafeCast (s, a)) + fun bind (SOCK s, SOCKADDR a) = doBindCall(s, a) end local - val doCall = doNetCall + val connct: OS.IO.iodesc * Word8Vector.vector -> unit = RunCall.rtsCallFull2 "PolyNetworkConnect" in - fun connect (SOCK s, a) = doCall (48, RunCall.unsafeCast (s, a)) + fun connectNB (SOCK s, SOCKADDR a) = + case nonBlockingCall connct (s,a) of SOME () => true | NONE => false + + fun connect (sockAndAddr as (skt, _)) = + if connectNB sockAndAddr + then () + else + let + (* In Windows failure is indicated by the bit being set in + the exception set rather than the write set. *) + val _ = select{wrs=[sockDesc skt], rds=[], exs=[sockDesc skt], timeout=NONE} + val anyError = getAndClearError skt + val theError = LibrarySupport.syserrorFromWord anyError + in + if anyError = 0w0 + then () + else raise OS.SysErr(OS.errorMsg theError, SOME theError) + end + end local - val doCall = doNetCall - fun connct sa = doCall (59, RunCall.unsafeCast sa) + val doListen: OS.IO.iodesc * int -> unit = RunCall.rtsCallFull2 "PolyNetworkListen" in - fun connectNB (SOCK s, a) = - case nonBlockingCall connct (s,a) of SOME () => true | NONE => false + fun listen (SOCK s, b) = doListen(s, b) end - fun listen (SOCK s, b) = - doNetCall (49, (s, b)) - (* On Windows sockets and streams are different. *) local val doCall = RunCall.rtsCallFull1 "PolyNetworkCloseSocket" in fun close (SOCK strm): unit = doCall(strm) end datatype shutdown_mode = NO_RECVS | NO_SENDS | NO_RECVS_OR_SENDS local - val doCall = doNetCall + val doCall: OS.IO.iodesc * int -> unit = RunCall.rtsCallFull2 "PolyNetworkShutdown" in fun shutdown (SOCK s, mode) = let val m = case mode of NO_RECVS => 1 | NO_SENDS => 2 | NO_RECVS_OR_SENDS => 3 in - doCall (50, (s, m)) + doCall(s, m) end end (* The IO descriptor is the underlying socket. *) fun ioDesc (SOCK s) = s; type out_flags = {don't_route : bool, oob : bool} type in_flags = {peek : bool, oob : bool} type 'a buf = {buf : 'a, i : int, sz : int option} local val nullOut = { don't_route = false, oob = false } and nullIn = { peek = false, oob = false } (* This implementation is copied from the implementation of Word8Array.array and Word8Vector.vector. *) type address = LibrarySupport.address datatype vector = datatype LibrarySupport.Word8Array.vector datatype array = datatype LibrarySupport.Word8Array.array val wordSize = LibrarySupport.wordSize - (* Send the data from an array or vector. Note: the underlying RTS function - deals with the special case of sending a single byte vector where the - "address" is actually the byte itself. *) + (* Send the data from an array or vector. *) local - val doCall = doNetCall - fun doSend i a = doCall (i, a) - in - fun send (SOCK sock, base: address, offset: int, length: int, rt: bool, oob: bool): int = - doSend 51 (sock, base, offset, length, rt, oob) - + val doSend: OS.IO.iodesc * address * int * int * bool * bool -> int = + RunCall.rtsCallFull1 "PolyNetworkSend" + in fun sendNB (SOCK sock, base: address, offset: int, length: int, rt: bool, oob: bool): int option = - nonBlockingCall (doSend 60) (sock, base, offset, length, rt, oob) + nonBlockingCall doSend (sock, base, offset, length, rt, oob) + + fun send (skt as SOCK sock, base, offset, length, rt, oob) = + ( + (* Wait until we can write. *) + select{wrs=[sockDesc skt], rds=[], exs=[], timeout=NONE}; + (* Send it. We should never get a WOULDBLOCK result so if we do we pass that back. *) + doSend (sock, base, offset, length, rt, oob) + ) end local (* Although the underlying call returns the number of bytes written the ML functions now return unit. *) - val doCall = doNetCall - fun doSendTo i a = doCall (i, a) - in - fun sendTo (SOCK sock, addr, base: address, offset: int, length: int, rt: bool, oob: bool): unit = - doSendTo 52 (RunCall.unsafeCast(sock, addr, base, offset, length, rt, oob)) - - fun sendToNB (SOCK sock, addr, base: address, offset: int, length: int, rt: bool, oob: bool): bool = - case nonBlockingCall (doSendTo 61) (RunCall.unsafeCast(sock, addr, base, offset, length, rt, oob)) of + val doSend: OS.IO.iodesc * Word8Vector.vector * address * int * int * bool * bool -> int = + RunCall.rtsCallFull1 "PolyNetworkSendTo" + in + fun sendToNB (SOCK sock, SOCKADDR addr, base: address, offset, length, rt, oob): bool = + case nonBlockingCall doSend (sock, addr, base, offset, length, rt, oob) of NONE => false | SOME _ => true + + fun sendTo (skt as SOCK sock, SOCKADDR addr, base: address, offset, length, rt, oob): unit = + ( + (* Wait until we can write. *) + select{wrs=[sockDesc skt], rds=[], exs=[], timeout=NONE}; + doSend (sock, addr, base, offset, length, rt, oob); + () + ) end local - val doCall = doNetCall - fun doRecv i a = doCall (i, a) + val doRecv: OS.IO.iodesc * address * int * int * bool * bool -> int = + RunCall.rtsCallFull1 "PolyNetworkReceive" in (* Receive the data into an array. *) - fun recv (SOCK sock, base: address, offset: int, length: int, peek: bool, oob: bool): int = - doRecv 53 (RunCall.unsafeCast(sock, base, offset, length, peek, oob)) - fun recvNB (SOCK sock, base: address, offset: int, length: int, peek: bool, oob: bool): int option = - nonBlockingCall (doRecv 62) (RunCall.unsafeCast(sock, base, offset, length, peek, oob)) + nonBlockingCall doRecv (sock, base, offset, length, peek, oob) + + fun recv (skt as SOCK sock, base, offset, length, rt, oob) = + ( + (* Wait until we can read. *) + select{wrs=[], rds=[sockDesc skt], exs=[], timeout=NONE}; + doRecv (sock, base, offset, length, rt, oob) + ) end local - val doCall = doNetCall - fun doRecvFrom i a = doCall (i, a) + val doRecvFrom: OS.IO.iodesc * address * int * int * bool * bool -> int * Word8Vector.vector = + RunCall.rtsCallFull1 "PolyNetworkReceiveFrom" in - fun recvFrom (SOCK sock, base: address, offset: int, length: int, peek: bool, oob: bool) = - RunCall.unsafeCast(doRecvFrom 54 (RunCall.unsafeCast (sock, base, offset, length, peek, oob))) - - fun recvFromNB (SOCK sock, base: address, offset: int, length: int, peek: bool, oob: bool) = - RunCall.unsafeCast(nonBlockingCall (doRecvFrom 63) (RunCall.unsafeCast (sock, base, offset, length, peek, oob))) + fun recvFromNB (SOCK sock, base, offset, length, peek, oob) = + case nonBlockingCall doRecvFrom (sock, base, offset, length, peek, oob) of + SOME(length, addr) => SOME(length, SOCKADDR addr) + | NONE => NONE + + fun recvFrom (skt as SOCK sock, base, offset, length, peek, oob) = + ( + (* Wait until we can read. *) + select{wrs=[], rds=[sockDesc skt], exs=[], timeout=NONE}; + case doRecvFrom (sock, base, offset, length, peek, oob) of + (length, addr) => (length, SOCKADDR addr) + ) end in fun sendVec' (sock, slice: Word8VectorSlice.slice, {don't_route, oob}) = let val (v, i, length) = Word8VectorSlice.base slice in send(sock, LibrarySupport.w8vectorAsAddress v, i + Word.toInt wordSize, length, don't_route, oob) end and sendVec (sock, vbuff) = sendVec'(sock, vbuff, nullOut) fun sendVecNB' (sock, slice: Word8VectorSlice.slice, {don't_route, oob}) = let val (v, i, length) = Word8VectorSlice.base slice in sendNB(sock, LibrarySupport.w8vectorAsAddress v, i + Word.toInt wordSize, length, don't_route, oob) end and sendVecNB (sock, vbuff) = sendVecNB'(sock, vbuff, nullOut) fun sendArr' (sock, slice: Word8ArraySlice.slice, {don't_route, oob}) = let val (Array(_, v), i, length) = Word8ArraySlice.base slice in send(sock, v, i, length, don't_route, oob) end and sendArr (sock, vbuff) = sendArr'(sock, vbuff, nullOut) fun sendArrNB' (sock, slice: Word8ArraySlice.slice, {don't_route, oob}) = let val (Array(_, v), i, length) = Word8ArraySlice.base slice in sendNB(sock, v, i, length, don't_route, oob) end and sendArrNB (sock, vbuff) = sendArrNB'(sock, vbuff, nullOut) fun sendVecTo' (sock, addr, slice: Word8VectorSlice.slice, {don't_route, oob}) = let val (v, i, length) = Word8VectorSlice.base slice in sendTo(sock, addr, LibrarySupport.w8vectorAsAddress v, i + Word.toInt wordSize, length, don't_route, oob) end and sendVecTo (sock, addr, vbuff) = sendVecTo'(sock, addr, vbuff, nullOut) fun sendVecToNB' (sock, addr, slice: Word8VectorSlice.slice, {don't_route, oob}) = let val (v, i, length) = Word8VectorSlice.base slice in sendToNB(sock, addr, LibrarySupport.w8vectorAsAddress v, i + Word.toInt wordSize, length, don't_route, oob) end and sendVecToNB (sock, addr, vbuff) = sendVecToNB'(sock, addr, vbuff, nullOut) fun sendArrTo' (sock, addr, slice: Word8ArraySlice.slice, {don't_route, oob}) = let val (Array(_, v), i, length) = Word8ArraySlice.base slice in sendTo(sock, addr, v, i, length, don't_route, oob) end and sendArrTo (sock, addr, vbuff) = sendArrTo'(sock, addr, vbuff, nullOut) fun sendArrToNB' (sock, addr, slice: Word8ArraySlice.slice, {don't_route, oob}) = let val (Array(_, v), i, length) = Word8ArraySlice.base slice in sendToNB(sock, addr, v, i, length, don't_route, oob) end and sendArrToNB (sock, addr, vbuff) = sendArrToNB'(sock, addr, vbuff, nullOut) fun recvArr' (sock, slice: Word8ArraySlice.slice, {peek, oob}) = let val (Array(_, v), i, length) = Word8ArraySlice.base slice in recv(sock, v, i, length, peek, oob) end and recvArr (sock, vbuff) = recvArr'(sock, vbuff, nullIn) fun recvArrNB' (sock, slice: Word8ArraySlice.slice, {peek, oob}) = let val (Array(_, v), i, length) = Word8ArraySlice.base slice in recvNB(sock, v, i, length, peek, oob) end and recvArrNB (sock, vbuff) = recvArrNB'(sock, vbuff, nullIn) (* To receive a vector first create an array, read into it, then copy it to a new vector. This does involve extra copying but it probably doesn't matter too much. *) fun recvVec' (sock, size, flags) = let val arr = Word8Array.array(size, 0w0); val recvd = recvArr'(sock, Word8ArraySlice.full arr, flags) in Word8ArraySlice.vector(Word8ArraySlice.slice(arr, 0, SOME recvd)) end and recvVec (sock, size) = recvVec'(sock, size, nullIn) fun recvVecNB' (sock, size, flags) = let val arr = Word8Array.array(size, 0w0); in case recvArrNB'(sock, Word8ArraySlice.full arr, flags) of NONE => NONE | SOME recvd => SOME(Word8ArraySlice.vector(Word8ArraySlice.slice(arr, 0, SOME recvd))) end and recvVecNB (sock, size) = recvVecNB'(sock, size, nullIn) fun recvArrFrom' (sock, slice: Word8ArraySlice.slice, {peek, oob}) = let val (Array(_, v), i, length) = Word8ArraySlice.base slice in recvFrom(sock, v, i, length, peek, oob) end and recvArrFrom (sock, abuff) = recvArrFrom'(sock, abuff, nullIn) fun recvArrFromNB' (sock, slice: Word8ArraySlice.slice, {peek, oob}) = let val (Array(_, v), i, length) = Word8ArraySlice.base slice in recvFromNB(sock, v, i, length, peek, oob) end and recvArrFromNB (sock, abuff) = recvArrFromNB'(sock, abuff, nullIn) fun recvVecFrom' (sock, size, flags) = let val arr = Word8Array.array(size, 0w0); val (rcvd, addr) = recvArrFrom'(sock, Word8ArraySlice.full arr, flags) in (Word8ArraySlice.vector(Word8ArraySlice.slice(arr, 0, SOME rcvd)), addr) end and recvVecFrom (sock, size) = recvVecFrom'(sock, size, nullIn) fun recvVecFromNB' (sock, size, flags) = let val arr = Word8Array.array(size, 0w0); in case recvArrFromNB'(sock, Word8ArraySlice.full arr, flags) of NONE => NONE | SOME (rcvd, addr) => SOME (Word8ArraySlice.vector(Word8ArraySlice.slice(arr, 0, SOME rcvd)), addr) end and recvVecFromNB (sock, size) = recvVecFromNB'(sock, size, nullIn) end - (* "select" call. *) - datatype sock_desc = SOCKDESC of OS.IO.iodesc - fun sockDesc (SOCK sock) = SOCKDESC sock (* Create a socket descriptor from a socket. *) - fun sameDesc (SOCKDESC a, SOCKDESC b) = a = b - - local - (* The underlying call takes three arrays and updates them with the sockets that are - in the appropriate state. It sets inactive elements to ~1. *) - val doIo: int * (OS.IO.iodesc Vector.vector * OS.IO.iodesc Vector.vector * OS.IO.iodesc Vector.vector * Time.time) -> - OS.IO.iodesc Vector.vector * OS.IO.iodesc Vector.vector * OS.IO.iodesc Vector.vector - = doNetCall - in - fun sys_select_block(rds, wrs, exs) = doIo(64, (rds, wrs, exs, Time.zeroTime)) - fun sys_select_poll(rds, wrs, exs) = doIo(65, (rds, wrs, exs, Time.zeroTime)) - (* The time parameter for a wait is the absolute time when the timeout expires. *) - and sys_select_wait (rds, wrs, exs, t) = doIo(66, (rds, wrs, exs, t)) - end - - fun select { rds: sock_desc list, wrs : sock_desc list, exs : sock_desc list, timeout: Time.time option } : - { rds: sock_desc list, wrs : sock_desc list, exs : sock_desc list } = - let - fun sockDescToDesc(SOCKDESC sock) = sock - (* Create the initial vectors. *) - val rdVec: OS.IO.iodesc Vector.vector = Vector.fromList(map sockDescToDesc rds) - val wrVec: OS.IO.iodesc Vector.vector = Vector.fromList(map sockDescToDesc wrs) - val exVec: OS.IO.iodesc Vector.vector = Vector.fromList(map sockDescToDesc exs) - open Time - val (rdResult, wrResult, exResult) = - (* Do the approriate select. *) - case timeout of - NONE => sys_select_block(rdVec, wrVec, exVec) - | SOME t => if t <= Time.zeroTime - then sys_select_poll(rdVec, wrVec, exVec) - else sys_select_wait(rdVec, wrVec, exVec, t + Time.now()); - (* Function to create the results. *) - fun getResults v = Vector.foldr (fn (sd, l) => SOCKDESC sd :: l) [] v - in - (* Convert the results. *) - { rds = getResults rdResult, wrs = getResults wrResult, exs = getResults exResult } - end - end; local (* Install the pretty printer for Socket.AF.addr_family This must be done outside the structure if we use opaque matching. *) fun printAF _ _ x = PolyML.PrettyString(Socket.AF.toString x) fun printSK _ _ x = PolyML.PrettyString(Socket.SOCK.toString x) fun prettySocket _ _ (_: ('a, 'b) Socket.sock) = PolyML.PrettyString "?" in val () = PolyML.addPrettyPrinter printAF val () = PolyML.addPrettyPrinter printSK val () = PolyML.addPrettyPrinter prettySocket 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/Time.sml b/basis/Time.sml index 6b81917c..3a0c73c2 100644 --- a/basis/Time.sml +++ b/basis/Time.sml @@ -1,212 +1,208 @@ (* Title: Standard Basis Library: Time Signature and structure. Author: David Matthews - Copyright David Matthews 2000, 2005, 2017 + Copyright David Matthews 2000, 2005, 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 *) signature TIME = sig eqtype time exception Time val zeroTime : time val fromReal : LargeReal.real -> time val toReal : time -> LargeReal.real val toSeconds : time -> LargeInt.int val toMilliseconds : time -> LargeInt.int val toMicroseconds : time -> LargeInt.int val toNanoseconds : time -> LargeInt.int val fromSeconds : LargeInt.int -> time val fromMilliseconds : LargeInt.int -> time val fromMicroseconds : LargeInt.int -> time val fromNanoseconds : LargeInt.int -> time val + : time * time -> time val - : time * time -> time val compare : time * time -> General.order val < : time * time -> bool val <= : time * time -> bool val > : time * time -> bool val >= : time * time -> bool val now : unit -> time val fmt : int -> time -> string val toString : time -> string val fromString : string -> time option val scan : (char, 'a) StringCvt.reader -> (time, 'a) StringCvt.reader end; structure Time :> TIME = struct (* Unix and Windows both use 64 bit quantities for times. Windows uses a 64-bit number of 100ns ticks, Unix uses one word of seconds and another of microseconds. To handle both easily we use a single arbitrary precision number for times with the actual resolution returned as an RTS call. The intention is retain as much precision as possible. *) type time = LargeInt.int (* Becomes abstract *) exception Time - local - val timingGeneralCall = RunCall.rtsCallFull2 "PolyTimingGeneral" - fun timingGeneral(code: int, arg:'a):'b = - RunCall.unsafeCast(timingGeneralCall(RunCall.unsafeCast(code, arg))) - in - fun callTiming (code: int) args = timingGeneral (code,args) - end - (* Get the number of ticks per microsecond and compute the corresponding values for milliseconds and seconds. *) - val ticksPerMicrosecond = callTiming 0 0 + val ticksPerMicrosecond = RunCall.rtsCallFull0 "PolyTimingTicksPerMicroSec" () val ticksPerMillisecond = ticksPerMicrosecond * 1000 val ticksPerSecond = ticksPerMillisecond * 1000 (* Check for very large time values. These cause problems if converted to dates. *) local val Years100000 = ticksPerSecond*60*60*24*365*100000 in fun checkTimeValue t = if t < ~ Years100000 orelse t > Years100000 then raise Time else t end; (* The real representation is as a number of seconds. *) local val realTicks = Real.fromLargeInt ticksPerSecond in fun fromReal (x: real): time = checkTimeValue(Real.toLargeInt IEEEReal.TO_NEAREST (x * realTicks)) and toReal (t: time): real = Real.fromLargeInt t / realTicks end val zeroTime = fromReal 0.0 (* Convert to seconds, etc.*) fun toSeconds x = x div ticksPerSecond and toMilliseconds x = x div ticksPerMillisecond and toMicroseconds x = x div ticksPerMicrosecond and toNanoseconds x = x * 1000 div ticksPerMicrosecond (* Convert from the integer representations. *) fun fromSeconds i = checkTimeValue(i * ticksPerSecond) and fromMilliseconds i = checkTimeValue(i * ticksPerMillisecond) and fromMicroseconds i = checkTimeValue(i * ticksPerMicrosecond) and fromNanoseconds i = checkTimeValue(i * ticksPerMicrosecond div 1000) (* Format as a fixed precision number. if n < 0 treat as n = 0. *) fun fmt n r = Real.fmt (StringCvt.FIX(SOME(Int.max(n, 0)))) (toReal r) val toString = fmt 3 (* The scanned string is a subset of the format of a real number. It does not have an exponent. At present we convert it as a real number but it would probably be better to treat it as an integer. *) fun scan getc src = let (* Return a list of digits. *) fun getdigits inp src = case getc src of NONE => (List.rev inp, src) | SOME(ch, src') => if ch >= #"0" andalso ch <= #"9" then getdigits ((Char.ord ch - Char.ord #"0") :: inp) src' else (List.rev inp, src) fun read_number sign src = case getc src of NONE => NONE | SOME(ch, _) => if not (ch >= #"0" andalso ch <= #"9" orelse ch = #".") then NONE (* Bad "*) else (* Digits or decimal. *) let (* Get the digits before the decimal point (if any) *) val (intPart, src'') = getdigits [] src (* Get the digits after the decimal point (if any). If there is a decimal point we swallow the decimal only if there is at least one digit after it. *) val (decPart, srcAfterMant) = case getc src'' of SOME (#".", src''') => ( (* Check that the next character is a digit. *) case getc src''' of NONE => ([], src'') | SOME(ch, _) => if ch >= #"0" andalso ch <= #"9" then getdigits [] src''' else ([], src'') ) | _ => ([], src'') in case (intPart, decPart) of ([], []) => NONE (* Must have a digit either before or after the dp. *) | _ => let (* Get exactly 9 digits after the decimal point. *) val decs = intPart @ (List.take(decPart @ [ 0, 0, 0, 0, 0, 0, 0, 0, 0 ], 9)); (* It's now in nanoseconds. *) val toInt = List.foldl (fn (i, j) => LargeInt.fromInt i + j*10) (0: time) decs in SOME(fromNanoseconds(if sign then ~toInt else toInt), srcAfterMant) end end in case getc src of NONE => NONE | SOME(ch, src') => if Char.isSpace ch (* Skip white space. *) then scan getc src' (* Recurse *) else if ch = #"+" (* Remove the + sign *) then read_number false src' else if ch = #"-" orelse ch = #"~" then read_number true src' else (* See if it's a valid digit or decimal point. *) read_number false src end val fromString = StringCvt.scanString scan (* Use the integer operations for these. *) val op < : (time * time) -> bool = LargeInt.< val op <= : (time * time) -> bool = LargeInt.<= val op > : (time * time) -> bool = LargeInt.> val op >= : (time * time) -> bool = LargeInt.>=; val compare = LargeInt.compare val op + : (time * time) -> time = LargeInt.+ val op - : (time * time) -> time = LargeInt.- - fun now () = callTiming 1 0 handle RunCall.SysErr _ => raise Time + local + val getNow: unit -> time = RunCall.rtsCallFull0 "PolyTimingGetNow" + in + fun now () = getNow() handle RunCall.SysErr _ => raise Time + end end; local (* Install the pretty printer for Time.time. This has to be done outside the structure because of the opaque matching. *) fun pretty _ _ x = PolyML.PrettyString(Time.toString x) in val () = PolyML.addPrettyPrinter pretty (* Add overloads for +, -, <= etc *) (* This is actually non-standard. The basis library documentation does not include Time.time among the types for which these operators are overloaded. *) val () = RunCall.addOverload Time.+ "+"; val () = RunCall.addOverload Time.- "-"; val () = RunCall.addOverload Time.< "<"; val () = RunCall.addOverload Time.> ">"; val () = RunCall.addOverload Time.<= "<="; val () = RunCall.addOverload Time.>= ">="; end diff --git a/basis/Timer.sml b/basis/Timer.sml index 2ed63382..37d74816 100644 --- a/basis/Timer.sml +++ b/basis/Timer.sml @@ -1,95 +1,89 @@ (* Title: Standard Basis Library: Timer Signature and structure. Author: David Matthews Copyright David Matthews 2000, 2005, 2008, 2017 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 *) (* G&R 2004 status: updated. Added checkCPUTimes. *) signature TIMER = sig type cpu_timer type real_timer val startCPUTimer : unit -> cpu_timer val checkCPUTimer : cpu_timer -> {usr : Time.time, sys : Time.time} val checkGCTime : cpu_timer -> Time.time val totalCPUTimer : unit -> cpu_timer val startRealTimer : unit -> real_timer val checkRealTimer : real_timer -> Time.time val totalRealTimer : unit -> real_timer val checkCPUTimes : cpu_timer -> { nongc: { usr : Time.time, sys : Time.time}, gc: { usr : Time.time, sys : Time.time} } end structure Timer :> TIMER = struct type cpu_timer = {userTime: Time.time, sysTime: Time.time, gcUTime: Time.time, gcSTime: Time.time } type real_timer = Time.time local open Time - - local - val timingGeneralCall = RunCall.rtsCallFull2 "PolyTimingGeneral" - in - fun doCall(code: int, arg:'a):'b = - RunCall.unsafeCast(timingGeneralCall(RunCall.unsafeCast(code, arg))) - end - fun getUserTime() = doCall(7, ()) - and getSysTime() = doCall(8, ()) - and getGCUTime() = doCall(9, ()) - and getGCSTime() = doCall(13, ()) + val getUserTime: unit -> Time.time = RunCall.rtsCallFull0 "PolyTimingGetUser" + and getSysTime: unit -> Time.time = RunCall.rtsCallFull0 "PolyTimingGetSystem" + and getGCUTime: unit -> Time.time = RunCall.rtsCallFull0 "PolyTimingGetGCUser" + and getGCSTime: unit -> Time.time = RunCall.rtsCallFull0 "PolyTimingGetGCSystem" in fun startCPUTimer () = {userTime=getUserTime(), sysTime=getSysTime(), gcUTime=getGCUTime(), gcSTime=getGCSTime() } and checkCPUTimer ({ userTime, sysTime, ...}: cpu_timer) = { usr = getUserTime() - userTime, sys = getSysTime() - sysTime} and checkGCTime ({ gcUTime, ...}: cpu_timer) = getGCUTime() - gcUTime and totalCPUTimer () = { userTime=Time.zeroTime, sysTime=Time.zeroTime, gcUTime=Time.zeroTime, gcSTime=Time.zeroTime } fun checkCPUTimes (timer as { gcUTime, gcSTime, ... }) = let val { usr, sys } = checkCPUTimer timer val gc_usr = getGCUTime() - gcUTime and gc_sys = getGCSTime() - gcSTime in { gc = { usr = gc_usr, sys = gc_sys }, nongc = { usr = usr-gc_usr, sys = sys-gc_sys } } end + + val startRealTimer: unit -> Time.time = RunCall.rtsCallFull0 "PolyTimingGetReal" fun totalRealTimer() = Time.zeroTime - and startRealTimer() = doCall(10, ()) and checkRealTimer t = startRealTimer() - t end end; (* Override the default printer so they're abstract. *) local fun prettyCPUTimer _ _ (_: Timer.cpu_timer) = PolyML.PrettyString "?" and prettyRealTimer _ _ (_: Timer.real_timer) = PolyML.PrettyString "?" in val () = PolyML.addPrettyPrinter prettyCPUTimer and () = PolyML.addPrettyPrinter prettyRealTimer end; diff --git a/basis/UnixSock.sml b/basis/UnixSock.sml index 78b1990e..96d44e52 100644 --- a/basis/UnixSock.sml +++ b/basis/UnixSock.sml @@ -1,80 +1,69 @@ (* Title: Standard Basis Library: Unix socket structure and signature. Author: David Matthews - Copyright David Matthews 2000, 2005, 2016 + Copyright David Matthews 2000, 2005, 2016, 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 UNIX_SOCK = sig type unix type 'sock_type sock = (unix, 'sock_type) Socket.sock type 'mode stream_sock = 'mode Socket.stream sock type dgram_sock = Socket.dgram sock type sock_addr = unix Socket.sock_addr val unixAF : Socket.AF.addr_family val toAddr : string -> sock_addr val fromAddr : sock_addr -> string structure Strm : sig val socket : unit -> 'mode stream_sock val socketPair : unit -> 'mode stream_sock * 'mode stream_sock end structure DGrm : sig val socket : unit -> dgram_sock val socketPair : unit -> dgram_sock * dgram_sock end end; structure UnixSock : UNIX_SOCK = struct abstype unix = ABSTRACT with end; type 'sock_type sock = (unix, 'sock_type) Socket.sock type 'mode stream_sock = 'mode Socket.stream sock type dgram_sock = Socket.dgram sock type sock_addr = unix Socket.sock_addr val unixAF : Socket.AF.addr_family = case Socket.AF.fromString "UNIX" of NONE => raise OS.SysErr("Missing address family", NONE) | SOME s => s - local - val doCall: int * string -> sock_addr - = RunCall.rtsCallFull2 "PolyNetworkGeneral" - in - fun toAddr s = doCall(56, s) - end - - local - val doCall: int * sock_addr -> string - = RunCall.rtsCallFull2 "PolyNetworkGeneral" - in - fun fromAddr s = doCall(57, s) - end + val toAddr: string -> sock_addr = RunCall.rtsCallFull1 "PolyNetworkUnixPathToSockAddr" + and fromAddr: sock_addr -> string = RunCall.rtsCallFull1 "PolyNetworkUnixSockAddrToPath" structure Strm = struct fun socket() = GenericSock.socket(unixAF, Socket.SOCK.stream) fun socketPair() = GenericSock.socketPair(unixAF, Socket.SOCK.stream) end structure DGrm = struct fun socket() = GenericSock.socket(unixAF, Socket.SOCK.dgram) fun socketPair() = GenericSock.socketPair(unixAF, Socket.SOCK.dgram) end end; diff --git a/basis/Windows.sml b/basis/Windows.sml index dcc27f0c..121eb593 100644 --- a/basis/Windows.sml +++ b/basis/Windows.sml @@ -1,726 +1,971 @@ (* Title: Standard Basis Library: Windows signature and structure Author: David Matthews Copyright David Matthews 2000, 2005, 2012, 2018, 2019 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) signature WINDOWS = sig structure Key : sig include BIT_FLAGS val allAccess : flags val createLink : flags val createSubKey : flags val enumerateSubKeys : flags val execute : flags val notify : flags val queryValue : flags val read : flags val setValue : flags val write : flags end structure Reg : sig eqtype hkey val classesRoot : hkey val currentUser : hkey val localMachine : hkey val users : hkey val performanceData : hkey val currentConfig : hkey val dynData : hkey datatype create_result = CREATED_NEW_KEY of hkey | OPENED_EXISTING_KEY of hkey val createKeyEx : hkey * string * Key.flags -> create_result val openKeyEx : hkey * string * Key.flags -> hkey val closeKey : hkey -> unit val deleteKey : hkey * string -> unit val deleteValue : hkey * string -> unit val enumKeyEx : hkey * int -> string option val enumValueEx : hkey * int -> string option datatype value = SZ of string | DWORD of SysWord.word | BINARY of Word8Vector.vector | MULTI_SZ of string list | EXPAND_SZ of string val queryValueEx : hkey * string -> value option val setValueEx : hkey * string * value -> unit end structure Config: sig val platformWin32s : SysWord.word val platformWin32Windows : SysWord.word val platformWin32NT : SysWord.word val platformWin32CE : SysWord.word val getVersionEx: unit -> { majorVersion: SysWord.word, minorVersion: SysWord.word, buildNumber: SysWord.word, platformId: SysWord.word, csdVersion: string } val getWindowsDirectory: unit -> string val getSystemDirectory: unit -> string val getComputerName: unit -> string val getUserName: unit -> string end structure DDE : sig type info val startDialog : string * string -> info val executeString : info * string * int * Time.time -> unit val stopDialog : info -> unit end val getVolumeInformation : string -> { volumeName : string, systemName : string, serialNumber : SysWord.word, maximumComponentLength : int } val findExecutable : string -> string option val launchApplication : string * string -> unit val openDocument : string -> unit val simpleExecute : string * string -> OS.Process.status type ('a,'b) proc val execute : string * string -> ('a, 'b) proc val textInstreamOf : (TextIO.instream, 'a) proc -> TextIO.instream val binInstreamOf : (BinIO.instream, 'a) proc -> BinIO.instream val textOutstreamOf : ('a, TextIO.outstream) proc -> TextIO.outstream val binOutstreamOf : ('a, BinIO.outstream) proc -> BinIO.outstream val reap : ('a, 'b) proc -> OS.Process.status structure Status : sig type status = SysWord.word val accessViolation : status val arrayBoundsExceeded : status val breakpoint : status val controlCExit : status val datatypeMisalignment : status val floatDenormalOperand : status val floatDivideByZero : status val floatInexactResult : status val floatInvalidOperation : status val floatOverflow : status val floatStackCheck : status val floatUnderflow : status val guardPageViolation : status val integerDivideByZero : status val integerOverflow : status val illegalInstruction : status val invalidDisposition : status val invalidHandle : status val inPageError : status val noncontinuableException: status val pending : status val privilegedInstruction : status val singleStep : status val stackOverflow : status val timeout : status val userAPC : status end val fromStatus : OS.Process.status -> Status.status val exit : Status.status -> 'a end structure Windows :> WINDOWS = struct - local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + open Foreign + + val cDWORD = cUint32 (* Defined to be 32-bit unsigned *) + + (* Conversion for a fixed size char array. *) + fun cCHARARRAY n : string conversion = + let + (* Make it a struct of chars *) + val { size=sizeC, align=alignC, ffiType=ffiTypeC } = LowLevel.cTypeChar + val arraySize = sizeC * Word.fromInt n + fun ffiType () = + LibFFI.createFFItype { + size = arraySize, align = alignC, typeCode=LibFFI.ffiTypeCodeStruct, + elements = List.tabulate (n, fn _ => ffiTypeC()) } + val arrayType: LowLevel.ctype = + { size = arraySize, align = alignC, ffiType = ffiType } + + open Memory + + fun load(v: voidStar): string = + let + (* It should be null-terminated but just in case... *) + fun sLen i = if i = Word.fromInt n orelse get8(v, i) = 0w0 then i else sLen(i+0w1) + val length = sLen 0w0 + fun loadChar i = + Char.chr(Word8.toInt(get8(v, Word.fromInt i))) + in + CharVector.tabulate(Word.toInt length, loadChar) + end + + fun store(v: voidStar, s: string) = + let + (* The length must be less than the size to allow for the null *) + val sLen = size s + val _ = sLen < n orelse raise Fail "string too long" + in + CharVector.appi(fn(i, ch) => set8(v, Word.fromInt i, Word8.fromInt(Char.ord ch))) s; + set8(v, Word.fromInt sLen, 0w0); + fn () => () + end + in + makeConversion { load = load, store = store, ctype = arrayType } + end + + (* These are called XXX32.DLL on both 32-bit and 64-bit. *) + fun kernel name = getSymbol(loadLibrary "kernel32.dll") name + and shell sym = getSymbol(loadLibrary "shell32.DLL") sym + and advapi sym = getSymbol(loadLibrary "advapi32.DLL") sym + + (* We need to use the Pascal calling convention on 32-bit Windows. *) + val winAbi = + case List.find (fn ("stdcall", _) => true | _ => false) LibFFI.abiList of + SOME(_, abi) => abi + | NONE => LibFFI.abiDefault + + (* As well as setting the abi we can also use the old argument order. *) + fun winCall1 sym argConv resConv = buildCall1withAbi(winAbi, sym, argConv, resConv) + and winCall2 sym argConv resConv = buildCall2withAbi(winAbi, sym, argConv, resConv) + and winCall3 sym argConv resConv = buildCall3withAbi(winAbi, sym, argConv, resConv) + and winCall5 sym argConv resConv = buildCall5withAbi(winAbi, sym, argConv, resConv) + and winCall6 sym argConv resConv = buildCall6withAbi(winAbi, sym, argConv, resConv) + and winCall8 sym argConv resConv = buildCall8withAbi(winAbi, sym, argConv, resConv) + and winCall9 sym argConv resConv = buildCall9withAbi(winAbi, sym, argConv, resConv) + and winCall12 sym argConv resConv = buildCall12withAbi(winAbi, sym, argConv, resConv) + + val MAX_PATH = 0w260 + + (* Convert a C string to ML. *) + fun fromCstring buff = + let + open Memory + (* We can't use #load cString because the argument is the address of + the address of the string. *) + fun sLen i = if get8(buff, i) = 0w0 then i else sLen(i+0w1) + val length = sLen 0w0 + fun loadChar i = + Char.chr(Word8.toInt(get8(buff, Word.fromInt i))) in - fun getConst i = SysWord.fromInt(winCall (1006, i)) + CharVector.tabulate(Word.toInt length, loadChar) end structure Key = struct type flags = SysWord.word fun toWord f = f fun fromWord f = f val flags = List.foldl (fn (a, b) => SysWord.orb(a,b)) 0w0 fun allSet (fl1, fl2) = SysWord.andb(fl1, fl2) = fl1 fun anySet (fl1, fl2) = SysWord.andb(fl1, fl2) <> 0w0 fun clear (fl1, fl2) = SysWord.andb(SysWord.notb fl1, fl2) - val allAccess : flags = getConst 0 - val createLink : flags = getConst 1 - val createSubKey : flags = getConst 2 - val enumerateSubKeys : flags = getConst 3 - val execute : flags = getConst 4 - val notify : flags = getConst 5 - val queryValue : flags = getConst 6 - val read : flags = getConst 7 - val setValue : flags = getConst 8 - val write : flags = getConst 9 + val queryValue = 0wx0001 + and setValue = 0wx0002 + and createSubKey = 0wx0004 + and enumerateSubKeys = 0wx0008 + and notify = 0wx0010 + and createLink = 0wx0020 + + val read = flags[0wx00020000, queryValue, enumerateSubKeys, notify] + and write = flags[0wx00020000, setValue, createSubKey] + + val execute = read + + val allAccess = flags[0wx000f0000, queryValue, setValue, createSubKey, enumerateSubKeys, notify, createLink] (* all is probably equivalent to allAccess. *) val all = flags[allAccess, createLink, createSubKey, enumerateSubKeys, execute, notify, queryValue, read, setValue, write] val intersect = List.foldl (fn (a, b) => SysWord.andb(a,b)) all end structure Reg = struct - - datatype hkey = - PREDEFINED of int - | SUBKEY of int (* Actually abstract. *) - val classesRoot = PREDEFINED 0 - val currentUser = PREDEFINED 1 - val localMachine = PREDEFINED 2 - val users = PREDEFINED 3 - val performanceData = PREDEFINED 4 - val currentConfig = PREDEFINED 5 - val dynData = PREDEFINED 6 + datatype hkey = PREDEFINED of SysWord.word | SUBKEY of Memory.volatileRef + + val classesRoot = PREDEFINED 0wx80000000 + and currentUser = PREDEFINED 0wx80000001 + and localMachine = PREDEFINED 0wx80000002 + and users = PREDEFINED 0wx80000003 + and performanceData = PREDEFINED 0wx80000004 + and currentConfig = PREDEFINED 0wx80000005 + and dynData = PREDEFINED 0wx80000006 + datatype create_result = CREATED_NEW_KEY of hkey | OPENED_EXISTING_KEY of hkey + datatype value = SZ of string | DWORD of SysWord.word | BINARY of Word8Vector.vector | MULTI_SZ of string list | EXPAND_SZ of string local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" - (* Open one of the root keys. *) - (* QUESTION: Why is this an option? The definition asks - the same question. I've removed the option type. *) - fun openRoot args = - SUBKEY(winCall(1007, args)) - (* Open a sub-key. *) - and openSubKey args = - SUBKEY(winCall(1008, args)) + val invalidHandle = valOf(OS.syserror "ERROR_INVALID_HANDLE") in - fun openKeyEx(PREDEFINED i, s, f) = - openRoot(i, s, SysWord.toInt f) - | openKeyEx(SUBKEY i, s, f) = - openSubKey(i, s, SysWord.toInt f) + (* When a subkey is opened the value is stored in a volatile ref. + This prevents the key from persisting. *) + fun getHkeyValue(PREDEFINED w) = Memory.sysWord2VoidStar w + | getHkeyValue(SUBKEY v) = + let + val w = Memory.getVolatileRef v + in + if w = 0w0 + then raise OS.SysErr("ERROR_INVALID_HANDLE", SOME invalidHandle) + else Memory.sysWord2VoidStar w + end end + + (* Check the result and raise an exception if it's non-zero. *) + fun checkLResult 0 = () + | checkLResult nonZero = + let + val err = Error.fromWord(SysWord.fromInt nonZero) + in + raise OS.SysErr(OS.errorMsg err, SOME err) + end local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val openKey = winCall5 (advapi "RegOpenKeyExA") (cPointer, cString, cDWORD, cDWORD, cStar cPointer) cLong + in + fun openKeyEx(hkey, key, flags) = + let + val keyRes = ref Memory.null + val result = openKey(getHkeyValue hkey, key, 0, SysWord.toInt(Key.toWord flags), keyRes) + in + checkLResult result; + SUBKEY(Memory.volatileRef(Memory.voidStar2Sysword(!keyRes))) + end + end - fun pairToResult (0, k) = CREATED_NEW_KEY (SUBKEY k) - | pairToResult (_, k) = OPENED_EXISTING_KEY (SUBKEY k) + local + val createKey = + winCall9 (advapi "RegCreateKeyExA") + (cPointer, cString, cDWORD, cPointer, cDWORD, cDWORD, cPointer, cStar cPointer, cStar cDWORD) cLong + in + fun createKeyEx(hkey, key, flags) = + let + val keyRes = ref Memory.null + val disp = ref 0 + val REG_OPTION_NON_VOLATILE = 0 + val REG_CREATED_NEW_KEY = 1 + val result = + createKey(getHkeyValue hkey, key, 0, Memory.null, REG_OPTION_NON_VOLATILE, + SysWord.toInt(Key.toWord flags), Memory.null, keyRes, disp) + in + checkLResult result; + (if ! disp = REG_CREATED_NEW_KEY then CREATED_NEW_KEY else OPENED_EXISTING_KEY) + (SUBKEY(Memory.volatileRef(Memory.voidStar2Sysword(!keyRes)))) + end + end + + local + val regCloseKey = winCall1 (advapi "RegCloseKey") cPointer cLong + in + fun closeKey hkey = checkLResult(regCloseKey(getHkeyValue hkey)) + end + + local + val regDeleteValue = winCall2 (advapi "RegDeleteValueA") (cPointer, cString) cLong + in + fun deleteValue(hkey, key) = checkLResult(regDeleteValue(getHkeyValue hkey, key)) + end - (* Open one of the root keys. *) - fun createRoot args = - pairToResult(winCall(1009, args)) - (* Open a sub-key. *) - and createSubKey args = - pairToResult(winCall(1010, args)) - + local + val regDeleteKey = winCall2 (advapi "RegDeleteKeyA") (cPointer, cString) cLong in - (* I've retained the third argument in this interface - which used to be used for VOLATILE (1) or - NON_VOLATILE (0). Keys are now always non-volatile. *) - fun createKeyEx(PREDEFINED i, s, f) = - createRoot(i, s, 0, SysWord.toInt f) - | createKeyEx(SUBKEY i, s, f) = - createSubKey(i, s, 0, SysWord.toInt f) + fun deleteKey(hkey, key) = checkLResult(regDeleteKey(getHkeyValue hkey, key)) end local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val regEnumKeyEx = + winCall8 (advapi "RegEnumKeyExA") + (cPointer, cDWORD, cPointer, cStar cDWORD, cPointer, cPointer, cPointer, cPointer) cLong + val regEnumVal = + winCall8 (advapi "RegEnumValueA") + (cPointer, cDWORD, cPointer, cStar cDWORD, cPointer, cPointer, cPointer, cPointer) cLong + + val regQueryInfoKey = + winCall12 (advapi "RegQueryInfoKeyA") + (cPointer, cPointer, cPointer, cPointer, cStar cDWORD, cStar cDWORD, cPointer, + cStar cDWORD, cStar cDWORD, cStar cDWORD, cPointer, cPointer) cLong + + fun getInfo hkey = + let + open Memory + val nSubKeys = ref 0 and maxSubKeyLen = ref 0 and nValues = ref 0 + and maxValueNameLen = ref 0 and maxValueLen = ref 0 + val result = + regQueryInfoKey(getHkeyValue hkey, null, null, null, nSubKeys, maxSubKeyLen, null, nValues, + maxValueNameLen, maxValueLen, null, null) + in + checkLResult result; + { nSubKeys = !nSubKeys, maxSubKeyLen = !maxSubKeyLen, nValues = ! nValues, + maxValueNameLen = !maxValueNameLen, maxValueLen= !maxValueLen} + end in - (* TODO: We wouldn't normally expect to close a - predefined key but it looks as though we might - have to be able to close HKEY_PERFORMANCE_DATA. *) - fun closeKey(PREDEFINED _) = () - | closeKey(SUBKEY i) = - winCall(1011, i) + fun enumKeyEx(hkey, n) = + let + val {nSubKeys, maxSubKeyLen, ...} = getInfo hkey + in + if n >= nSubKeys + then NONE + else + let + open Memory + val buff = malloc(Word.fromInt(maxSubKeyLen + 1)) + val buffLen = ref(maxSubKeyLen + 1) + val result = + regEnumKeyEx(getHkeyValue hkey, n, buff, buffLen, null, null, null, null) + in + checkLResult result handle exn as OS.SysErr _ => (free buff; raise exn); + SOME(fromCstring buff) before free buff + end + end + + and enumValueEx(hkey, n) = + let + val {nValues, maxValueNameLen, ...} = getInfo hkey + in + if n >= nValues + then NONE + else + let + open Memory + val buff = malloc(Word.fromInt(maxValueNameLen + 1)) + val buffLen = ref(maxValueNameLen + 1) + val result = + regEnumVal(getHkeyValue hkey, n, buff, buffLen, null, null, null, null) + in + checkLResult result handle exn as OS.SysErr _ => (free buff; raise exn); + SOME(fromCstring buff) before free buff + end + end end local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val queryVal = + winCall6 (advapi "RegQueryValueExA") (cPointer, cString, cPointer, cStar cDWORD, cPointer, cStar cDWORD) cLong + + val ERROR_MORE_DATA = 234 + val ERROR_FILE_NOT_FOUND = 2 fun unpackString v = let val len = Word8Vector.length v in if len = 0 then "" else Byte.unpackStringVec(Word8VectorSlice.slice(v, 0, SOME(len -1))) end fun unpackStringList v = let val len = Word8Vector.length v fun unpack start i = if i >= len orelse Word8Vector.sub(v, i) = 0w0 then if i = start then [] else Byte.unpackStringVec(Word8VectorSlice.slice(v, start, SOME(i - start))) :: unpack (i+1) (i+1) else unpack start (i+1) in unpack 0 0 end - - fun queryResultToValues(t, v) = - (* Decode the type code and the value. Strings are null terminated so - the last character must be removed. *) - case t of - 1 => SZ(unpackString v) - | 4 => DWORD(PackWord32Little.subVec(v, 0)) - | 2 => EXPAND_SZ(unpackString v) - | 7 => MULTI_SZ(unpackStringList v) - | _ => BINARY v + + (* Repeat allocating the buffer until it's big enough. *) + fun requery(hkey, valueName, buff, buffSize) = + let + open Memory + val buffSizeRef = ref buffSize + val typeVal = ref 0 + val result = queryVal(getHkeyValue hkey, valueName, Memory.null, typeVal, buff, buffSizeRef) + in + (* Returns 0 (success) if the buffer is null. Return ERROR_MORE_DATA if it is + not null but not big enough. *) + if result = ERROR_MORE_DATA orelse result = 0 andalso ! buffSizeRef > buffSize + then + let + val () = free buff + val buff = malloc(Word.fromInt(!buffSizeRef)) + in + requery(hkey, valueName, buff, !buffSizeRef) + end + else if result = 0 + then (* Big enough - return result. N.B. This could be NULL. *) + let + val v = Word8Vector.tabulate(! buffSizeRef, fn i => get8(buff, Word.fromInt i)) + val () = free buff + in + case !typeVal of + 1 => SOME(SZ(unpackString v)) + | 4 => SOME(DWORD(PackWord32Little.subVec(v, 0))) + | 2 => SOME(EXPAND_SZ(unpackString v)) + | 7 => SOME(MULTI_SZ(unpackStringList v)) + | _ => SOME(BINARY v) + end + else if result = ERROR_FILE_NOT_FOUND + then NONE + else (free buff; checkLResult result; raise Match (* Unused: we've raised an exception *)) + end - val errorFileNotFound = valOf(OS.syserror "ERROR_FILE_NOT_FOUND") in - (* The queryValue functions simply return a type and a vector of bytes. - The type code is decoded and the bytes unpacked appropriately. *) - fun queryValueEx(key, s) = - SOME(queryResultToValues( - case key of - PREDEFINED i => winCall(1012, (i, s)) - | SUBKEY i => winCall(1013, (i, s)) - )) - handle ex as OS.SysErr(_, SOME err) => - if err = errorFileNotFound - then NONE - else raise ex + fun queryValueEx (hkey, valueName) = requery(hkey, valueName, Memory.null, 0) end local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" - in - fun deleteValue(PREDEFINED i, s) = - (winCall(1022, (i, s))) - | deleteValue(SUBKEY i, s) = - (winCall(1023, (i, s))) - end + val setValue = winCall6 (advapi "RegSetValueExA") (cPointer, cString, cDWORD, cDWORD, cByteArray, cDWORD) cLong - local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" fun packString s = let val len = String.size s val arr = Word8Array.array(len+1, 0w0) in Byte.packString(arr, 0, Substring.full s); Word8Array.vector arr end fun packStringList sl = let (* The string list is packed as a set of null-terminated strings with a final null at the end. *) (* TODO: Check for nulls in the strings themselves? *) fun totalSize n [] = n | totalSize n (s::sl) = totalSize (n + String.size s + 1) sl val len = totalSize 1 sl val arr = Word8Array.array(len, 0w0) fun pack _ [] = () | pack n (s::sl) = ( Byte.packString(arr, n, Substring.full s); pack (n + String.size s + 1) sl ) in pack 0 sl; Word8Array.vector arr end fun valuesToTypeVal(SZ s) = (1, packString s) | valuesToTypeVal(EXPAND_SZ s) = (2, packString s) | valuesToTypeVal(BINARY s) = (3, s) | valuesToTypeVal(DWORD n) = let (* Pack the 32 bit value into an array, then extract that. *) val arr = Word8Array.array(4, 0w0) in PackWord32Little.update(arr, 0, n); (4, Word8Array.vector arr) end | valuesToTypeVal(MULTI_SZ s) = (7, packStringList s) in - fun setValueEx(key, name, v) = - let - val (t, s) = valuesToTypeVal v - val (call, k) = - case key of - PREDEFINED i => (1016, i) - | SUBKEY i => (1017, i) - in - (winCall(call, (k, name, t, s))) - end - end - - local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" - in - fun enumKeyEx(PREDEFINED i, n) = - (winCall(1018, (i, n))) - | enumKeyEx(SUBKEY i, n) = - (winCall(1019, (i, n))) - - fun enumValueEx(PREDEFINED i, n) = - (winCall(1020, (i, n))) - | enumValueEx(SUBKEY i, n) = - (winCall(1021, (i, n))) - end - - local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" - (* In Windows NT RegDeleteKey will fail if the key has subkeys. - To give the same behaviour in both Windows 95 and NT we have - to recursively delete any subkeys. *) - fun basicDeleteKey(PREDEFINED i, s) = - (winCall(1014, (i, s))) - | basicDeleteKey(SUBKEY i, s) = - (winCall(1015, (i, s))) - in - fun deleteKey(k, s) = + fun setValueEx(hkey, name, v) = let - val sk = openKeyEx(k, s, Key.enumerateSubKeys) - fun deleteSubKeys () = - case enumKeyEx(sk, 0) of - NONE => () - | SOME name => (deleteKey(sk, name); deleteSubKeys()) + val (t, s) = valuesToTypeVal v + val length = Word8Vector.length s + val result = setValue(getHkeyValue hkey, name, 0, t, s, length) in - deleteSubKeys() handle exn => (closeKey sk; raise exn); - closeKey sk; - basicDeleteKey(k, s) + checkLResult result end end end structure DDE = struct - type info = int (* Actually abstract. *) + type info = SysWord.word (* Actually a volatile word containing the conversation handle. *) - local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" - in - fun startDialog (service, topic) = - winCall(1038, (service, topic)) - end + val startDialog: string * string -> info = RunCall.rtsCallFull2 "PolyWindowsDDEStartDialogue" + and stopDialog: info -> unit = RunCall.rtsCallFull1 "PolyWindowsDDEClose" local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val winCall: info * string -> bool = RunCall.rtsCallFull2 "PolyWindowsDDEExecute" in (* The timeout and retry count apply only in the case of a busy result. The Windows call takes a timeout parameter as the length of time to wait for a response and maybe we should use it for that as well. *) fun executeString (info, cmd, retry, delay) = let fun try n = - if winCall(1039, (info, cmd)) + if winCall(info, cmd) then () (* Succeeded. *) else if n = 0 then raise OS.SysErr("DDE Server busy", NONE) else ( OS.IO.poll([], SOME delay); try (n-1) ) in try retry end end - local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" - in - fun stopDialog (info) = winCall(1040, info) - end end (* DDE *) - (* No (longer?) in Basis library local - val winCall = RunCall.run_call2 POLY_SYS_os_specific - in - fun fileTimeToLocalFileTime t = winCall(1030, t) - fun localFileTimeToFileTime t = winCall(1031, t) - end - *) - - local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val getVol = + winCall8(kernel "GetVolumeInformationA") + (cString, cPointer, cDWORD, cStar cDWORD, cStar cDWORD, cStar cDWORD, cPointer, cDWORD) cInt in fun getVolumeInformation root = let - val (vol, sys, serial, max) = - winCall(1032, root) + open Memory + val volBuffer = malloc (MAX_PATH+0w1) + and sysBuffer = malloc (MAX_PATH+0w1) + + val volSerial = ref 0 + and volMaxComponent = ref 0 + and fileSysFlags = ref 0 in - { volumeName = vol, systemName = sys, - serialNumber = SysWord.fromInt serial, - maximumComponentLength = max } + if getVol(root, volBuffer, Word.toInt(MAX_PATH+0w1), volSerial, volMaxComponent, fileSysFlags, + sysBuffer, Word.toInt(MAX_PATH+0w1)) = 0 + then + let + val err = Error.fromWord(Error.getLastError()) + in + free volBuffer; free sysBuffer; + raise OS.SysErr(OS.errorMsg err, SOME err) + end + else + { volumeName = fromCstring volBuffer, systemName = fromCstring sysBuffer, + serialNumber = SysWord.fromInt (!volSerial), + maximumComponentLength = ! volMaxComponent} before (free volBuffer; free sysBuffer) end end local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val findExeca: string * int * Memory.voidStar -> int = + winCall3 (shell "FindExecutableA") (cString, cInt, cPointer) cInt in - fun findExecutable s = SOME(winCall(1033, s)) handle OS.SysErr _ => NONE + fun findExecutable s = + let + open Memory + val buff = malloc MAX_PATH + val result = + if findExeca(s, 0 (* NULL *), buff) > 32 + then SOME(fromCstring buff) + else NONE + in + free buff; + result + end end local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val shellExecuteInfo = + cStruct15(cDWORD, cUlong, cPointer (*HWND*), cString, cString, cOptionPtr cString, cOptionPtr cString, cInt, + cPointer (*HINSTANCE*), cPointer, cPointer (*cString*), cPointer (*HKEY*), cDWORD, cPointer (*HANDLE*), cPointer (*HANDLE*)) + val {ctype={size, ...}, ...} = breakConversion shellExecuteInfo + val shellExec = winCall1 (shell "ShellExecuteExA") (cStar shellExecuteInfo) cInt + (* We probably want handle the error ourselves rather than popping up a UI. *) + val SEE_MASK_FLAG_NO_UI = 0x00000400 in - fun openDocument s = winCall(1034, s) + fun openDocument file = + let + val r = + ref(Word.toInt size, SEE_MASK_FLAG_NO_UI, Memory.null, "open", file, NONE, NONE, 1 (* SW_SHOWNORMAL *), + Memory.null, Memory.null, Memory.null, Memory.null, 0, Memory.null, Memory.null) + in + if shellExec r = 0 + then + let + val err = Error.fromWord(Error.getLastError()) + in + raise OS.SysErr(OS.errorMsg err, SOME err) + end + else () + end + + and launchApplication (command, arg) = + let + val r = + ref(Word.toInt size, SEE_MASK_FLAG_NO_UI, Memory.null, "open", command, SOME arg, NONE, 1 (* SW_SHOWNORMAL *), + Memory.null, Memory.null, Memory.null, Memory.null, 0, Memory.null, Memory.null) + in + if shellExec r = 0 + then + let + val err = Error.fromWord(Error.getLastError()) + in + raise OS.SysErr(OS.errorMsg err, SOME err) + end + else () + end + end - local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" - in - fun launchApplication (command, arg) = - winCall(1035, (command, arg)) - end - abstype pid = PID of int with end; (* Abstract *) datatype ('a,'b) proc = WinProc of { pid: pid, result: OS.Process.status option ref, closeActions: (unit->unit) list ref, lock: Thread.Mutex.mutex } (* Run a process and return a proces object which will allow us to extract the input and output streams. *) local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val winCall = RunCall.rtsCallFull2 "PolyWindowsExecute" in fun execute(command, arg): ('a,'b) proc = let - val run: pid = winCall (1000, (command, arg)) + val run: pid = winCall (command, arg) in WinProc{ pid=run, result=ref NONE, closeActions=ref [], lock=Thread.Mutex.mutex() } end end (* Local function to protect access. *) fun winProtect f (w as WinProc{lock, ...}) = ThreadLib.protect lock f w local val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun sys_get_buffsize (strm: OS.IO.iodesc): int = doIo(15, strm, 0) end local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val winCall: pid * bool * bool -> OS.IO.iodesc = + RunCall.rtsCallFull3 "PolyWindowsOpenProcessHandle" fun textInstreamOf'(WinProc{pid, closeActions, ...}) = let (* Get the underlying file descriptor. *) - val n = winCall (1001, RunCall.unsafeCast pid) + val n = winCall(pid, true, true) val textPrimRd = LibraryIOSupport.wrapInFileDescr {fd=n, name="TextPipeInput", initBlkMode=true} val streamIo = TextIO.mkInstream(TextIO.StreamIO.mkInstream(textPrimRd, "")) fun closeThis() = TextIO.closeIn streamIo val () = closeActions := closeThis :: ! closeActions in streamIo end fun textOutstreamOf'(WinProc{pid, closeActions, ...}) = let - val n = winCall (1002, RunCall.unsafeCast pid) + val n = winCall (pid, false, true) val buffSize = sys_get_buffsize n val textPrimWr = LibraryIOSupport.wrapOutFileDescr{fd=n, name="TextPipeOutput", appendMode=false, initBlkMode=true, chunkSize=buffSize} (* Construct a stream. *) val streamIo = TextIO.mkOutstream(TextIO.StreamIO.mkOutstream(textPrimWr, IO.LINE_BUF)) fun closeThis() = TextIO.closeOut streamIo val () = closeActions := closeThis :: ! closeActions in streamIo end fun binInstreamOf'(WinProc{pid, closeActions, ...}) = let (* Get the underlying file descriptor. *) - val n = winCall (1003, RunCall.unsafeCast pid) + val n = winCall (pid, true, false) val binPrimRd = LibraryIOSupport.wrapBinInFileDescr {fd=n, name="BinPipeInput", initBlkMode=true} val streamIo = BinIO.mkInstream(BinIO.StreamIO.mkInstream(binPrimRd, Word8Vector.fromList [])) fun closeThis() = BinIO.closeIn streamIo val () = closeActions := closeThis :: ! closeActions in streamIo end fun binOutstreamOf'(WinProc{pid, closeActions, ...}) = let - val n = winCall (1004, RunCall.unsafeCast pid) + val n = winCall (pid, false, false) val buffSize = sys_get_buffsize n val binPrimWr = LibraryIOSupport.wrapBinOutFileDescr{fd=n, name="BinPipeOutput", appendMode=false, initBlkMode=true, chunkSize=buffSize} (* Construct a stream. *) val streamIo = BinIO.mkOutstream(BinIO.StreamIO.mkOutstream(binPrimWr, IO.LINE_BUF)) fun closeThis() = BinIO.closeOut streamIo val () = closeActions := closeThis :: ! closeActions in streamIo end in fun textInstreamOf w = winProtect textInstreamOf' w and textOutstreamOf w = winProtect textOutstreamOf' w and binInstreamOf w = winProtect binInstreamOf' w and binOutstreamOf w = winProtect binOutstreamOf' w end (* reap - wait until the process finishes and get the result. Note: this is defined to be able to return the result repeatedly. *) local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val winCall: pid -> OS.Process.status = RunCall.rtsCallFull1 "PolyWindowsGetProcessResult" fun reap'(WinProc{result=ref(SOME r), ...}) = r | reap'(WinProc{pid, result, closeActions, ...}) = let val _ = List.app(fn f => f()) (!closeActions) val _ = closeActions := [] - val res: OS.Process.status = winCall (1005, RunCall.unsafeCast pid) + val res: OS.Process.status = winCall pid val _ = result := SOME res in res end in fun reap w = winProtect reap' w end local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val winCall: string * string -> pid = RunCall.rtsCallFull2 "PolyWindowsSimpleExecute" in (* Run a process and wait for the result. Rather than do the whole thing as a single RTS call we first start the process and then call "reap" to get the result. This allows this to be run as a separate ML process if necessary without blocking everything. This is similar to OS.Process.system but differs in that the streams are directed to NUL and this runs the executable directly, not via cmd.exe/command.com so cannot run DOS commands. OS.Process.system waits for the result within the RTS call so the whole of ML will be blocked until the process completes. *) fun simpleExecute (command, arg) = let - val run: pid = winCall(1037, (command, arg)) + val run: pid = winCall(command, arg) val process = WinProc{ pid=run, result=ref NONE, closeActions=ref [], lock=Thread.Mutex.mutex() } in reap process end end structure Status = struct type status = SysWord.word - val accessViolation = getConst 10 - val arrayBoundsExceeded = getConst 11 - val breakpoint = getConst 12 - val controlCExit = getConst 13 - val datatypeMisalignment = getConst 14 - val floatDenormalOperand = getConst 15 - val floatDivideByZero = getConst 16 - val floatInexactResult = getConst 17 - val floatInvalidOperation = getConst 18 - val floatOverflow = getConst 19 - val floatStackCheck = getConst 20 - val floatUnderflow = getConst 21 - val guardPageViolation = getConst 22 - val integerDivideByZero = getConst 23 - val integerOverflow = getConst 24 - val illegalInstruction = getConst 25 - val invalidDisposition = getConst 26 - val invalidHandle = getConst 27 - val inPageError = getConst 28 + val accessViolation = 0wxC0000005 + val arrayBoundsExceeded = 0wxC000008C + val breakpoint = 0wx80000003 + val controlCExit = 0wxC000013A + val datatypeMisalignment = 0wx80000002 + val floatDenormalOperand = 0wxC000008D + val floatDivideByZero = 0wxC000008E + val floatInexactResult = 0wxC000008F + val floatInvalidOperation = 0wxC0000090 + val floatOverflow = 0wxC0000091 + val floatStackCheck = 0wxC0000092 + val floatUnderflow = 0wxC0000093 + val guardPageViolation = 0wx80000001 + val integerDivideByZero = 0wxC0000094 + val integerOverflow = 0wxC0000095 + val illegalInstruction = 0wxC000001D + val invalidDisposition = 0wxC0000026 + val invalidHandle = 0wxC0000008 + val inPageError = 0wxC0000006 (* This was given as nocontinuableException *) - val noncontinuableException= getConst 29 - val pending = getConst 30 - val privilegedInstruction = getConst 31 - val singleStep = getConst 32 - val stackOverflow = getConst 33 - val timeout = getConst 34 - val userAPC = getConst 35 + val noncontinuableException= 0wxC0000025 + val pending = 0wx103 + val privilegedInstruction = 0wxC0000096 + val singleStep = 0wx80000004 + val stackOverflow = 0wxC00000FD + val timeout = 0wx102 + val userAPC = 0wxC0 end (* The status is implemented as an integer. *) fun fromStatus (s: OS.Process.status): Status.status = SysWord.fromInt(RunCall.unsafeCast s); fun exit (s: Status.status) = OS.Process.exit(RunCall.unsafeCast(SysWord.toInt s)) structure Config = struct local - val winCall: int*unit->int*int*int*int*string = - RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val osVersionInfo = + cStruct6(cDWORD, cDWORD, cDWORD, cDWORD, cDWORD, cCHARARRAY 128) + val { ctype={size, ...}, ...} = breakConversion osVersionInfo + val callGetVersion = + winCall1 (kernel "GetVersionExA") (cStar osVersionInfo) cInt in fun getVersionEx () = let - val (major, minor, build, platform, version) = - winCall(1050, ()) + val r = ref(Word.toInt size, 0, 0, 0, 0, "") in - { majorVersion = SysWord.fromInt major, - minorVersion = SysWord.fromInt minor, - buildNumber = SysWord.fromInt build, - platformId = SysWord.fromInt platform, - csdVersion = version } + if callGetVersion r = 0 + then + let + val err = Error.fromWord(Error.getLastError()) + in + raise OS.SysErr(OS.errorMsg err, SOME err) + end + else + let + val (_, major, minor, build, platform, version) = !r + in + { majorVersion = SysWord.fromInt major, + minorVersion = SysWord.fromInt minor, + buildNumber = SysWord.fromInt build, + platformId = SysWord.fromInt platform, + csdVersion = version } + end end end local - val winCall: int*unit->string = - RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + (* Get Windows directory and System directory. *) + val getWinDir: Memory.voidStar * int -> int = + winCall2(kernel "GetWindowsDirectoryA") (cPointer, cUint) cUint + and getSysDir: Memory.voidStar * int -> int = + winCall2(kernel "GetSystemDirectoryA") (cPointer, cUint) cUint + + fun getDirectory getDir () = + let + open Memory + val buff = malloc MAX_PATH + val result = getDir(buff, Word.toInt MAX_PATH) + in + if result = 0 + then + let + val err = Error.fromWord(Error.getLastError()) + in + free buff; + raise OS.SysErr(OS.errorMsg err, SOME err) + end + else fromCstring buff before free buff + end + in + val getWindowsDirectory = getDirectory getWinDir + and getSystemDirectory = getDirectory getSysDir + end + + local + val getCompName: Memory.voidStar * int ref -> int = + winCall2(kernel "GetComputerNameA") (cPointer, cStar cDWORD) cInt + and getUsrName: Memory.voidStar * int ref -> int = + winCall2(advapi "GetUserNameA") (cPointer, cStar cDWORD) cUint + + val MAX_COMPUTERNAME_LENGTH = 015 + and UNLEN = 256 + + fun getName (getNm, len) () = + let + open Memory + val buff = malloc(Word.fromInt len) + val result = getNm(buff, ref len) + in + if result = 0 + then + let + val err = Error.fromWord(Error.getLastError()) + in + free buff; + raise OS.SysErr(OS.errorMsg err, SOME err) + end + else fromCstring buff before free buff + end in - fun getWindowsDirectory () = winCall(1051, ()) - and getSystemDirectory () = winCall(1052, ()) - and getComputerName () = winCall(1053, ()) - and getUserName () = winCall(1054, ()) + val getComputerName = getName(getCompName, MAX_COMPUTERNAME_LENGTH+1) + and getUserName = getName(getUsrName, UNLEN+1) end - val platformWin32s = getConst 36 - val platformWin32Windows = getConst 37 - val platformWin32NT = getConst 38 - val platformWin32CE = getConst 39 + (* All of these are long since dead *) + val platformWin32s = 0w0 + val platformWin32Windows = 0w1 + val platformWin32NT = 0w2 + val platformWin32CE = 0w3 end end; local (* Add pretty printers to hide internals. *) fun prettyRegKey _ _ (_: Windows.Reg.hkey) = PolyML.PrettyString "?" and prettyDDEInfo _ _ (_: Windows.DDE.info) = PolyML.PrettyString "?" and prettyProc _ _ (_: ('a, 'b) Windows.proc) = PolyML.PrettyString "?" in val () = PolyML.addPrettyPrinter prettyRegKey and () = PolyML.addPrettyPrinter prettyDDEInfo and () = PolyML.addPrettyPrinter prettyProc end; diff --git a/basis/build.sml b/basis/build.sml index 1ba418d6..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 + 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"; (* Relies on OS. *) -val () = Bootstrap.use "basis/InitialPolyML.ML"; (* Relies on OS. *) +val () = Bootstrap.use "basis/ExnPrinter.sml"; +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/NetHostDB.sml"; +val () = Bootstrap.use "basis/Socket.sml"; val () = Bootstrap.use "basis/NetProtDB.sml"; val () = Bootstrap.use "basis/NetServDB.sml"; -val () = Bootstrap.use "basis/Socket.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/ForeignConstants.sml"; -val () = Bootstrap.use "basis/ForeignMemory.sml"; -val () = Bootstrap.useWithParms [Bootstrap.Universal.tagInject Bootstrap.maxInlineSizeTag 1000] "basis/Foreign.sml"; +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. *) diff --git a/config.h.in b/config.h.in index 1b4ea5b1..16006b58 100644 --- a/config.h.in +++ b/config.h.in @@ -1,679 +1,682 @@ /* config.h.in. Generated from configure.ac by autoheader. */ /* Define if building universal (internal helper macro) */ #undef AC_APPLE_UNIVERSAL_BUILD /* Define to one of `_getb67', `GETB67', `getb67' for Cray-2 and Cray-YMP systems. This function is required for `alloca.c' support on those systems. */ #undef CRAY_STACKSEG_END /* Define to 1 if using `alloca.c'. */ #undef C_ALLOCA /* Define to the type of elements in the array set by `getgroups'. Usually this is either `int' or `gid_t'. */ #undef GETGROUPS_T /* Define to 1 if the `getpgrp' function requires zero arguments. */ #undef GETPGRP_VOID /* Define to 1 if you have `alloca', as a function or macro. */ #undef HAVE_ALLOCA /* Define to 1 if you have and it should be used (not on Ultrix). */ #undef HAVE_ALLOCA_H +/* Define to 1 if you have the header file. */ +#undef HAVE_ARPA_INET_H + /* Define to 1 if you have the header file. */ #undef HAVE_ASM_ELF_H /* Define to 1 if you have the header file. */ #undef HAVE_ASSERT_H /* Define to 1 if you have the `ctermid' function. */ #undef HAVE_CTERMID /* Define to 1 if you have the header file. */ #undef HAVE_CTYPE_H /* Define to 1 if you have the declaration of `fpsetmask', and to 0 if you don't. */ #undef HAVE_DECL_FPSETMASK /* Define to 1 if you have the header file. */ #undef HAVE_DIRECT_H /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_DIRENT_H /* Define to 1 if you have the header file. */ #undef HAVE_DLFCN_H /* Define to 1 if you have the `dlopen' function. */ #undef HAVE_DLOPEN /* Define to 1 if you have the `dtoa' function. */ #undef HAVE_DTOA /* Define to 1 if you have and header files. */ #undef HAVE_ELF_ABI_H /* Define to 1 if you have the header file. */ #undef HAVE_ELF_H /* Define to 1 if you have the header file. */ #undef HAVE_ERRNO_H /* Define to 1 if you have the header file. */ #undef HAVE_EXCPT_H /* Define to 1 if you have the header file. */ #undef HAVE_FCNTL_H /* Define to 1 if you have the header file. */ #undef HAVE_FENV_H /* Define to 1 if you have the header file. */ #undef HAVE_FLOAT_H /* Define to 1 if you have the header file. */ #undef HAVE_FPU_CONTROL_H /* Define to 1 if your system has a working `getgroups' function. */ #undef HAVE_GETGROUPS /* Define to 1 if you have the `getpagesize' function. */ #undef HAVE_GETPAGESIZE /* Define to 1 if you have the gmp.h header file */ #undef HAVE_GMP_H /* Define to 1 if you have the `gmtime_r' function. */ #undef HAVE_GMTIME_R /* Define to 1 if you have .note.GNU-stack support in the assembler. */ #undef HAVE_GNU_STACK /* Define to 1 if you have the header file. */ #undef HAVE_GRP_H /* Define to 1 if you have the header file. */ #undef HAVE_IEEEFP_H /* Define to 1 if the system has the type `IMAGE_FILE_HEADER'. */ #undef HAVE_IMAGE_FILE_HEADER /* Define to 1 if the system has the type `intptr_t'. */ #undef HAVE_INTPTR_T /* Define to 1 if you have the header file. */ #undef HAVE_INTTYPES_H /* Define to 1 if you have the header file. */ #undef HAVE_IO_H /* Define to 1 if you have the `gcc' library (-lgcc). */ #undef HAVE_LIBGCC /* Define to 1 if you have the `gcc_s' library (-lgcc_s). */ #undef HAVE_LIBGCC_S /* Define to 1 if you have the `gdi32' library (-lgdi32). */ #undef HAVE_LIBGDI32 /* Define to 1 if you have libgmp */ #undef HAVE_LIBGMP /* Define to 1 if you have the `pthread' library (-lpthread). */ #undef HAVE_LIBPTHREAD /* Define to 1 if you have the `stdc++' library (-lstdc++). */ #undef HAVE_LIBSTDC__ /* Define to 1 if you have the `ws2_32' library (-lws2_32). */ #undef HAVE_LIBWS2_32 /* Define to 1 if you have the `X11' library (-lX11). */ #undef HAVE_LIBX11 /* Define to 1 if you have the `Xext' library (-lXext). */ #undef HAVE_LIBXEXT /* Define to 1 if you have the `Xm' library (-lXm). */ #undef HAVE_LIBXM /* Define to 1 if you have the `Xt' library (-lXt). */ #undef HAVE_LIBXT /* Define to 1 if you have the header file. */ #undef HAVE_LIMITS_H /* Define to 1 if you have the header file. */ #undef HAVE_LOCALE_H /* Define to 1 if you have the `localtime_r' function. */ #undef HAVE_LOCALTIME_R /* Define to 1 if the system has the type `long long'. */ #undef HAVE_LONG_LONG /* Define to 1 if you have the header file. */ #undef HAVE_MACHINE_RELOC_H /* Define to 1 if you have the header file. */ #undef HAVE_MACH_O_RELOC_H /* Define to 1 if you have the header file. */ #undef HAVE_MALLOC_H /* Define to 1 if you have the header file. */ #undef HAVE_MATH_H /* Define to 1 if `gregs' is a member of `mcontext_t'. */ #undef HAVE_MCONTEXT_T_GREGS /* Define to 1 if `mc_esp' is a member of `mcontext_t'. */ #undef HAVE_MCONTEXT_T_MC_ESP /* Define to 1 if `regs' is a member of `mcontext_t'. */ #undef HAVE_MCONTEXT_T_REGS /* Define to 1 if you have the header file. */ #undef HAVE_MEMORY_H /* Define to 1 if you have the `mkstemp' function. */ #undef HAVE_MKSTEMP /* Define to 1 if you have the `mmap' function. */ #undef HAVE_MMAP /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_NDIR_H /* Define to 1 if you have the header file. */ #undef HAVE_NETDB_H /* Define to 1 if you have the header file. */ #undef HAVE_NETINET_IN_H /* Define to 1 if you have the header file. */ #undef HAVE_NETINET_TCP_H /* Define to 1 if you have the PE/COFF types. */ #undef HAVE_PECOFF /* Define to 1 if you have the header file. */ #undef HAVE_POLL_H /* Define to 1 if you have the header file. */ #undef HAVE_PTHREAD_H /* Define to 1 if you have the header file. */ #undef HAVE_PWD_H /* Define to 1 if you have the header file. */ #undef HAVE_SEMAPHORE_H /* Define to 1 if you have the `sigaltstack' function. */ #undef HAVE_SIGALTSTACK /* Define to 1 if the system has the type `sighandler_t'. */ #undef HAVE_SIGHANDLER_T /* Define to 1 if you have the header file. */ #undef HAVE_SIGINFO_H /* Define to 1 if you have the header file. */ #undef HAVE_SIGNAL_H /* Define to 1 if the system has the type `sig_t'. */ #undef HAVE_SIG_T /* Define to 1 if the system has the type `socklen_t'. */ #undef HAVE_SOCKLEN_T /* Define to 1 if the system has the type `ssize_t'. */ #undef HAVE_SSIZE_T /* Define to 1 if the system has the type `stack_t'. */ #undef HAVE_STACK_T /* Define to 1 if `stat' has the bug that it succeeds when given the zero-length file name argument. */ #undef HAVE_STAT_EMPTY_STRING_BUG /* Define to 1 if you have the header file. */ #undef HAVE_STDARG_H /* Define to 1 if stdbool.h conforms to C99. */ #undef HAVE_STDBOOL_H /* Define to 1 if you have the header file. */ #undef HAVE_STDDEF_H /* Define to 1 if you have the header file. */ #undef HAVE_STDINT_H /* Define to 1 if you have the header file. */ #undef HAVE_STDIO_H /* Define to 1 if you have the header file. */ #undef HAVE_STDLIB_H /* Define to 1 if you have the header file. */ #undef HAVE_STRINGS_H /* Define to 1 if you have the header file. */ #undef HAVE_STRING_H /* Define to 1 if you have the `strtod' function. */ #undef HAVE_STRTOD /* Define to 1 if `ss' is a member of `struct mcontext'. */ #undef HAVE_STRUCT_MCONTEXT_SS /* Define to 1 if the system has the type `struct sigcontext'. */ #undef HAVE_STRUCT_SIGCONTEXT /* Define to 1 if `sun_len' is a member of `struct sockaddr_un'. */ #undef HAVE_STRUCT_SOCKADDR_UN_SUN_LEN /* Define to 1 if `st_atim' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_ATIM /* Define to 1 if `st_atimensec' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_ATIMENSEC /* Define to 1 if `st_atimespec' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_ATIMESPEC /* Define to 1 if `st_atime_n' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_ATIME_N /* Define to 1 if `st_uatime' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_UATIME /* Define to 1 if `ss' is a member of `struct __darwin_mcontext32'. */ #undef HAVE_STRUCT___DARWIN_MCONTEXT32_SS /* Define to 1 if `__ss' is a member of `struct __darwin_mcontext32'. */ #undef HAVE_STRUCT___DARWIN_MCONTEXT32___SS /* Define to 1 if `ss' is a member of `struct __darwin_mcontext64'. */ #undef HAVE_STRUCT___DARWIN_MCONTEXT64_SS /* Define to 1 if `__ss' is a member of `struct __darwin_mcontext64'. */ #undef HAVE_STRUCT___DARWIN_MCONTEXT64___SS /* Define to 1 if `ss' is a member of `struct __darwin_mcontext'. */ #undef HAVE_STRUCT___DARWIN_MCONTEXT_SS /* Define to 1 if `__ss' is a member of `struct __darwin_mcontext'. */ #undef HAVE_STRUCT___DARWIN_MCONTEXT___SS /* Define to 1 if you have the `sysctl' function. */ #undef HAVE_SYSCTL /* Define to 1 if you have the `sysctlbyname' function. */ #undef HAVE_SYSCTLBYNAME /* Define to 1 if the system has the type `SYSTEM_LOGICAL_PROCESSOR_INFORMATION'. */ #undef HAVE_SYSTEM_LOGICAL_PROCESSOR_INFORMATION /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_SYS_DIR_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_ELF_386_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_ELF_AMD64_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_ELF_SPARC_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_ERRNO_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_FILE_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_FILIO_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_IOCTL_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_MMAN_H /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_SYS_NDIR_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_PARAM_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_RESOURCE_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SELECT_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SIGNAL_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SOCKET_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SOCKIO_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_STAT_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SYSCTL_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SYSTEMINFO_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TERMIOS_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TIMES_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TIME_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TYPES_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_UIO_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_UN_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_UTSNAME_H /* Define to 1 if you have that is POSIX.1 compatible. */ #undef HAVE_SYS_WAIT_H /* Define to 1 if you have the `tcdrain' function. */ #undef HAVE_TCDRAIN /* Define to 1 if you have the header file. */ #undef HAVE_TCHAR_H /* Define to 1 if you have the header file. */ #undef HAVE_TERMIOS_H /* Define to 1 if you have the header file. */ #undef HAVE_TIME_H /* Define to 1 if you have the header file. */ #undef HAVE_UCONTEXT_H /* Define to 1 if the system has the type `ucontext_t'. */ #undef HAVE_UCONTEXT_T /* Define to 1 if the system has the type `uintptr_t'. */ #undef HAVE_UINTPTR_T /* Define to 1 if you have the header file. */ #undef HAVE_UNISTD_H /* Define to 1 if you have the header file. */ #undef HAVE_VALUES_H /* Define to 1 if you have the header file. */ #undef HAVE_WINDOWS_H /* Define to 1 if you have the header file. */ #undef HAVE_X11_XLIB_H /* Define to 1 if you have the header file. */ #undef HAVE_XM_XM_H /* Define to 1 if the system has the type `_Bool'. */ #undef HAVE__BOOL /* Define if the host is an ARM (64-bit) */ #undef HOSTARCHITECTURE_AARCH64 /* Define if the host is an Alpha (64-bit) */ #undef HOSTARCHITECTURE_ALPHA /* Define if the host is an ARM (32-bit) */ #undef HOSTARCHITECTURE_ARM /* Define if the host is an HP PA-RISC (32-bit) */ #undef HOSTARCHITECTURE_HPPA /* Define if the host is an Itanium */ #undef HOSTARCHITECTURE_IA64 /* Define if the host is a Motorola 68000 */ #undef HOSTARCHITECTURE_M68K /* Define if the host is a MIPS (32-bit) */ #undef HOSTARCHITECTURE_MIPS /* Define if the host is a MIPS (64-bit) */ #undef HOSTARCHITECTURE_MIPS64 /* Define if the host is a PowerPC (32-bit) */ #undef HOSTARCHITECTURE_PPC /* Define if the host is a PowerPC (64-bit) */ #undef HOSTARCHITECTURE_PPC64 /* Define if the host is a RISC-V (32-bit) */ #undef HOSTARCHITECTURE_RISCV32 /* Define if the host is a RISC-V (64-bit) */ #undef HOSTARCHITECTURE_RISCV64 /* Define if the host is an S/390 (32-bit) */ #undef HOSTARCHITECTURE_S390 /* Define if the host is an S/390 (64-bit) */ #undef HOSTARCHITECTURE_S390X /* Define if the host is a SuperH (32-bit) */ #undef HOSTARCHITECTURE_SH /* Define if the host is a Sparc (32-bit) */ #undef HOSTARCHITECTURE_SPARC /* Define if the host is a Sparc (64-bit) */ #undef HOSTARCHITECTURE_SPARC64 /* Define if the host is an X86 (32-bit ABI, 64-bit processor) */ #undef HOSTARCHITECTURE_X32 /* Define if the host is an X86 (32-bit) */ #undef HOSTARCHITECTURE_X86 /* Define if the host is an X86 (64-bit) */ #undef HOSTARCHITECTURE_X86_64 /* Define to 1 if `lstat' dereferences a symlink specified with a trailing slash. */ #undef LSTAT_FOLLOWS_SLASHED_SYMLINK /* Define to the sub-directory where libtool stores uninstalled libraries. */ #undef LT_OBJDIR /* Name of package */ #undef PACKAGE /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT /* Define to the full name of this package. */ #undef PACKAGE_NAME /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME /* Define to the home page for this package. */ #undef PACKAGE_URL /* Define to the version of this package. */ #undef PACKAGE_VERSION /* Define if this should use 32-bit values in 64-bit architectures */ #undef POLYML32IN64 /* Define to the type of arg 1 for `select'. */ #undef SELECT_TYPE_ARG1 /* Define to the type of args 2, 3 and 4 for `select'. */ #undef SELECT_TYPE_ARG234 /* Define to the type of arg 5 for `select'. */ #undef SELECT_TYPE_ARG5 /* The size of `double', as computed by sizeof. */ #undef SIZEOF_DOUBLE /* The size of `float', as computed by sizeof. */ #undef SIZEOF_FLOAT /* The size of `int', as computed by sizeof. */ #undef SIZEOF_INT /* The size of `long', as computed by sizeof. */ #undef SIZEOF_LONG /* The size of `long long', as computed by sizeof. */ #undef SIZEOF_LONG_LONG /* The size of `void*', as computed by sizeof. */ #undef SIZEOF_VOIDP /* If using the C implementation of alloca, define if you know the direction of stack growth for your system; otherwise it will be automatically deduced at runtime. STACK_DIRECTION > 0 => grows toward higher addresses STACK_DIRECTION < 0 => grows toward lower addresses STACK_DIRECTION = 0 => direction of growth unknown */ #undef STACK_DIRECTION /* Define to 1 if you have the ANSI C header files. */ #undef STDC_HEADERS /* Defined if external symbols are prefixed by underscores */ #undef SYMBOLS_REQUIRE_UNDERSCORE /* Define to 1 if you can safely include both and . */ #undef TIME_WITH_SYS_TIME /* Define to 1 if your declares `struct tm'. */ #undef TM_IN_SYS_TIME /* Version number of package */ #undef VERSION /* Define if the X-Windows interface should be built */ #undef WITH_XWINDOWS /* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most significant byte first (like Motorola and SPARC, unlike Intel). */ #if defined AC_APPLE_UNIVERSAL_BUILD # if defined __BIG_ENDIAN__ # define WORDS_BIGENDIAN 1 # endif #else # ifndef WORDS_BIGENDIAN # undef WORDS_BIGENDIAN # endif #endif /* Enable large inode numbers on Mac OS X 10.5. */ #ifndef _DARWIN_USE_64_BIT_INODE # define _DARWIN_USE_64_BIT_INODE 1 #endif /* Number of bits in a file offset, on hosts where this is settable. */ #undef _FILE_OFFSET_BITS /* Define for large files, on AIX-style hosts. */ #undef _LARGE_FILES /* Define for Solaris 2.5.1 so the uint32_t typedef from , , or is not used. If the typedef were allowed, the #define below would cause a syntax error. */ #undef _UINT32_T /* Define for Solaris 2.5.1 so the uint64_t typedef from , , or is not used. If the typedef were allowed, the #define below would cause a syntax error. */ #undef _UINT64_T /* Define to empty if `const' does not conform to ANSI C. */ #undef const /* Define to `int' if doesn't define. */ #undef gid_t /* Define to the type of a signed integer type of width exactly 16 bits if such a type exists and the standard includes do not define it. */ #undef int16_t /* Define to the type of a signed integer type of width exactly 32 bits if such a type exists and the standard includes do not define it. */ #undef int32_t /* Define to the type of a signed integer type of width exactly 64 bits if such a type exists and the standard includes do not define it. */ #undef int64_t /* Define to the type of a signed integer type wide enough to hold a pointer, if such a type exists, and if the system does not define it. */ #undef intptr_t /* Define to `int' if does not define. */ #undef mode_t /* Define to `long int' if does not define. */ #undef off_t /* Define to `int' if does not define. */ #undef pid_t /* Define to `unsigned int' if does not define. */ #undef size_t /* Define to `int' if does not define. */ #undef ssize_t /* Define to `int' if doesn't define. */ #undef uid_t /* Define to the type of an unsigned integer type of width exactly 16 bits if such a type exists and the standard includes do not define it. */ #undef uint16_t /* Define to the type of an unsigned integer type of width exactly 32 bits if such a type exists and the standard includes do not define it. */ #undef uint32_t /* Define to the type of an unsigned integer type of width exactly 64 bits if such a type exists and the standard includes do not define it. */ #undef uint64_t /* Define to the type of an unsigned integer type wide enough to hold a pointer, if such a type exists, and if the system does not define it. */ #undef uintptr_t diff --git a/configure b/configure index d87a86b0..13ba4e8d 100755 --- a/configure +++ b/configure @@ -1,25368 +1,25368 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69 for Poly/ML 5.8. # # Report bugs to . # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 as_fn_exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 test \$(( 1 + 1 )) = 2 || exit 1 test -n \"\${ZSH_VERSION+set}\${BASH_VERSION+set}\" || ( ECHO='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' ECHO=\$ECHO\$ECHO\$ECHO\$ECHO\$ECHO ECHO=\$ECHO\$ECHO\$ECHO\$ECHO\$ECHO\$ECHO PATH=/empty FPATH=/empty; export PATH FPATH test \"X\`printf %s \$ECHO\`\" = \"X\$ECHO\" \\ || test \"X\`print -r -- \$ECHO\`\" = \"X\$ECHO\" ) || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org and polyml AT polyml $0: DOT org about your system, including any error possibly $0: output before this message. Then install a modern $0: shell, or manually run the script under such a shell if $0: you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" SHELL=${CONFIG_SHELL-/bin/sh} test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME='Poly/ML' PACKAGE_TARNAME='polyml' PACKAGE_VERSION='5.8' PACKAGE_STRING='Poly/ML 5.8' PACKAGE_BUGREPORT='polyml AT polyml DOT org' PACKAGE_URL='' # Factoring default headers for most tests. ac_includes_default="\ #include #ifdef HAVE_SYS_TYPES_H # include #endif #ifdef HAVE_SYS_STAT_H # include #endif #ifdef STDC_HEADERS # include # include #else # ifdef HAVE_STDLIB_H # include # endif #endif #ifdef HAVE_STRING_H # if !defined STDC_HEADERS && defined HAVE_MEMORY_H # include # endif # include #endif #ifdef HAVE_STRINGS_H # include #endif #ifdef HAVE_INTTYPES_H # include #endif #ifdef HAVE_STDINT_H # include #endif #ifdef HAVE_UNISTD_H # include #endif" ac_unique_file="polyexports.h" enable_option_checking=no ac_subst_vars='am__EXEEXT_FALSE am__EXEEXT_TRUE LTLIBOBJS INTINFISINT_FALSE INTINFISINT_TRUE moduledir polyc_CFLAGS GIT_VERSION gitinstalled dependentlibs MACOSLDOPTS_FALSE MACOSLDOPTS_TRUE WINDOWSGUI_FALSE WINDOWSGUI_TRUE NO_UNDEFINED_FALSE NO_UNDEFINED_TRUE NATIVE_WINDOWS_FALSE NATIVE_WINDOWS_TRUE WINDOWSCALLCONV_FALSE WINDOWSCALLCONV_TRUE ARCHX8632IN64_FALSE ARCHX8632IN64_TRUE ARCHINTERPRET64_FALSE ARCHINTERPRET64_TRUE ARCHINTERPRET_FALSE ARCHINTERPRET_TRUE ARCHX86_64_FALSE ARCHX86_64_TRUE ARCHI386_FALSE ARCHI386_TRUE POW_LIB LIBOBJS EXPMACHO_FALSE EXPMACHO_TRUE EXPELF_FALSE EXPELF_TRUE EXPPECOFF_FALSE EXPPECOFF_TRUE XMKMF WINDRES INTERNAL_LIBFFI_FALSE INTERNAL_LIBFFI_TRUE FFI_LIBS FFI_CFLAGS subdirs PKG_CONFIG_LIBDIR PKG_CONFIG_PATH PKG_CONFIG ALLOCA sys_symbol_underscore am__fastdepCCAS_FALSE am__fastdepCCAS_TRUE CCASDEPMODE CCASFLAGS CCAS CXXCPP am__fastdepCXX_FALSE am__fastdepCXX_TRUE CXXDEPMODE ac_ct_CXX CXXFLAGS CXX MAINT MAINTAINER_MODE_FALSE MAINTAINER_MODE_TRUE LT_SYS_LIBRARY_PATH OTOOL64 OTOOL LIPO NMEDIT DSYMUTIL MANIFEST_TOOL RANLIB ac_ct_AR AR LN_S NM ac_ct_DUMPBIN DUMPBIN LD FGREP SED LIBTOOL OBJDUMP DLLTOOL AS OSFLAG EGREP GREP CPP am__fastdepCC_FALSE am__fastdepCC_TRUE CCDEPMODE am__nodep AMDEPBACKSLASH AMDEP_FALSE AMDEP_TRUE am__quote am__include DEPDIR OBJEXT EXEEXT ac_ct_CC CPPFLAGS LDFLAGS CFLAGS CC host_os host_vendor host_cpu host build_os build_vendor build_cpu build AM_BACKSLASH AM_DEFAULT_VERBOSITY AM_DEFAULT_V AM_V am__untar am__tar AMTAR am__leading_dot SET_MAKE AWK mkdir_p MKDIR_P INSTALL_STRIP_PROGRAM STRIP install_sh MAKEINFO AUTOHEADER AUTOMAKE AUTOCONF ACLOCAL VERSION PACKAGE CYGPATH_W am__isrc INSTALL_DATA INSTALL_SCRIPT INSTALL_PROGRAM target_alias host_alias build_alias LIBS ECHO_T ECHO_N ECHO_C DEFS mandir localedir libdir psdir pdfdir dvidir htmldir infodir docdir oldincludedir includedir runstatedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking enable_silent_rules enable_debug enable_dependency_tracking enable_shared enable_static with_pic enable_fast_install with_aix_soname with_gnu_ld with_sysroot enable_libtool_lock enable_maintainer_mode enable_largefile with_gmp with_system_libffi enable_windows_gui with_x enable_native_codegeneration enable_compact32bit with_moduledir enable_intinf_as_int ' ac_precious_vars='build_alias host_alias target_alias CC CFLAGS LDFLAGS LIBS CPPFLAGS CPP LT_SYS_LIBRARY_PATH CXX CXXFLAGS CCC CXXCPP CCAS CCASFLAGS PKG_CONFIG PKG_CONFIG_PATH PKG_CONFIG_LIBDIR FFI_CFLAGS FFI_LIBS XMKMF' ac_subdirs_all='libpolyml/libffi' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *=) ac_optarg= ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -runstatedir | --runstatedir | --runstatedi | --runstated \ | --runstate | --runstat | --runsta | --runst | --runs \ | --run | --ru | --r) ac_prev=runstatedir ;; -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ | --run=* | --ru=* | --r=*) runstatedir=$ac_optarg ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir runstatedir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures Poly/ML 5.8 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/polyml] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF Program names: --program-prefix=PREFIX prepend PREFIX to installed program names --program-suffix=SUFFIX append SUFFIX to installed program names --program-transform-name=PROGRAM run sed PROGRAM on installed program names X features: --x-includes=DIR X include files are in DIR --x-libraries=DIR X library files are in DIR System types: --build=BUILD configure for building on BUILD [guessed] --host=HOST cross-compile to build programs to run on HOST [BUILD] _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in short | recursive ) echo "Configuration of Poly/ML 5.8:";; esac cat <<\_ACEOF Optional Features: --disable-option-checking ignore unrecognized --enable/--with options --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-silent-rules less verbose build output (undo: "make V=1") --disable-silent-rules verbose build output (undo: "make V=0") --enable-debug Compiles without optimisation for debugging --enable-dependency-tracking do not reject slow dependency extractors --disable-dependency-tracking speeds up one-time build --enable-shared[=PKGS] build shared libraries [default=yes] --enable-static[=PKGS] build static libraries [default=yes] --enable-fast-install[=PKGS] optimize for fast installation [default=yes] --disable-libtool-lock avoid locking (might break parallel builds) --enable-maintainer-mode enable make rules and dependencies not useful (and sometimes confusing) to the casual installer --disable-largefile omit support for large files --enable-windows-gui create a GUI in Windows. If this is disabled use a Windows console. [default=yes] --disable-native-codegeneration disable the native code generator and use the slow byte code interpreter instead. --enable-compact32bit use 32-bit values rather than native 64-bits. --enable-intinf-as-int set arbitrary precision as the default int type Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-pic[=PKGS] try to use only PIC/non-PIC objects [default=use both] --with-aix-soname=aix|svr4|both shared library versioning (aka "SONAME") variant to provide on AIX, [default=aix]. --with-gnu-ld assume the C compiler uses GNU ld [default=no] --with-sysroot[=DIR] Search for dependent libraries within DIR (or the compiler's sysroot if not specified). --with-gmp use the GMP library for arbitrary precision arithmetic [default=check] --with-system-libffi use the version of libffi installed on your system rather than the version supplied with poly [default=no] --with-x use the X Window System --with-moduledir=DIR directory for Poly/ML modules Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a nonstandard directory LIBS libraries to pass to the linker, e.g. -l CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if you have headers in a nonstandard directory CPP C preprocessor LT_SYS_LIBRARY_PATH User-defined run-time library search path. CXX C++ compiler command CXXFLAGS C++ compiler flags CXXCPP C++ preprocessor CCAS assembler compiler command (defaults to CC) CCASFLAGS assembler compiler flags (defaults to CFLAGS) PKG_CONFIG path to pkg-config utility PKG_CONFIG_PATH directories to add to pkg-config's search path PKG_CONFIG_LIBDIR path overriding pkg-config's built-in search path FFI_CFLAGS C compiler flags for FFI, overriding pkg-config FFI_LIBS linker flags for FFI, overriding pkg-config XMKMF Path to xmkmf, Makefile generator for X Window System Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. Report bugs to . _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for guested configure. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF Poly/ML configure 5.8 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## # ac_fn_c_try_compile LINENO # -------------------------- # Try to compile conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_compile # ac_fn_c_check_decl LINENO SYMBOL VAR INCLUDES # --------------------------------------------- # Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR # accordingly. ac_fn_c_check_decl () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack as_decl_name=`echo $2|sed 's/ *(.*//'` as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'` { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5 $as_echo_n "checking whether $as_decl_name is declared... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { #ifndef $as_decl_name #ifdef __cplusplus (void) $as_decl_use; #else (void) $as_decl_name; #endif #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : eval "$3=yes" else eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_decl # ac_fn_c_try_cpp LINENO # ---------------------- # Try to preprocess conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_cpp () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } > conftest.i && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_cpp # ac_fn_c_try_run LINENO # ---------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. Assumes # that executables *can* be run. ac_fn_c_try_run () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then : ac_retval=0 else $as_echo "$as_me: program exited with status $ac_status" >&5 $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=$ac_status fi rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_run # ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists and can be compiled using the include files in # INCLUDES, setting the cache variable VAR accordingly. ac_fn_c_check_header_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> _ACEOF if ac_fn_c_try_compile "$LINENO"; then : eval "$3=yes" else eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_compile # ac_fn_c_try_link LINENO # ----------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_link () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext conftest$ac_exeext if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || test -x conftest$ac_exeext }; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would # interfere with the next link command; also delete a directory that is # left behind by Apple's compiler. We do this before executing the actions. rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_link # ac_fn_c_check_func LINENO FUNC VAR # ---------------------------------- # Tests whether FUNC exists, setting the cache variable VAR accordingly ac_fn_c_check_func () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Define $2 to an innocuous variant, in case declares $2. For example, HP-UX 11i declares gettimeofday. */ #define $2 innocuous_$2 /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $2 (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $2 /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $2 (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$2 || defined __stub___$2 choke me #endif int main () { return $2 (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : eval "$3=yes" else eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_func # ac_fn_cxx_try_compile LINENO # ---------------------------- # Try to compile conftest.$ac_ext, and return whether this succeeded. ac_fn_cxx_try_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_cxx_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_cxx_try_compile # ac_fn_cxx_try_cpp LINENO # ------------------------ # Try to preprocess conftest.$ac_ext, and return whether this succeeded. ac_fn_cxx_try_cpp () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } > conftest.i && { test -z "$ac_cxx_preproc_warn_flag$ac_cxx_werror_flag" || test ! -s conftest.err }; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_cxx_try_cpp # ac_fn_cxx_try_link LINENO # ------------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. ac_fn_cxx_try_link () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext conftest$ac_exeext if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_cxx_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || test -x conftest$ac_exeext }; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would # interfere with the next link command; also delete a directory that is # left behind by Apple's compiler. We do this before executing the actions. rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_cxx_try_link # ac_fn_c_check_type LINENO TYPE VAR INCLUDES # ------------------------------------------- # Tests whether TYPE exists after having included INCLUDES, setting cache # variable VAR accordingly. ac_fn_c_check_type () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else eval "$3=no" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { if (sizeof ($2)) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { if (sizeof (($2))) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : else eval "$3=yes" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_type # ac_fn_c_check_header_mongrel LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists, giving a warning if it cannot be compiled using # the include files in INCLUDES and setting the cache variable VAR # accordingly. ac_fn_c_check_header_mongrel () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if eval \${$3+:} false; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5 $as_echo_n "checking $2 usability... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_header_compiler=yes else ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5 $as_echo_n "checking $2 presence... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include <$2> _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : ac_header_preproc=yes else ac_header_preproc=no fi rm -f conftest.err conftest.i conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #(( yes:no: ) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} ;; no:yes:* ) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} ( $as_echo "## --------------------------------------- ## ## Report this to polyml AT polyml DOT org ## ## --------------------------------------- ##" ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else eval "$3=\$ac_header_compiler" fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_mongrel # ac_fn_c_find_intX_t LINENO BITS VAR # ----------------------------------- # Finds a signed integer type with width BITS, setting cache variable VAR # accordingly. ac_fn_c_find_intX_t () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for int$2_t" >&5 $as_echo_n "checking for int$2_t... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else eval "$3=no" # Order is important - never check a type that is potentially smaller # than half of the expected target width. for ac_type in int$2_t 'int' 'long int' \ 'long long int' 'short int' 'signed char'; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default enum { N = $2 / 2 - 1 }; int main () { static int test_array [1 - 2 * !(0 < ($ac_type) ((((($ac_type) 1 << N) << N) - 1) * 2 + 1))]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default enum { N = $2 / 2 - 1 }; int main () { static int test_array [1 - 2 * !(($ac_type) ((((($ac_type) 1 << N) << N) - 1) * 2 + 1) < ($ac_type) ((((($ac_type) 1 << N) << N) - 1) * 2 + 2))]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : else case $ac_type in #( int$2_t) : eval "$3=yes" ;; #( *) : eval "$3=\$ac_type" ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if eval test \"x\$"$3"\" = x"no"; then : else break fi done fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_find_intX_t # ac_fn_c_find_uintX_t LINENO BITS VAR # ------------------------------------ # Finds an unsigned integer type with width BITS, setting cache variable VAR # accordingly. ac_fn_c_find_uintX_t () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for uint$2_t" >&5 $as_echo_n "checking for uint$2_t... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else eval "$3=no" # Order is important - never check a type that is potentially smaller # than half of the expected target width. for ac_type in uint$2_t 'unsigned int' 'unsigned long int' \ 'unsigned long long int' 'unsigned short int' 'unsigned char'; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !((($ac_type) -1 >> ($2 / 2 - 1)) >> ($2 / 2 - 1) == 3)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : case $ac_type in #( uint$2_t) : eval "$3=yes" ;; #( *) : eval "$3=\$ac_type" ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if eval test \"x\$"$3"\" = x"no"; then : else break fi done fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_find_uintX_t # ac_fn_c_check_member LINENO AGGR MEMBER VAR INCLUDES # ---------------------------------------------------- # Tries to find if the field MEMBER exists in type AGGR, after including # INCLUDES, setting cache variable VAR accordingly. ac_fn_c_check_member () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2.$3" >&5 $as_echo_n "checking for $2.$3... " >&6; } if eval \${$4+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $5 int main () { static $2 ac_aggr; if (ac_aggr.$3) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : eval "$4=yes" else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $5 int main () { static $2 ac_aggr; if (sizeof ac_aggr.$3) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : eval "$4=yes" else eval "$4=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$4 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_member # ac_fn_c_compute_int LINENO EXPR VAR INCLUDES # -------------------------------------------- # Tries to find the compile-time value of EXPR in a program that includes # INCLUDES, setting VAR accordingly. Returns whether the value could be # computed ac_fn_c_compute_int () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if test "$cross_compiling" = yes; then # Depending upon the size, compute the lo and hi bounds. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) >= 0)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_lo=0 ac_mid=0 while :; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) <= $ac_mid)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_hi=$ac_mid; break else as_fn_arith $ac_mid + 1 && ac_lo=$as_val if test $ac_lo -le $ac_mid; then ac_lo= ac_hi= break fi as_fn_arith 2 '*' $ac_mid + 1 && ac_mid=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext done else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) < 0)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_hi=-1 ac_mid=-1 while :; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) >= $ac_mid)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_lo=$ac_mid; break else as_fn_arith '(' $ac_mid ')' - 1 && ac_hi=$as_val if test $ac_mid -le $ac_hi; then ac_lo= ac_hi= break fi as_fn_arith 2 '*' $ac_mid && ac_mid=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext done else ac_lo= ac_hi= fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext # Binary search between lo and hi bounds. while test "x$ac_lo" != "x$ac_hi"; do as_fn_arith '(' $ac_hi - $ac_lo ')' / 2 + $ac_lo && ac_mid=$as_val cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) <= $ac_mid)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_hi=$ac_mid else as_fn_arith '(' $ac_mid ')' + 1 && ac_lo=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext done case $ac_lo in #(( ?*) eval "$3=\$ac_lo"; ac_retval=0 ;; '') ac_retval=1 ;; esac else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 static long int longval () { return $2; } static unsigned long int ulongval () { return $2; } #include #include int main () { FILE *f = fopen ("conftest.val", "w"); if (! f) return 1; if (($2) < 0) { long int i = longval (); if (i != ($2)) return 1; fprintf (f, "%ld", i); } else { unsigned long int i = ulongval (); if (i != ($2)) return 1; fprintf (f, "%lu", i); } /* Do not output a trailing newline, as this causes \r\n confusion on some platforms. */ return ferror (f) || fclose (f) != 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : echo >>conftest.val; read $3 config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by Poly/ML $as_me 5.8, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo $as_echo "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo $as_echo "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then $as_echo "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then $as_echo "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then # We do not want a PATH search for config.site. case $CONFIG_SITE in #(( -*) ac_site_file1=./$CONFIG_SITE;; */*) ac_site_file1=$CONFIG_SITE;; *) ac_site_file1=./$CONFIG_SITE;; esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu am__api_version='1.15' ac_aux_dir= for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do if test -f "$ac_dir/install-sh"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install-sh -c" break elif test -f "$ac_dir/install.sh"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install.sh -c" break elif test -f "$ac_dir/shtool"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/shtool install -c" break fi done if test -z "$ac_aux_dir"; then as_fn_error $? "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 fi # These three variables are undocumented and unsupported, # and are intended to be withdrawn in a future Autoconf release. # They can cause serious problems if a builder's source tree is in a directory # whose full name contains unusual characters. ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. # Find a good install program. We prefer a C program (faster), # so one script is as good as another. But avoid the broken or # incompatible versions: # SysV /etc/install, /usr/sbin/install # SunOS /usr/etc/install # IRIX /sbin/install # AIX /bin/install # AmigaOS /C/install, which installs bootblocks on floppy discs # AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag # AFS /usr/afsws/bin/install, which mishandles nonexistent args # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # OS/2's system install, which has a completely different semantic # ./install, which can be erroneously created by make from ./install.sh. # Reject install programs that cannot install multiple files. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for a BSD-compatible install" >&5 $as_echo_n "checking for a BSD-compatible install... " >&6; } if test -z "$INSTALL"; then if ${ac_cv_path_install+:} false; then : $as_echo_n "(cached) " >&6 else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. # Account for people who put trailing slashes in PATH elements. case $as_dir/ in #(( ./ | .// | /[cC]/* | \ /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ ?:[\\/]os2[\\/]install[\\/]* | ?:[\\/]OS2[\\/]INSTALL[\\/]* | \ /usr/ucb/* ) ;; *) # OSF1 and SCO ODT 3.0 have their own names for install. # Don't use installbsd from OSF since it installs stuff as root # by default. for ac_prog in ginstall scoinst install; do for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_prog$ac_exec_ext"; then if test $ac_prog = install && grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # AIX install. It has an incompatible calling convention. : elif test $ac_prog = install && grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # program-specific install script used by HP pwplus--don't use. : else rm -rf conftest.one conftest.two conftest.dir echo one > conftest.one echo two > conftest.two mkdir conftest.dir if "$as_dir/$ac_prog$ac_exec_ext" -c conftest.one conftest.two "`pwd`/conftest.dir" && test -s conftest.one && test -s conftest.two && test -s conftest.dir/conftest.one && test -s conftest.dir/conftest.two then ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c" break 3 fi fi fi done done ;; esac done IFS=$as_save_IFS rm -rf conftest.one conftest.two conftest.dir fi if test "${ac_cv_path_install+set}" = set; then INSTALL=$ac_cv_path_install else # As a last resort, use the slow shell script. Don't cache a # value for INSTALL within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the value is a relative name. INSTALL=$ac_install_sh fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $INSTALL" >&5 $as_echo "$INSTALL" >&6; } # Use test -z because SunOS4 sh mishandles braces in ${var-val}. # It thinks the first close brace ends the variable substitution. test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether build environment is sane" >&5 $as_echo_n "checking whether build environment is sane... " >&6; } # Reject unsafe characters in $srcdir or the absolute working directory # name. Accept space and tab only in the latter. am_lf=' ' case `pwd` in *[\\\"\#\$\&\'\`$am_lf]*) as_fn_error $? "unsafe absolute working directory name" "$LINENO" 5;; esac case $srcdir in *[\\\"\#\$\&\'\`$am_lf\ \ ]*) as_fn_error $? "unsafe srcdir value: '$srcdir'" "$LINENO" 5;; esac # Do 'set' in a subshell so we don't clobber the current shell's # arguments. Must try -L first in case configure is actually a # symlink; some systems play weird games with the mod time of symlinks # (eg FreeBSD returns the mod time of the symlink's containing # directory). if ( am_has_slept=no for am_try in 1 2; do echo "timestamp, slept: $am_has_slept" > conftest.file set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null` if test "$*" = "X"; then # -L didn't work. set X `ls -t "$srcdir/configure" conftest.file` fi if test "$*" != "X $srcdir/configure conftest.file" \ && test "$*" != "X conftest.file $srcdir/configure"; then # If neither matched, then we have a broken ls. This can happen # if, for instance, CONFIG_SHELL is bash and it inherits a # broken ls alias from the environment. This has actually # happened. Such a system could not be considered "sane". as_fn_error $? "ls -t appears to fail. Make sure there is not a broken alias in your environment" "$LINENO" 5 fi if test "$2" = conftest.file || test $am_try -eq 2; then break fi # Just in case. sleep 1 am_has_slept=yes done test "$2" = conftest.file ) then # Ok. : else as_fn_error $? "newly created file is older than distributed files! Check your system clock" "$LINENO" 5 fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } # If we didn't sleep, we still need to ensure time stamps of config.status and # generated files are strictly newer. am_sleep_pid= if grep 'slept: no' conftest.file >/dev/null 2>&1; then ( sleep 1 ) & am_sleep_pid=$! fi rm -f conftest.file test "$program_prefix" != NONE && program_transform_name="s&^&$program_prefix&;$program_transform_name" # Use a double $ so make ignores it. test "$program_suffix" != NONE && program_transform_name="s&\$&$program_suffix&;$program_transform_name" # Double any \ or $. # By default was `s,x,x', remove it if useless. ac_script='s/[\\$]/&&/g;s/;s,x,x,$//' program_transform_name=`$as_echo "$program_transform_name" | sed "$ac_script"` # Expand $ac_aux_dir to an absolute path. am_aux_dir=`cd "$ac_aux_dir" && pwd` if test x"${MISSING+set}" != xset; then case $am_aux_dir in *\ * | *\ *) MISSING="\${SHELL} \"$am_aux_dir/missing\"" ;; *) MISSING="\${SHELL} $am_aux_dir/missing" ;; esac fi # Use eval to expand $SHELL if eval "$MISSING --is-lightweight"; then am_missing_run="$MISSING " else am_missing_run= { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 'missing' script is too old or missing" >&5 $as_echo "$as_me: WARNING: 'missing' script is too old or missing" >&2;} fi if test x"${install_sh+set}" != xset; then case $am_aux_dir in *\ * | *\ *) install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;; *) install_sh="\${SHELL} $am_aux_dir/install-sh" esac fi # Installed binaries are usually stripped using 'strip' when the user # run "make install-strip". However 'strip' might not be the right # tool to use in cross-compilation environments, therefore Automake # will honor the 'STRIP' environment variable to overrule this program. if test "$cross_compiling" != no; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}strip", so it can be a program name with args. set dummy ${ac_tool_prefix}strip; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_STRIP+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$STRIP"; then ac_cv_prog_STRIP="$STRIP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_STRIP="${ac_tool_prefix}strip" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi STRIP=$ac_cv_prog_STRIP if test -n "$STRIP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $STRIP" >&5 $as_echo "$STRIP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_STRIP"; then ac_ct_STRIP=$STRIP # Extract the first word of "strip", so it can be a program name with args. set dummy strip; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_STRIP+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_STRIP"; then ac_cv_prog_ac_ct_STRIP="$ac_ct_STRIP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_STRIP="strip" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_STRIP=$ac_cv_prog_ac_ct_STRIP if test -n "$ac_ct_STRIP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_STRIP" >&5 $as_echo "$ac_ct_STRIP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_STRIP" = x; then STRIP=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac STRIP=$ac_ct_STRIP fi else STRIP="$ac_cv_prog_STRIP" fi fi INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for a thread-safe mkdir -p" >&5 $as_echo_n "checking for a thread-safe mkdir -p... " >&6; } if test -z "$MKDIR_P"; then if ${ac_cv_path_mkdir+:} false; then : $as_echo_n "(cached) " >&6 else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/opt/sfw/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in mkdir gmkdir; do for ac_exec_ext in '' $ac_executable_extensions; do as_fn_executable_p "$as_dir/$ac_prog$ac_exec_ext" || continue case `"$as_dir/$ac_prog$ac_exec_ext" --version 2>&1` in #( 'mkdir (GNU coreutils) '* | \ 'mkdir (coreutils) '* | \ 'mkdir (fileutils) '4.1*) ac_cv_path_mkdir=$as_dir/$ac_prog$ac_exec_ext break 3;; esac done done done IFS=$as_save_IFS fi test -d ./--version && rmdir ./--version if test "${ac_cv_path_mkdir+set}" = set; then MKDIR_P="$ac_cv_path_mkdir -p" else # As a last resort, use the slow shell script. Don't cache a # value for MKDIR_P within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the value is a relative name. MKDIR_P="$ac_install_sh -d" fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MKDIR_P" >&5 $as_echo "$MKDIR_P" >&6; } for ac_prog in gawk mawk nawk awk do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_AWK+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$AWK"; then ac_cv_prog_AWK="$AWK" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_AWK="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi AWK=$ac_cv_prog_AWK if test -n "$AWK"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AWK" >&5 $as_echo "$AWK" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$AWK" && break done { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5 $as_echo_n "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; } set x ${MAKE-make} ac_make=`$as_echo "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'` if eval \${ac_cv_prog_make_${ac_make}_set+:} false; then : $as_echo_n "(cached) " >&6 else cat >conftest.make <<\_ACEOF SHELL = /bin/sh all: @echo '@@@%%%=$(MAKE)=@@@%%%' _ACEOF # GNU make sometimes prints "make[1]: Entering ...", which would confuse us. case `${MAKE-make} -f conftest.make 2>/dev/null` in *@@@%%%=?*=@@@%%%*) eval ac_cv_prog_make_${ac_make}_set=yes;; *) eval ac_cv_prog_make_${ac_make}_set=no;; esac rm -f conftest.make fi if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } SET_MAKE= else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } SET_MAKE="MAKE=${MAKE-make}" fi rm -rf .tst 2>/dev/null mkdir .tst 2>/dev/null if test -d .tst; then am__leading_dot=. else am__leading_dot=_ fi rmdir .tst 2>/dev/null # Check whether --enable-silent-rules was given. if test "${enable_silent_rules+set}" = set; then : enableval=$enable_silent_rules; fi case $enable_silent_rules in # ((( yes) AM_DEFAULT_VERBOSITY=0;; no) AM_DEFAULT_VERBOSITY=1;; *) AM_DEFAULT_VERBOSITY=1;; esac am_make=${MAKE-make} { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $am_make supports nested variables" >&5 $as_echo_n "checking whether $am_make supports nested variables... " >&6; } if ${am_cv_make_support_nested_variables+:} false; then : $as_echo_n "(cached) " >&6 else if $as_echo 'TRUE=$(BAR$(V)) BAR0=false BAR1=true V=1 am__doit: @$(TRUE) .PHONY: am__doit' | $am_make -f - >/dev/null 2>&1; then am_cv_make_support_nested_variables=yes else am_cv_make_support_nested_variables=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_make_support_nested_variables" >&5 $as_echo "$am_cv_make_support_nested_variables" >&6; } if test $am_cv_make_support_nested_variables = yes; then AM_V='$(V)' AM_DEFAULT_V='$(AM_DEFAULT_VERBOSITY)' else AM_V=$AM_DEFAULT_VERBOSITY AM_DEFAULT_V=$AM_DEFAULT_VERBOSITY fi AM_BACKSLASH='\' if test "`cd $srcdir && pwd`" != "`pwd`"; then # Use -I$(srcdir) only when $(srcdir) != ., so that make's output # is not polluted with repeated "-I." am__isrc=' -I$(srcdir)' # test to see if srcdir already configured if test -f $srcdir/config.status; then as_fn_error $? "source directory already configured; run \"make distclean\" there first" "$LINENO" 5 fi fi # test whether we have cygpath if test -z "$CYGPATH_W"; then if (cygpath --version) >/dev/null 2>/dev/null; then CYGPATH_W='cygpath -w' else CYGPATH_W=echo fi fi # Define the identity of the package. PACKAGE='polyml' VERSION='5.8' cat >>confdefs.h <<_ACEOF #define PACKAGE "$PACKAGE" _ACEOF cat >>confdefs.h <<_ACEOF #define VERSION "$VERSION" _ACEOF # Some tools Automake needs. ACLOCAL=${ACLOCAL-"${am_missing_run}aclocal-${am__api_version}"} AUTOCONF=${AUTOCONF-"${am_missing_run}autoconf"} AUTOMAKE=${AUTOMAKE-"${am_missing_run}automake-${am__api_version}"} AUTOHEADER=${AUTOHEADER-"${am_missing_run}autoheader"} MAKEINFO=${MAKEINFO-"${am_missing_run}makeinfo"} # For better backward compatibility. To be removed once Automake 1.9.x # dies out for good. For more background, see: # # mkdir_p='$(MKDIR_P)' # We need awk for the "check" target (and possibly the TAP driver). The # system "awk" is bad on some platforms. # Always define AMTAR for backward compatibility. Yes, it's still used # in the wild :-( We should find a proper way to deprecate it ... AMTAR='$${TAR-tar}' # We'll loop over all known methods to create a tar archive until one works. _am_tools='gnutar pax cpio none' am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -' # POSIX will say in a future version that running "rm -f" with no argument # is OK; and we want to be able to make that assumption in our Makefile # recipes. So use an aggressive probe to check that the usage we want is # actually supported "in the wild" to an acceptable degree. # See automake bug#10828. # To make any issue more visible, cause the running configure to be aborted # by default if the 'rm' program in use doesn't match our expectations; the # user can still override this though. if rm -f && rm -fr && rm -rf; then : OK; else cat >&2 <<'END' Oops! Your 'rm' program seems unable to run without file operands specified on the command line, even when the '-f' option is present. This is contrary to the behaviour of most rm programs out there, and not conforming with the upcoming POSIX standard: Please tell bug-automake@gnu.org about your system, including the value of your $PATH and any error possibly output before this message. This can help us improve future automake versions. END if test x"$ACCEPT_INFERIOR_RM_PROGRAM" = x"yes"; then echo 'Configuration will proceed anyway, since you have set the' >&2 echo 'ACCEPT_INFERIOR_RM_PROGRAM variable to "yes"' >&2 echo >&2 else cat >&2 <<'END' Aborting the configuration process, to ensure you take notice of the issue. You can download and install GNU coreutils to get an 'rm' implementation that behaves properly: . If you want to complete the configuration process using your problematic 'rm' anyway, export the environment variable ACCEPT_INFERIOR_RM_PROGRAM to "yes", and re-run configure. END as_fn_error $? "Your 'rm' program is bad, sorry." "$LINENO" 5 fi fi # libtoolize recommends this line. ac_debug_mode="no" # Check whether --enable-debug was given. if test "${enable_debug+set}" = set; then : enableval=$enable_debug; ac_debug_mode="yes" fi if test "$ac_debug_mode" != "yes"; then # Default to maximum optimisation. -O2 is not good enough. # Set CCASFLAGS to empty so that it doesn't get set to CFLAGS. # The -g option on assembler causes problems on Sparc/Solaris 10. # test X || Y is equivalent to if !X then Y test "${CFLAGS+set}" = set || CFLAGS="-O3" test "${CXXFLAGS+set}" = set || CXXFLAGS="-O3" test "${CCASFLAGS+set}" = set || CCASFLAGS="" else test "${CFLAGS+set}" = set || CFLAGS="-g" test "${CXXFLAGS+set}" = set || CXXFLAGS="-g" test "${CCASFLAGS+set}" = set || CCASFLAGS="" fi # Make sure we can run config.sub. $SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 || as_fn_error $? "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5 { $as_echo "$as_me:${as_lineno-$LINENO}: checking build system type" >&5 $as_echo_n "checking build system type... " >&6; } if ${ac_cv_build+:} false; then : $as_echo_n "(cached) " >&6 else ac_build_alias=$build_alias test "x$ac_build_alias" = x && ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"` test "x$ac_build_alias" = x && as_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5 ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` || as_fn_error $? "$SHELL $ac_aux_dir/config.sub $ac_build_alias failed" "$LINENO" 5 fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5 $as_echo "$ac_cv_build" >&6; } case $ac_cv_build in *-*-*) ;; *) as_fn_error $? "invalid value of canonical build" "$LINENO" 5;; esac build=$ac_cv_build ac_save_IFS=$IFS; IFS='-' set x $ac_cv_build shift build_cpu=$1 build_vendor=$2 shift; shift # Remember, the first character of IFS is used to create $*, # except with old shells: build_os=$* IFS=$ac_save_IFS case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking host system type" >&5 $as_echo_n "checking host system type... " >&6; } if ${ac_cv_host+:} false; then : $as_echo_n "(cached) " >&6 else if test "x$host_alias" = x; then ac_cv_host=$ac_cv_build else ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` || as_fn_error $? "$SHELL $ac_aux_dir/config.sub $host_alias failed" "$LINENO" 5 fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5 $as_echo "$ac_cv_host" >&6; } case $ac_cv_host in *-*-*) ;; *) as_fn_error $? "invalid value of canonical host" "$LINENO" 5;; esac host=$ac_cv_host ac_save_IFS=$IFS; IFS='-' set x $ac_cv_host shift host_cpu=$1 host_vendor=$2 shift; shift # Remember, the first character of IFS is used to create $*, # except with old shells: host_os=$* IFS=$ac_save_IFS case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac # If the compiler defines _WIN32 we're building for native Windows otherwise we're # building for something else. DEPDIR="${am__leading_dot}deps" ac_config_commands="$ac_config_commands depfiles" am_make=${MAKE-make} cat > confinc << 'END' am__doit: @echo this is the am__doit target .PHONY: am__doit END # If we don't find an include directive, just comment out the code. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for style of include used by $am_make" >&5 $as_echo_n "checking for style of include used by $am_make... " >&6; } am__include="#" am__quote= _am_result=none # First try GNU make style include. echo "include confinc" > confmf # Ignore all kinds of additional output from 'make'. case `$am_make -s -f confmf 2> /dev/null` in #( *the\ am__doit\ target*) am__include=include am__quote= _am_result=GNU ;; esac # Now try BSD make style include. if test "$am__include" = "#"; then echo '.include "confinc"' > confmf case `$am_make -s -f confmf 2> /dev/null` in #( *the\ am__doit\ target*) am__include=.include am__quote="\"" _am_result=BSD ;; esac fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $_am_result" >&5 $as_echo "$_am_result" >&6; } rm -f confinc confmf # Check whether --enable-dependency-tracking was given. if test "${enable_dependency_tracking+set}" = set; then : enableval=$enable_dependency_tracking; fi if test "x$enable_dependency_tracking" != xno; then am_depcomp="$ac_aux_dir/depcomp" AMDEPBACKSLASH='\' am__nodep='_no' fi if test "x$enable_dependency_tracking" != xno; then AMDEP_TRUE= AMDEP_FALSE='#' else AMDEP_TRUE='#' AMDEP_FALSE= fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. set dummy ${ac_tool_prefix}gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. set dummy ${ac_tool_prefix}cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}cc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue fi ac_cv_prog_CC="cc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS if test $ac_prog_rejected = yes; then # We found a bogon in the path, so make sure we never use it. set dummy $ac_cv_prog_CC shift if test $# != 0; then # We chose a different compiler from the bogus one. # However, it has the same basename, so the bogon will be chosen # first if we set CC to just the basename; use the full file name. shift ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" fi fi fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then for ac_prog in cl.exe do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC for ac_prog in cl.exe do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$ac_ct_CC" && break done if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi fi test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "no acceptable C compiler found in \$PATH See \`config.log' for more details" "$LINENO" 5; } # Provide some information about the compiler. $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 $as_echo_n "checking whether the C compiler works... " >&6; } ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` # The possible output files: ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" ac_rmfiles= for ac_file in $ac_files do case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; * ) ac_rmfiles="$ac_rmfiles $ac_file";; esac done rm -f $ac_rmfiles if { { ac_try="$ac_link_default" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link_default") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. # So ignore a value of `no', otherwise this would lead to `EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, # so that the user can short-circuit this test for compilers unknown to # Autoconf. for ac_file in $ac_files '' do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; then :; else ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi # We set ac_cv_exeext here because the later test for it is not # safe: cross compilers may not add the suffix if given an `-o' # argument, so we may need to know it at that point already. # Even if this section looks crufty: it has the advantage of # actually working. break;; * ) break;; esac done test "$ac_cv_exeext" = no && ac_cv_exeext= else ac_file='' fi if test -z "$ac_file"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "C compiler cannot create executables See \`config.log' for more details" "$LINENO" 5; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 $as_echo_n "checking for C compiler default output file name... " >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 $as_echo "$ac_file" >&6; } ac_exeext=$ac_cv_exeext rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 $as_echo_n "checking for suffix of executables... " >&6; } if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : # If both `conftest.exe' and `conftest' are `present' (well, observable) # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` break;; * ) break;; esac done else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of executables: cannot compile and link See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest conftest$ac_cv_exeext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 $as_echo "$ac_cv_exeext" >&6; } rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { FILE *f = fopen ("conftest.out", "w"); return ferror (f) || fclose (f) != 0; ; return 0; } _ACEOF ac_clean_files="$ac_clean_files conftest.out" # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 $as_echo_n "checking whether we are cross compiling... " >&6; } if test "$cross_compiling" != yes; then { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } if { ac_try='./conftest$ac_cv_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then cross_compiling=no else if test "$cross_compiling" = maybe; then cross_compiling=yes else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details" "$LINENO" 5; } fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 $as_echo "$cross_compiling" >&6; } rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out ac_clean_files=$ac_clean_files_save { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 $as_echo_n "checking for suffix of object files... " >&6; } if ${ac_cv_objext+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.o conftest.obj if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : for ac_file in conftest.o conftest.obj conftest.*; do test -f "$ac_file" || continue; case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of object files: cannot compile See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 $as_echo "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 $as_echo_n "checking whether we are using the GNU C compiler... " >&6; } if ${ac_cv_c_compiler_gnu+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_compiler_gnu=yes else ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 $as_echo "$ac_cv_c_compiler_gnu" >&6; } if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+set} ac_save_CFLAGS=$CFLAGS { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 $as_echo_n "checking whether $CC accepts -g... " >&6; } if ${ac_cv_prog_cc_g+:} false; then : $as_echo_n "(cached) " >&6 else ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes else CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : else ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 $as_echo "$ac_cv_prog_cc_g" >&6; } if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" else CFLAGS="-g" fi else if test "$GCC" = yes; then CFLAGS="-O2" else CFLAGS= fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 $as_echo_n "checking for $CC option to accept ISO C89... " >&6; } if ${ac_cv_prog_cc_c89+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include struct stat; /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); static char *e (p, i) char **p; int i; { return p[i]; } static char *f (char * (*g) (char **, int), char **p, ...) { char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not '\xHH' hex character constants. These don't provoke an error unfortunately, instead are silently treated as 'x'. The following induces an error, until -std is added to get proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an array size at least. It's necessary to write '\x00'==0 to get something that's true only with -std. */ int osf4_cc_array ['\x00' == 0 ? 1 : -1]; /* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters inside strings and character constants. */ #define FOO(x) 'x' int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; char **argv; int main () { return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; ; return 0; } _ACEOF for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_c89=$ac_arg fi rm -f core conftest.err conftest.$ac_objext test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi # AC_CACHE_VAL case "x$ac_cv_prog_cc_c89" in x) { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c89" { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 $as_echo "$ac_cv_prog_cc_c89" >&6; } ;; esac if test "x$ac_cv_prog_cc_c89" != xno; then : fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC understands -c and -o together" >&5 $as_echo_n "checking whether $CC understands -c and -o together... " >&6; } if ${am_cv_prog_cc_c_o+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF # Make sure it works both with $CC and with simple cc. # Following AC_PROG_CC_C_O, we do the test twice because some # compilers refuse to overwrite an existing .o file with -o, # though they will create one. am_cv_prog_cc_c_o=yes for am_i in 1 2; do if { echo "$as_me:$LINENO: $CC -c conftest.$ac_ext -o conftest2.$ac_objext" >&5 ($CC -c conftest.$ac_ext -o conftest2.$ac_objext) >&5 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } \ && test -f conftest2.$ac_objext; then : OK else am_cv_prog_cc_c_o=no break fi done rm -f core conftest* unset am_i fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_prog_cc_c_o" >&5 $as_echo "$am_cv_prog_cc_c_o" >&6; } if test "$am_cv_prog_cc_c_o" != yes; then # Losing compiler, so override with the script. # FIXME: It is wrong to rewrite CC. # But if we don't then we get into trouble of one sort or another. # A longer-term fix would be to have automake use am__CC in this case, # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" CC="$am_aux_dir/compile $CC" fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu depcc="$CC" am_compiler_list= { $as_echo "$as_me:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5 $as_echo_n "checking dependency style of $depcc... " >&6; } if ${am_cv_CC_dependencies_compiler_type+:} false; then : $as_echo_n "(cached) " >&6 else if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then # We make a subdir and do the tests there. Otherwise we can end up # making bogus files that we don't know about and never remove. For # instance it was reported that on HP-UX the gcc test will end up # making a dummy file named 'D' -- because '-MD' means "put the output # in D". rm -rf conftest.dir mkdir conftest.dir # Copy depcomp to subdir because otherwise we won't find it if we're # using a relative directory. cp "$am_depcomp" conftest.dir cd conftest.dir # We will build objects and dependencies in a subdirectory because # it helps to detect inapplicable dependency modes. For instance # both Tru64's cc and ICC support -MD to output dependencies as a # side effect of compilation, but ICC will put the dependencies in # the current directory while Tru64 will put them in the object # directory. mkdir sub am_cv_CC_dependencies_compiler_type=none if test "$am_compiler_list" = ""; then am_compiler_list=`sed -n 's/^#*\([a-zA-Z0-9]*\))$/\1/p' < ./depcomp` fi am__universal=false case " $depcc " in #( *\ -arch\ *\ -arch\ *) am__universal=true ;; esac for depmode in $am_compiler_list; do # Setup a source with many dependencies, because some compilers # like to wrap large dependency lists on column 80 (with \), and # we should not choose a depcomp mode which is confused by this. # # We need to recreate these files for each test, as the compiler may # overwrite some of them when testing with obscure command lines. # This happens at least with the AIX C compiler. : > sub/conftest.c for i in 1 2 3 4 5 6; do echo '#include "conftst'$i'.h"' >> sub/conftest.c # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with # Solaris 10 /bin/sh. echo '/* dummy */' > sub/conftst$i.h done echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf # We check with '-c' and '-o' for the sake of the "dashmstdout" # mode. It turns out that the SunPro C++ compiler does not properly # handle '-M -o', and we need to detect this. Also, some Intel # versions had trouble with output in subdirs. am__obj=sub/conftest.${OBJEXT-o} am__minus_obj="-o $am__obj" case $depmode in gcc) # This depmode causes a compiler race in universal mode. test "$am__universal" = false || continue ;; nosideeffect) # After this tag, mechanisms are not by side-effect, so they'll # only be used when explicitly requested. if test "x$enable_dependency_tracking" = xyes; then continue else break fi ;; msvc7 | msvc7msys | msvisualcpp | msvcmsys) # This compiler won't grok '-c -o', but also, the minuso test has # not run yet. These depmodes are late enough in the game, and # so weak that their functioning should not be impacted. am__obj=conftest.${OBJEXT-o} am__minus_obj= ;; none) break ;; esac if depmode=$depmode \ source=sub/conftest.c object=$am__obj \ depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ >/dev/null 2>conftest.err && grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && grep $am__obj sub/conftest.Po > /dev/null 2>&1 && ${MAKE-make} -s -f confmf > /dev/null 2>&1; then # icc doesn't choke on unknown options, it will just issue warnings # or remarks (even with -Werror). So we grep stderr for any message # that says an option was ignored or not supported. # When given -MP, icc 7.0 and 7.1 complain thusly: # icc: Command line warning: ignoring option '-M'; no argument required # The diagnosis changed in icc 8.0: # icc: Command line remark: option '-MP' not supported if (grep 'ignoring option' conftest.err || grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else am_cv_CC_dependencies_compiler_type=$depmode break fi fi done cd .. rm -rf conftest.dir else am_cv_CC_dependencies_compiler_type=none fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_CC_dependencies_compiler_type" >&5 $as_echo "$am_cv_CC_dependencies_compiler_type" >&6; } CCDEPMODE=depmode=$am_cv_CC_dependencies_compiler_type if test "x$enable_dependency_tracking" != xno \ && test "$am_cv_CC_dependencies_compiler_type" = gcc3; then am__fastdepCC_TRUE= am__fastdepCC_FALSE='#' else am__fastdepCC_TRUE='#' am__fastdepCC_FALSE= fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 $as_echo_n "checking how to run the C preprocessor... " >&6; } # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then if ${ac_cv_prog_CPP+:} false; then : $as_echo_n "(cached) " >&6 else # Double quotes because CPP needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" do ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok; then : break fi done ac_cv_prog_CPP=$CPP fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 $as_echo "$CPP" >&6; } ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok; then : else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details" "$LINENO" 5; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 $as_echo_n "checking for grep that handles long lines and -e... " >&6; } if ${ac_cv_path_GREP+:} false; then : $as_echo_n "(cached) " >&6 else if test -z "$GREP"; then ac_path_GREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in grep ggrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_GREP" || continue # Check for GNU ac_path_GREP and select it if it is found. # Check for GNU $ac_path_GREP case `"$ac_path_GREP" --version 2>&1` in *GNU*) ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'GREP' >> "conftest.nl" "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_GREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_GREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_GREP"; then as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_GREP=$GREP fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 $as_echo "$ac_cv_path_GREP" >&6; } GREP="$ac_cv_path_GREP" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 $as_echo_n "checking for egrep... " >&6; } if ${ac_cv_path_EGREP+:} false; then : $as_echo_n "(cached) " >&6 else if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 then ac_cv_path_EGREP="$GREP -E" else if test -z "$EGREP"; then ac_path_EGREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in egrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_EGREP" || continue # Check for GNU ac_path_EGREP and select it if it is found. # Check for GNU $ac_path_EGREP case `"$ac_path_EGREP" --version 2>&1` in *GNU*) ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'EGREP' >> "conftest.nl" "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_EGREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_EGREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_EGREP"; then as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_EGREP=$EGREP fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 $as_echo "$ac_cv_path_EGREP" >&6; } EGREP="$ac_cv_path_EGREP" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; } if ${ac_cv_header_stdc+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_stdc=yes else ac_cv_header_stdc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "memchr" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "free" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then : : else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ (('a' <= (c) && (c) <= 'i') \ || ('j' <= (c) && (c) <= 'r') \ || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) return 2; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : else ac_cv_header_stdc=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 $as_echo "$ac_cv_header_stdc" >&6; } if test $ac_cv_header_stdc = yes; then $as_echo "#define STDC_HEADERS 1" >>confdefs.h fi # On IRIX 5.3, sys/types and inttypes.h are conflicting. for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ inttypes.h stdint.h unistd.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default " if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done ac_fn_c_check_decl "$LINENO" "_WIN32" "ac_cv_have_decl__WIN32" "$ac_includes_default" if test "x$ac_cv_have_decl__WIN32" = xyes; then : poly_native_windows=yes else poly_native_windows=no fi # If we are building on cygwin or mingw we need to give the -no-defined flag to # build a DLL. We also have to use Windows calling conventions rather than # SysV on 64-bit. poly_use_windowscc=no poly_need_macosopt=no case "${host_os}" in darwin*) OSFLAG=-DMACOSX poly_need_macosopt=yes ;; sunos* | solaris*) OSFLAG=-DSOLARIS ;; *mingw* | *cygwin*) poly_no_undefined=yes poly_use_windowscc=yes ;; esac # libpolyml can be a DLL but libpolymain can't. # Enable shared libraries by default. It complicates installation a bit if the # the library is installed to a non-standard location but simplifies polyc. case `pwd` in *\ * | *\ *) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Libtool does not cope well with whitespace in \`pwd\`" >&5 $as_echo "$as_me: WARNING: Libtool does not cope well with whitespace in \`pwd\`" >&2;} ;; esac macro_version='2.4.6' macro_revision='2.4.6' ltmain=$ac_aux_dir/ltmain.sh # Backslashify metacharacters that are still active within # double-quoted strings. sed_quote_subst='s/\(["`$\\]\)/\\\1/g' # Same as above, but do not quote variable references. double_quote_subst='s/\(["`\\]\)/\\\1/g' # Sed substitution to delay expansion of an escaped shell variable in a # double_quote_subst'ed string. delay_variable_subst='s/\\\\\\\\\\\$/\\\\\\$/g' # Sed substitution to delay expansion of an escaped single quote. delay_single_quote_subst='s/'\''/'\'\\\\\\\'\''/g' # Sed substitution to avoid accidental globbing in evaled expressions no_glob_subst='s/\*/\\\*/g' ECHO='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO$ECHO { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to print strings" >&5 $as_echo_n "checking how to print strings... " >&6; } # Test print first, because it will be a builtin if present. if test "X`( print -r -- -n ) 2>/dev/null`" = X-n && \ test "X`print -r -- $ECHO 2>/dev/null`" = "X$ECHO"; then ECHO='print -r --' elif test "X`printf %s $ECHO 2>/dev/null`" = "X$ECHO"; then ECHO='printf %s\n' else # Use this function as a fallback that always works. func_fallback_echo () { eval 'cat <<_LTECHO_EOF $1 _LTECHO_EOF' } ECHO='func_fallback_echo' fi # func_echo_all arg... # Invoke $ECHO with all args, space-separated. func_echo_all () { $ECHO "" } case $ECHO in printf*) { $as_echo "$as_me:${as_lineno-$LINENO}: result: printf" >&5 $as_echo "printf" >&6; } ;; print*) { $as_echo "$as_me:${as_lineno-$LINENO}: result: print -r" >&5 $as_echo "print -r" >&6; } ;; *) { $as_echo "$as_me:${as_lineno-$LINENO}: result: cat" >&5 $as_echo "cat" >&6; } ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking for a sed that does not truncate output" >&5 $as_echo_n "checking for a sed that does not truncate output... " >&6; } if ${ac_cv_path_SED+:} false; then : $as_echo_n "(cached) " >&6 else ac_script=s/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb/ for ac_i in 1 2 3 4 5 6 7; do ac_script="$ac_script$as_nl$ac_script" done echo "$ac_script" 2>/dev/null | sed 99q >conftest.sed { ac_script=; unset ac_script;} if test -z "$SED"; then ac_path_SED_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in sed gsed; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_SED="$as_dir/$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_SED" || continue # Check for GNU ac_path_SED and select it if it is found. # Check for GNU $ac_path_SED case `"$ac_path_SED" --version 2>&1` in *GNU*) ac_cv_path_SED="$ac_path_SED" ac_path_SED_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo '' >> "conftest.nl" "$ac_path_SED" -f conftest.sed < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_SED_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_SED="$ac_path_SED" ac_path_SED_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_SED_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_SED"; then as_fn_error $? "no acceptable sed could be found in \$PATH" "$LINENO" 5 fi else ac_cv_path_SED=$SED fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_SED" >&5 $as_echo "$ac_cv_path_SED" >&6; } SED="$ac_cv_path_SED" rm -f conftest.sed test -z "$SED" && SED=sed Xsed="$SED -e 1s/^X//" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for fgrep" >&5 $as_echo_n "checking for fgrep... " >&6; } if ${ac_cv_path_FGREP+:} false; then : $as_echo_n "(cached) " >&6 else if echo 'ab*c' | $GREP -F 'ab*c' >/dev/null 2>&1 then ac_cv_path_FGREP="$GREP -F" else if test -z "$FGREP"; then ac_path_FGREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in fgrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_FGREP="$as_dir/$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_FGREP" || continue # Check for GNU ac_path_FGREP and select it if it is found. # Check for GNU $ac_path_FGREP case `"$ac_path_FGREP" --version 2>&1` in *GNU*) ac_cv_path_FGREP="$ac_path_FGREP" ac_path_FGREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'FGREP' >> "conftest.nl" "$ac_path_FGREP" FGREP < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_FGREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_FGREP="$ac_path_FGREP" ac_path_FGREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_FGREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_FGREP"; then as_fn_error $? "no acceptable fgrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_FGREP=$FGREP fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_FGREP" >&5 $as_echo "$ac_cv_path_FGREP" >&6; } FGREP="$ac_cv_path_FGREP" test -z "$GREP" && GREP=grep # Check whether --with-gnu-ld was given. if test "${with_gnu_ld+set}" = set; then : withval=$with_gnu_ld; test no = "$withval" || with_gnu_ld=yes else with_gnu_ld=no fi ac_prog=ld if test yes = "$GCC"; then # Check if gcc -print-prog-name=ld gives a path. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ld used by $CC" >&5 $as_echo_n "checking for ld used by $CC... " >&6; } case $host in *-*-mingw*) # gcc leaves a trailing carriage return, which upsets mingw ac_prog=`($CC -print-prog-name=ld) 2>&5 | tr -d '\015'` ;; *) ac_prog=`($CC -print-prog-name=ld) 2>&5` ;; esac case $ac_prog in # Accept absolute paths. [\\/]* | ?:[\\/]*) re_direlt='/[^/][^/]*/\.\./' # Canonicalize the pathname of ld ac_prog=`$ECHO "$ac_prog"| $SED 's%\\\\%/%g'` while $ECHO "$ac_prog" | $GREP "$re_direlt" > /dev/null 2>&1; do ac_prog=`$ECHO $ac_prog| $SED "s%$re_direlt%/%"` done test -z "$LD" && LD=$ac_prog ;; "") # If it fails, then pretend we aren't using GCC. ac_prog=ld ;; *) # If it is relative, then search for the first ld in PATH. with_gnu_ld=unknown ;; esac elif test yes = "$with_gnu_ld"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for GNU ld" >&5 $as_echo_n "checking for GNU ld... " >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for non-GNU ld" >&5 $as_echo_n "checking for non-GNU ld... " >&6; } fi if ${lt_cv_path_LD+:} false; then : $as_echo_n "(cached) " >&6 else if test -z "$LD"; then lt_save_ifs=$IFS; IFS=$PATH_SEPARATOR for ac_dir in $PATH; do IFS=$lt_save_ifs test -z "$ac_dir" && ac_dir=. if test -f "$ac_dir/$ac_prog" || test -f "$ac_dir/$ac_prog$ac_exeext"; then lt_cv_path_LD=$ac_dir/$ac_prog # Check to see if the program is GNU ld. I'd rather use --version, # but apparently some variants of GNU ld only accept -v. # Break only if it was the GNU/non-GNU ld that we prefer. case `"$lt_cv_path_LD" -v 2>&1 &5 $as_echo "$LD" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -z "$LD" && as_fn_error $? "no acceptable ld found in \$PATH" "$LINENO" 5 { $as_echo "$as_me:${as_lineno-$LINENO}: checking if the linker ($LD) is GNU ld" >&5 $as_echo_n "checking if the linker ($LD) is GNU ld... " >&6; } if ${lt_cv_prog_gnu_ld+:} false; then : $as_echo_n "(cached) " >&6 else # I'd rather use --version here, but apparently some GNU lds only accept -v. case `$LD -v 2>&1 &5 $as_echo "$lt_cv_prog_gnu_ld" >&6; } with_gnu_ld=$lt_cv_prog_gnu_ld { $as_echo "$as_me:${as_lineno-$LINENO}: checking for BSD- or MS-compatible name lister (nm)" >&5 $as_echo_n "checking for BSD- or MS-compatible name lister (nm)... " >&6; } if ${lt_cv_path_NM+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$NM"; then # Let the user override the test. lt_cv_path_NM=$NM else lt_nm_to_check=${ac_tool_prefix}nm if test -n "$ac_tool_prefix" && test "$build" = "$host"; then lt_nm_to_check="$lt_nm_to_check nm" fi for lt_tmp_nm in $lt_nm_to_check; do lt_save_ifs=$IFS; IFS=$PATH_SEPARATOR for ac_dir in $PATH /usr/ccs/bin/elf /usr/ccs/bin /usr/ucb /bin; do IFS=$lt_save_ifs test -z "$ac_dir" && ac_dir=. tmp_nm=$ac_dir/$lt_tmp_nm if test -f "$tmp_nm" || test -f "$tmp_nm$ac_exeext"; then # Check to see if the nm accepts a BSD-compat flag. # Adding the 'sed 1q' prevents false positives on HP-UX, which says: # nm: unknown option "B" ignored # Tru64's nm complains that /dev/null is an invalid object file # MSYS converts /dev/null to NUL, MinGW nm treats NUL as empty case $build_os in mingw*) lt_bad_file=conftest.nm/nofile ;; *) lt_bad_file=/dev/null ;; esac case `"$tmp_nm" -B $lt_bad_file 2>&1 | sed '1q'` in *$lt_bad_file* | *'Invalid file or object type'*) lt_cv_path_NM="$tmp_nm -B" break 2 ;; *) case `"$tmp_nm" -p /dev/null 2>&1 | sed '1q'` in */dev/null*) lt_cv_path_NM="$tmp_nm -p" break 2 ;; *) lt_cv_path_NM=${lt_cv_path_NM="$tmp_nm"} # keep the first match, but continue # so that we can try to find one that supports BSD flags ;; esac ;; esac fi done IFS=$lt_save_ifs done : ${lt_cv_path_NM=no} fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_path_NM" >&5 $as_echo "$lt_cv_path_NM" >&6; } if test no != "$lt_cv_path_NM"; then NM=$lt_cv_path_NM else # Didn't find any BSD compatible name lister, look for dumpbin. if test -n "$DUMPBIN"; then : # Let the user override the test. else if test -n "$ac_tool_prefix"; then for ac_prog in dumpbin "link -dump" do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_DUMPBIN+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$DUMPBIN"; then ac_cv_prog_DUMPBIN="$DUMPBIN" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_DUMPBIN="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi DUMPBIN=$ac_cv_prog_DUMPBIN if test -n "$DUMPBIN"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $DUMPBIN" >&5 $as_echo "$DUMPBIN" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$DUMPBIN" && break done fi if test -z "$DUMPBIN"; then ac_ct_DUMPBIN=$DUMPBIN for ac_prog in dumpbin "link -dump" do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_DUMPBIN+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_DUMPBIN"; then ac_cv_prog_ac_ct_DUMPBIN="$ac_ct_DUMPBIN" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_DUMPBIN="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_DUMPBIN=$ac_cv_prog_ac_ct_DUMPBIN if test -n "$ac_ct_DUMPBIN"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_DUMPBIN" >&5 $as_echo "$ac_ct_DUMPBIN" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$ac_ct_DUMPBIN" && break done if test "x$ac_ct_DUMPBIN" = x; then DUMPBIN=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac DUMPBIN=$ac_ct_DUMPBIN fi fi case `$DUMPBIN -symbols -headers /dev/null 2>&1 | sed '1q'` in *COFF*) DUMPBIN="$DUMPBIN -symbols -headers" ;; *) DUMPBIN=: ;; esac fi if test : != "$DUMPBIN"; then NM=$DUMPBIN fi fi test -z "$NM" && NM=nm { $as_echo "$as_me:${as_lineno-$LINENO}: checking the name lister ($NM) interface" >&5 $as_echo_n "checking the name lister ($NM) interface... " >&6; } if ${lt_cv_nm_interface+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_nm_interface="BSD nm" echo "int some_variable = 0;" > conftest.$ac_ext (eval echo "\"\$as_me:$LINENO: $ac_compile\"" >&5) (eval "$ac_compile" 2>conftest.err) cat conftest.err >&5 (eval echo "\"\$as_me:$LINENO: $NM \\\"conftest.$ac_objext\\\"\"" >&5) (eval "$NM \"conftest.$ac_objext\"" 2>conftest.err > conftest.out) cat conftest.err >&5 (eval echo "\"\$as_me:$LINENO: output\"" >&5) cat conftest.out >&5 if $GREP 'External.*some_variable' conftest.out > /dev/null; then lt_cv_nm_interface="MS dumpbin" fi rm -f conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_nm_interface" >&5 $as_echo "$lt_cv_nm_interface" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ln -s works" >&5 $as_echo_n "checking whether ln -s works... " >&6; } LN_S=$as_ln_s if test "$LN_S" = "ln -s"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no, using $LN_S" >&5 $as_echo "no, using $LN_S" >&6; } fi # find the maximum length of command line arguments { $as_echo "$as_me:${as_lineno-$LINENO}: checking the maximum length of command line arguments" >&5 $as_echo_n "checking the maximum length of command line arguments... " >&6; } if ${lt_cv_sys_max_cmd_len+:} false; then : $as_echo_n "(cached) " >&6 else i=0 teststring=ABCD case $build_os in msdosdjgpp*) # On DJGPP, this test can blow up pretty badly due to problems in libc # (any single argument exceeding 2000 bytes causes a buffer overrun # during glob expansion). Even if it were fixed, the result of this # check would be larger than it should be. lt_cv_sys_max_cmd_len=12288; # 12K is about right ;; gnu*) # Under GNU Hurd, this test is not required because there is # no limit to the length of command line arguments. # Libtool will interpret -1 as no limit whatsoever lt_cv_sys_max_cmd_len=-1; ;; cygwin* | mingw* | cegcc*) # On Win9x/ME, this test blows up -- it succeeds, but takes # about 5 minutes as the teststring grows exponentially. # Worse, since 9x/ME are not pre-emptively multitasking, # you end up with a "frozen" computer, even though with patience # the test eventually succeeds (with a max line length of 256k). # Instead, let's just punt: use the minimum linelength reported by # all of the supported platforms: 8192 (on NT/2K/XP). lt_cv_sys_max_cmd_len=8192; ;; mint*) # On MiNT this can take a long time and run out of memory. lt_cv_sys_max_cmd_len=8192; ;; amigaos*) # On AmigaOS with pdksh, this test takes hours, literally. # So we just punt and use a minimum line length of 8192. lt_cv_sys_max_cmd_len=8192; ;; bitrig* | darwin* | dragonfly* | freebsd* | netbsd* | openbsd*) # This has been around since 386BSD, at least. Likely further. if test -x /sbin/sysctl; then lt_cv_sys_max_cmd_len=`/sbin/sysctl -n kern.argmax` elif test -x /usr/sbin/sysctl; then lt_cv_sys_max_cmd_len=`/usr/sbin/sysctl -n kern.argmax` else lt_cv_sys_max_cmd_len=65536 # usable default for all BSDs fi # And add a safety zone lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 4` lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \* 3` ;; interix*) # We know the value 262144 and hardcode it with a safety zone (like BSD) lt_cv_sys_max_cmd_len=196608 ;; os2*) # The test takes a long time on OS/2. lt_cv_sys_max_cmd_len=8192 ;; osf*) # Dr. Hans Ekkehard Plesser reports seeing a kernel panic running configure # due to this test when exec_disable_arg_limit is 1 on Tru64. It is not # nice to cause kernel panics so lets avoid the loop below. # First set a reasonable default. lt_cv_sys_max_cmd_len=16384 # if test -x /sbin/sysconfig; then case `/sbin/sysconfig -q proc exec_disable_arg_limit` in *1*) lt_cv_sys_max_cmd_len=-1 ;; esac fi ;; sco3.2v5*) lt_cv_sys_max_cmd_len=102400 ;; sysv5* | sco5v6* | sysv4.2uw2*) kargmax=`grep ARG_MAX /etc/conf/cf.d/stune 2>/dev/null` if test -n "$kargmax"; then lt_cv_sys_max_cmd_len=`echo $kargmax | sed 's/.*[ ]//'` else lt_cv_sys_max_cmd_len=32768 fi ;; *) lt_cv_sys_max_cmd_len=`(getconf ARG_MAX) 2> /dev/null` if test -n "$lt_cv_sys_max_cmd_len" && \ test undefined != "$lt_cv_sys_max_cmd_len"; then lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 4` lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \* 3` else # Make teststring a little bigger before we do anything with it. # a 1K string should be a reasonable start. for i in 1 2 3 4 5 6 7 8; do teststring=$teststring$teststring done SHELL=${SHELL-${CONFIG_SHELL-/bin/sh}} # If test is not a shell built-in, we'll probably end up computing a # maximum length that is only half of the actual maximum length, but # we can't tell. while { test X`env echo "$teststring$teststring" 2>/dev/null` \ = "X$teststring$teststring"; } >/dev/null 2>&1 && test 17 != "$i" # 1/2 MB should be enough do i=`expr $i + 1` teststring=$teststring$teststring done # Only check the string length outside the loop. lt_cv_sys_max_cmd_len=`expr "X$teststring" : ".*" 2>&1` teststring= # Add a significant safety factor because C++ compilers can tack on # massive amounts of additional arguments before passing them to the # linker. It appears as though 1/2 is a usable value. lt_cv_sys_max_cmd_len=`expr $lt_cv_sys_max_cmd_len \/ 2` fi ;; esac fi if test -n "$lt_cv_sys_max_cmd_len"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_sys_max_cmd_len" >&5 $as_echo "$lt_cv_sys_max_cmd_len" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: none" >&5 $as_echo "none" >&6; } fi max_cmd_len=$lt_cv_sys_max_cmd_len : ${CP="cp -f"} : ${MV="mv -f"} : ${RM="rm -f"} if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then lt_unset=unset else lt_unset=false fi # test EBCDIC or ASCII case `echo X|tr X '\101'` in A) # ASCII based system # \n is not interpreted correctly by Solaris 8 /usr/ucb/tr lt_SP2NL='tr \040 \012' lt_NL2SP='tr \015\012 \040\040' ;; *) # EBCDIC based system lt_SP2NL='tr \100 \n' lt_NL2SP='tr \r\n \100\100' ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to convert $build file names to $host format" >&5 $as_echo_n "checking how to convert $build file names to $host format... " >&6; } if ${lt_cv_to_host_file_cmd+:} false; then : $as_echo_n "(cached) " >&6 else case $host in *-*-mingw* ) case $build in *-*-mingw* ) # actually msys lt_cv_to_host_file_cmd=func_convert_file_msys_to_w32 ;; *-*-cygwin* ) lt_cv_to_host_file_cmd=func_convert_file_cygwin_to_w32 ;; * ) # otherwise, assume *nix lt_cv_to_host_file_cmd=func_convert_file_nix_to_w32 ;; esac ;; *-*-cygwin* ) case $build in *-*-mingw* ) # actually msys lt_cv_to_host_file_cmd=func_convert_file_msys_to_cygwin ;; *-*-cygwin* ) lt_cv_to_host_file_cmd=func_convert_file_noop ;; * ) # otherwise, assume *nix lt_cv_to_host_file_cmd=func_convert_file_nix_to_cygwin ;; esac ;; * ) # unhandled hosts (and "normal" native builds) lt_cv_to_host_file_cmd=func_convert_file_noop ;; esac fi to_host_file_cmd=$lt_cv_to_host_file_cmd { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_to_host_file_cmd" >&5 $as_echo "$lt_cv_to_host_file_cmd" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to convert $build file names to toolchain format" >&5 $as_echo_n "checking how to convert $build file names to toolchain format... " >&6; } if ${lt_cv_to_tool_file_cmd+:} false; then : $as_echo_n "(cached) " >&6 else #assume ordinary cross tools, or native build. lt_cv_to_tool_file_cmd=func_convert_file_noop case $host in *-*-mingw* ) case $build in *-*-mingw* ) # actually msys lt_cv_to_tool_file_cmd=func_convert_file_msys_to_w32 ;; esac ;; esac fi to_tool_file_cmd=$lt_cv_to_tool_file_cmd { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_to_tool_file_cmd" >&5 $as_echo "$lt_cv_to_tool_file_cmd" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $LD option to reload object files" >&5 $as_echo_n "checking for $LD option to reload object files... " >&6; } if ${lt_cv_ld_reload_flag+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_ld_reload_flag='-r' fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ld_reload_flag" >&5 $as_echo "$lt_cv_ld_reload_flag" >&6; } reload_flag=$lt_cv_ld_reload_flag case $reload_flag in "" | " "*) ;; *) reload_flag=" $reload_flag" ;; esac reload_cmds='$LD$reload_flag -o $output$reload_objs' case $host_os in cygwin* | mingw* | pw32* | cegcc*) if test yes != "$GCC"; then reload_cmds=false fi ;; darwin*) if test yes = "$GCC"; then reload_cmds='$LTCC $LTCFLAGS -nostdlib $wl-r -o $output$reload_objs' else reload_cmds='$LD$reload_flag -o $output$reload_objs' fi ;; esac if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}objdump", so it can be a program name with args. set dummy ${ac_tool_prefix}objdump; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OBJDUMP+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OBJDUMP"; then ac_cv_prog_OBJDUMP="$OBJDUMP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OBJDUMP="${ac_tool_prefix}objdump" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi OBJDUMP=$ac_cv_prog_OBJDUMP if test -n "$OBJDUMP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OBJDUMP" >&5 $as_echo "$OBJDUMP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_OBJDUMP"; then ac_ct_OBJDUMP=$OBJDUMP # Extract the first word of "objdump", so it can be a program name with args. set dummy objdump; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_OBJDUMP+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_OBJDUMP"; then ac_cv_prog_ac_ct_OBJDUMP="$ac_ct_OBJDUMP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_OBJDUMP="objdump" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_OBJDUMP=$ac_cv_prog_ac_ct_OBJDUMP if test -n "$ac_ct_OBJDUMP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_OBJDUMP" >&5 $as_echo "$ac_ct_OBJDUMP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_OBJDUMP" = x; then OBJDUMP="false" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac OBJDUMP=$ac_ct_OBJDUMP fi else OBJDUMP="$ac_cv_prog_OBJDUMP" fi test -z "$OBJDUMP" && OBJDUMP=objdump { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to recognize dependent libraries" >&5 $as_echo_n "checking how to recognize dependent libraries... " >&6; } if ${lt_cv_deplibs_check_method+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_file_magic_cmd='$MAGIC_CMD' lt_cv_file_magic_test_file= lt_cv_deplibs_check_method='unknown' # Need to set the preceding variable on all platforms that support # interlibrary dependencies. # 'none' -- dependencies not supported. # 'unknown' -- same as none, but documents that we really don't know. # 'pass_all' -- all dependencies passed with no checks. # 'test_compile' -- check by making test program. # 'file_magic [[regex]]' -- check by looking for files in library path # that responds to the $file_magic_cmd with a given extended regex. # If you have 'file' or equivalent on your system and you're not sure # whether 'pass_all' will *always* work, you probably want this one. case $host_os in aix[4-9]*) lt_cv_deplibs_check_method=pass_all ;; beos*) lt_cv_deplibs_check_method=pass_all ;; bsdi[45]*) lt_cv_deplibs_check_method='file_magic ELF [0-9][0-9]*-bit [ML]SB (shared object|dynamic lib)' lt_cv_file_magic_cmd='/usr/bin/file -L' lt_cv_file_magic_test_file=/shlib/libc.so ;; cygwin*) # func_win32_libid is a shell function defined in ltmain.sh lt_cv_deplibs_check_method='file_magic ^x86 archive import|^x86 DLL' lt_cv_file_magic_cmd='func_win32_libid' ;; mingw* | pw32*) # Base MSYS/MinGW do not provide the 'file' command needed by # func_win32_libid shell function, so use a weaker test based on 'objdump', # unless we find 'file', for example because we are cross-compiling. if ( file / ) >/dev/null 2>&1; then lt_cv_deplibs_check_method='file_magic ^x86 archive import|^x86 DLL' lt_cv_file_magic_cmd='func_win32_libid' else # Keep this pattern in sync with the one in func_win32_libid. lt_cv_deplibs_check_method='file_magic file format (pei*-i386(.*architecture: i386)?|pe-arm-wince|pe-x86-64)' lt_cv_file_magic_cmd='$OBJDUMP -f' fi ;; cegcc*) # use the weaker test based on 'objdump'. See mingw*. lt_cv_deplibs_check_method='file_magic file format pe-arm-.*little(.*architecture: arm)?' lt_cv_file_magic_cmd='$OBJDUMP -f' ;; darwin* | rhapsody*) lt_cv_deplibs_check_method=pass_all ;; freebsd* | dragonfly*) if echo __ELF__ | $CC -E - | $GREP __ELF__ > /dev/null; then case $host_cpu in i*86 ) # Not sure whether the presence of OpenBSD here was a mistake. # Let's accept both of them until this is cleared up. lt_cv_deplibs_check_method='file_magic (FreeBSD|OpenBSD|DragonFly)/i[3-9]86 (compact )?demand paged shared library' lt_cv_file_magic_cmd=/usr/bin/file lt_cv_file_magic_test_file=`echo /usr/lib/libc.so.*` ;; esac else lt_cv_deplibs_check_method=pass_all fi ;; haiku*) lt_cv_deplibs_check_method=pass_all ;; hpux10.20* | hpux11*) lt_cv_file_magic_cmd=/usr/bin/file case $host_cpu in ia64*) lt_cv_deplibs_check_method='file_magic (s[0-9][0-9][0-9]|ELF-[0-9][0-9]) shared object file - IA64' lt_cv_file_magic_test_file=/usr/lib/hpux32/libc.so ;; hppa*64*) lt_cv_deplibs_check_method='file_magic (s[0-9][0-9][0-9]|ELF[ -][0-9][0-9])(-bit)?( [LM]SB)? shared object( file)?[, -]* PA-RISC [0-9]\.[0-9]' lt_cv_file_magic_test_file=/usr/lib/pa20_64/libc.sl ;; *) lt_cv_deplibs_check_method='file_magic (s[0-9][0-9][0-9]|PA-RISC[0-9]\.[0-9]) shared library' lt_cv_file_magic_test_file=/usr/lib/libc.sl ;; esac ;; interix[3-9]*) # PIC code is broken on Interix 3.x, that's why |\.a not |_pic\.a here lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so|\.a)$' ;; irix5* | irix6* | nonstopux*) case $LD in *-32|*"-32 ") libmagic=32-bit;; *-n32|*"-n32 ") libmagic=N32;; *-64|*"-64 ") libmagic=64-bit;; *) libmagic=never-match;; esac lt_cv_deplibs_check_method=pass_all ;; # This must be glibc/ELF. linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) lt_cv_deplibs_check_method=pass_all ;; netbsd* | netbsdelf*-gnu) if echo __ELF__ | $CC -E - | $GREP __ELF__ > /dev/null; then lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so\.[0-9]+\.[0-9]+|_pic\.a)$' else lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so|_pic\.a)$' fi ;; newos6*) lt_cv_deplibs_check_method='file_magic ELF [0-9][0-9]*-bit [ML]SB (executable|dynamic lib)' lt_cv_file_magic_cmd=/usr/bin/file lt_cv_file_magic_test_file=/usr/lib/libnls.so ;; *nto* | *qnx*) lt_cv_deplibs_check_method=pass_all ;; openbsd* | bitrig*) if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`"; then lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so\.[0-9]+\.[0-9]+|\.so|_pic\.a)$' else lt_cv_deplibs_check_method='match_pattern /lib[^/]+(\.so\.[0-9]+\.[0-9]+|_pic\.a)$' fi ;; osf3* | osf4* | osf5*) lt_cv_deplibs_check_method=pass_all ;; rdos*) lt_cv_deplibs_check_method=pass_all ;; solaris*) lt_cv_deplibs_check_method=pass_all ;; sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*) lt_cv_deplibs_check_method=pass_all ;; sysv4 | sysv4.3*) case $host_vendor in motorola) lt_cv_deplibs_check_method='file_magic ELF [0-9][0-9]*-bit [ML]SB (shared object|dynamic lib) M[0-9][0-9]* Version [0-9]' lt_cv_file_magic_test_file=`echo /usr/lib/libc.so*` ;; ncr) lt_cv_deplibs_check_method=pass_all ;; sequent) lt_cv_file_magic_cmd='/bin/file' lt_cv_deplibs_check_method='file_magic ELF [0-9][0-9]*-bit [LM]SB (shared object|dynamic lib )' ;; sni) lt_cv_file_magic_cmd='/bin/file' lt_cv_deplibs_check_method="file_magic ELF [0-9][0-9]*-bit [LM]SB dynamic lib" lt_cv_file_magic_test_file=/lib/libc.so ;; siemens) lt_cv_deplibs_check_method=pass_all ;; pc) lt_cv_deplibs_check_method=pass_all ;; esac ;; tpf*) lt_cv_deplibs_check_method=pass_all ;; os2*) lt_cv_deplibs_check_method=pass_all ;; esac fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_deplibs_check_method" >&5 $as_echo "$lt_cv_deplibs_check_method" >&6; } file_magic_glob= want_nocaseglob=no if test "$build" = "$host"; then case $host_os in mingw* | pw32*) if ( shopt | grep nocaseglob ) >/dev/null 2>&1; then want_nocaseglob=yes else file_magic_glob=`echo aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ | $SED -e "s/\(..\)/s\/[\1]\/[\1]\/g;/g"` fi ;; esac fi file_magic_cmd=$lt_cv_file_magic_cmd deplibs_check_method=$lt_cv_deplibs_check_method test -z "$deplibs_check_method" && deplibs_check_method=unknown if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}dlltool", so it can be a program name with args. set dummy ${ac_tool_prefix}dlltool; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_DLLTOOL+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$DLLTOOL"; then ac_cv_prog_DLLTOOL="$DLLTOOL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_DLLTOOL="${ac_tool_prefix}dlltool" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi DLLTOOL=$ac_cv_prog_DLLTOOL if test -n "$DLLTOOL"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $DLLTOOL" >&5 $as_echo "$DLLTOOL" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_DLLTOOL"; then ac_ct_DLLTOOL=$DLLTOOL # Extract the first word of "dlltool", so it can be a program name with args. set dummy dlltool; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_DLLTOOL+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_DLLTOOL"; then ac_cv_prog_ac_ct_DLLTOOL="$ac_ct_DLLTOOL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_DLLTOOL="dlltool" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_DLLTOOL=$ac_cv_prog_ac_ct_DLLTOOL if test -n "$ac_ct_DLLTOOL"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_DLLTOOL" >&5 $as_echo "$ac_ct_DLLTOOL" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_DLLTOOL" = x; then DLLTOOL="false" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac DLLTOOL=$ac_ct_DLLTOOL fi else DLLTOOL="$ac_cv_prog_DLLTOOL" fi test -z "$DLLTOOL" && DLLTOOL=dlltool { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to associate runtime and link libraries" >&5 $as_echo_n "checking how to associate runtime and link libraries... " >&6; } if ${lt_cv_sharedlib_from_linklib_cmd+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_sharedlib_from_linklib_cmd='unknown' case $host_os in cygwin* | mingw* | pw32* | cegcc*) # two different shell functions defined in ltmain.sh; # decide which one to use based on capabilities of $DLLTOOL case `$DLLTOOL --help 2>&1` in *--identify-strict*) lt_cv_sharedlib_from_linklib_cmd=func_cygming_dll_for_implib ;; *) lt_cv_sharedlib_from_linklib_cmd=func_cygming_dll_for_implib_fallback ;; esac ;; *) # fallback: assume linklib IS sharedlib lt_cv_sharedlib_from_linklib_cmd=$ECHO ;; esac fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_sharedlib_from_linklib_cmd" >&5 $as_echo "$lt_cv_sharedlib_from_linklib_cmd" >&6; } sharedlib_from_linklib_cmd=$lt_cv_sharedlib_from_linklib_cmd test -z "$sharedlib_from_linklib_cmd" && sharedlib_from_linklib_cmd=$ECHO if test -n "$ac_tool_prefix"; then for ac_prog in ar do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_AR+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$AR"; then ac_cv_prog_AR="$AR" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_AR="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi AR=$ac_cv_prog_AR if test -n "$AR"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AR" >&5 $as_echo "$AR" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$AR" && break done fi if test -z "$AR"; then ac_ct_AR=$AR for ac_prog in ar do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_AR+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_AR"; then ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_AR="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_AR=$ac_cv_prog_ac_ct_AR if test -n "$ac_ct_AR"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_AR" >&5 $as_echo "$ac_ct_AR" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$ac_ct_AR" && break done if test "x$ac_ct_AR" = x; then AR="false" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac AR=$ac_ct_AR fi fi : ${AR=ar} : ${AR_FLAGS=cru} { $as_echo "$as_me:${as_lineno-$LINENO}: checking for archiver @FILE support" >&5 $as_echo_n "checking for archiver @FILE support... " >&6; } if ${lt_cv_ar_at_file+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_ar_at_file=no cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : echo conftest.$ac_objext > conftest.lst lt_ar_try='$AR $AR_FLAGS libconftest.a @conftest.lst >&5' { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$lt_ar_try\""; } >&5 (eval $lt_ar_try) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } if test 0 -eq "$ac_status"; then # Ensure the archiver fails upon bogus file names. rm -f conftest.$ac_objext libconftest.a { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$lt_ar_try\""; } >&5 (eval $lt_ar_try) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } if test 0 -ne "$ac_status"; then lt_cv_ar_at_file=@ fi fi rm -f conftest.* libconftest.a fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ar_at_file" >&5 $as_echo "$lt_cv_ar_at_file" >&6; } if test no = "$lt_cv_ar_at_file"; then archiver_list_spec= else archiver_list_spec=$lt_cv_ar_at_file fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}strip", so it can be a program name with args. set dummy ${ac_tool_prefix}strip; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_STRIP+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$STRIP"; then ac_cv_prog_STRIP="$STRIP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_STRIP="${ac_tool_prefix}strip" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi STRIP=$ac_cv_prog_STRIP if test -n "$STRIP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $STRIP" >&5 $as_echo "$STRIP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_STRIP"; then ac_ct_STRIP=$STRIP # Extract the first word of "strip", so it can be a program name with args. set dummy strip; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_STRIP+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_STRIP"; then ac_cv_prog_ac_ct_STRIP="$ac_ct_STRIP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_STRIP="strip" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_STRIP=$ac_cv_prog_ac_ct_STRIP if test -n "$ac_ct_STRIP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_STRIP" >&5 $as_echo "$ac_ct_STRIP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_STRIP" = x; then STRIP=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac STRIP=$ac_ct_STRIP fi else STRIP="$ac_cv_prog_STRIP" fi test -z "$STRIP" && STRIP=: if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args. set dummy ${ac_tool_prefix}ranlib; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_RANLIB+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi RANLIB=$ac_cv_prog_RANLIB if test -n "$RANLIB"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5 $as_echo "$RANLIB" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_RANLIB"; then ac_ct_RANLIB=$RANLIB # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_RANLIB+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_RANLIB"; then ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_RANLIB="ranlib" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB if test -n "$ac_ct_RANLIB"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5 $as_echo "$ac_ct_RANLIB" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_RANLIB" = x; then RANLIB=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac RANLIB=$ac_ct_RANLIB fi else RANLIB="$ac_cv_prog_RANLIB" fi test -z "$RANLIB" && RANLIB=: # Determine commands to create old-style static archives. old_archive_cmds='$AR $AR_FLAGS $oldlib$oldobjs' old_postinstall_cmds='chmod 644 $oldlib' old_postuninstall_cmds= if test -n "$RANLIB"; then case $host_os in bitrig* | openbsd*) old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB -t \$tool_oldlib" ;; *) old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB \$tool_oldlib" ;; esac old_archive_cmds="$old_archive_cmds~\$RANLIB \$tool_oldlib" fi case $host_os in darwin*) lock_old_archive_extraction=yes ;; *) lock_old_archive_extraction=no ;; esac # If no C compiler was specified, use CC. LTCC=${LTCC-"$CC"} # If no C compiler flags were specified, use CFLAGS. LTCFLAGS=${LTCFLAGS-"$CFLAGS"} # Allow CC to be a program name with arguments. compiler=$CC # Check for command to grab the raw symbol name followed by C symbol from nm. { $as_echo "$as_me:${as_lineno-$LINENO}: checking command to parse $NM output from $compiler object" >&5 $as_echo_n "checking command to parse $NM output from $compiler object... " >&6; } if ${lt_cv_sys_global_symbol_pipe+:} false; then : $as_echo_n "(cached) " >&6 else # These are sane defaults that work on at least a few old systems. # [They come from Ultrix. What could be older than Ultrix?!! ;)] # Character class describing NM global symbol codes. symcode='[BCDEGRST]' # Regexp to match symbols that can be accessed directly from C. sympat='\([_A-Za-z][_A-Za-z0-9]*\)' # Define system-specific variables. case $host_os in aix*) symcode='[BCDT]' ;; cygwin* | mingw* | pw32* | cegcc*) symcode='[ABCDGISTW]' ;; hpux*) if test ia64 = "$host_cpu"; then symcode='[ABCDEGRST]' fi ;; irix* | nonstopux*) symcode='[BCDEGRST]' ;; osf*) symcode='[BCDEGQRST]' ;; solaris*) symcode='[BDRT]' ;; sco3.2v5*) symcode='[DT]' ;; sysv4.2uw2*) symcode='[DT]' ;; sysv5* | sco5v6* | unixware* | OpenUNIX*) symcode='[ABDT]' ;; sysv4) symcode='[DFNSTU]' ;; esac # If we're using GNU nm, then use its standard symbol codes. case `$NM -V 2>&1` in *GNU* | *'with BFD'*) symcode='[ABCDGIRSTW]' ;; esac if test "$lt_cv_nm_interface" = "MS dumpbin"; then # Gets list of data symbols to import. lt_cv_sys_global_symbol_to_import="sed -n -e 's/^I .* \(.*\)$/\1/p'" # Adjust the below global symbol transforms to fixup imported variables. lt_cdecl_hook=" -e 's/^I .* \(.*\)$/extern __declspec(dllimport) char \1;/p'" lt_c_name_hook=" -e 's/^I .* \(.*\)$/ {\"\1\", (void *) 0},/p'" lt_c_name_lib_hook="\ -e 's/^I .* \(lib.*\)$/ {\"\1\", (void *) 0},/p'\ -e 's/^I .* \(.*\)$/ {\"lib\1\", (void *) 0},/p'" else # Disable hooks by default. lt_cv_sys_global_symbol_to_import= lt_cdecl_hook= lt_c_name_hook= lt_c_name_lib_hook= fi # Transform an extracted symbol line into a proper C declaration. # Some systems (esp. on ia64) link data and code symbols differently, # so use this general approach. lt_cv_sys_global_symbol_to_cdecl="sed -n"\ $lt_cdecl_hook\ " -e 's/^T .* \(.*\)$/extern int \1();/p'"\ " -e 's/^$symcode$symcode* .* \(.*\)$/extern char \1;/p'" # Transform an extracted symbol line into symbol name and symbol address lt_cv_sys_global_symbol_to_c_name_address="sed -n"\ $lt_c_name_hook\ " -e 's/^: \(.*\) .*$/ {\"\1\", (void *) 0},/p'"\ " -e 's/^$symcode$symcode* .* \(.*\)$/ {\"\1\", (void *) \&\1},/p'" # Transform an extracted symbol line into symbol name with lib prefix and # symbol address. lt_cv_sys_global_symbol_to_c_name_address_lib_prefix="sed -n"\ $lt_c_name_lib_hook\ " -e 's/^: \(.*\) .*$/ {\"\1\", (void *) 0},/p'"\ " -e 's/^$symcode$symcode* .* \(lib.*\)$/ {\"\1\", (void *) \&\1},/p'"\ " -e 's/^$symcode$symcode* .* \(.*\)$/ {\"lib\1\", (void *) \&\1},/p'" # Handle CRLF in mingw tool chain opt_cr= case $build_os in mingw*) opt_cr=`$ECHO 'x\{0,1\}' | tr x '\015'` # option cr in regexp ;; esac # Try without a prefix underscore, then with it. for ac_symprfx in "" "_"; do # Transform symcode, sympat, and symprfx into a raw symbol and a C symbol. symxfrm="\\1 $ac_symprfx\\2 \\2" # Write the raw and C identifiers. if test "$lt_cv_nm_interface" = "MS dumpbin"; then # Fake it for dumpbin and say T for any non-static function, # D for any global variable and I for any imported variable. # Also find C++ and __fastcall symbols from MSVC++, # which start with @ or ?. lt_cv_sys_global_symbol_pipe="$AWK '"\ " {last_section=section; section=\$ 3};"\ " /^COFF SYMBOL TABLE/{for(i in hide) delete hide[i]};"\ " /Section length .*#relocs.*(pick any)/{hide[last_section]=1};"\ " /^ *Symbol name *: /{split(\$ 0,sn,\":\"); si=substr(sn[2],2)};"\ " /^ *Type *: code/{print \"T\",si,substr(si,length(prfx))};"\ " /^ *Type *: data/{print \"I\",si,substr(si,length(prfx))};"\ " \$ 0!~/External *\|/{next};"\ " / 0+ UNDEF /{next}; / UNDEF \([^|]\)*()/{next};"\ " {if(hide[section]) next};"\ " {f=\"D\"}; \$ 0~/\(\).*\|/{f=\"T\"};"\ " {split(\$ 0,a,/\||\r/); split(a[2],s)};"\ " s[1]~/^[@?]/{print f,s[1],s[1]; next};"\ " s[1]~prfx {split(s[1],t,\"@\"); print f,t[1],substr(t[1],length(prfx))}"\ " ' prfx=^$ac_symprfx" else lt_cv_sys_global_symbol_pipe="sed -n -e 's/^.*[ ]\($symcode$symcode*\)[ ][ ]*$ac_symprfx$sympat$opt_cr$/$symxfrm/p'" fi lt_cv_sys_global_symbol_pipe="$lt_cv_sys_global_symbol_pipe | sed '/ __gnu_lto/d'" # Check to see that the pipe works correctly. pipe_works=no rm -f conftest* cat > conftest.$ac_ext <<_LT_EOF #ifdef __cplusplus extern "C" { #endif char nm_test_var; void nm_test_func(void); void nm_test_func(void){} #ifdef __cplusplus } #endif int main(){nm_test_var='a';nm_test_func();return(0);} _LT_EOF if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 (eval $ac_compile) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then # Now try to grab the symbols. nlist=conftest.nm if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$NM conftest.$ac_objext \| "$lt_cv_sys_global_symbol_pipe" \> $nlist\""; } >&5 (eval $NM conftest.$ac_objext \| "$lt_cv_sys_global_symbol_pipe" \> $nlist) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && test -s "$nlist"; then # Try sorting and uniquifying the output. if sort "$nlist" | uniq > "$nlist"T; then mv -f "$nlist"T "$nlist" else rm -f "$nlist"T fi # Make sure that we snagged all the symbols we need. if $GREP ' nm_test_var$' "$nlist" >/dev/null; then if $GREP ' nm_test_func$' "$nlist" >/dev/null; then cat <<_LT_EOF > conftest.$ac_ext /* Keep this code in sync between libtool.m4, ltmain, lt_system.h, and tests. */ #if defined _WIN32 || defined __CYGWIN__ || defined _WIN32_WCE /* DATA imports from DLLs on WIN32 can't be const, because runtime relocations are performed -- see ld's documentation on pseudo-relocs. */ # define LT_DLSYM_CONST #elif defined __osf__ /* This system does not cope well with relocations in const data. */ # define LT_DLSYM_CONST #else # define LT_DLSYM_CONST const #endif #ifdef __cplusplus extern "C" { #endif _LT_EOF # Now generate the symbol file. eval "$lt_cv_sys_global_symbol_to_cdecl"' < "$nlist" | $GREP -v main >> conftest.$ac_ext' cat <<_LT_EOF >> conftest.$ac_ext /* The mapping between symbol names and symbols. */ LT_DLSYM_CONST struct { const char *name; void *address; } lt__PROGRAM__LTX_preloaded_symbols[] = { { "@PROGRAM@", (void *) 0 }, _LT_EOF $SED "s/^$symcode$symcode* .* \(.*\)$/ {\"\1\", (void *) \&\1},/" < "$nlist" | $GREP -v main >> conftest.$ac_ext cat <<\_LT_EOF >> conftest.$ac_ext {0, (void *) 0} }; /* This works around a problem in FreeBSD linker */ #ifdef FREEBSD_WORKAROUND static const void *lt_preloaded_setup() { return lt__PROGRAM__LTX_preloaded_symbols; } #endif #ifdef __cplusplus } #endif _LT_EOF # Now try linking the two files. mv conftest.$ac_objext conftstm.$ac_objext lt_globsym_save_LIBS=$LIBS lt_globsym_save_CFLAGS=$CFLAGS LIBS=conftstm.$ac_objext CFLAGS="$CFLAGS$lt_prog_compiler_no_builtin_flag" if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_link\""; } >&5 (eval $ac_link) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && test -s conftest$ac_exeext; then pipe_works=yes fi LIBS=$lt_globsym_save_LIBS CFLAGS=$lt_globsym_save_CFLAGS else echo "cannot find nm_test_func in $nlist" >&5 fi else echo "cannot find nm_test_var in $nlist" >&5 fi else echo "cannot run $lt_cv_sys_global_symbol_pipe" >&5 fi else echo "$progname: failed program was:" >&5 cat conftest.$ac_ext >&5 fi rm -rf conftest* conftst* # Do not use the global_symbol_pipe unless it works. if test yes = "$pipe_works"; then break else lt_cv_sys_global_symbol_pipe= fi done fi if test -z "$lt_cv_sys_global_symbol_pipe"; then lt_cv_sys_global_symbol_to_cdecl= fi if test -z "$lt_cv_sys_global_symbol_pipe$lt_cv_sys_global_symbol_to_cdecl"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: failed" >&5 $as_echo "failed" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } fi # Response file support. if test "$lt_cv_nm_interface" = "MS dumpbin"; then nm_file_list_spec='@' elif $NM --help 2>/dev/null | grep '[@]FILE' >/dev/null; then nm_file_list_spec='@' fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sysroot" >&5 $as_echo_n "checking for sysroot... " >&6; } # Check whether --with-sysroot was given. if test "${with_sysroot+set}" = set; then : withval=$with_sysroot; else with_sysroot=no fi lt_sysroot= case $with_sysroot in #( yes) if test yes = "$GCC"; then lt_sysroot=`$CC --print-sysroot 2>/dev/null` fi ;; #( /*) lt_sysroot=`echo "$with_sysroot" | sed -e "$sed_quote_subst"` ;; #( no|'') ;; #( *) { $as_echo "$as_me:${as_lineno-$LINENO}: result: $with_sysroot" >&5 $as_echo "$with_sysroot" >&6; } as_fn_error $? "The sysroot must be an absolute path." "$LINENO" 5 ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${lt_sysroot:-no}" >&5 $as_echo "${lt_sysroot:-no}" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking for a working dd" >&5 $as_echo_n "checking for a working dd... " >&6; } if ${ac_cv_path_lt_DD+:} false; then : $as_echo_n "(cached) " >&6 else printf 0123456789abcdef0123456789abcdef >conftest.i cat conftest.i conftest.i >conftest2.i : ${lt_DD:=$DD} if test -z "$lt_DD"; then ac_path_lt_DD_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in dd; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_lt_DD="$as_dir/$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_lt_DD" || continue if "$ac_path_lt_DD" bs=32 count=1 conftest.out 2>/dev/null; then cmp -s conftest.i conftest.out \ && ac_cv_path_lt_DD="$ac_path_lt_DD" ac_path_lt_DD_found=: fi $ac_path_lt_DD_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_lt_DD"; then : fi else ac_cv_path_lt_DD=$lt_DD fi rm -f conftest.i conftest2.i conftest.out fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_lt_DD" >&5 $as_echo "$ac_cv_path_lt_DD" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to truncate binary pipes" >&5 $as_echo_n "checking how to truncate binary pipes... " >&6; } if ${lt_cv_truncate_bin+:} false; then : $as_echo_n "(cached) " >&6 else printf 0123456789abcdef0123456789abcdef >conftest.i cat conftest.i conftest.i >conftest2.i lt_cv_truncate_bin= if "$ac_cv_path_lt_DD" bs=32 count=1 conftest.out 2>/dev/null; then cmp -s conftest.i conftest.out \ && lt_cv_truncate_bin="$ac_cv_path_lt_DD bs=4096 count=1" fi rm -f conftest.i conftest2.i conftest.out test -z "$lt_cv_truncate_bin" && lt_cv_truncate_bin="$SED -e 4q" fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_truncate_bin" >&5 $as_echo "$lt_cv_truncate_bin" >&6; } # Calculate cc_basename. Skip known compiler wrappers and cross-prefix. func_cc_basename () { for cc_temp in $*""; do case $cc_temp in compile | *[\\/]compile | ccache | *[\\/]ccache ) ;; distcc | *[\\/]distcc | purify | *[\\/]purify ) ;; \-*) ;; *) break;; esac done func_cc_basename_result=`$ECHO "$cc_temp" | $SED "s%.*/%%; s%^$host_alias-%%"` } # Check whether --enable-libtool-lock was given. if test "${enable_libtool_lock+set}" = set; then : enableval=$enable_libtool_lock; fi test no = "$enable_libtool_lock" || enable_libtool_lock=yes # Some flags need to be propagated to the compiler or linker for good # libtool support. case $host in ia64-*-hpux*) # Find out what ABI is being produced by ac_compile, and set mode # options accordingly. echo 'int i;' > conftest.$ac_ext if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 (eval $ac_compile) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then case `/usr/bin/file conftest.$ac_objext` in *ELF-32*) HPUX_IA64_MODE=32 ;; *ELF-64*) HPUX_IA64_MODE=64 ;; esac fi rm -rf conftest* ;; *-*-irix6*) # Find out what ABI is being produced by ac_compile, and set linker # options accordingly. echo '#line '$LINENO' "configure"' > conftest.$ac_ext if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 (eval $ac_compile) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then if test yes = "$lt_cv_prog_gnu_ld"; then case `/usr/bin/file conftest.$ac_objext` in *32-bit*) LD="${LD-ld} -melf32bsmip" ;; *N32*) LD="${LD-ld} -melf32bmipn32" ;; *64-bit*) LD="${LD-ld} -melf64bmip" ;; esac else case `/usr/bin/file conftest.$ac_objext` in *32-bit*) LD="${LD-ld} -32" ;; *N32*) LD="${LD-ld} -n32" ;; *64-bit*) LD="${LD-ld} -64" ;; esac fi fi rm -rf conftest* ;; mips64*-*linux*) # Find out what ABI is being produced by ac_compile, and set linker # options accordingly. echo '#line '$LINENO' "configure"' > conftest.$ac_ext if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 (eval $ac_compile) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then emul=elf case `/usr/bin/file conftest.$ac_objext` in *32-bit*) emul="${emul}32" ;; *64-bit*) emul="${emul}64" ;; esac case `/usr/bin/file conftest.$ac_objext` in *MSB*) emul="${emul}btsmip" ;; *LSB*) emul="${emul}ltsmip" ;; esac case `/usr/bin/file conftest.$ac_objext` in *N32*) emul="${emul}n32" ;; esac LD="${LD-ld} -m $emul" fi rm -rf conftest* ;; x86_64-*kfreebsd*-gnu|x86_64-*linux*|powerpc*-*linux*| \ s390*-*linux*|s390*-*tpf*|sparc*-*linux*) # Find out what ABI is being produced by ac_compile, and set linker # options accordingly. Note that the listed cases only cover the # situations where additional linker options are needed (such as when # doing 32-bit compilation for a host where ld defaults to 64-bit, or # vice versa); the common cases where no linker options are needed do # not appear in the list. echo 'int i;' > conftest.$ac_ext if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 (eval $ac_compile) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then case `/usr/bin/file conftest.o` in *32-bit*) case $host in x86_64-*kfreebsd*-gnu) LD="${LD-ld} -m elf_i386_fbsd" ;; x86_64-*linux*) case `/usr/bin/file conftest.o` in *x86-64*) LD="${LD-ld} -m elf32_x86_64" ;; *) LD="${LD-ld} -m elf_i386" ;; esac ;; powerpc64le-*linux*) LD="${LD-ld} -m elf32lppclinux" ;; powerpc64-*linux*) LD="${LD-ld} -m elf32ppclinux" ;; s390x-*linux*) LD="${LD-ld} -m elf_s390" ;; sparc64-*linux*) LD="${LD-ld} -m elf32_sparc" ;; esac ;; *64-bit*) case $host in x86_64-*kfreebsd*-gnu) LD="${LD-ld} -m elf_x86_64_fbsd" ;; x86_64-*linux*) LD="${LD-ld} -m elf_x86_64" ;; powerpcle-*linux*) LD="${LD-ld} -m elf64lppc" ;; powerpc-*linux*) LD="${LD-ld} -m elf64ppc" ;; s390*-*linux*|s390*-*tpf*) LD="${LD-ld} -m elf64_s390" ;; sparc*-*linux*) LD="${LD-ld} -m elf64_sparc" ;; esac ;; esac fi rm -rf conftest* ;; *-*-sco3.2v5*) # On SCO OpenServer 5, we need -belf to get full-featured binaries. SAVE_CFLAGS=$CFLAGS CFLAGS="$CFLAGS -belf" { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler needs -belf" >&5 $as_echo_n "checking whether the C compiler needs -belf... " >&6; } if ${lt_cv_cc_needs_belf+:} false; then : $as_echo_n "(cached) " >&6 else ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : lt_cv_cc_needs_belf=yes else lt_cv_cc_needs_belf=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_cc_needs_belf" >&5 $as_echo "$lt_cv_cc_needs_belf" >&6; } if test yes != "$lt_cv_cc_needs_belf"; then # this is probably gcc 2.8.0, egcs 1.0 or newer; no need for -belf CFLAGS=$SAVE_CFLAGS fi ;; *-*solaris*) # Find out what ABI is being produced by ac_compile, and set linker # options accordingly. echo 'int i;' > conftest.$ac_ext if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 (eval $ac_compile) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then case `/usr/bin/file conftest.o` in *64-bit*) case $lt_cv_prog_gnu_ld in yes*) case $host in i?86-*-solaris*|x86_64-*-solaris*) LD="${LD-ld} -m elf_x86_64" ;; sparc*-*-solaris*) LD="${LD-ld} -m elf64_sparc" ;; esac # GNU ld 2.21 introduced _sol2 emulations. Use them if available. if ${LD-ld} -V | grep _sol2 >/dev/null 2>&1; then LD=${LD-ld}_sol2 fi ;; *) if ${LD-ld} -64 -r -o conftest2.o conftest.o >/dev/null 2>&1; then LD="${LD-ld} -64" fi ;; esac ;; esac fi rm -rf conftest* ;; esac need_locks=$enable_libtool_lock if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}mt", so it can be a program name with args. set dummy ${ac_tool_prefix}mt; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_MANIFEST_TOOL+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$MANIFEST_TOOL"; then ac_cv_prog_MANIFEST_TOOL="$MANIFEST_TOOL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_MANIFEST_TOOL="${ac_tool_prefix}mt" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi MANIFEST_TOOL=$ac_cv_prog_MANIFEST_TOOL if test -n "$MANIFEST_TOOL"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MANIFEST_TOOL" >&5 $as_echo "$MANIFEST_TOOL" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_MANIFEST_TOOL"; then ac_ct_MANIFEST_TOOL=$MANIFEST_TOOL # Extract the first word of "mt", so it can be a program name with args. set dummy mt; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_MANIFEST_TOOL+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_MANIFEST_TOOL"; then ac_cv_prog_ac_ct_MANIFEST_TOOL="$ac_ct_MANIFEST_TOOL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_MANIFEST_TOOL="mt" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_MANIFEST_TOOL=$ac_cv_prog_ac_ct_MANIFEST_TOOL if test -n "$ac_ct_MANIFEST_TOOL"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_MANIFEST_TOOL" >&5 $as_echo "$ac_ct_MANIFEST_TOOL" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_MANIFEST_TOOL" = x; then MANIFEST_TOOL=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac MANIFEST_TOOL=$ac_ct_MANIFEST_TOOL fi else MANIFEST_TOOL="$ac_cv_prog_MANIFEST_TOOL" fi test -z "$MANIFEST_TOOL" && MANIFEST_TOOL=mt { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $MANIFEST_TOOL is a manifest tool" >&5 $as_echo_n "checking if $MANIFEST_TOOL is a manifest tool... " >&6; } if ${lt_cv_path_mainfest_tool+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_path_mainfest_tool=no echo "$as_me:$LINENO: $MANIFEST_TOOL '-?'" >&5 $MANIFEST_TOOL '-?' 2>conftest.err > conftest.out cat conftest.err >&5 if $GREP 'Manifest Tool' conftest.out > /dev/null; then lt_cv_path_mainfest_tool=yes fi rm -f conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_path_mainfest_tool" >&5 $as_echo "$lt_cv_path_mainfest_tool" >&6; } if test yes != "$lt_cv_path_mainfest_tool"; then MANIFEST_TOOL=: fi case $host_os in rhapsody* | darwin*) if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}dsymutil", so it can be a program name with args. set dummy ${ac_tool_prefix}dsymutil; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_DSYMUTIL+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$DSYMUTIL"; then ac_cv_prog_DSYMUTIL="$DSYMUTIL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_DSYMUTIL="${ac_tool_prefix}dsymutil" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi DSYMUTIL=$ac_cv_prog_DSYMUTIL if test -n "$DSYMUTIL"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $DSYMUTIL" >&5 $as_echo "$DSYMUTIL" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_DSYMUTIL"; then ac_ct_DSYMUTIL=$DSYMUTIL # Extract the first word of "dsymutil", so it can be a program name with args. set dummy dsymutil; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_DSYMUTIL+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_DSYMUTIL"; then ac_cv_prog_ac_ct_DSYMUTIL="$ac_ct_DSYMUTIL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_DSYMUTIL="dsymutil" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_DSYMUTIL=$ac_cv_prog_ac_ct_DSYMUTIL if test -n "$ac_ct_DSYMUTIL"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_DSYMUTIL" >&5 $as_echo "$ac_ct_DSYMUTIL" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_DSYMUTIL" = x; then DSYMUTIL=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac DSYMUTIL=$ac_ct_DSYMUTIL fi else DSYMUTIL="$ac_cv_prog_DSYMUTIL" fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}nmedit", so it can be a program name with args. set dummy ${ac_tool_prefix}nmedit; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_NMEDIT+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$NMEDIT"; then ac_cv_prog_NMEDIT="$NMEDIT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_NMEDIT="${ac_tool_prefix}nmedit" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi NMEDIT=$ac_cv_prog_NMEDIT if test -n "$NMEDIT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $NMEDIT" >&5 $as_echo "$NMEDIT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_NMEDIT"; then ac_ct_NMEDIT=$NMEDIT # Extract the first word of "nmedit", so it can be a program name with args. set dummy nmedit; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_NMEDIT+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_NMEDIT"; then ac_cv_prog_ac_ct_NMEDIT="$ac_ct_NMEDIT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_NMEDIT="nmedit" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_NMEDIT=$ac_cv_prog_ac_ct_NMEDIT if test -n "$ac_ct_NMEDIT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_NMEDIT" >&5 $as_echo "$ac_ct_NMEDIT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_NMEDIT" = x; then NMEDIT=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac NMEDIT=$ac_ct_NMEDIT fi else NMEDIT="$ac_cv_prog_NMEDIT" fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}lipo", so it can be a program name with args. set dummy ${ac_tool_prefix}lipo; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_LIPO+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$LIPO"; then ac_cv_prog_LIPO="$LIPO" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_LIPO="${ac_tool_prefix}lipo" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi LIPO=$ac_cv_prog_LIPO if test -n "$LIPO"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $LIPO" >&5 $as_echo "$LIPO" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_LIPO"; then ac_ct_LIPO=$LIPO # Extract the first word of "lipo", so it can be a program name with args. set dummy lipo; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_LIPO+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_LIPO"; then ac_cv_prog_ac_ct_LIPO="$ac_ct_LIPO" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_LIPO="lipo" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_LIPO=$ac_cv_prog_ac_ct_LIPO if test -n "$ac_ct_LIPO"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_LIPO" >&5 $as_echo "$ac_ct_LIPO" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_LIPO" = x; then LIPO=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac LIPO=$ac_ct_LIPO fi else LIPO="$ac_cv_prog_LIPO" fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}otool", so it can be a program name with args. set dummy ${ac_tool_prefix}otool; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OTOOL+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OTOOL"; then ac_cv_prog_OTOOL="$OTOOL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OTOOL="${ac_tool_prefix}otool" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi OTOOL=$ac_cv_prog_OTOOL if test -n "$OTOOL"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OTOOL" >&5 $as_echo "$OTOOL" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_OTOOL"; then ac_ct_OTOOL=$OTOOL # Extract the first word of "otool", so it can be a program name with args. set dummy otool; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_OTOOL+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_OTOOL"; then ac_cv_prog_ac_ct_OTOOL="$ac_ct_OTOOL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_OTOOL="otool" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_OTOOL=$ac_cv_prog_ac_ct_OTOOL if test -n "$ac_ct_OTOOL"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_OTOOL" >&5 $as_echo "$ac_ct_OTOOL" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_OTOOL" = x; then OTOOL=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac OTOOL=$ac_ct_OTOOL fi else OTOOL="$ac_cv_prog_OTOOL" fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}otool64", so it can be a program name with args. set dummy ${ac_tool_prefix}otool64; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OTOOL64+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OTOOL64"; then ac_cv_prog_OTOOL64="$OTOOL64" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OTOOL64="${ac_tool_prefix}otool64" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi OTOOL64=$ac_cv_prog_OTOOL64 if test -n "$OTOOL64"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OTOOL64" >&5 $as_echo "$OTOOL64" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_OTOOL64"; then ac_ct_OTOOL64=$OTOOL64 # Extract the first word of "otool64", so it can be a program name with args. set dummy otool64; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_OTOOL64+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_OTOOL64"; then ac_cv_prog_ac_ct_OTOOL64="$ac_ct_OTOOL64" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_OTOOL64="otool64" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_OTOOL64=$ac_cv_prog_ac_ct_OTOOL64 if test -n "$ac_ct_OTOOL64"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_OTOOL64" >&5 $as_echo "$ac_ct_OTOOL64" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_OTOOL64" = x; then OTOOL64=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac OTOOL64=$ac_ct_OTOOL64 fi else OTOOL64="$ac_cv_prog_OTOOL64" fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for -single_module linker flag" >&5 $as_echo_n "checking for -single_module linker flag... " >&6; } if ${lt_cv_apple_cc_single_mod+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_apple_cc_single_mod=no if test -z "$LT_MULTI_MODULE"; then # By default we will add the -single_module flag. You can override # by either setting the environment variable LT_MULTI_MODULE # non-empty at configure time, or by adding -multi_module to the # link flags. rm -rf libconftest.dylib* echo "int foo(void){return 1;}" > conftest.c echo "$LTCC $LTCFLAGS $LDFLAGS -o libconftest.dylib \ -dynamiclib -Wl,-single_module conftest.c" >&5 $LTCC $LTCFLAGS $LDFLAGS -o libconftest.dylib \ -dynamiclib -Wl,-single_module conftest.c 2>conftest.err _lt_result=$? # If there is a non-empty error log, and "single_module" # appears in it, assume the flag caused a linker warning if test -s conftest.err && $GREP single_module conftest.err; then cat conftest.err >&5 # Otherwise, if the output was created with a 0 exit code from # the compiler, it worked. elif test -f libconftest.dylib && test 0 = "$_lt_result"; then lt_cv_apple_cc_single_mod=yes else cat conftest.err >&5 fi rm -rf libconftest.dylib* rm -f conftest.* fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_apple_cc_single_mod" >&5 $as_echo "$lt_cv_apple_cc_single_mod" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking for -exported_symbols_list linker flag" >&5 $as_echo_n "checking for -exported_symbols_list linker flag... " >&6; } if ${lt_cv_ld_exported_symbols_list+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_ld_exported_symbols_list=no save_LDFLAGS=$LDFLAGS echo "_main" > conftest.sym LDFLAGS="$LDFLAGS -Wl,-exported_symbols_list,conftest.sym" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : lt_cv_ld_exported_symbols_list=yes else lt_cv_ld_exported_symbols_list=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$save_LDFLAGS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ld_exported_symbols_list" >&5 $as_echo "$lt_cv_ld_exported_symbols_list" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking for -force_load linker flag" >&5 $as_echo_n "checking for -force_load linker flag... " >&6; } if ${lt_cv_ld_force_load+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_ld_force_load=no cat > conftest.c << _LT_EOF int forced_loaded() { return 2;} _LT_EOF echo "$LTCC $LTCFLAGS -c -o conftest.o conftest.c" >&5 $LTCC $LTCFLAGS -c -o conftest.o conftest.c 2>&5 echo "$AR cru libconftest.a conftest.o" >&5 $AR cru libconftest.a conftest.o 2>&5 echo "$RANLIB libconftest.a" >&5 $RANLIB libconftest.a 2>&5 cat > conftest.c << _LT_EOF int main() { return 0;} _LT_EOF echo "$LTCC $LTCFLAGS $LDFLAGS -o conftest conftest.c -Wl,-force_load,./libconftest.a" >&5 $LTCC $LTCFLAGS $LDFLAGS -o conftest conftest.c -Wl,-force_load,./libconftest.a 2>conftest.err _lt_result=$? if test -s conftest.err && $GREP force_load conftest.err; then cat conftest.err >&5 elif test -f conftest && test 0 = "$_lt_result" && $GREP forced_load conftest >/dev/null 2>&1; then lt_cv_ld_force_load=yes else cat conftest.err >&5 fi rm -f conftest.err libconftest.a conftest conftest.c rm -rf conftest.dSYM fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ld_force_load" >&5 $as_echo "$lt_cv_ld_force_load" >&6; } case $host_os in rhapsody* | darwin1.[012]) _lt_dar_allow_undefined='$wl-undefined ${wl}suppress' ;; darwin1.*) _lt_dar_allow_undefined='$wl-flat_namespace $wl-undefined ${wl}suppress' ;; darwin*) # darwin 5.x on # if running on 10.5 or later, the deployment target defaults # to the OS version, if on x86, and 10.4, the deployment # target defaults to 10.4. Don't you love it? case ${MACOSX_DEPLOYMENT_TARGET-10.0},$host in 10.0,*86*-darwin8*|10.0,*-darwin[91]*) _lt_dar_allow_undefined='$wl-undefined ${wl}dynamic_lookup' ;; 10.[012][,.]*) _lt_dar_allow_undefined='$wl-flat_namespace $wl-undefined ${wl}suppress' ;; 10.*) _lt_dar_allow_undefined='$wl-undefined ${wl}dynamic_lookup' ;; esac ;; esac if test yes = "$lt_cv_apple_cc_single_mod"; then _lt_dar_single_mod='$single_module' fi if test yes = "$lt_cv_ld_exported_symbols_list"; then _lt_dar_export_syms=' $wl-exported_symbols_list,$output_objdir/$libname-symbols.expsym' else _lt_dar_export_syms='~$NMEDIT -s $output_objdir/$libname-symbols.expsym $lib' fi if test : != "$DSYMUTIL" && test no = "$lt_cv_ld_force_load"; then _lt_dsymutil='~$DSYMUTIL $lib || :' else _lt_dsymutil= fi ;; esac # func_munge_path_list VARIABLE PATH # ----------------------------------- # VARIABLE is name of variable containing _space_ separated list of # directories to be munged by the contents of PATH, which is string # having a format: # "DIR[:DIR]:" # string "DIR[ DIR]" will be prepended to VARIABLE # ":DIR[:DIR]" # string "DIR[ DIR]" will be appended to VARIABLE # "DIRP[:DIRP]::[DIRA:]DIRA" # string "DIRP[ DIRP]" will be prepended to VARIABLE and string # "DIRA[ DIRA]" will be appended to VARIABLE # "DIR[:DIR]" # VARIABLE will be replaced by "DIR[ DIR]" func_munge_path_list () { case x$2 in x) ;; *:) eval $1=\"`$ECHO $2 | $SED 's/:/ /g'` \$$1\" ;; x:*) eval $1=\"\$$1 `$ECHO $2 | $SED 's/:/ /g'`\" ;; *::*) eval $1=\"\$$1\ `$ECHO $2 | $SED -e 's/.*:://' -e 's/:/ /g'`\" eval $1=\"`$ECHO $2 | $SED -e 's/::.*//' -e 's/:/ /g'`\ \$$1\" ;; *) eval $1=\"`$ECHO $2 | $SED 's/:/ /g'`\" ;; esac } for ac_header in dlfcn.h do : ac_fn_c_check_header_compile "$LINENO" "dlfcn.h" "ac_cv_header_dlfcn_h" "$ac_includes_default " if test "x$ac_cv_header_dlfcn_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_DLFCN_H 1 _ACEOF fi done # Set options enable_win32_dll=yes case $host in *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-cegcc*) if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}as", so it can be a program name with args. set dummy ${ac_tool_prefix}as; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_AS+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$AS"; then ac_cv_prog_AS="$AS" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_AS="${ac_tool_prefix}as" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi AS=$ac_cv_prog_AS if test -n "$AS"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AS" >&5 $as_echo "$AS" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_AS"; then ac_ct_AS=$AS # Extract the first word of "as", so it can be a program name with args. set dummy as; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_AS+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_AS"; then ac_cv_prog_ac_ct_AS="$ac_ct_AS" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_AS="as" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_AS=$ac_cv_prog_ac_ct_AS if test -n "$ac_ct_AS"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_AS" >&5 $as_echo "$ac_ct_AS" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_AS" = x; then AS="false" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac AS=$ac_ct_AS fi else AS="$ac_cv_prog_AS" fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}dlltool", so it can be a program name with args. set dummy ${ac_tool_prefix}dlltool; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_DLLTOOL+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$DLLTOOL"; then ac_cv_prog_DLLTOOL="$DLLTOOL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_DLLTOOL="${ac_tool_prefix}dlltool" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi DLLTOOL=$ac_cv_prog_DLLTOOL if test -n "$DLLTOOL"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $DLLTOOL" >&5 $as_echo "$DLLTOOL" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_DLLTOOL"; then ac_ct_DLLTOOL=$DLLTOOL # Extract the first word of "dlltool", so it can be a program name with args. set dummy dlltool; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_DLLTOOL+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_DLLTOOL"; then ac_cv_prog_ac_ct_DLLTOOL="$ac_ct_DLLTOOL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_DLLTOOL="dlltool" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_DLLTOOL=$ac_cv_prog_ac_ct_DLLTOOL if test -n "$ac_ct_DLLTOOL"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_DLLTOOL" >&5 $as_echo "$ac_ct_DLLTOOL" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_DLLTOOL" = x; then DLLTOOL="false" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac DLLTOOL=$ac_ct_DLLTOOL fi else DLLTOOL="$ac_cv_prog_DLLTOOL" fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}objdump", so it can be a program name with args. set dummy ${ac_tool_prefix}objdump; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OBJDUMP+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OBJDUMP"; then ac_cv_prog_OBJDUMP="$OBJDUMP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OBJDUMP="${ac_tool_prefix}objdump" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi OBJDUMP=$ac_cv_prog_OBJDUMP if test -n "$OBJDUMP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OBJDUMP" >&5 $as_echo "$OBJDUMP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_OBJDUMP"; then ac_ct_OBJDUMP=$OBJDUMP # Extract the first word of "objdump", so it can be a program name with args. set dummy objdump; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_OBJDUMP+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_OBJDUMP"; then ac_cv_prog_ac_ct_OBJDUMP="$ac_ct_OBJDUMP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_OBJDUMP="objdump" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_OBJDUMP=$ac_cv_prog_ac_ct_OBJDUMP if test -n "$ac_ct_OBJDUMP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_OBJDUMP" >&5 $as_echo "$ac_ct_OBJDUMP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_OBJDUMP" = x; then OBJDUMP="false" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac OBJDUMP=$ac_ct_OBJDUMP fi else OBJDUMP="$ac_cv_prog_OBJDUMP" fi ;; esac test -z "$AS" && AS=as test -z "$DLLTOOL" && DLLTOOL=dlltool test -z "$OBJDUMP" && OBJDUMP=objdump enable_dlopen=no # Check whether --enable-shared was given. if test "${enable_shared+set}" = set; then : enableval=$enable_shared; p=${PACKAGE-default} case $enableval in yes) enable_shared=yes ;; no) enable_shared=no ;; *) enable_shared=no # Look at the argument we got. We use all the common list separators. lt_save_ifs=$IFS; IFS=$IFS$PATH_SEPARATOR, for pkg in $enableval; do IFS=$lt_save_ifs if test "X$pkg" = "X$p"; then enable_shared=yes fi done IFS=$lt_save_ifs ;; esac else enable_shared=yes fi # Check whether --enable-static was given. if test "${enable_static+set}" = set; then : enableval=$enable_static; p=${PACKAGE-default} case $enableval in yes) enable_static=yes ;; no) enable_static=no ;; *) enable_static=no # Look at the argument we got. We use all the common list separators. lt_save_ifs=$IFS; IFS=$IFS$PATH_SEPARATOR, for pkg in $enableval; do IFS=$lt_save_ifs if test "X$pkg" = "X$p"; then enable_static=yes fi done IFS=$lt_save_ifs ;; esac else enable_static=yes fi # Check whether --with-pic was given. if test "${with_pic+set}" = set; then : withval=$with_pic; lt_p=${PACKAGE-default} case $withval in yes|no) pic_mode=$withval ;; *) pic_mode=default # Look at the argument we got. We use all the common list separators. lt_save_ifs=$IFS; IFS=$IFS$PATH_SEPARATOR, for lt_pkg in $withval; do IFS=$lt_save_ifs if test "X$lt_pkg" = "X$lt_p"; then pic_mode=yes fi done IFS=$lt_save_ifs ;; esac else pic_mode=default fi # Check whether --enable-fast-install was given. if test "${enable_fast_install+set}" = set; then : enableval=$enable_fast_install; p=${PACKAGE-default} case $enableval in yes) enable_fast_install=yes ;; no) enable_fast_install=no ;; *) enable_fast_install=no # Look at the argument we got. We use all the common list separators. lt_save_ifs=$IFS; IFS=$IFS$PATH_SEPARATOR, for pkg in $enableval; do IFS=$lt_save_ifs if test "X$pkg" = "X$p"; then enable_fast_install=yes fi done IFS=$lt_save_ifs ;; esac else enable_fast_install=yes fi shared_archive_member_spec= case $host,$enable_shared in power*-*-aix[5-9]*,yes) { $as_echo "$as_me:${as_lineno-$LINENO}: checking which variant of shared library versioning to provide" >&5 $as_echo_n "checking which variant of shared library versioning to provide... " >&6; } # Check whether --with-aix-soname was given. if test "${with_aix_soname+set}" = set; then : withval=$with_aix_soname; case $withval in aix|svr4|both) ;; *) as_fn_error $? "Unknown argument to --with-aix-soname" "$LINENO" 5 ;; esac lt_cv_with_aix_soname=$with_aix_soname else if ${lt_cv_with_aix_soname+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_with_aix_soname=aix fi with_aix_soname=$lt_cv_with_aix_soname fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $with_aix_soname" >&5 $as_echo "$with_aix_soname" >&6; } if test aix != "$with_aix_soname"; then # For the AIX way of multilib, we name the shared archive member # based on the bitwidth used, traditionally 'shr.o' or 'shr_64.o', # and 'shr.imp' or 'shr_64.imp', respectively, for the Import File. # Even when GNU compilers ignore OBJECT_MODE but need '-maix64' flag, # the AIX toolchain works better with OBJECT_MODE set (default 32). if test 64 = "${OBJECT_MODE-32}"; then shared_archive_member_spec=shr_64 else shared_archive_member_spec=shr fi fi ;; *) with_aix_soname=aix ;; esac # This can be used to rebuild libtool when needed LIBTOOL_DEPS=$ltmain # Always use our own libtool. LIBTOOL='$(SHELL) $(top_builddir)/libtool' test -z "$LN_S" && LN_S="ln -s" if test -n "${ZSH_VERSION+set}"; then setopt NO_GLOB_SUBST fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for objdir" >&5 $as_echo_n "checking for objdir... " >&6; } if ${lt_cv_objdir+:} false; then : $as_echo_n "(cached) " >&6 else rm -f .libs 2>/dev/null mkdir .libs 2>/dev/null if test -d .libs; then lt_cv_objdir=.libs else # MS-DOS does not allow filenames that begin with a dot. lt_cv_objdir=_libs fi rmdir .libs 2>/dev/null fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_objdir" >&5 $as_echo "$lt_cv_objdir" >&6; } objdir=$lt_cv_objdir cat >>confdefs.h <<_ACEOF #define LT_OBJDIR "$lt_cv_objdir/" _ACEOF case $host_os in aix3*) # AIX sometimes has problems with the GCC collect2 program. For some # reason, if we set the COLLECT_NAMES environment variable, the problems # vanish in a puff of smoke. if test set != "${COLLECT_NAMES+set}"; then COLLECT_NAMES= export COLLECT_NAMES fi ;; esac # Global variables: ofile=libtool can_build_shared=yes # All known linkers require a '.a' archive for static linking (except MSVC, # which needs '.lib'). libext=a with_gnu_ld=$lt_cv_prog_gnu_ld old_CC=$CC old_CFLAGS=$CFLAGS # Set sane defaults for various variables test -z "$CC" && CC=cc test -z "$LTCC" && LTCC=$CC test -z "$LTCFLAGS" && LTCFLAGS=$CFLAGS test -z "$LD" && LD=ld test -z "$ac_objext" && ac_objext=o func_cc_basename $compiler cc_basename=$func_cc_basename_result # Only perform the check for file, if the check method requires it test -z "$MAGIC_CMD" && MAGIC_CMD=file case $deplibs_check_method in file_magic*) if test "$file_magic_cmd" = '$MAGIC_CMD'; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ${ac_tool_prefix}file" >&5 $as_echo_n "checking for ${ac_tool_prefix}file... " >&6; } if ${lt_cv_path_MAGIC_CMD+:} false; then : $as_echo_n "(cached) " >&6 else case $MAGIC_CMD in [\\/*] | ?:[\\/]*) lt_cv_path_MAGIC_CMD=$MAGIC_CMD # Let the user override the test with a path. ;; *) lt_save_MAGIC_CMD=$MAGIC_CMD lt_save_ifs=$IFS; IFS=$PATH_SEPARATOR ac_dummy="/usr/bin$PATH_SEPARATOR$PATH" for ac_dir in $ac_dummy; do IFS=$lt_save_ifs test -z "$ac_dir" && ac_dir=. if test -f "$ac_dir/${ac_tool_prefix}file"; then lt_cv_path_MAGIC_CMD=$ac_dir/"${ac_tool_prefix}file" if test -n "$file_magic_test_file"; then case $deplibs_check_method in "file_magic "*) file_magic_regex=`expr "$deplibs_check_method" : "file_magic \(.*\)"` MAGIC_CMD=$lt_cv_path_MAGIC_CMD if eval $file_magic_cmd \$file_magic_test_file 2> /dev/null | $EGREP "$file_magic_regex" > /dev/null; then : else cat <<_LT_EOF 1>&2 *** Warning: the command libtool uses to detect shared libraries, *** $file_magic_cmd, produces output that libtool cannot recognize. *** The result is that libtool may fail to recognize shared libraries *** as such. This will affect the creation of libtool libraries that *** depend on shared libraries, but programs linked with such libtool *** libraries will work regardless of this problem. Nevertheless, you *** may want to report the problem to your system manager and/or to *** bug-libtool@gnu.org _LT_EOF fi ;; esac fi break fi done IFS=$lt_save_ifs MAGIC_CMD=$lt_save_MAGIC_CMD ;; esac fi MAGIC_CMD=$lt_cv_path_MAGIC_CMD if test -n "$MAGIC_CMD"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MAGIC_CMD" >&5 $as_echo "$MAGIC_CMD" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test -z "$lt_cv_path_MAGIC_CMD"; then if test -n "$ac_tool_prefix"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for file" >&5 $as_echo_n "checking for file... " >&6; } if ${lt_cv_path_MAGIC_CMD+:} false; then : $as_echo_n "(cached) " >&6 else case $MAGIC_CMD in [\\/*] | ?:[\\/]*) lt_cv_path_MAGIC_CMD=$MAGIC_CMD # Let the user override the test with a path. ;; *) lt_save_MAGIC_CMD=$MAGIC_CMD lt_save_ifs=$IFS; IFS=$PATH_SEPARATOR ac_dummy="/usr/bin$PATH_SEPARATOR$PATH" for ac_dir in $ac_dummy; do IFS=$lt_save_ifs test -z "$ac_dir" && ac_dir=. if test -f "$ac_dir/file"; then lt_cv_path_MAGIC_CMD=$ac_dir/"file" if test -n "$file_magic_test_file"; then case $deplibs_check_method in "file_magic "*) file_magic_regex=`expr "$deplibs_check_method" : "file_magic \(.*\)"` MAGIC_CMD=$lt_cv_path_MAGIC_CMD if eval $file_magic_cmd \$file_magic_test_file 2> /dev/null | $EGREP "$file_magic_regex" > /dev/null; then : else cat <<_LT_EOF 1>&2 *** Warning: the command libtool uses to detect shared libraries, *** $file_magic_cmd, produces output that libtool cannot recognize. *** The result is that libtool may fail to recognize shared libraries *** as such. This will affect the creation of libtool libraries that *** depend on shared libraries, but programs linked with such libtool *** libraries will work regardless of this problem. Nevertheless, you *** may want to report the problem to your system manager and/or to *** bug-libtool@gnu.org _LT_EOF fi ;; esac fi break fi done IFS=$lt_save_ifs MAGIC_CMD=$lt_save_MAGIC_CMD ;; esac fi MAGIC_CMD=$lt_cv_path_MAGIC_CMD if test -n "$MAGIC_CMD"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MAGIC_CMD" >&5 $as_echo "$MAGIC_CMD" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi else MAGIC_CMD=: fi fi fi ;; esac # Use C for the default configuration in the libtool script lt_save_CC=$CC ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # Source file extension for C test sources. ac_ext=c # Object file extension for compiled C test sources. objext=o objext=$objext # Code to be used in simple compile tests lt_simple_compile_test_code="int some_variable = 0;" # Code to be used in simple link tests lt_simple_link_test_code='int main(){return(0);}' # If no C compiler was specified, use CC. LTCC=${LTCC-"$CC"} # If no C compiler flags were specified, use CFLAGS. LTCFLAGS=${LTCFLAGS-"$CFLAGS"} # Allow CC to be a program name with arguments. compiler=$CC # Save the default compiler, since it gets overwritten when the other # tags are being tested, and _LT_TAGVAR(compiler, []) is a NOP. compiler_DEFAULT=$CC # save warnings/boilerplate of simple test code ac_outfile=conftest.$ac_objext echo "$lt_simple_compile_test_code" >conftest.$ac_ext eval "$ac_compile" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err _lt_compiler_boilerplate=`cat conftest.err` $RM conftest* ac_outfile=conftest.$ac_objext echo "$lt_simple_link_test_code" >conftest.$ac_ext eval "$ac_link" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err _lt_linker_boilerplate=`cat conftest.err` $RM -r conftest* ## CAVEAT EMPTOR: ## There is no encapsulation within the following macros, do not change ## the running order or otherwise move them around unless you know exactly ## what you are doing... if test -n "$compiler"; then lt_prog_compiler_no_builtin_flag= if test yes = "$GCC"; then case $cc_basename in nvcc*) lt_prog_compiler_no_builtin_flag=' -Xcompiler -fno-builtin' ;; *) lt_prog_compiler_no_builtin_flag=' -fno-builtin' ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -fno-rtti -fno-exceptions" >&5 $as_echo_n "checking if $compiler supports -fno-rtti -fno-exceptions... " >&6; } if ${lt_cv_prog_compiler_rtti_exceptions+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_prog_compiler_rtti_exceptions=no ac_outfile=conftest.$ac_objext echo "$lt_simple_compile_test_code" > conftest.$ac_ext lt_compiler_flag="-fno-rtti -fno-exceptions" ## exclude from sc_useless_quotes_in_assignment # Insert the option either (1) after the last *FLAGS variable, or # (2) before a word containing "conftest.", or (3) at the end. # Note that $ac_compile itself does not contain backslashes and begins # with a dollar sign (not a hyphen), so the echo should work correctly. # The option is referenced via a variable to avoid confusing sed. lt_compile=`echo "$ac_compile" | $SED \ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5) (eval "$lt_compile" 2>conftest.err) ac_status=$? cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 if (exit $ac_status) && test -s "$ac_outfile"; then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings other than the usual output. $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' >conftest.exp $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 if test ! -s conftest.er2 || diff conftest.exp conftest.er2 >/dev/null; then lt_cv_prog_compiler_rtti_exceptions=yes fi fi $RM conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_rtti_exceptions" >&5 $as_echo "$lt_cv_prog_compiler_rtti_exceptions" >&6; } if test yes = "$lt_cv_prog_compiler_rtti_exceptions"; then lt_prog_compiler_no_builtin_flag="$lt_prog_compiler_no_builtin_flag -fno-rtti -fno-exceptions" else : fi fi lt_prog_compiler_wl= lt_prog_compiler_pic= lt_prog_compiler_static= if test yes = "$GCC"; then lt_prog_compiler_wl='-Wl,' lt_prog_compiler_static='-static' case $host_os in aix*) # All AIX code is PIC. if test ia64 = "$host_cpu"; then # AIX 5 now supports IA64 processor lt_prog_compiler_static='-Bstatic' fi lt_prog_compiler_pic='-fPIC' ;; amigaos*) case $host_cpu in powerpc) # see comment about AmigaOS4 .so support lt_prog_compiler_pic='-fPIC' ;; m68k) # FIXME: we need at least 68020 code to build shared libraries, but # adding the '-m68020' flag to GCC prevents building anything better, # like '-m68040'. lt_prog_compiler_pic='-m68020 -resident32 -malways-restore-a4' ;; esac ;; beos* | irix5* | irix6* | nonstopux* | osf3* | osf4* | osf5*) # PIC is the default for these OSes. ;; mingw* | cygwin* | pw32* | os2* | cegcc*) # This hack is so that the source file can tell whether it is being # built for inclusion in a dll (and should export symbols for example). # Although the cygwin gcc ignores -fPIC, still need this for old-style # (--disable-auto-import) libraries lt_prog_compiler_pic='-DDLL_EXPORT' case $host_os in os2*) lt_prog_compiler_static='$wl-static' ;; esac ;; darwin* | rhapsody*) # PIC is the default on this platform # Common symbols not allowed in MH_DYLIB files lt_prog_compiler_pic='-fno-common' ;; haiku*) # PIC is the default for Haiku. # The "-static" flag exists, but is broken. lt_prog_compiler_static= ;; hpux*) # PIC is the default for 64-bit PA HP-UX, but not for 32-bit # PA HP-UX. On IA64 HP-UX, PIC is the default but the pic flag # sets the default TLS model and affects inlining. case $host_cpu in hppa*64*) # +Z the default ;; *) lt_prog_compiler_pic='-fPIC' ;; esac ;; interix[3-9]*) # Interix 3.x gcc -fpic/-fPIC options generate broken code. # Instead, we relocate shared libraries at runtime. ;; msdosdjgpp*) # Just because we use GCC doesn't mean we suddenly get shared libraries # on systems that don't support them. lt_prog_compiler_can_build_shared=no enable_shared=no ;; *nto* | *qnx*) # QNX uses GNU C++, but need to define -shared option too, otherwise # it will coredump. lt_prog_compiler_pic='-fPIC -shared' ;; sysv4*MP*) if test -d /usr/nec; then lt_prog_compiler_pic=-Kconform_pic fi ;; *) lt_prog_compiler_pic='-fPIC' ;; esac case $cc_basename in nvcc*) # Cuda Compiler Driver 2.2 lt_prog_compiler_wl='-Xlinker ' if test -n "$lt_prog_compiler_pic"; then lt_prog_compiler_pic="-Xcompiler $lt_prog_compiler_pic" fi ;; esac else # PORTME Check for flag to pass linker flags through the system compiler. case $host_os in aix*) lt_prog_compiler_wl='-Wl,' if test ia64 = "$host_cpu"; then # AIX 5 now supports IA64 processor lt_prog_compiler_static='-Bstatic' else lt_prog_compiler_static='-bnso -bI:/lib/syscalls.exp' fi ;; darwin* | rhapsody*) # PIC is the default on this platform # Common symbols not allowed in MH_DYLIB files lt_prog_compiler_pic='-fno-common' case $cc_basename in nagfor*) # NAG Fortran compiler lt_prog_compiler_wl='-Wl,-Wl,,' lt_prog_compiler_pic='-PIC' lt_prog_compiler_static='-Bstatic' ;; esac ;; mingw* | cygwin* | pw32* | os2* | cegcc*) # This hack is so that the source file can tell whether it is being # built for inclusion in a dll (and should export symbols for example). lt_prog_compiler_pic='-DDLL_EXPORT' case $host_os in os2*) lt_prog_compiler_static='$wl-static' ;; esac ;; hpux9* | hpux10* | hpux11*) lt_prog_compiler_wl='-Wl,' # PIC is the default for IA64 HP-UX and 64-bit HP-UX, but # not for PA HP-UX. case $host_cpu in hppa*64*|ia64*) # +Z the default ;; *) lt_prog_compiler_pic='+Z' ;; esac # Is there a better lt_prog_compiler_static that works with the bundled CC? lt_prog_compiler_static='$wl-a ${wl}archive' ;; irix5* | irix6* | nonstopux*) lt_prog_compiler_wl='-Wl,' # PIC (with -KPIC) is the default. lt_prog_compiler_static='-non_shared' ;; linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) case $cc_basename in # old Intel for x86_64, which still supported -KPIC. ecc*) lt_prog_compiler_wl='-Wl,' lt_prog_compiler_pic='-KPIC' lt_prog_compiler_static='-static' ;; # icc used to be incompatible with GCC. # ICC 10 doesn't accept -KPIC any more. icc* | ifort*) lt_prog_compiler_wl='-Wl,' lt_prog_compiler_pic='-fPIC' lt_prog_compiler_static='-static' ;; # Lahey Fortran 8.1. lf95*) lt_prog_compiler_wl='-Wl,' lt_prog_compiler_pic='--shared' lt_prog_compiler_static='--static' ;; nagfor*) # NAG Fortran compiler lt_prog_compiler_wl='-Wl,-Wl,,' lt_prog_compiler_pic='-PIC' lt_prog_compiler_static='-Bstatic' ;; tcc*) # Fabrice Bellard et al's Tiny C Compiler lt_prog_compiler_wl='-Wl,' lt_prog_compiler_pic='-fPIC' lt_prog_compiler_static='-static' ;; pgcc* | pgf77* | pgf90* | pgf95* | pgfortran*) # Portland Group compilers (*not* the Pentium gcc compiler, # which looks to be a dead project) lt_prog_compiler_wl='-Wl,' lt_prog_compiler_pic='-fpic' lt_prog_compiler_static='-Bstatic' ;; ccc*) lt_prog_compiler_wl='-Wl,' # All Alpha code is PIC. lt_prog_compiler_static='-non_shared' ;; xl* | bgxl* | bgf* | mpixl*) # IBM XL C 8.0/Fortran 10.1, 11.1 on PPC and BlueGene lt_prog_compiler_wl='-Wl,' lt_prog_compiler_pic='-qpic' lt_prog_compiler_static='-qstaticlink' ;; *) case `$CC -V 2>&1 | sed 5q` in *Sun\ Ceres\ Fortran* | *Sun*Fortran*\ [1-7].* | *Sun*Fortran*\ 8.[0-3]*) # Sun Fortran 8.3 passes all unrecognized flags to the linker lt_prog_compiler_pic='-KPIC' lt_prog_compiler_static='-Bstatic' lt_prog_compiler_wl='' ;; *Sun\ F* | *Sun*Fortran*) lt_prog_compiler_pic='-KPIC' lt_prog_compiler_static='-Bstatic' lt_prog_compiler_wl='-Qoption ld ' ;; *Sun\ C*) # Sun C 5.9 lt_prog_compiler_pic='-KPIC' lt_prog_compiler_static='-Bstatic' lt_prog_compiler_wl='-Wl,' ;; *Intel*\ [CF]*Compiler*) lt_prog_compiler_wl='-Wl,' lt_prog_compiler_pic='-fPIC' lt_prog_compiler_static='-static' ;; *Portland\ Group*) lt_prog_compiler_wl='-Wl,' lt_prog_compiler_pic='-fpic' lt_prog_compiler_static='-Bstatic' ;; esac ;; esac ;; newsos6) lt_prog_compiler_pic='-KPIC' lt_prog_compiler_static='-Bstatic' ;; *nto* | *qnx*) # QNX uses GNU C++, but need to define -shared option too, otherwise # it will coredump. lt_prog_compiler_pic='-fPIC -shared' ;; osf3* | osf4* | osf5*) lt_prog_compiler_wl='-Wl,' # All OSF/1 code is PIC. lt_prog_compiler_static='-non_shared' ;; rdos*) lt_prog_compiler_static='-non_shared' ;; solaris*) lt_prog_compiler_pic='-KPIC' lt_prog_compiler_static='-Bstatic' case $cc_basename in f77* | f90* | f95* | sunf77* | sunf90* | sunf95*) lt_prog_compiler_wl='-Qoption ld ';; *) lt_prog_compiler_wl='-Wl,';; esac ;; sunos4*) lt_prog_compiler_wl='-Qoption ld ' lt_prog_compiler_pic='-PIC' lt_prog_compiler_static='-Bstatic' ;; sysv4 | sysv4.2uw2* | sysv4.3*) lt_prog_compiler_wl='-Wl,' lt_prog_compiler_pic='-KPIC' lt_prog_compiler_static='-Bstatic' ;; sysv4*MP*) if test -d /usr/nec; then lt_prog_compiler_pic='-Kconform_pic' lt_prog_compiler_static='-Bstatic' fi ;; sysv5* | unixware* | sco3.2v5* | sco5v6* | OpenUNIX*) lt_prog_compiler_wl='-Wl,' lt_prog_compiler_pic='-KPIC' lt_prog_compiler_static='-Bstatic' ;; unicos*) lt_prog_compiler_wl='-Wl,' lt_prog_compiler_can_build_shared=no ;; uts4*) lt_prog_compiler_pic='-pic' lt_prog_compiler_static='-Bstatic' ;; *) lt_prog_compiler_can_build_shared=no ;; esac fi case $host_os in # For platforms that do not support PIC, -DPIC is meaningless: *djgpp*) lt_prog_compiler_pic= ;; *) lt_prog_compiler_pic="$lt_prog_compiler_pic -DPIC" ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $compiler option to produce PIC" >&5 $as_echo_n "checking for $compiler option to produce PIC... " >&6; } if ${lt_cv_prog_compiler_pic+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_prog_compiler_pic=$lt_prog_compiler_pic fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic" >&5 $as_echo "$lt_cv_prog_compiler_pic" >&6; } lt_prog_compiler_pic=$lt_cv_prog_compiler_pic # # Check to make sure the PIC flag actually works. # if test -n "$lt_prog_compiler_pic"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler PIC flag $lt_prog_compiler_pic works" >&5 $as_echo_n "checking if $compiler PIC flag $lt_prog_compiler_pic works... " >&6; } if ${lt_cv_prog_compiler_pic_works+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_prog_compiler_pic_works=no ac_outfile=conftest.$ac_objext echo "$lt_simple_compile_test_code" > conftest.$ac_ext lt_compiler_flag="$lt_prog_compiler_pic -DPIC" ## exclude from sc_useless_quotes_in_assignment # Insert the option either (1) after the last *FLAGS variable, or # (2) before a word containing "conftest.", or (3) at the end. # Note that $ac_compile itself does not contain backslashes and begins # with a dollar sign (not a hyphen), so the echo should work correctly. # The option is referenced via a variable to avoid confusing sed. lt_compile=`echo "$ac_compile" | $SED \ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5) (eval "$lt_compile" 2>conftest.err) ac_status=$? cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 if (exit $ac_status) && test -s "$ac_outfile"; then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings other than the usual output. $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' >conftest.exp $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 if test ! -s conftest.er2 || diff conftest.exp conftest.er2 >/dev/null; then lt_cv_prog_compiler_pic_works=yes fi fi $RM conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic_works" >&5 $as_echo "$lt_cv_prog_compiler_pic_works" >&6; } if test yes = "$lt_cv_prog_compiler_pic_works"; then case $lt_prog_compiler_pic in "" | " "*) ;; *) lt_prog_compiler_pic=" $lt_prog_compiler_pic" ;; esac else lt_prog_compiler_pic= lt_prog_compiler_can_build_shared=no fi fi # # Check to make sure the static flag actually works. # wl=$lt_prog_compiler_wl eval lt_tmp_static_flag=\"$lt_prog_compiler_static\" { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler static flag $lt_tmp_static_flag works" >&5 $as_echo_n "checking if $compiler static flag $lt_tmp_static_flag works... " >&6; } if ${lt_cv_prog_compiler_static_works+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_prog_compiler_static_works=no save_LDFLAGS=$LDFLAGS LDFLAGS="$LDFLAGS $lt_tmp_static_flag" echo "$lt_simple_link_test_code" > conftest.$ac_ext if (eval $ac_link 2>conftest.err) && test -s conftest$ac_exeext; then # The linker can only warn and ignore the option if not recognized # So say no if there are warnings if test -s conftest.err; then # Append any errors to the config.log. cat conftest.err 1>&5 $ECHO "$_lt_linker_boilerplate" | $SED '/^$/d' > conftest.exp $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 if diff conftest.exp conftest.er2 >/dev/null; then lt_cv_prog_compiler_static_works=yes fi else lt_cv_prog_compiler_static_works=yes fi fi $RM -r conftest* LDFLAGS=$save_LDFLAGS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_static_works" >&5 $as_echo "$lt_cv_prog_compiler_static_works" >&6; } if test yes = "$lt_cv_prog_compiler_static_works"; then : else lt_prog_compiler_static= fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -c -o file.$ac_objext" >&5 $as_echo_n "checking if $compiler supports -c -o file.$ac_objext... " >&6; } if ${lt_cv_prog_compiler_c_o+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_prog_compiler_c_o=no $RM -r conftest 2>/dev/null mkdir conftest cd conftest mkdir out echo "$lt_simple_compile_test_code" > conftest.$ac_ext lt_compiler_flag="-o out/conftest2.$ac_objext" # Insert the option either (1) after the last *FLAGS variable, or # (2) before a word containing "conftest.", or (3) at the end. # Note that $ac_compile itself does not contain backslashes and begins # with a dollar sign (not a hyphen), so the echo should work correctly. lt_compile=`echo "$ac_compile" | $SED \ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' > out/conftest.exp $SED '/^$/d; /^ *+/d' out/conftest.err >out/conftest.er2 if test ! -s out/conftest.er2 || diff out/conftest.exp out/conftest.er2 >/dev/null; then lt_cv_prog_compiler_c_o=yes fi fi chmod u+w . 2>&5 $RM conftest* # SGI C++ compiler will create directory out/ii_files/ for # template instantiation test -d out/ii_files && $RM out/ii_files/* && rmdir out/ii_files $RM out/* && rmdir out cd .. $RM -r conftest $RM conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_c_o" >&5 $as_echo "$lt_cv_prog_compiler_c_o" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -c -o file.$ac_objext" >&5 $as_echo_n "checking if $compiler supports -c -o file.$ac_objext... " >&6; } if ${lt_cv_prog_compiler_c_o+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_prog_compiler_c_o=no $RM -r conftest 2>/dev/null mkdir conftest cd conftest mkdir out echo "$lt_simple_compile_test_code" > conftest.$ac_ext lt_compiler_flag="-o out/conftest2.$ac_objext" # Insert the option either (1) after the last *FLAGS variable, or # (2) before a word containing "conftest.", or (3) at the end. # Note that $ac_compile itself does not contain backslashes and begins # with a dollar sign (not a hyphen), so the echo should work correctly. lt_compile=`echo "$ac_compile" | $SED \ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' > out/conftest.exp $SED '/^$/d; /^ *+/d' out/conftest.err >out/conftest.er2 if test ! -s out/conftest.er2 || diff out/conftest.exp out/conftest.er2 >/dev/null; then lt_cv_prog_compiler_c_o=yes fi fi chmod u+w . 2>&5 $RM conftest* # SGI C++ compiler will create directory out/ii_files/ for # template instantiation test -d out/ii_files && $RM out/ii_files/* && rmdir out/ii_files $RM out/* && rmdir out cd .. $RM -r conftest $RM conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_c_o" >&5 $as_echo "$lt_cv_prog_compiler_c_o" >&6; } hard_links=nottested if test no = "$lt_cv_prog_compiler_c_o" && test no != "$need_locks"; then # do not overwrite the value of need_locks provided by the user { $as_echo "$as_me:${as_lineno-$LINENO}: checking if we can lock with hard links" >&5 $as_echo_n "checking if we can lock with hard links... " >&6; } hard_links=yes $RM conftest* ln conftest.a conftest.b 2>/dev/null && hard_links=no touch conftest.a ln conftest.a conftest.b 2>&5 || hard_links=no ln conftest.a conftest.b 2>/dev/null && hard_links=no { $as_echo "$as_me:${as_lineno-$LINENO}: result: $hard_links" >&5 $as_echo "$hard_links" >&6; } if test no = "$hard_links"; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: '$CC' does not support '-c -o', so 'make -j' may be unsafe" >&5 $as_echo "$as_me: WARNING: '$CC' does not support '-c -o', so 'make -j' may be unsafe" >&2;} need_locks=warn fi else need_locks=no fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the $compiler linker ($LD) supports shared libraries" >&5 $as_echo_n "checking whether the $compiler linker ($LD) supports shared libraries... " >&6; } runpath_var= allow_undefined_flag= always_export_symbols=no archive_cmds= archive_expsym_cmds= compiler_needs_object=no enable_shared_with_static_runtimes=no export_dynamic_flag_spec= export_symbols_cmds='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols' hardcode_automatic=no hardcode_direct=no hardcode_direct_absolute=no hardcode_libdir_flag_spec= hardcode_libdir_separator= hardcode_minus_L=no hardcode_shlibpath_var=unsupported inherit_rpath=no link_all_deplibs=unknown module_cmds= module_expsym_cmds= old_archive_from_new_cmds= old_archive_from_expsyms_cmds= thread_safe_flag_spec= whole_archive_flag_spec= # include_expsyms should be a list of space-separated symbols to be *always* # included in the symbol list include_expsyms= # exclude_expsyms can be an extended regexp of symbols to exclude # it will be wrapped by ' (' and ')$', so one must not match beginning or # end of line. Example: 'a|bc|.*d.*' will exclude the symbols 'a' and 'bc', # as well as any symbol that contains 'd'. exclude_expsyms='_GLOBAL_OFFSET_TABLE_|_GLOBAL__F[ID]_.*' # Although _GLOBAL_OFFSET_TABLE_ is a valid symbol C name, most a.out # platforms (ab)use it in PIC code, but their linkers get confused if # the symbol is explicitly referenced. Since portable code cannot # rely on this symbol name, it's probably fine to never include it in # preloaded symbol tables. # Exclude shared library initialization/finalization symbols. extract_expsyms_cmds= case $host_os in cygwin* | mingw* | pw32* | cegcc*) # FIXME: the MSVC++ port hasn't been tested in a loooong time # When not using gcc, we currently assume that we are using # Microsoft Visual C++. if test yes != "$GCC"; then with_gnu_ld=no fi ;; interix*) # we just hope/assume this is gcc and not c89 (= MSVC++) with_gnu_ld=yes ;; openbsd* | bitrig*) with_gnu_ld=no ;; linux* | k*bsd*-gnu | gnu*) link_all_deplibs=no ;; esac ld_shlibs=yes # On some targets, GNU ld is compatible enough with the native linker # that we're better off using the native interface for both. lt_use_gnu_ld_interface=no if test yes = "$with_gnu_ld"; then case $host_os in aix*) # The AIX port of GNU ld has always aspired to compatibility # with the native linker. However, as the warning in the GNU ld # block says, versions before 2.19.5* couldn't really create working # shared libraries, regardless of the interface used. case `$LD -v 2>&1` in *\ \(GNU\ Binutils\)\ 2.19.5*) ;; *\ \(GNU\ Binutils\)\ 2.[2-9]*) ;; *\ \(GNU\ Binutils\)\ [3-9]*) ;; *) lt_use_gnu_ld_interface=yes ;; esac ;; *) lt_use_gnu_ld_interface=yes ;; esac fi if test yes = "$lt_use_gnu_ld_interface"; then # If archive_cmds runs LD, not CC, wlarc should be empty wlarc='$wl' # Set some defaults for GNU ld with shared library support. These # are reset later if shared libraries are not supported. Putting them # here allows them to be overridden if necessary. runpath_var=LD_RUN_PATH hardcode_libdir_flag_spec='$wl-rpath $wl$libdir' export_dynamic_flag_spec='$wl--export-dynamic' # ancient GNU ld didn't support --whole-archive et. al. if $LD --help 2>&1 | $GREP 'no-whole-archive' > /dev/null; then whole_archive_flag_spec=$wlarc'--whole-archive$convenience '$wlarc'--no-whole-archive' else whole_archive_flag_spec= fi supports_anon_versioning=no case `$LD -v | $SED -e 's/(^)\+)\s\+//' 2>&1` in *GNU\ gold*) supports_anon_versioning=yes ;; *\ [01].* | *\ 2.[0-9].* | *\ 2.10.*) ;; # catch versions < 2.11 *\ 2.11.93.0.2\ *) supports_anon_versioning=yes ;; # RH7.3 ... *\ 2.11.92.0.12\ *) supports_anon_versioning=yes ;; # Mandrake 8.2 ... *\ 2.11.*) ;; # other 2.11 versions *) supports_anon_versioning=yes ;; esac # See if GNU ld supports shared libraries. case $host_os in aix[3-9]*) # On AIX/PPC, the GNU linker is very broken if test ia64 != "$host_cpu"; then ld_shlibs=no cat <<_LT_EOF 1>&2 *** Warning: the GNU linker, at least up to release 2.19, is reported *** to be unable to reliably create shared libraries on AIX. *** Therefore, libtool is disabling shared libraries support. If you *** really care for shared libraries, you may want to install binutils *** 2.20 or above, or modify your PATH so that a non-GNU linker is found. *** You will then need to restart the configuration process. _LT_EOF fi ;; amigaos*) case $host_cpu in powerpc) # see comment about AmigaOS4 .so support archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' archive_expsym_cmds='' ;; m68k) archive_cmds='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)' hardcode_libdir_flag_spec='-L$libdir' hardcode_minus_L=yes ;; esac ;; beos*) if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then allow_undefined_flag=unsupported # Joseph Beckenbach says some releases of gcc # support --undefined. This deserves some investigation. FIXME archive_cmds='$CC -nostart $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' else ld_shlibs=no fi ;; cygwin* | mingw* | pw32* | cegcc*) # _LT_TAGVAR(hardcode_libdir_flag_spec, ) is actually meaningless, # as there is no search path for DLLs. hardcode_libdir_flag_spec='-L$libdir' export_dynamic_flag_spec='$wl--export-all-symbols' allow_undefined_flag=unsupported always_export_symbols=no enable_shared_with_static_runtimes=yes export_symbols_cmds='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[BCDGRS][ ]/s/.*[ ]\([^ ]*\)/\1 DATA/;s/^.*[ ]__nm__\([^ ]*\)[ ][^ ]*/\1 DATA/;/^I[ ]/d;/^[AITW][ ]/s/.* //'\'' | sort | uniq > $export_symbols' exclude_expsyms='[_]+GLOBAL_OFFSET_TABLE_|[_]+GLOBAL__[FID]_.*|[_]+head_[A-Za-z0-9_]+_dll|[A-Za-z0-9_]+_dll_iname' if $LD --help 2>&1 | $GREP 'auto-import' > /dev/null; then archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags -o $output_objdir/$soname $wl--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib' # If the export-symbols file already is a .def file, use it as # is; otherwise, prepend EXPORTS... archive_expsym_cmds='if test DEF = "`$SED -n -e '\''s/^[ ]*//'\'' -e '\''/^\(;.*\)*$/d'\'' -e '\''s/^\(EXPORTS\|LIBRARY\)\([ ].*\)*$/DEF/p'\'' -e q $export_symbols`" ; then cp $export_symbols $output_objdir/$soname.def; else echo EXPORTS > $output_objdir/$soname.def; cat $export_symbols >> $output_objdir/$soname.def; fi~ $CC -shared $output_objdir/$soname.def $libobjs $deplibs $compiler_flags -o $output_objdir/$soname $wl--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib' else ld_shlibs=no fi ;; haiku*) archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' link_all_deplibs=yes ;; os2*) hardcode_libdir_flag_spec='-L$libdir' hardcode_minus_L=yes allow_undefined_flag=unsupported shrext_cmds=.dll archive_cmds='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ $ECHO EXPORTS >> $output_objdir/$libname.def~ emxexp $libobjs | $SED /"_DLL_InitTerm"/d >> $output_objdir/$libname.def~ $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ emximp -o $lib $output_objdir/$libname.def' archive_expsym_cmds='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ $ECHO EXPORTS >> $output_objdir/$libname.def~ prefix_cmds="$SED"~ if test EXPORTS = "`$SED 1q $export_symbols`"; then prefix_cmds="$prefix_cmds -e 1d"; fi~ prefix_cmds="$prefix_cmds -e \"s/^\(.*\)$/_\1/g\""~ cat $export_symbols | $prefix_cmds >> $output_objdir/$libname.def~ $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ emximp -o $lib $output_objdir/$libname.def' old_archive_From_new_cmds='emximp -o $output_objdir/${libname}_dll.a $output_objdir/$libname.def' enable_shared_with_static_runtimes=yes ;; interix[3-9]*) hardcode_direct=no hardcode_shlibpath_var=no hardcode_libdir_flag_spec='$wl-rpath,$libdir' export_dynamic_flag_spec='$wl-E' # Hack: On Interix 3.x, we cannot compile PIC because of a broken gcc. # Instead, shared libraries are loaded at an image base (0x10000000 by # default) and relocated if they conflict, which is a slow very memory # consuming and fragmenting process. To avoid this, we pick a random, # 256 KiB-aligned image base between 0x50000000 and 0x6FFC0000 at link # time. Moving up from 0x10000000 also allows more sbrk(2) space. archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-h,$soname $wl--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib' archive_expsym_cmds='sed "s|^|_|" $export_symbols >$output_objdir/$soname.expsym~$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-h,$soname $wl--retain-symbols-file,$output_objdir/$soname.expsym $wl--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib' ;; gnu* | linux* | tpf* | k*bsd*-gnu | kopensolaris*-gnu) tmp_diet=no if test linux-dietlibc = "$host_os"; then case $cc_basename in diet\ *) tmp_diet=yes;; # linux-dietlibc with static linking (!diet-dyn) esac fi if $LD --help 2>&1 | $EGREP ': supported targets:.* elf' > /dev/null \ && test no = "$tmp_diet" then tmp_addflag=' $pic_flag' tmp_sharedflag='-shared' case $cc_basename,$host_cpu in pgcc*) # Portland Group C compiler whole_archive_flag_spec='$wl--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' tmp_addflag=' $pic_flag' ;; pgf77* | pgf90* | pgf95* | pgfortran*) # Portland Group f77 and f90 compilers whole_archive_flag_spec='$wl--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' tmp_addflag=' $pic_flag -Mnomain' ;; ecc*,ia64* | icc*,ia64*) # Intel C compiler on ia64 tmp_addflag=' -i_dynamic' ;; efc*,ia64* | ifort*,ia64*) # Intel Fortran compiler on ia64 tmp_addflag=' -i_dynamic -nofor_main' ;; ifc* | ifort*) # Intel Fortran compiler tmp_addflag=' -nofor_main' ;; lf95*) # Lahey Fortran 8.1 whole_archive_flag_spec= tmp_sharedflag='--shared' ;; nagfor*) # NAGFOR 5.3 tmp_sharedflag='-Wl,-shared' ;; xl[cC]* | bgxl[cC]* | mpixl[cC]*) # IBM XL C 8.0 on PPC (deal with xlf below) tmp_sharedflag='-qmkshrobj' tmp_addflag= ;; nvcc*) # Cuda Compiler Driver 2.2 whole_archive_flag_spec='$wl--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' compiler_needs_object=yes ;; esac case `$CC -V 2>&1 | sed 5q` in *Sun\ C*) # Sun C 5.9 whole_archive_flag_spec='$wl--whole-archive`new_convenience=; for conv in $convenience\"\"; do test -z \"$conv\" || new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' compiler_needs_object=yes tmp_sharedflag='-G' ;; *Sun\ F*) # Sun Fortran 8.3 tmp_sharedflag='-G' ;; esac archive_cmds='$CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' if test yes = "$supports_anon_versioning"; then archive_expsym_cmds='echo "{ global:" > $output_objdir/$libname.ver~ cat $export_symbols | sed -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~ echo "local: *; };" >> $output_objdir/$libname.ver~ $CC '"$tmp_sharedflag""$tmp_addflag"' $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-version-script $wl$output_objdir/$libname.ver -o $lib' fi case $cc_basename in tcc*) export_dynamic_flag_spec='-rdynamic' ;; xlf* | bgf* | bgxlf* | mpixlf*) # IBM XL Fortran 10.1 on PPC cannot create shared libs itself whole_archive_flag_spec='--whole-archive$convenience --no-whole-archive' hardcode_libdir_flag_spec='$wl-rpath $wl$libdir' archive_cmds='$LD -shared $libobjs $deplibs $linker_flags -soname $soname -o $lib' if test yes = "$supports_anon_versioning"; then archive_expsym_cmds='echo "{ global:" > $output_objdir/$libname.ver~ cat $export_symbols | sed -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~ echo "local: *; };" >> $output_objdir/$libname.ver~ $LD -shared $libobjs $deplibs $linker_flags -soname $soname -version-script $output_objdir/$libname.ver -o $lib' fi ;; esac else ld_shlibs=no fi ;; netbsd* | netbsdelf*-gnu) if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then archive_cmds='$LD -Bshareable $libobjs $deplibs $linker_flags -o $lib' wlarc= else archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' archive_expsym_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' fi ;; solaris*) if $LD -v 2>&1 | $GREP 'BFD 2\.8' > /dev/null; then ld_shlibs=no cat <<_LT_EOF 1>&2 *** Warning: The releases 2.8.* of the GNU linker cannot reliably *** create shared libraries on Solaris systems. Therefore, libtool *** is disabling shared libraries support. We urge you to upgrade GNU *** binutils to release 2.9.1 or newer. Another option is to modify *** your PATH or compiler configuration so that the native linker is *** used, and then restart. _LT_EOF elif $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' archive_expsym_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' else ld_shlibs=no fi ;; sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX*) case `$LD -v 2>&1` in *\ [01].* | *\ 2.[0-9].* | *\ 2.1[0-5].*) ld_shlibs=no cat <<_LT_EOF 1>&2 *** Warning: Releases of the GNU linker prior to 2.16.91.0.3 cannot *** reliably create shared libraries on SCO systems. Therefore, libtool *** is disabling shared libraries support. We urge you to upgrade GNU *** binutils to release 2.16.91.0.3 or newer. Another option is to modify *** your PATH or compiler configuration so that the native linker is *** used, and then restart. _LT_EOF ;; *) # For security reasons, it is highly recommended that you always # use absolute paths for naming shared libraries, and exclude the # DT_RUNPATH tag from executables and libraries. But doing so # requires that you compile everything twice, which is a pain. if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then hardcode_libdir_flag_spec='$wl-rpath $wl$libdir' archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' archive_expsym_cmds='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' else ld_shlibs=no fi ;; esac ;; sunos4*) archive_cmds='$LD -assert pure-text -Bshareable -o $lib $libobjs $deplibs $linker_flags' wlarc= hardcode_direct=yes hardcode_shlibpath_var=no ;; *) if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' archive_expsym_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' else ld_shlibs=no fi ;; esac if test no = "$ld_shlibs"; then runpath_var= hardcode_libdir_flag_spec= export_dynamic_flag_spec= whole_archive_flag_spec= fi else # PORTME fill in a description of your system's linker (not GNU ld) case $host_os in aix3*) allow_undefined_flag=unsupported always_export_symbols=yes archive_expsym_cmds='$LD -o $output_objdir/$soname $libobjs $deplibs $linker_flags -bE:$export_symbols -T512 -H512 -bM:SRE~$AR $AR_FLAGS $lib $output_objdir/$soname' # Note: this linker hardcodes the directories in LIBPATH if there # are no directories specified by -L. hardcode_minus_L=yes if test yes = "$GCC" && test -z "$lt_prog_compiler_static"; then # Neither direct hardcoding nor static linking is supported with a # broken collect2. hardcode_direct=unsupported fi ;; aix[4-9]*) if test ia64 = "$host_cpu"; then # On IA64, the linker does run time linking by default, so we don't # have to do anything special. aix_use_runtimelinking=no exp_sym_flag='-Bexport' no_entry_flag= else # If we're using GNU nm, then we don't want the "-C" option. # -C means demangle to GNU nm, but means don't demangle to AIX nm. # Without the "-l" option, or with the "-B" option, AIX nm treats # weak defined symbols like other global defined symbols, whereas # GNU nm marks them as "W". # While the 'weak' keyword is ignored in the Export File, we need # it in the Import File for the 'aix-soname' feature, so we have # to replace the "-B" option with "-P" for AIX nm. if $NM -V 2>&1 | $GREP 'GNU' > /dev/null; then export_symbols_cmds='$NM -Bpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W")) && (substr(\$ 3,1,1) != ".")) { if (\$ 2 == "W") { print \$ 3 " weak" } else { print \$ 3 } } }'\'' | sort -u > $export_symbols' else export_symbols_cmds='`func_echo_all $NM | $SED -e '\''s/B\([^B]*\)$/P\1/'\''` -PCpgl $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) && (substr(\$ 1,1,1) != ".")) { if ((\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) { print \$ 1 " weak" } else { print \$ 1 } } }'\'' | sort -u > $export_symbols' fi aix_use_runtimelinking=no # Test if we are trying to use run time linking or normal # AIX style linking. If -brtl is somewhere in LDFLAGS, we # have runtime linking enabled, and use it for executables. # For shared libraries, we enable/disable runtime linking # depending on the kind of the shared library created - # when "with_aix_soname,aix_use_runtimelinking" is: # "aix,no" lib.a(lib.so.V) shared, rtl:no, for executables # "aix,yes" lib.so shared, rtl:yes, for executables # lib.a static archive # "both,no" lib.so.V(shr.o) shared, rtl:yes # lib.a(lib.so.V) shared, rtl:no, for executables # "both,yes" lib.so.V(shr.o) shared, rtl:yes, for executables # lib.a(lib.so.V) shared, rtl:no # "svr4,*" lib.so.V(shr.o) shared, rtl:yes, for executables # lib.a static archive case $host_os in aix4.[23]|aix4.[23].*|aix[5-9]*) for ld_flag in $LDFLAGS; do if (test x-brtl = "x$ld_flag" || test x-Wl,-brtl = "x$ld_flag"); then aix_use_runtimelinking=yes break fi done if test svr4,no = "$with_aix_soname,$aix_use_runtimelinking"; then # With aix-soname=svr4, we create the lib.so.V shared archives only, # so we don't have lib.a shared libs to link our executables. # We have to force runtime linking in this case. aix_use_runtimelinking=yes LDFLAGS="$LDFLAGS -Wl,-brtl" fi ;; esac exp_sym_flag='-bexport' no_entry_flag='-bnoentry' fi # When large executables or shared objects are built, AIX ld can # have problems creating the table of contents. If linking a library # or program results in "error TOC overflow" add -mminimal-toc to # CXXFLAGS/CFLAGS for g++/gcc. In the cases where that is not # enough to fix the problem, add -Wl,-bbigtoc to LDFLAGS. archive_cmds='' hardcode_direct=yes hardcode_direct_absolute=yes hardcode_libdir_separator=':' link_all_deplibs=yes file_list_spec='$wl-f,' case $with_aix_soname,$aix_use_runtimelinking in aix,*) ;; # traditional, no import file svr4,* | *,yes) # use import file # The Import File defines what to hardcode. hardcode_direct=no hardcode_direct_absolute=no ;; esac if test yes = "$GCC"; then case $host_os in aix4.[012]|aix4.[012].*) # We only want to do this on AIX 4.2 and lower, the check # below for broken collect2 doesn't work under 4.3+ collect2name=`$CC -print-prog-name=collect2` if test -f "$collect2name" && strings "$collect2name" | $GREP resolve_lib_name >/dev/null then # We have reworked collect2 : else # We have old collect2 hardcode_direct=unsupported # It fails to find uninstalled libraries when the uninstalled # path is not listed in the libpath. Setting hardcode_minus_L # to unsupported forces relinking hardcode_minus_L=yes hardcode_libdir_flag_spec='-L$libdir' hardcode_libdir_separator= fi ;; esac shared_flag='-shared' if test yes = "$aix_use_runtimelinking"; then shared_flag="$shared_flag "'$wl-G' fi # Need to ensure runtime linking is disabled for the traditional # shared library, or the linker may eventually find shared libraries # /with/ Import File - we do not want to mix them. shared_flag_aix='-shared' shared_flag_svr4='-shared $wl-G' else # not using gcc if test ia64 = "$host_cpu"; then # VisualAge C++, Version 5.5 for AIX 5L for IA-64, Beta 3 Release # chokes on -Wl,-G. The following line is correct: shared_flag='-G' else if test yes = "$aix_use_runtimelinking"; then shared_flag='$wl-G' else shared_flag='$wl-bM:SRE' fi shared_flag_aix='$wl-bM:SRE' shared_flag_svr4='$wl-G' fi fi export_dynamic_flag_spec='$wl-bexpall' # It seems that -bexpall does not export symbols beginning with # underscore (_), so it is better to generate a list of symbols to export. always_export_symbols=yes if test aix,yes = "$with_aix_soname,$aix_use_runtimelinking"; then # Warning - without using the other runtime loading flags (-brtl), # -berok will link without error, but may produce a broken library. allow_undefined_flag='-berok' # Determine the default libpath from the value encoded in an # empty executable. if test set = "${lt_cv_aix_libpath+set}"; then aix_libpath=$lt_cv_aix_libpath else if ${lt_cv_aix_libpath_+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : lt_aix_libpath_sed=' /Import File Strings/,/^$/ { /^0/ { s/^0 *\([^ ]*\) *$/\1/ p } }' lt_cv_aix_libpath_=`dump -H conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` # Check for a 64-bit object if we didn't find anything. if test -z "$lt_cv_aix_libpath_"; then lt_cv_aix_libpath_=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` fi fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext if test -z "$lt_cv_aix_libpath_"; then lt_cv_aix_libpath_=/usr/lib:/lib fi fi aix_libpath=$lt_cv_aix_libpath_ fi hardcode_libdir_flag_spec='$wl-blibpath:$libdir:'"$aix_libpath" archive_expsym_cmds='$CC -o $output_objdir/$soname $libobjs $deplibs $wl'$no_entry_flag' $compiler_flags `if test -n "$allow_undefined_flag"; then func_echo_all "$wl$allow_undefined_flag"; else :; fi` $wl'$exp_sym_flag:\$export_symbols' '$shared_flag else if test ia64 = "$host_cpu"; then hardcode_libdir_flag_spec='$wl-R $libdir:/usr/lib:/lib' allow_undefined_flag="-z nodefs" archive_expsym_cmds="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs '"\$wl$no_entry_flag"' $compiler_flags $wl$allow_undefined_flag '"\$wl$exp_sym_flag:\$export_symbols" else # Determine the default libpath from the value encoded in an # empty executable. if test set = "${lt_cv_aix_libpath+set}"; then aix_libpath=$lt_cv_aix_libpath else if ${lt_cv_aix_libpath_+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : lt_aix_libpath_sed=' /Import File Strings/,/^$/ { /^0/ { s/^0 *\([^ ]*\) *$/\1/ p } }' lt_cv_aix_libpath_=`dump -H conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` # Check for a 64-bit object if we didn't find anything. if test -z "$lt_cv_aix_libpath_"; then lt_cv_aix_libpath_=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` fi fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext if test -z "$lt_cv_aix_libpath_"; then lt_cv_aix_libpath_=/usr/lib:/lib fi fi aix_libpath=$lt_cv_aix_libpath_ fi hardcode_libdir_flag_spec='$wl-blibpath:$libdir:'"$aix_libpath" # Warning - without using the other run time loading flags, # -berok will link without error, but may produce a broken library. no_undefined_flag=' $wl-bernotok' allow_undefined_flag=' $wl-berok' if test yes = "$with_gnu_ld"; then # We only use this code for GNU lds that support --whole-archive. whole_archive_flag_spec='$wl--whole-archive$convenience $wl--no-whole-archive' else # Exported symbols can be pulled into shared objects from archives whole_archive_flag_spec='$convenience' fi archive_cmds_need_lc=yes archive_expsym_cmds='$RM -r $output_objdir/$realname.d~$MKDIR $output_objdir/$realname.d' # -brtl affects multiple linker settings, -berok does not and is overridden later compiler_flags_filtered='`func_echo_all "$compiler_flags " | $SED -e "s%-brtl\\([, ]\\)%-berok\\1%g"`' if test svr4 != "$with_aix_soname"; then # This is similar to how AIX traditionally builds its shared libraries. archive_expsym_cmds="$archive_expsym_cmds"'~$CC '$shared_flag_aix' -o $output_objdir/$realname.d/$soname $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$realname.d/$soname' fi if test aix != "$with_aix_soname"; then archive_expsym_cmds="$archive_expsym_cmds"'~$CC '$shared_flag_svr4' -o $output_objdir/$realname.d/$shared_archive_member_spec.o $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$STRIP -e $output_objdir/$realname.d/$shared_archive_member_spec.o~( func_echo_all "#! $soname($shared_archive_member_spec.o)"; if test shr_64 = "$shared_archive_member_spec"; then func_echo_all "# 64"; else func_echo_all "# 32"; fi; cat $export_symbols ) > $output_objdir/$realname.d/$shared_archive_member_spec.imp~$AR $AR_FLAGS $output_objdir/$soname $output_objdir/$realname.d/$shared_archive_member_spec.o $output_objdir/$realname.d/$shared_archive_member_spec.imp' else # used by -dlpreopen to get the symbols archive_expsym_cmds="$archive_expsym_cmds"'~$MV $output_objdir/$realname.d/$soname $output_objdir' fi archive_expsym_cmds="$archive_expsym_cmds"'~$RM -r $output_objdir/$realname.d' fi fi ;; amigaos*) case $host_cpu in powerpc) # see comment about AmigaOS4 .so support archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' archive_expsym_cmds='' ;; m68k) archive_cmds='$RM $output_objdir/a2ixlibrary.data~$ECHO "#define NAME $libname" > $output_objdir/a2ixlibrary.data~$ECHO "#define LIBRARY_ID 1" >> $output_objdir/a2ixlibrary.data~$ECHO "#define VERSION $major" >> $output_objdir/a2ixlibrary.data~$ECHO "#define REVISION $revision" >> $output_objdir/a2ixlibrary.data~$AR $AR_FLAGS $lib $libobjs~$RANLIB $lib~(cd $output_objdir && a2ixlibrary -32)' hardcode_libdir_flag_spec='-L$libdir' hardcode_minus_L=yes ;; esac ;; bsdi[45]*) export_dynamic_flag_spec=-rdynamic ;; cygwin* | mingw* | pw32* | cegcc*) # When not using gcc, we currently assume that we are using # Microsoft Visual C++. # hardcode_libdir_flag_spec is actually meaningless, as there is # no search path for DLLs. case $cc_basename in cl*) # Native MSVC hardcode_libdir_flag_spec=' ' allow_undefined_flag=unsupported always_export_symbols=yes file_list_spec='@' # Tell ltmain to make .lib files, not .a files. libext=lib # Tell ltmain to make .dll files, not .so files. shrext_cmds=.dll # FIXME: Setting linknames here is a bad hack. archive_cmds='$CC -o $output_objdir/$soname $libobjs $compiler_flags $deplibs -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~linknames=' archive_expsym_cmds='if test DEF = "`$SED -n -e '\''s/^[ ]*//'\'' -e '\''/^\(;.*\)*$/d'\'' -e '\''s/^\(EXPORTS\|LIBRARY\)\([ ].*\)*$/DEF/p'\'' -e q $export_symbols`" ; then cp "$export_symbols" "$output_objdir/$soname.def"; echo "$tool_output_objdir$soname.def" > "$output_objdir/$soname.exp"; else $SED -e '\''s/^/-link -EXPORT:/'\'' < $export_symbols > $output_objdir/$soname.exp; fi~ $CC -o $tool_output_objdir$soname $libobjs $compiler_flags $deplibs "@$tool_output_objdir$soname.exp" -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~ linknames=' # The linker will not automatically build a static lib if we build a DLL. # _LT_TAGVAR(old_archive_from_new_cmds, )='true' enable_shared_with_static_runtimes=yes exclude_expsyms='_NULL_IMPORT_DESCRIPTOR|_IMPORT_DESCRIPTOR_.*' export_symbols_cmds='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[BCDGRS][ ]/s/.*[ ]\([^ ]*\)/\1,DATA/'\'' | $SED -e '\''/^[AITW][ ]/s/.*[ ]//'\'' | sort | uniq > $export_symbols' # Don't use ranlib old_postinstall_cmds='chmod 644 $oldlib' postlink_cmds='lt_outputfile="@OUTPUT@"~ lt_tool_outputfile="@TOOL_OUTPUT@"~ case $lt_outputfile in *.exe|*.EXE) ;; *) lt_outputfile=$lt_outputfile.exe lt_tool_outputfile=$lt_tool_outputfile.exe ;; esac~ if test : != "$MANIFEST_TOOL" && test -f "$lt_outputfile.manifest"; then $MANIFEST_TOOL -manifest "$lt_tool_outputfile.manifest" -outputresource:"$lt_tool_outputfile" || exit 1; $RM "$lt_outputfile.manifest"; fi' ;; *) # Assume MSVC wrapper hardcode_libdir_flag_spec=' ' allow_undefined_flag=unsupported # Tell ltmain to make .lib files, not .a files. libext=lib # Tell ltmain to make .dll files, not .so files. shrext_cmds=.dll # FIXME: Setting linknames here is a bad hack. archive_cmds='$CC -o $lib $libobjs $compiler_flags `func_echo_all "$deplibs" | $SED '\''s/ -lc$//'\''` -link -dll~linknames=' # The linker will automatically build a .lib file if we build a DLL. old_archive_from_new_cmds='true' # FIXME: Should let the user specify the lib program. old_archive_cmds='lib -OUT:$oldlib$oldobjs$old_deplibs' enable_shared_with_static_runtimes=yes ;; esac ;; darwin* | rhapsody*) archive_cmds_need_lc=no hardcode_direct=no hardcode_automatic=yes hardcode_shlibpath_var=unsupported if test yes = "$lt_cv_ld_force_load"; then whole_archive_flag_spec='`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience $wl-force_load,$conv\"; done; func_echo_all \"$new_convenience\"`' else whole_archive_flag_spec='' fi link_all_deplibs=yes allow_undefined_flag=$_lt_dar_allow_undefined case $cc_basename in ifort*|nagfor*) _lt_dar_can_shared=yes ;; *) _lt_dar_can_shared=$GCC ;; esac if test yes = "$_lt_dar_can_shared"; then output_verbose_link_cmd=func_echo_all archive_cmds="\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring $_lt_dar_single_mod$_lt_dsymutil" module_cmds="\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags$_lt_dsymutil" archive_expsym_cmds="sed 's|^|_|' < \$export_symbols > \$output_objdir/\$libname-symbols.expsym~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring $_lt_dar_single_mod$_lt_dar_export_syms$_lt_dsymutil" module_expsym_cmds="sed -e 's|^|_|' < \$export_symbols > \$output_objdir/\$libname-symbols.expsym~\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags$_lt_dar_export_syms$_lt_dsymutil" else ld_shlibs=no fi ;; dgux*) archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' hardcode_libdir_flag_spec='-L$libdir' hardcode_shlibpath_var=no ;; # FreeBSD 2.2.[012] allows us to include c++rt0.o to get C++ constructor # support. Future versions do this automatically, but an explicit c++rt0.o # does not break anything, and helps significantly (at the cost of a little # extra space). freebsd2.2*) archive_cmds='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags /usr/lib/c++rt0.o' hardcode_libdir_flag_spec='-R$libdir' hardcode_direct=yes hardcode_shlibpath_var=no ;; # Unfortunately, older versions of FreeBSD 2 do not have this feature. freebsd2.*) archive_cmds='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags' hardcode_direct=yes hardcode_minus_L=yes hardcode_shlibpath_var=no ;; # FreeBSD 3 and greater uses gcc -shared to do shared libraries. freebsd* | dragonfly*) archive_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' hardcode_libdir_flag_spec='-R$libdir' hardcode_direct=yes hardcode_shlibpath_var=no ;; hpux9*) if test yes = "$GCC"; then archive_cmds='$RM $output_objdir/$soname~$CC -shared $pic_flag $wl+b $wl$install_libdir -o $output_objdir/$soname $libobjs $deplibs $compiler_flags~test "x$output_objdir/$soname" = "x$lib" || mv $output_objdir/$soname $lib' else archive_cmds='$RM $output_objdir/$soname~$LD -b +b $install_libdir -o $output_objdir/$soname $libobjs $deplibs $linker_flags~test "x$output_objdir/$soname" = "x$lib" || mv $output_objdir/$soname $lib' fi hardcode_libdir_flag_spec='$wl+b $wl$libdir' hardcode_libdir_separator=: hardcode_direct=yes # hardcode_minus_L: Not really in the search PATH, # but as the default location of the library. hardcode_minus_L=yes export_dynamic_flag_spec='$wl-E' ;; hpux10*) if test yes,no = "$GCC,$with_gnu_ld"; then archive_cmds='$CC -shared $pic_flag $wl+h $wl$soname $wl+b $wl$install_libdir -o $lib $libobjs $deplibs $compiler_flags' else archive_cmds='$LD -b +h $soname +b $install_libdir -o $lib $libobjs $deplibs $linker_flags' fi if test no = "$with_gnu_ld"; then hardcode_libdir_flag_spec='$wl+b $wl$libdir' hardcode_libdir_separator=: hardcode_direct=yes hardcode_direct_absolute=yes export_dynamic_flag_spec='$wl-E' # hardcode_minus_L: Not really in the search PATH, # but as the default location of the library. hardcode_minus_L=yes fi ;; hpux11*) if test yes,no = "$GCC,$with_gnu_ld"; then case $host_cpu in hppa*64*) archive_cmds='$CC -shared $wl+h $wl$soname -o $lib $libobjs $deplibs $compiler_flags' ;; ia64*) archive_cmds='$CC -shared $pic_flag $wl+h $wl$soname $wl+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags' ;; *) archive_cmds='$CC -shared $pic_flag $wl+h $wl$soname $wl+b $wl$install_libdir -o $lib $libobjs $deplibs $compiler_flags' ;; esac else case $host_cpu in hppa*64*) archive_cmds='$CC -b $wl+h $wl$soname -o $lib $libobjs $deplibs $compiler_flags' ;; ia64*) archive_cmds='$CC -b $wl+h $wl$soname $wl+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags' ;; *) # Older versions of the 11.00 compiler do not understand -b yet # (HP92453-01 A.11.01.20 doesn't, HP92453-01 B.11.X.35175-35176.GP does) { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $CC understands -b" >&5 $as_echo_n "checking if $CC understands -b... " >&6; } if ${lt_cv_prog_compiler__b+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_prog_compiler__b=no save_LDFLAGS=$LDFLAGS LDFLAGS="$LDFLAGS -b" echo "$lt_simple_link_test_code" > conftest.$ac_ext if (eval $ac_link 2>conftest.err) && test -s conftest$ac_exeext; then # The linker can only warn and ignore the option if not recognized # So say no if there are warnings if test -s conftest.err; then # Append any errors to the config.log. cat conftest.err 1>&5 $ECHO "$_lt_linker_boilerplate" | $SED '/^$/d' > conftest.exp $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 if diff conftest.exp conftest.er2 >/dev/null; then lt_cv_prog_compiler__b=yes fi else lt_cv_prog_compiler__b=yes fi fi $RM -r conftest* LDFLAGS=$save_LDFLAGS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler__b" >&5 $as_echo "$lt_cv_prog_compiler__b" >&6; } if test yes = "$lt_cv_prog_compiler__b"; then archive_cmds='$CC -b $wl+h $wl$soname $wl+b $wl$install_libdir -o $lib $libobjs $deplibs $compiler_flags' else archive_cmds='$LD -b +h $soname +b $install_libdir -o $lib $libobjs $deplibs $linker_flags' fi ;; esac fi if test no = "$with_gnu_ld"; then hardcode_libdir_flag_spec='$wl+b $wl$libdir' hardcode_libdir_separator=: case $host_cpu in hppa*64*|ia64*) hardcode_direct=no hardcode_shlibpath_var=no ;; *) hardcode_direct=yes hardcode_direct_absolute=yes export_dynamic_flag_spec='$wl-E' # hardcode_minus_L: Not really in the search PATH, # but as the default location of the library. hardcode_minus_L=yes ;; esac fi ;; irix5* | irix6* | nonstopux*) if test yes = "$GCC"; then archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' # Try to use the -exported_symbol ld option, if it does not # work, assume that -exports_file does not work either and # implicitly export all symbols. # This should be the same for all languages, so no per-tag cache variable. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the $host_os linker accepts -exported_symbol" >&5 $as_echo_n "checking whether the $host_os linker accepts -exported_symbol... " >&6; } if ${lt_cv_irix_exported_symbol+:} false; then : $as_echo_n "(cached) " >&6 else save_LDFLAGS=$LDFLAGS LDFLAGS="$LDFLAGS -shared $wl-exported_symbol ${wl}foo $wl-update_registry $wl/dev/null" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int foo (void) { return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : lt_cv_irix_exported_symbol=yes else lt_cv_irix_exported_symbol=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$save_LDFLAGS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_irix_exported_symbol" >&5 $as_echo "$lt_cv_irix_exported_symbol" >&6; } if test yes = "$lt_cv_irix_exported_symbol"; then archive_expsym_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations $wl-exports_file $wl$export_symbols -o $lib' fi link_all_deplibs=no else archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' archive_expsym_cmds='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -exports_file $export_symbols -o $lib' fi archive_cmds_need_lc='no' hardcode_libdir_flag_spec='$wl-rpath $wl$libdir' hardcode_libdir_separator=: inherit_rpath=yes link_all_deplibs=yes ;; linux*) case $cc_basename in tcc*) # Fabrice Bellard et al's Tiny C Compiler ld_shlibs=yes archive_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' ;; esac ;; netbsd* | netbsdelf*-gnu) if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then archive_cmds='$LD -Bshareable -o $lib $libobjs $deplibs $linker_flags' # a.out else archive_cmds='$LD -shared -o $lib $libobjs $deplibs $linker_flags' # ELF fi hardcode_libdir_flag_spec='-R$libdir' hardcode_direct=yes hardcode_shlibpath_var=no ;; newsos6) archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' hardcode_direct=yes hardcode_libdir_flag_spec='$wl-rpath $wl$libdir' hardcode_libdir_separator=: hardcode_shlibpath_var=no ;; *nto* | *qnx*) ;; openbsd* | bitrig*) if test -f /usr/libexec/ld.so; then hardcode_direct=yes hardcode_shlibpath_var=no hardcode_direct_absolute=yes if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`"; then archive_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags $wl-retain-symbols-file,$export_symbols' hardcode_libdir_flag_spec='$wl-rpath,$libdir' export_dynamic_flag_spec='$wl-E' else archive_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' hardcode_libdir_flag_spec='$wl-rpath,$libdir' fi else ld_shlibs=no fi ;; os2*) hardcode_libdir_flag_spec='-L$libdir' hardcode_minus_L=yes allow_undefined_flag=unsupported shrext_cmds=.dll archive_cmds='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ $ECHO EXPORTS >> $output_objdir/$libname.def~ emxexp $libobjs | $SED /"_DLL_InitTerm"/d >> $output_objdir/$libname.def~ $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ emximp -o $lib $output_objdir/$libname.def' archive_expsym_cmds='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ $ECHO EXPORTS >> $output_objdir/$libname.def~ prefix_cmds="$SED"~ if test EXPORTS = "`$SED 1q $export_symbols`"; then prefix_cmds="$prefix_cmds -e 1d"; fi~ prefix_cmds="$prefix_cmds -e \"s/^\(.*\)$/_\1/g\""~ cat $export_symbols | $prefix_cmds >> $output_objdir/$libname.def~ $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ emximp -o $lib $output_objdir/$libname.def' old_archive_From_new_cmds='emximp -o $output_objdir/${libname}_dll.a $output_objdir/$libname.def' enable_shared_with_static_runtimes=yes ;; osf3*) if test yes = "$GCC"; then allow_undefined_flag=' $wl-expect_unresolved $wl\*' archive_cmds='$CC -shared$allow_undefined_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' else allow_undefined_flag=' -expect_unresolved \*' archive_cmds='$CC -shared$allow_undefined_flag $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' fi archive_cmds_need_lc='no' hardcode_libdir_flag_spec='$wl-rpath $wl$libdir' hardcode_libdir_separator=: ;; osf4* | osf5*) # as osf3* with the addition of -msym flag if test yes = "$GCC"; then allow_undefined_flag=' $wl-expect_unresolved $wl\*' archive_cmds='$CC -shared$allow_undefined_flag $pic_flag $libobjs $deplibs $compiler_flags $wl-msym $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' hardcode_libdir_flag_spec='$wl-rpath $wl$libdir' else allow_undefined_flag=' -expect_unresolved \*' archive_cmds='$CC -shared$allow_undefined_flag $libobjs $deplibs $compiler_flags -msym -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' archive_expsym_cmds='for i in `cat $export_symbols`; do printf "%s %s\\n" -exported_symbol "\$i" >> $lib.exp; done; printf "%s\\n" "-hidden">> $lib.exp~ $CC -shared$allow_undefined_flag $wl-input $wl$lib.exp $compiler_flags $libobjs $deplibs -soname $soname `test -n "$verstring" && $ECHO "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib~$RM $lib.exp' # Both c and cxx compiler support -rpath directly hardcode_libdir_flag_spec='-rpath $libdir' fi archive_cmds_need_lc='no' hardcode_libdir_separator=: ;; solaris*) no_undefined_flag=' -z defs' if test yes = "$GCC"; then wlarc='$wl' archive_cmds='$CC -shared $pic_flag $wl-z ${wl}text $wl-h $wl$soname -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ $CC -shared $pic_flag $wl-z ${wl}text $wl-M $wl$lib.exp $wl-h $wl$soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp' else case `$CC -V 2>&1` in *"Compilers 5.0"*) wlarc='' archive_cmds='$LD -G$allow_undefined_flag -h $soname -o $lib $libobjs $deplibs $linker_flags' archive_expsym_cmds='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ $LD -G$allow_undefined_flag -M $lib.exp -h $soname -o $lib $libobjs $deplibs $linker_flags~$RM $lib.exp' ;; *) wlarc='$wl' archive_cmds='$CC -G$allow_undefined_flag -h $soname -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ $CC -G$allow_undefined_flag -M $lib.exp -h $soname -o $lib $libobjs $deplibs $compiler_flags~$RM $lib.exp' ;; esac fi hardcode_libdir_flag_spec='-R$libdir' hardcode_shlibpath_var=no case $host_os in solaris2.[0-5] | solaris2.[0-5].*) ;; *) # The compiler driver will combine and reorder linker options, # but understands '-z linker_flag'. GCC discards it without '$wl', # but is careful enough not to reorder. # Supported since Solaris 2.6 (maybe 2.5.1?) if test yes = "$GCC"; then whole_archive_flag_spec='$wl-z ${wl}allextract$convenience $wl-z ${wl}defaultextract' else whole_archive_flag_spec='-z allextract$convenience -z defaultextract' fi ;; esac link_all_deplibs=yes ;; sunos4*) if test sequent = "$host_vendor"; then # Use $CC to link under sequent, because it throws in some extra .o # files that make .init and .fini sections work. archive_cmds='$CC -G $wl-h $soname -o $lib $libobjs $deplibs $compiler_flags' else archive_cmds='$LD -assert pure-text -Bstatic -o $lib $libobjs $deplibs $linker_flags' fi hardcode_libdir_flag_spec='-L$libdir' hardcode_direct=yes hardcode_minus_L=yes hardcode_shlibpath_var=no ;; sysv4) case $host_vendor in sni) archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' hardcode_direct=yes # is this really true??? ;; siemens) ## LD is ld it makes a PLAMLIB ## CC just makes a GrossModule. archive_cmds='$LD -G -o $lib $libobjs $deplibs $linker_flags' reload_cmds='$CC -r -o $output$reload_objs' hardcode_direct=no ;; motorola) archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' hardcode_direct=no #Motorola manual says yes, but my tests say they lie ;; esac runpath_var='LD_RUN_PATH' hardcode_shlibpath_var=no ;; sysv4.3*) archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' hardcode_shlibpath_var=no export_dynamic_flag_spec='-Bexport' ;; sysv4*MP*) if test -d /usr/nec; then archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' hardcode_shlibpath_var=no runpath_var=LD_RUN_PATH hardcode_runpath_var=yes ld_shlibs=yes fi ;; sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[01].[10]* | unixware7* | sco3.2v5.0.[024]*) no_undefined_flag='$wl-z,text' archive_cmds_need_lc=no hardcode_shlibpath_var=no runpath_var='LD_RUN_PATH' if test yes = "$GCC"; then archive_cmds='$CC -shared $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds='$CC -shared $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' else archive_cmds='$CC -G $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds='$CC -G $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' fi ;; sysv5* | sco3.2v5* | sco5v6*) # Note: We CANNOT use -z defs as we might desire, because we do not # link with -lc, and that would cause any symbols used from libc to # always be unresolved, which means just about no library would # ever link correctly. If we're not using GNU ld we use -z text # though, which does catch some bad symbols but isn't as heavy-handed # as -z defs. no_undefined_flag='$wl-z,text' allow_undefined_flag='$wl-z,nodefs' archive_cmds_need_lc=no hardcode_shlibpath_var=no hardcode_libdir_flag_spec='$wl-R,$libdir' hardcode_libdir_separator=':' link_all_deplibs=yes export_dynamic_flag_spec='$wl-Bexport' runpath_var='LD_RUN_PATH' if test yes = "$GCC"; then archive_cmds='$CC -shared $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds='$CC -shared $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' else archive_cmds='$CC -G $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds='$CC -G $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' fi ;; uts4*) archive_cmds='$LD -G -h $soname -o $lib $libobjs $deplibs $linker_flags' hardcode_libdir_flag_spec='-L$libdir' hardcode_shlibpath_var=no ;; *) ld_shlibs=no ;; esac if test sni = "$host_vendor"; then case $host in sysv4 | sysv4.2uw2* | sysv4.3* | sysv5*) export_dynamic_flag_spec='$wl-Blargedynsym' ;; esac fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ld_shlibs" >&5 $as_echo "$ld_shlibs" >&6; } test no = "$ld_shlibs" && can_build_shared=no with_gnu_ld=$with_gnu_ld # # Do we need to explicitly link libc? # case "x$archive_cmds_need_lc" in x|xyes) # Assume -lc should be added archive_cmds_need_lc=yes if test yes,yes = "$GCC,$enable_shared"; then case $archive_cmds in *'~'*) # FIXME: we may have to deal with multi-command sequences. ;; '$CC '*) # Test whether the compiler implicitly links with -lc since on some # systems, -lgcc has to come before -lc. If gcc already passes -lc # to ld, don't add -lc before -lgcc. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether -lc should be explicitly linked in" >&5 $as_echo_n "checking whether -lc should be explicitly linked in... " >&6; } if ${lt_cv_archive_cmds_need_lc+:} false; then : $as_echo_n "(cached) " >&6 else $RM conftest* echo "$lt_simple_compile_test_code" > conftest.$ac_ext if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 (eval $ac_compile) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } 2>conftest.err; then soname=conftest lib=conftest libobjs=conftest.$ac_objext deplibs= wl=$lt_prog_compiler_wl pic_flag=$lt_prog_compiler_pic compiler_flags=-v linker_flags=-v verstring= output_objdir=. libname=conftest lt_save_allow_undefined_flag=$allow_undefined_flag allow_undefined_flag= if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$archive_cmds 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1\""; } >&5 (eval $archive_cmds 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then lt_cv_archive_cmds_need_lc=no else lt_cv_archive_cmds_need_lc=yes fi allow_undefined_flag=$lt_save_allow_undefined_flag else cat conftest.err 1>&5 fi $RM conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_archive_cmds_need_lc" >&5 $as_echo "$lt_cv_archive_cmds_need_lc" >&6; } archive_cmds_need_lc=$lt_cv_archive_cmds_need_lc ;; esac fi ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking dynamic linker characteristics" >&5 $as_echo_n "checking dynamic linker characteristics... " >&6; } if test yes = "$GCC"; then case $host_os in darwin*) lt_awk_arg='/^libraries:/,/LR/' ;; *) lt_awk_arg='/^libraries:/' ;; esac case $host_os in mingw* | cegcc*) lt_sed_strip_eq='s|=\([A-Za-z]:\)|\1|g' ;; *) lt_sed_strip_eq='s|=/|/|g' ;; esac lt_search_path_spec=`$CC -print-search-dirs | awk $lt_awk_arg | $SED -e "s/^libraries://" -e $lt_sed_strip_eq` case $lt_search_path_spec in *\;*) # if the path contains ";" then we assume it to be the separator # otherwise default to the standard path separator (i.e. ":") - it is # assumed that no part of a normal pathname contains ";" but that should # okay in the real world where ";" in dirpaths is itself problematic. lt_search_path_spec=`$ECHO "$lt_search_path_spec" | $SED 's/;/ /g'` ;; *) lt_search_path_spec=`$ECHO "$lt_search_path_spec" | $SED "s/$PATH_SEPARATOR/ /g"` ;; esac # Ok, now we have the path, separated by spaces, we can step through it # and add multilib dir if necessary... lt_tmp_lt_search_path_spec= lt_multi_os_dir=/`$CC $CPPFLAGS $CFLAGS $LDFLAGS -print-multi-os-directory 2>/dev/null` # ...but if some path component already ends with the multilib dir we assume # that all is fine and trust -print-search-dirs as is (GCC 4.2? or newer). case "$lt_multi_os_dir; $lt_search_path_spec " in "/; "* | "/.; "* | "/./; "* | *"$lt_multi_os_dir "* | *"$lt_multi_os_dir/ "*) lt_multi_os_dir= ;; esac for lt_sys_path in $lt_search_path_spec; do if test -d "$lt_sys_path$lt_multi_os_dir"; then lt_tmp_lt_search_path_spec="$lt_tmp_lt_search_path_spec $lt_sys_path$lt_multi_os_dir" elif test -n "$lt_multi_os_dir"; then test -d "$lt_sys_path" && \ lt_tmp_lt_search_path_spec="$lt_tmp_lt_search_path_spec $lt_sys_path" fi done lt_search_path_spec=`$ECHO "$lt_tmp_lt_search_path_spec" | awk ' BEGIN {RS = " "; FS = "/|\n";} { lt_foo = ""; lt_count = 0; for (lt_i = NF; lt_i > 0; lt_i--) { if ($lt_i != "" && $lt_i != ".") { if ($lt_i == "..") { lt_count++; } else { if (lt_count == 0) { lt_foo = "/" $lt_i lt_foo; } else { lt_count--; } } } } if (lt_foo != "") { lt_freq[lt_foo]++; } if (lt_freq[lt_foo] == 1) { print lt_foo; } }'` # AWK program above erroneously prepends '/' to C:/dos/paths # for these hosts. case $host_os in mingw* | cegcc*) lt_search_path_spec=`$ECHO "$lt_search_path_spec" |\ $SED 's|/\([A-Za-z]:\)|\1|g'` ;; esac sys_lib_search_path_spec=`$ECHO "$lt_search_path_spec" | $lt_NL2SP` else sys_lib_search_path_spec="/lib /usr/lib /usr/local/lib" fi library_names_spec= libname_spec='lib$name' soname_spec= shrext_cmds=.so postinstall_cmds= postuninstall_cmds= finish_cmds= finish_eval= shlibpath_var= shlibpath_overrides_runpath=unknown version_type=none dynamic_linker="$host_os ld.so" sys_lib_dlsearch_path_spec="/lib /usr/lib" need_lib_prefix=unknown hardcode_into_libs=no # when you set need_version to no, make sure it does not cause -set_version # flags to be left without arguments need_version=unknown case $host_os in aix3*) version_type=linux # correct to gnu/linux during the next big refactor library_names_spec='$libname$release$shared_ext$versuffix $libname.a' shlibpath_var=LIBPATH # AIX 3 has no versioning support, so we append a major version to the name. soname_spec='$libname$release$shared_ext$major' ;; aix[4-9]*) version_type=linux # correct to gnu/linux during the next big refactor need_lib_prefix=no need_version=no hardcode_into_libs=yes if test ia64 = "$host_cpu"; then # AIX 5 supports IA64 library_names_spec='$libname$release$shared_ext$major $libname$release$shared_ext$versuffix $libname$shared_ext' shlibpath_var=LD_LIBRARY_PATH else # With GCC up to 2.95.x, collect2 would create an import file # for dependence libraries. The import file would start with # the line '#! .'. This would cause the generated library to # depend on '.', always an invalid library. This was fixed in # development snapshots of GCC prior to 3.0. case $host_os in aix4 | aix4.[01] | aix4.[01].*) if { echo '#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 97)' echo ' yes ' echo '#endif'; } | $CC -E - | $GREP yes > /dev/null; then : else can_build_shared=no fi ;; esac # Using Import Files as archive members, it is possible to support # filename-based versioning of shared library archives on AIX. While # this would work for both with and without runtime linking, it will # prevent static linking of such archives. So we do filename-based # shared library versioning with .so extension only, which is used # when both runtime linking and shared linking is enabled. # Unfortunately, runtime linking may impact performance, so we do # not want this to be the default eventually. Also, we use the # versioned .so libs for executables only if there is the -brtl # linker flag in LDFLAGS as well, or --with-aix-soname=svr4 only. # To allow for filename-based versioning support, we need to create # libNAME.so.V as an archive file, containing: # *) an Import File, referring to the versioned filename of the # archive as well as the shared archive member, telling the # bitwidth (32 or 64) of that shared object, and providing the # list of exported symbols of that shared object, eventually # decorated with the 'weak' keyword # *) the shared object with the F_LOADONLY flag set, to really avoid # it being seen by the linker. # At run time we better use the real file rather than another symlink, # but for link time we create the symlink libNAME.so -> libNAME.so.V case $with_aix_soname,$aix_use_runtimelinking in # AIX (on Power*) has no versioning support, so currently we cannot hardcode correct # soname into executable. Probably we can add versioning support to # collect2, so additional links can be useful in future. aix,yes) # traditional libtool dynamic_linker='AIX unversionable lib.so' # If using run time linking (on AIX 4.2 or later) use lib.so # instead of lib.a to let people know that these are not # typical AIX shared libraries. library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' ;; aix,no) # traditional AIX only dynamic_linker='AIX lib.a(lib.so.V)' # We preserve .a as extension for shared libraries through AIX4.2 # and later when we are not doing run time linking. library_names_spec='$libname$release.a $libname.a' soname_spec='$libname$release$shared_ext$major' ;; svr4,*) # full svr4 only dynamic_linker="AIX lib.so.V($shared_archive_member_spec.o)" library_names_spec='$libname$release$shared_ext$major $libname$shared_ext' # We do not specify a path in Import Files, so LIBPATH fires. shlibpath_overrides_runpath=yes ;; *,yes) # both, prefer svr4 dynamic_linker="AIX lib.so.V($shared_archive_member_spec.o), lib.a(lib.so.V)" library_names_spec='$libname$release$shared_ext$major $libname$shared_ext' # unpreferred sharedlib libNAME.a needs extra handling postinstall_cmds='test -n "$linkname" || linkname="$realname"~func_stripname "" ".so" "$linkname"~$install_shared_prog "$dir/$func_stripname_result.$libext" "$destdir/$func_stripname_result.$libext"~test -z "$tstripme" || test -z "$striplib" || $striplib "$destdir/$func_stripname_result.$libext"' postuninstall_cmds='for n in $library_names $old_library; do :; done~func_stripname "" ".so" "$n"~test "$func_stripname_result" = "$n" || func_append rmfiles " $odir/$func_stripname_result.$libext"' # We do not specify a path in Import Files, so LIBPATH fires. shlibpath_overrides_runpath=yes ;; *,no) # both, prefer aix dynamic_linker="AIX lib.a(lib.so.V), lib.so.V($shared_archive_member_spec.o)" library_names_spec='$libname$release.a $libname.a' soname_spec='$libname$release$shared_ext$major' # unpreferred sharedlib libNAME.so.V and symlink libNAME.so need extra handling postinstall_cmds='test -z "$dlname" || $install_shared_prog $dir/$dlname $destdir/$dlname~test -z "$tstripme" || test -z "$striplib" || $striplib $destdir/$dlname~test -n "$linkname" || linkname=$realname~func_stripname "" ".a" "$linkname"~(cd "$destdir" && $LN_S -f $dlname $func_stripname_result.so)' postuninstall_cmds='test -z "$dlname" || func_append rmfiles " $odir/$dlname"~for n in $old_library $library_names; do :; done~func_stripname "" ".a" "$n"~func_append rmfiles " $odir/$func_stripname_result.so"' ;; esac shlibpath_var=LIBPATH fi ;; amigaos*) case $host_cpu in powerpc) # Since July 2007 AmigaOS4 officially supports .so libraries. # When compiling the executable, add -use-dynld -Lsobjs: to the compileline. library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' ;; m68k) library_names_spec='$libname.ixlibrary $libname.a' # Create ${libname}_ixlibrary.a entries in /sys/libs. finish_eval='for lib in `ls $libdir/*.ixlibrary 2>/dev/null`; do libname=`func_echo_all "$lib" | $SED '\''s%^.*/\([^/]*\)\.ixlibrary$%\1%'\''`; $RM /sys/libs/${libname}_ixlibrary.a; $show "cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a"; cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a || exit 1; done' ;; esac ;; beos*) library_names_spec='$libname$shared_ext' dynamic_linker="$host_os ld.so" shlibpath_var=LIBRARY_PATH ;; bsdi[45]*) version_type=linux # correct to gnu/linux during the next big refactor need_version=no library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' finish_cmds='PATH="\$PATH:/sbin" ldconfig $libdir' shlibpath_var=LD_LIBRARY_PATH sys_lib_search_path_spec="/shlib /usr/lib /usr/X11/lib /usr/contrib/lib /lib /usr/local/lib" sys_lib_dlsearch_path_spec="/shlib /usr/lib /usr/local/lib" # the default ld.so.conf also contains /usr/contrib/lib and # /usr/X11R6/lib (/usr/X11 is a link to /usr/X11R6), but let us allow # libtool to hard-code these into programs ;; cygwin* | mingw* | pw32* | cegcc*) version_type=windows shrext_cmds=.dll need_version=no need_lib_prefix=no case $GCC,$cc_basename in yes,*) # gcc library_names_spec='$libname.dll.a' # DLL is installed to $(libdir)/../bin by postinstall_cmds postinstall_cmds='base_file=`basename \$file`~ dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\$base_file'\''i; echo \$dlname'\''`~ dldir=$destdir/`dirname \$dlpath`~ test -d \$dldir || mkdir -p \$dldir~ $install_prog $dir/$dlname \$dldir/$dlname~ chmod a+x \$dldir/$dlname~ if test -n '\''$stripme'\'' && test -n '\''$striplib'\''; then eval '\''$striplib \$dldir/$dlname'\'' || exit \$?; fi' postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~ dlpath=$dir/\$dldll~ $RM \$dlpath' shlibpath_overrides_runpath=yes case $host_os in cygwin*) # Cygwin DLLs use 'cyg' prefix rather than 'lib' soname_spec='`echo $libname | sed -e 's/^lib/cyg/'``echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' sys_lib_search_path_spec="$sys_lib_search_path_spec /usr/lib/w32api" ;; mingw* | cegcc*) # MinGW DLLs use traditional 'lib' prefix soname_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' ;; pw32*) # pw32 DLLs use 'pw' prefix rather than 'lib' library_names_spec='`echo $libname | sed -e 's/^lib/pw/'``echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' ;; esac dynamic_linker='Win32 ld.exe' ;; *,cl*) # Native MSVC libname_spec='$name' soname_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' library_names_spec='$libname.dll.lib' case $build_os in mingw*) sys_lib_search_path_spec= lt_save_ifs=$IFS IFS=';' for lt_path in $LIB do IFS=$lt_save_ifs # Let DOS variable expansion print the short 8.3 style file name. lt_path=`cd "$lt_path" 2>/dev/null && cmd //C "for %i in (".") do @echo %~si"` sys_lib_search_path_spec="$sys_lib_search_path_spec $lt_path" done IFS=$lt_save_ifs # Convert to MSYS style. sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | sed -e 's|\\\\|/|g' -e 's| \\([a-zA-Z]\\):| /\\1|g' -e 's|^ ||'` ;; cygwin*) # Convert to unix form, then to dos form, then back to unix form # but this time dos style (no spaces!) so that the unix form looks # like /cygdrive/c/PROGRA~1:/cygdr... sys_lib_search_path_spec=`cygpath --path --unix "$LIB"` sys_lib_search_path_spec=`cygpath --path --dos "$sys_lib_search_path_spec" 2>/dev/null` sys_lib_search_path_spec=`cygpath --path --unix "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"` ;; *) sys_lib_search_path_spec=$LIB if $ECHO "$sys_lib_search_path_spec" | $GREP ';[c-zC-Z]:/' >/dev/null; then # It is most probably a Windows format PATH. sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e 's/;/ /g'` else sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"` fi # FIXME: find the short name or the path components, as spaces are # common. (e.g. "Program Files" -> "PROGRA~1") ;; esac # DLL is installed to $(libdir)/../bin by postinstall_cmds postinstall_cmds='base_file=`basename \$file`~ dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\$base_file'\''i; echo \$dlname'\''`~ dldir=$destdir/`dirname \$dlpath`~ test -d \$dldir || mkdir -p \$dldir~ $install_prog $dir/$dlname \$dldir/$dlname' postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~ dlpath=$dir/\$dldll~ $RM \$dlpath' shlibpath_overrides_runpath=yes dynamic_linker='Win32 link.exe' ;; *) # Assume MSVC wrapper library_names_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext $libname.lib' dynamic_linker='Win32 ld.exe' ;; esac # FIXME: first we should search . and the directory the executable is in shlibpath_var=PATH ;; darwin* | rhapsody*) dynamic_linker="$host_os dyld" version_type=darwin need_lib_prefix=no need_version=no library_names_spec='$libname$release$major$shared_ext $libname$shared_ext' soname_spec='$libname$release$major$shared_ext' shlibpath_overrides_runpath=yes shlibpath_var=DYLD_LIBRARY_PATH shrext_cmds='`test .$module = .yes && echo .so || echo .dylib`' sys_lib_search_path_spec="$sys_lib_search_path_spec /usr/local/lib" sys_lib_dlsearch_path_spec='/usr/local/lib /lib /usr/lib' ;; dgux*) version_type=linux # correct to gnu/linux during the next big refactor need_lib_prefix=no need_version=no library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' shlibpath_var=LD_LIBRARY_PATH ;; freebsd* | dragonfly*) # DragonFly does not have aout. When/if they implement a new # versioning mechanism, adjust this. if test -x /usr/bin/objformat; then objformat=`/usr/bin/objformat` else case $host_os in freebsd[23].*) objformat=aout ;; *) objformat=elf ;; esac fi version_type=freebsd-$objformat case $version_type in freebsd-elf*) library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' need_version=no need_lib_prefix=no ;; freebsd-*) library_names_spec='$libname$release$shared_ext$versuffix $libname$shared_ext$versuffix' need_version=yes ;; esac shlibpath_var=LD_LIBRARY_PATH case $host_os in freebsd2.*) shlibpath_overrides_runpath=yes ;; freebsd3.[01]* | freebsdelf3.[01]*) shlibpath_overrides_runpath=yes hardcode_into_libs=yes ;; freebsd3.[2-9]* | freebsdelf3.[2-9]* | \ freebsd4.[0-5] | freebsdelf4.[0-5] | freebsd4.1.1 | freebsdelf4.1.1) shlibpath_overrides_runpath=no hardcode_into_libs=yes ;; *) # from 4.6 on, and DragonFly shlibpath_overrides_runpath=yes hardcode_into_libs=yes ;; esac ;; haiku*) version_type=linux # correct to gnu/linux during the next big refactor need_lib_prefix=no need_version=no dynamic_linker="$host_os runtime_loader" library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' shlibpath_var=LIBRARY_PATH shlibpath_overrides_runpath=no sys_lib_dlsearch_path_spec='/boot/home/config/lib /boot/common/lib /boot/system/lib' hardcode_into_libs=yes ;; hpux9* | hpux10* | hpux11*) # Give a soname corresponding to the major version so that dld.sl refuses to # link against other versions. version_type=sunos need_lib_prefix=no need_version=no case $host_cpu in ia64*) shrext_cmds='.so' hardcode_into_libs=yes dynamic_linker="$host_os dld.so" shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes # Unless +noenvvar is specified. library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' if test 32 = "$HPUX_IA64_MODE"; then sys_lib_search_path_spec="/usr/lib/hpux32 /usr/local/lib/hpux32 /usr/local/lib" sys_lib_dlsearch_path_spec=/usr/lib/hpux32 else sys_lib_search_path_spec="/usr/lib/hpux64 /usr/local/lib/hpux64" sys_lib_dlsearch_path_spec=/usr/lib/hpux64 fi ;; hppa*64*) shrext_cmds='.sl' hardcode_into_libs=yes dynamic_linker="$host_os dld.sl" shlibpath_var=LD_LIBRARY_PATH # How should we handle SHLIB_PATH shlibpath_overrides_runpath=yes # Unless +noenvvar is specified. library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' sys_lib_search_path_spec="/usr/lib/pa20_64 /usr/ccs/lib/pa20_64" sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec ;; *) shrext_cmds='.sl' dynamic_linker="$host_os dld.sl" shlibpath_var=SHLIB_PATH shlibpath_overrides_runpath=no # +s is required to enable SHLIB_PATH library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' ;; esac # HP-UX runs *really* slowly unless shared libraries are mode 555, ... postinstall_cmds='chmod 555 $lib' # or fails outright, so override atomically: install_override_mode=555 ;; interix[3-9]*) version_type=linux # correct to gnu/linux during the next big refactor need_lib_prefix=no need_version=no library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' dynamic_linker='Interix 3.x ld.so.1 (PE, like ELF)' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no hardcode_into_libs=yes ;; irix5* | irix6* | nonstopux*) case $host_os in nonstopux*) version_type=nonstopux ;; *) if test yes = "$lt_cv_prog_gnu_ld"; then version_type=linux # correct to gnu/linux during the next big refactor else version_type=irix fi ;; esac need_lib_prefix=no need_version=no soname_spec='$libname$release$shared_ext$major' library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$release$shared_ext $libname$shared_ext' case $host_os in irix5* | nonstopux*) libsuff= shlibsuff= ;; *) case $LD in # libtool.m4 will add one of these switches to LD *-32|*"-32 "|*-melf32bsmip|*"-melf32bsmip ") libsuff= shlibsuff= libmagic=32-bit;; *-n32|*"-n32 "|*-melf32bmipn32|*"-melf32bmipn32 ") libsuff=32 shlibsuff=N32 libmagic=N32;; *-64|*"-64 "|*-melf64bmip|*"-melf64bmip ") libsuff=64 shlibsuff=64 libmagic=64-bit;; *) libsuff= shlibsuff= libmagic=never-match;; esac ;; esac shlibpath_var=LD_LIBRARY${shlibsuff}_PATH shlibpath_overrides_runpath=no sys_lib_search_path_spec="/usr/lib$libsuff /lib$libsuff /usr/local/lib$libsuff" sys_lib_dlsearch_path_spec="/usr/lib$libsuff /lib$libsuff" hardcode_into_libs=yes ;; # No shared lib support for Linux oldld, aout, or coff. linux*oldld* | linux*aout* | linux*coff*) dynamic_linker=no ;; linux*android*) version_type=none # Android doesn't support versioned libraries. need_lib_prefix=no need_version=no library_names_spec='$libname$release$shared_ext' soname_spec='$libname$release$shared_ext' finish_cmds= shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes # This implies no fast_install, which is unacceptable. # Some rework will be needed to allow for fast_install # before this can be enabled. hardcode_into_libs=yes dynamic_linker='Android linker' # Don't embed -rpath directories since the linker doesn't support them. hardcode_libdir_flag_spec='-L$libdir' ;; # This must be glibc/ELF. linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) version_type=linux # correct to gnu/linux during the next big refactor need_lib_prefix=no need_version=no library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' finish_cmds='PATH="\$PATH:/sbin" ldconfig -n $libdir' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no # Some binutils ld are patched to set DT_RUNPATH if ${lt_cv_shlibpath_overrides_runpath+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_shlibpath_overrides_runpath=no save_LDFLAGS=$LDFLAGS save_libdir=$libdir eval "libdir=/foo; wl=\"$lt_prog_compiler_wl\"; \ LDFLAGS=\"\$LDFLAGS $hardcode_libdir_flag_spec\"" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : if ($OBJDUMP -p conftest$ac_exeext) 2>/dev/null | grep "RUNPATH.*$libdir" >/dev/null; then : lt_cv_shlibpath_overrides_runpath=yes fi fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$save_LDFLAGS libdir=$save_libdir fi shlibpath_overrides_runpath=$lt_cv_shlibpath_overrides_runpath # This implies no fast_install, which is unacceptable. # Some rework will be needed to allow for fast_install # before this can be enabled. hardcode_into_libs=yes # Ideally, we could use ldconfig to report *all* directores which are # searched for libraries, however this is still not possible. Aside from not # being certain /sbin/ldconfig is available, command # 'ldconfig -N -X -v | grep ^/' on 64bit Fedora does not report /usr/lib64, # even though it is searched at run-time. Try to do the best guess by # appending ld.so.conf contents (and includes) to the search path. if test -f /etc/ld.so.conf; then lt_ld_extra=`awk '/^include / { system(sprintf("cd /etc; cat %s 2>/dev/null", \$2)); skip = 1; } { if (!skip) print \$0; skip = 0; }' < /etc/ld.so.conf | $SED -e 's/#.*//;/^[ ]*hwcap[ ]/d;s/[:, ]/ /g;s/=[^=]*$//;s/=[^= ]* / /g;s/"//g;/^$/d' | tr '\n' ' '` sys_lib_dlsearch_path_spec="/lib /usr/lib $lt_ld_extra" fi # We used to test for /lib/ld.so.1 and disable shared libraries on # powerpc, because MkLinux only supported shared libraries with the # GNU dynamic linker. Since this was broken with cross compilers, # most powerpc-linux boxes support dynamic linking these days and # people can always --disable-shared, the test was removed, and we # assume the GNU/Linux dynamic linker is in use. dynamic_linker='GNU/Linux ld.so' ;; netbsdelf*-gnu) version_type=linux need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no hardcode_into_libs=yes dynamic_linker='NetBSD ld.elf_so' ;; netbsd*) version_type=sunos need_lib_prefix=no need_version=no if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then library_names_spec='$libname$release$shared_ext$versuffix $libname$shared_ext$versuffix' finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir' dynamic_linker='NetBSD (a.out) ld.so' else library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' dynamic_linker='NetBSD ld.elf_so' fi shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes hardcode_into_libs=yes ;; newsos6) version_type=linux # correct to gnu/linux during the next big refactor library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes ;; *nto* | *qnx*) version_type=qnx need_lib_prefix=no need_version=no library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no hardcode_into_libs=yes dynamic_linker='ldqnx.so' ;; openbsd* | bitrig*) version_type=sunos sys_lib_dlsearch_path_spec=/usr/lib need_lib_prefix=no if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`"; then need_version=no else need_version=yes fi library_names_spec='$libname$release$shared_ext$versuffix $libname$shared_ext$versuffix' finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes ;; os2*) libname_spec='$name' version_type=windows shrext_cmds=.dll need_version=no need_lib_prefix=no # OS/2 can only load a DLL with a base name of 8 characters or less. soname_spec='`test -n "$os2dllname" && libname="$os2dllname"; v=$($ECHO $release$versuffix | tr -d .-); n=$($ECHO $libname | cut -b -$((8 - ${#v})) | tr . _); $ECHO $n$v`$shared_ext' library_names_spec='${libname}_dll.$libext' dynamic_linker='OS/2 ld.exe' shlibpath_var=BEGINLIBPATH sys_lib_search_path_spec="/lib /usr/lib /usr/local/lib" sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec postinstall_cmds='base_file=`basename \$file`~ dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\$base_file'\''i; $ECHO \$dlname'\''`~ dldir=$destdir/`dirname \$dlpath`~ test -d \$dldir || mkdir -p \$dldir~ $install_prog $dir/$dlname \$dldir/$dlname~ chmod a+x \$dldir/$dlname~ if test -n '\''$stripme'\'' && test -n '\''$striplib'\''; then eval '\''$striplib \$dldir/$dlname'\'' || exit \$?; fi' postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; $ECHO \$dlname'\''`~ dlpath=$dir/\$dldll~ $RM \$dlpath' ;; osf3* | osf4* | osf5*) version_type=osf need_lib_prefix=no need_version=no soname_spec='$libname$release$shared_ext$major' library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' shlibpath_var=LD_LIBRARY_PATH sys_lib_search_path_spec="/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc /usr/lib /usr/local/lib /var/shlib" sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec ;; rdos*) dynamic_linker=no ;; solaris*) version_type=linux # correct to gnu/linux during the next big refactor need_lib_prefix=no need_version=no library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes hardcode_into_libs=yes # ldd complains unless libraries are executable postinstall_cmds='chmod +x $lib' ;; sunos4*) version_type=sunos library_names_spec='$libname$release$shared_ext$versuffix $libname$shared_ext$versuffix' finish_cmds='PATH="\$PATH:/usr/etc" ldconfig $libdir' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes if test yes = "$with_gnu_ld"; then need_lib_prefix=no fi need_version=yes ;; sysv4 | sysv4.3*) version_type=linux # correct to gnu/linux during the next big refactor library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' shlibpath_var=LD_LIBRARY_PATH case $host_vendor in sni) shlibpath_overrides_runpath=no need_lib_prefix=no runpath_var=LD_RUN_PATH ;; siemens) need_lib_prefix=no ;; motorola) need_lib_prefix=no need_version=no shlibpath_overrides_runpath=no sys_lib_search_path_spec='/lib /usr/lib /usr/ccs/lib' ;; esac ;; sysv4*MP*) if test -d /usr/nec; then version_type=linux # correct to gnu/linux during the next big refactor library_names_spec='$libname$shared_ext.$versuffix $libname$shared_ext.$major $libname$shared_ext' soname_spec='$libname$shared_ext.$major' shlibpath_var=LD_LIBRARY_PATH fi ;; sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*) version_type=sco need_lib_prefix=no need_version=no library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes hardcode_into_libs=yes if test yes = "$with_gnu_ld"; then sys_lib_search_path_spec='/usr/local/lib /usr/gnu/lib /usr/ccs/lib /usr/lib /lib' else sys_lib_search_path_spec='/usr/ccs/lib /usr/lib' case $host_os in sco3.2v5*) sys_lib_search_path_spec="$sys_lib_search_path_spec /lib" ;; esac fi sys_lib_dlsearch_path_spec='/usr/lib' ;; tpf*) # TPF is a cross-target only. Preferred cross-host = GNU/Linux. version_type=linux # correct to gnu/linux during the next big refactor need_lib_prefix=no need_version=no library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no hardcode_into_libs=yes ;; uts4*) version_type=linux # correct to gnu/linux during the next big refactor library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' shlibpath_var=LD_LIBRARY_PATH ;; *) dynamic_linker=no ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: result: $dynamic_linker" >&5 $as_echo "$dynamic_linker" >&6; } test no = "$dynamic_linker" && can_build_shared=no variables_saved_for_relink="PATH $shlibpath_var $runpath_var" if test yes = "$GCC"; then variables_saved_for_relink="$variables_saved_for_relink GCC_EXEC_PREFIX COMPILER_PATH LIBRARY_PATH" fi if test set = "${lt_cv_sys_lib_search_path_spec+set}"; then sys_lib_search_path_spec=$lt_cv_sys_lib_search_path_spec fi if test set = "${lt_cv_sys_lib_dlsearch_path_spec+set}"; then sys_lib_dlsearch_path_spec=$lt_cv_sys_lib_dlsearch_path_spec fi # remember unaugmented sys_lib_dlsearch_path content for libtool script decls... configure_time_dlsearch_path=$sys_lib_dlsearch_path_spec # ... but it needs LT_SYS_LIBRARY_PATH munging for other configure-time code func_munge_path_list sys_lib_dlsearch_path_spec "$LT_SYS_LIBRARY_PATH" # to be used as default LT_SYS_LIBRARY_PATH value in generated libtool configure_time_lt_sys_library_path=$LT_SYS_LIBRARY_PATH { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to hardcode library paths into programs" >&5 $as_echo_n "checking how to hardcode library paths into programs... " >&6; } hardcode_action= if test -n "$hardcode_libdir_flag_spec" || test -n "$runpath_var" || test yes = "$hardcode_automatic"; then # We can hardcode non-existent directories. if test no != "$hardcode_direct" && # If the only mechanism to avoid hardcoding is shlibpath_var, we # have to relink, otherwise we might link with an installed library # when we should be linking with a yet-to-be-installed one ## test no != "$_LT_TAGVAR(hardcode_shlibpath_var, )" && test no != "$hardcode_minus_L"; then # Linking always hardcodes the temporary library directory. hardcode_action=relink else # We can link without hardcoding, and we can hardcode nonexisting dirs. hardcode_action=immediate fi else # We cannot hardcode anything, or else we can only hardcode existing # directories. hardcode_action=unsupported fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $hardcode_action" >&5 $as_echo "$hardcode_action" >&6; } if test relink = "$hardcode_action" || test yes = "$inherit_rpath"; then # Fast installation is not supported enable_fast_install=no elif test yes = "$shlibpath_overrides_runpath" || test no = "$enable_shared"; then # Fast installation is not necessary enable_fast_install=needless fi if test yes != "$enable_dlopen"; then enable_dlopen=unknown enable_dlopen_self=unknown enable_dlopen_self_static=unknown else lt_cv_dlopen=no lt_cv_dlopen_libs= case $host_os in beos*) lt_cv_dlopen=load_add_on lt_cv_dlopen_libs= lt_cv_dlopen_self=yes ;; mingw* | pw32* | cegcc*) lt_cv_dlopen=LoadLibrary lt_cv_dlopen_libs= ;; cygwin*) lt_cv_dlopen=dlopen lt_cv_dlopen_libs= ;; darwin*) # if libdl is installed we need to link against it { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 $as_echo_n "checking for dlopen in -ldl... " >&6; } if ${ac_cv_lib_dl_dlopen+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlopen (); int main () { return dlopen (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_dl_dlopen=yes else ac_cv_lib_dl_dlopen=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 $as_echo "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = xyes; then : lt_cv_dlopen=dlopen lt_cv_dlopen_libs=-ldl else lt_cv_dlopen=dyld lt_cv_dlopen_libs= lt_cv_dlopen_self=yes fi ;; tpf*) # Don't try to run any link tests for TPF. We know it's impossible # because TPF is a cross-compiler, and we know how we open DSOs. lt_cv_dlopen=dlopen lt_cv_dlopen_libs= lt_cv_dlopen_self=no ;; *) ac_fn_c_check_func "$LINENO" "shl_load" "ac_cv_func_shl_load" if test "x$ac_cv_func_shl_load" = xyes; then : lt_cv_dlopen=shl_load else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5 $as_echo_n "checking for shl_load in -ldld... " >&6; } if ${ac_cv_lib_dld_shl_load+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char shl_load (); int main () { return shl_load (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_dld_shl_load=yes else ac_cv_lib_dld_shl_load=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5 $as_echo "$ac_cv_lib_dld_shl_load" >&6; } if test "x$ac_cv_lib_dld_shl_load" = xyes; then : lt_cv_dlopen=shl_load lt_cv_dlopen_libs=-ldld else ac_fn_c_check_func "$LINENO" "dlopen" "ac_cv_func_dlopen" if test "x$ac_cv_func_dlopen" = xyes; then : lt_cv_dlopen=dlopen else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 $as_echo_n "checking for dlopen in -ldl... " >&6; } if ${ac_cv_lib_dl_dlopen+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlopen (); int main () { return dlopen (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_dl_dlopen=yes else ac_cv_lib_dl_dlopen=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 $as_echo "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = xyes; then : lt_cv_dlopen=dlopen lt_cv_dlopen_libs=-ldl else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -lsvld" >&5 $as_echo_n "checking for dlopen in -lsvld... " >&6; } if ${ac_cv_lib_svld_dlopen+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lsvld $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlopen (); int main () { return dlopen (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_svld_dlopen=yes else ac_cv_lib_svld_dlopen=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_svld_dlopen" >&5 $as_echo "$ac_cv_lib_svld_dlopen" >&6; } if test "x$ac_cv_lib_svld_dlopen" = xyes; then : lt_cv_dlopen=dlopen lt_cv_dlopen_libs=-lsvld else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dld_link in -ldld" >&5 $as_echo_n "checking for dld_link in -ldld... " >&6; } if ${ac_cv_lib_dld_dld_link+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dld_link (); int main () { return dld_link (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_dld_dld_link=yes else ac_cv_lib_dld_dld_link=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_dld_link" >&5 $as_echo "$ac_cv_lib_dld_dld_link" >&6; } if test "x$ac_cv_lib_dld_dld_link" = xyes; then : lt_cv_dlopen=dld_link lt_cv_dlopen_libs=-ldld fi fi fi fi fi fi ;; esac if test no = "$lt_cv_dlopen"; then enable_dlopen=no else enable_dlopen=yes fi case $lt_cv_dlopen in dlopen) save_CPPFLAGS=$CPPFLAGS test yes = "$ac_cv_header_dlfcn_h" && CPPFLAGS="$CPPFLAGS -DHAVE_DLFCN_H" save_LDFLAGS=$LDFLAGS wl=$lt_prog_compiler_wl eval LDFLAGS=\"\$LDFLAGS $export_dynamic_flag_spec\" save_LIBS=$LIBS LIBS="$lt_cv_dlopen_libs $LIBS" { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether a program can dlopen itself" >&5 $as_echo_n "checking whether a program can dlopen itself... " >&6; } if ${lt_cv_dlopen_self+:} false; then : $as_echo_n "(cached) " >&6 else if test yes = "$cross_compiling"; then : lt_cv_dlopen_self=cross else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 lt_status=$lt_dlunknown cat > conftest.$ac_ext <<_LT_EOF #line $LINENO "configure" #include "confdefs.h" #if HAVE_DLFCN_H #include #endif #include #ifdef RTLD_GLOBAL # define LT_DLGLOBAL RTLD_GLOBAL #else # ifdef DL_GLOBAL # define LT_DLGLOBAL DL_GLOBAL # else # define LT_DLGLOBAL 0 # endif #endif /* We may have to define LT_DLLAZY_OR_NOW in the command line if we find out it does not work in some platform. */ #ifndef LT_DLLAZY_OR_NOW # ifdef RTLD_LAZY # define LT_DLLAZY_OR_NOW RTLD_LAZY # else # ifdef DL_LAZY # define LT_DLLAZY_OR_NOW DL_LAZY # else # ifdef RTLD_NOW # define LT_DLLAZY_OR_NOW RTLD_NOW # else # ifdef DL_NOW # define LT_DLLAZY_OR_NOW DL_NOW # else # define LT_DLLAZY_OR_NOW 0 # endif # endif # endif # endif #endif /* When -fvisibility=hidden is used, assume the code has been annotated correspondingly for the symbols needed. */ #if defined __GNUC__ && (((__GNUC__ == 3) && (__GNUC_MINOR__ >= 3)) || (__GNUC__ > 3)) int fnord () __attribute__((visibility("default"))); #endif int fnord () { return 42; } int main () { void *self = dlopen (0, LT_DLGLOBAL|LT_DLLAZY_OR_NOW); int status = $lt_dlunknown; if (self) { if (dlsym (self,"fnord")) status = $lt_dlno_uscore; else { if (dlsym( self,"_fnord")) status = $lt_dlneed_uscore; else puts (dlerror ()); } /* dlclose (self); */ } else puts (dlerror ()); return status; } _LT_EOF if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_link\""; } >&5 (eval $ac_link) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && test -s "conftest$ac_exeext" 2>/dev/null; then (./conftest; exit; ) >&5 2>/dev/null lt_status=$? case x$lt_status in x$lt_dlno_uscore) lt_cv_dlopen_self=yes ;; x$lt_dlneed_uscore) lt_cv_dlopen_self=yes ;; x$lt_dlunknown|x*) lt_cv_dlopen_self=no ;; esac else : # compilation failed lt_cv_dlopen_self=no fi fi rm -fr conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_dlopen_self" >&5 $as_echo "$lt_cv_dlopen_self" >&6; } if test yes = "$lt_cv_dlopen_self"; then wl=$lt_prog_compiler_wl eval LDFLAGS=\"\$LDFLAGS $lt_prog_compiler_static\" { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether a statically linked program can dlopen itself" >&5 $as_echo_n "checking whether a statically linked program can dlopen itself... " >&6; } if ${lt_cv_dlopen_self_static+:} false; then : $as_echo_n "(cached) " >&6 else if test yes = "$cross_compiling"; then : lt_cv_dlopen_self_static=cross else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 lt_status=$lt_dlunknown cat > conftest.$ac_ext <<_LT_EOF #line $LINENO "configure" #include "confdefs.h" #if HAVE_DLFCN_H #include #endif #include #ifdef RTLD_GLOBAL # define LT_DLGLOBAL RTLD_GLOBAL #else # ifdef DL_GLOBAL # define LT_DLGLOBAL DL_GLOBAL # else # define LT_DLGLOBAL 0 # endif #endif /* We may have to define LT_DLLAZY_OR_NOW in the command line if we find out it does not work in some platform. */ #ifndef LT_DLLAZY_OR_NOW # ifdef RTLD_LAZY # define LT_DLLAZY_OR_NOW RTLD_LAZY # else # ifdef DL_LAZY # define LT_DLLAZY_OR_NOW DL_LAZY # else # ifdef RTLD_NOW # define LT_DLLAZY_OR_NOW RTLD_NOW # else # ifdef DL_NOW # define LT_DLLAZY_OR_NOW DL_NOW # else # define LT_DLLAZY_OR_NOW 0 # endif # endif # endif # endif #endif /* When -fvisibility=hidden is used, assume the code has been annotated correspondingly for the symbols needed. */ #if defined __GNUC__ && (((__GNUC__ == 3) && (__GNUC_MINOR__ >= 3)) || (__GNUC__ > 3)) int fnord () __attribute__((visibility("default"))); #endif int fnord () { return 42; } int main () { void *self = dlopen (0, LT_DLGLOBAL|LT_DLLAZY_OR_NOW); int status = $lt_dlunknown; if (self) { if (dlsym (self,"fnord")) status = $lt_dlno_uscore; else { if (dlsym( self,"_fnord")) status = $lt_dlneed_uscore; else puts (dlerror ()); } /* dlclose (self); */ } else puts (dlerror ()); return status; } _LT_EOF if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_link\""; } >&5 (eval $ac_link) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && test -s "conftest$ac_exeext" 2>/dev/null; then (./conftest; exit; ) >&5 2>/dev/null lt_status=$? case x$lt_status in x$lt_dlno_uscore) lt_cv_dlopen_self_static=yes ;; x$lt_dlneed_uscore) lt_cv_dlopen_self_static=yes ;; x$lt_dlunknown|x*) lt_cv_dlopen_self_static=no ;; esac else : # compilation failed lt_cv_dlopen_self_static=no fi fi rm -fr conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_dlopen_self_static" >&5 $as_echo "$lt_cv_dlopen_self_static" >&6; } fi CPPFLAGS=$save_CPPFLAGS LDFLAGS=$save_LDFLAGS LIBS=$save_LIBS ;; esac case $lt_cv_dlopen_self in yes|no) enable_dlopen_self=$lt_cv_dlopen_self ;; *) enable_dlopen_self=unknown ;; esac case $lt_cv_dlopen_self_static in yes|no) enable_dlopen_self_static=$lt_cv_dlopen_self_static ;; *) enable_dlopen_self_static=unknown ;; esac fi striplib= old_striplib= { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether stripping libraries is possible" >&5 $as_echo_n "checking whether stripping libraries is possible... " >&6; } if test -n "$STRIP" && $STRIP -V 2>&1 | $GREP "GNU strip" >/dev/null; then test -z "$old_striplib" && old_striplib="$STRIP --strip-debug" test -z "$striplib" && striplib="$STRIP --strip-unneeded" { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else # FIXME - insert some real tests, host_os isn't really good enough case $host_os in darwin*) if test -n "$STRIP"; then striplib="$STRIP -x" old_striplib="$STRIP -S" { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi ;; *) { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } ;; esac fi # Report what library types will actually be built { $as_echo "$as_me:${as_lineno-$LINENO}: checking if libtool supports shared libraries" >&5 $as_echo_n "checking if libtool supports shared libraries... " >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: result: $can_build_shared" >&5 $as_echo "$can_build_shared" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to build shared libraries" >&5 $as_echo_n "checking whether to build shared libraries... " >&6; } test no = "$can_build_shared" && enable_shared=no # On AIX, shared libraries and static libraries use the same namespace, and # are all built from PIC. case $host_os in aix3*) test yes = "$enable_shared" && enable_static=no if test -n "$RANLIB"; then archive_cmds="$archive_cmds~\$RANLIB \$lib" postinstall_cmds='$RANLIB $lib' fi ;; aix[4-9]*) if test ia64 != "$host_cpu"; then case $enable_shared,$with_aix_soname,$aix_use_runtimelinking in yes,aix,yes) ;; # shared object as lib.so file only yes,svr4,*) ;; # shared object as lib.so archive member only yes,*) enable_static=no ;; # shared object in lib.a archive as well esac fi ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: result: $enable_shared" >&5 $as_echo "$enable_shared" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to build static libraries" >&5 $as_echo_n "checking whether to build static libraries... " >&6; } # Make sure either enable_shared or enable_static is yes. test yes = "$enable_shared" || enable_static=yes { $as_echo "$as_me:${as_lineno-$LINENO}: result: $enable_static" >&5 $as_echo "$enable_static" >&6; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu CC=$lt_save_CC ac_config_commands="$ac_config_commands libtool" # Only expand once: { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to enable maintainer-specific portions of Makefiles" >&5 $as_echo_n "checking whether to enable maintainer-specific portions of Makefiles... " >&6; } # Check whether --enable-maintainer-mode was given. if test "${enable_maintainer_mode+set}" = set; then : enableval=$enable_maintainer_mode; USE_MAINTAINER_MODE=$enableval else USE_MAINTAINER_MODE=no fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $USE_MAINTAINER_MODE" >&5 $as_echo "$USE_MAINTAINER_MODE" >&6; } if test $USE_MAINTAINER_MODE = yes; then MAINTAINER_MODE_TRUE= MAINTAINER_MODE_FALSE='#' else MAINTAINER_MODE_TRUE='#' MAINTAINER_MODE_FALSE= fi MAINT=$MAINTAINER_MODE_TRUE # Check we're in the right directory ac_config_headers="$ac_config_headers config.h" # Checks for programs. ac_ext=cpp ac_cpp='$CXXCPP $CPPFLAGS' ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_cxx_compiler_gnu if test -z "$CXX"; then if test -n "$CCC"; then CXX=$CCC else if test -n "$ac_tool_prefix"; then for ac_prog in g++ c++ gpp aCC CC cxx cc++ cl.exe FCC KCC RCC xlC_r xlC do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CXX+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CXX"; then ac_cv_prog_CXX="$CXX" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CXX="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CXX=$ac_cv_prog_CXX if test -n "$CXX"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CXX" >&5 $as_echo "$CXX" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$CXX" && break done fi if test -z "$CXX"; then ac_ct_CXX=$CXX for ac_prog in g++ c++ gpp aCC CC cxx cc++ cl.exe FCC KCC RCC xlC_r xlC do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_CXX+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CXX"; then ac_cv_prog_ac_ct_CXX="$ac_ct_CXX" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CXX="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CXX=$ac_cv_prog_ac_ct_CXX if test -n "$ac_ct_CXX"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CXX" >&5 $as_echo "$ac_ct_CXX" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$ac_ct_CXX" && break done if test "x$ac_ct_CXX" = x; then CXX="g++" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CXX=$ac_ct_CXX fi fi fi fi # Provide some information about the compiler. $as_echo "$as_me:${as_lineno-$LINENO}: checking for C++ compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C++ compiler" >&5 $as_echo_n "checking whether we are using the GNU C++ compiler... " >&6; } if ${ac_cv_cxx_compiler_gnu+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_cxx_try_compile "$LINENO"; then : ac_compiler_gnu=yes else ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_cxx_compiler_gnu=$ac_compiler_gnu fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cxx_compiler_gnu" >&5 $as_echo "$ac_cv_cxx_compiler_gnu" >&6; } if test $ac_compiler_gnu = yes; then GXX=yes else GXX= fi ac_test_CXXFLAGS=${CXXFLAGS+set} ac_save_CXXFLAGS=$CXXFLAGS { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CXX accepts -g" >&5 $as_echo_n "checking whether $CXX accepts -g... " >&6; } if ${ac_cv_prog_cxx_g+:} false; then : $as_echo_n "(cached) " >&6 else ac_save_cxx_werror_flag=$ac_cxx_werror_flag ac_cxx_werror_flag=yes ac_cv_prog_cxx_g=no CXXFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_cxx_try_compile "$LINENO"; then : ac_cv_prog_cxx_g=yes else CXXFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_cxx_try_compile "$LINENO"; then : else ac_cxx_werror_flag=$ac_save_cxx_werror_flag CXXFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_cxx_try_compile "$LINENO"; then : ac_cv_prog_cxx_g=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cxx_werror_flag=$ac_save_cxx_werror_flag fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cxx_g" >&5 $as_echo "$ac_cv_prog_cxx_g" >&6; } if test "$ac_test_CXXFLAGS" = set; then CXXFLAGS=$ac_save_CXXFLAGS elif test $ac_cv_prog_cxx_g = yes; then if test "$GXX" = yes; then CXXFLAGS="-g -O2" else CXXFLAGS="-g" fi else if test "$GXX" = yes; then CXXFLAGS="-O2" else CXXFLAGS= fi fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu depcc="$CXX" am_compiler_list= { $as_echo "$as_me:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5 $as_echo_n "checking dependency style of $depcc... " >&6; } if ${am_cv_CXX_dependencies_compiler_type+:} false; then : $as_echo_n "(cached) " >&6 else if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then # We make a subdir and do the tests there. Otherwise we can end up # making bogus files that we don't know about and never remove. For # instance it was reported that on HP-UX the gcc test will end up # making a dummy file named 'D' -- because '-MD' means "put the output # in D". rm -rf conftest.dir mkdir conftest.dir # Copy depcomp to subdir because otherwise we won't find it if we're # using a relative directory. cp "$am_depcomp" conftest.dir cd conftest.dir # We will build objects and dependencies in a subdirectory because # it helps to detect inapplicable dependency modes. For instance # both Tru64's cc and ICC support -MD to output dependencies as a # side effect of compilation, but ICC will put the dependencies in # the current directory while Tru64 will put them in the object # directory. mkdir sub am_cv_CXX_dependencies_compiler_type=none if test "$am_compiler_list" = ""; then am_compiler_list=`sed -n 's/^#*\([a-zA-Z0-9]*\))$/\1/p' < ./depcomp` fi am__universal=false case " $depcc " in #( *\ -arch\ *\ -arch\ *) am__universal=true ;; esac for depmode in $am_compiler_list; do # Setup a source with many dependencies, because some compilers # like to wrap large dependency lists on column 80 (with \), and # we should not choose a depcomp mode which is confused by this. # # We need to recreate these files for each test, as the compiler may # overwrite some of them when testing with obscure command lines. # This happens at least with the AIX C compiler. : > sub/conftest.c for i in 1 2 3 4 5 6; do echo '#include "conftst'$i'.h"' >> sub/conftest.c # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with # Solaris 10 /bin/sh. echo '/* dummy */' > sub/conftst$i.h done echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf # We check with '-c' and '-o' for the sake of the "dashmstdout" # mode. It turns out that the SunPro C++ compiler does not properly # handle '-M -o', and we need to detect this. Also, some Intel # versions had trouble with output in subdirs. am__obj=sub/conftest.${OBJEXT-o} am__minus_obj="-o $am__obj" case $depmode in gcc) # This depmode causes a compiler race in universal mode. test "$am__universal" = false || continue ;; nosideeffect) # After this tag, mechanisms are not by side-effect, so they'll # only be used when explicitly requested. if test "x$enable_dependency_tracking" = xyes; then continue else break fi ;; msvc7 | msvc7msys | msvisualcpp | msvcmsys) # This compiler won't grok '-c -o', but also, the minuso test has # not run yet. These depmodes are late enough in the game, and # so weak that their functioning should not be impacted. am__obj=conftest.${OBJEXT-o} am__minus_obj= ;; none) break ;; esac if depmode=$depmode \ source=sub/conftest.c object=$am__obj \ depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ >/dev/null 2>conftest.err && grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && grep $am__obj sub/conftest.Po > /dev/null 2>&1 && ${MAKE-make} -s -f confmf > /dev/null 2>&1; then # icc doesn't choke on unknown options, it will just issue warnings # or remarks (even with -Werror). So we grep stderr for any message # that says an option was ignored or not supported. # When given -MP, icc 7.0 and 7.1 complain thusly: # icc: Command line warning: ignoring option '-M'; no argument required # The diagnosis changed in icc 8.0: # icc: Command line remark: option '-MP' not supported if (grep 'ignoring option' conftest.err || grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else am_cv_CXX_dependencies_compiler_type=$depmode break fi fi done cd .. rm -rf conftest.dir else am_cv_CXX_dependencies_compiler_type=none fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_CXX_dependencies_compiler_type" >&5 $as_echo "$am_cv_CXX_dependencies_compiler_type" >&6; } CXXDEPMODE=depmode=$am_cv_CXX_dependencies_compiler_type if test "x$enable_dependency_tracking" != xno \ && test "$am_cv_CXX_dependencies_compiler_type" = gcc3; then am__fastdepCXX_TRUE= am__fastdepCXX_FALSE='#' else am__fastdepCXX_TRUE='#' am__fastdepCXX_FALSE= fi func_stripname_cnf () { case $2 in .*) func_stripname_result=`$ECHO "$3" | $SED "s%^$1%%; s%\\\\$2\$%%"`;; *) func_stripname_result=`$ECHO "$3" | $SED "s%^$1%%; s%$2\$%%"`;; esac } # func_stripname_cnf if test -n "$CXX" && ( test no != "$CXX" && ( (test g++ = "$CXX" && `g++ -v >/dev/null 2>&1` ) || (test g++ != "$CXX"))); then ac_ext=cpp ac_cpp='$CXXCPP $CPPFLAGS' ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_cxx_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C++ preprocessor" >&5 $as_echo_n "checking how to run the C++ preprocessor... " >&6; } if test -z "$CXXCPP"; then if ${ac_cv_prog_CXXCPP+:} false; then : $as_echo_n "(cached) " >&6 else # Double quotes because CXXCPP needs to be expanded for CXXCPP in "$CXX -E" "/lib/cpp" do ac_preproc_ok=false for ac_cxx_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_cxx_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_cxx_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok; then : break fi done ac_cv_prog_CXXCPP=$CXXCPP fi CXXCPP=$ac_cv_prog_CXXCPP else ac_cv_prog_CXXCPP=$CXXCPP fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CXXCPP" >&5 $as_echo "$CXXCPP" >&6; } ac_preproc_ok=false for ac_cxx_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_cxx_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_cxx_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok; then : else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "C++ preprocessor \"$CXXCPP\" fails sanity check See \`config.log' for more details" "$LINENO" 5; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu else _lt_caught_CXX_error=yes fi ac_ext=cpp ac_cpp='$CXXCPP $CPPFLAGS' ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_cxx_compiler_gnu archive_cmds_need_lc_CXX=no allow_undefined_flag_CXX= always_export_symbols_CXX=no archive_expsym_cmds_CXX= compiler_needs_object_CXX=no export_dynamic_flag_spec_CXX= hardcode_direct_CXX=no hardcode_direct_absolute_CXX=no hardcode_libdir_flag_spec_CXX= hardcode_libdir_separator_CXX= hardcode_minus_L_CXX=no hardcode_shlibpath_var_CXX=unsupported hardcode_automatic_CXX=no inherit_rpath_CXX=no module_cmds_CXX= module_expsym_cmds_CXX= link_all_deplibs_CXX=unknown old_archive_cmds_CXX=$old_archive_cmds reload_flag_CXX=$reload_flag reload_cmds_CXX=$reload_cmds no_undefined_flag_CXX= whole_archive_flag_spec_CXX= enable_shared_with_static_runtimes_CXX=no # Source file extension for C++ test sources. ac_ext=cpp # Object file extension for compiled C++ test sources. objext=o objext_CXX=$objext # No sense in running all these tests if we already determined that # the CXX compiler isn't working. Some variables (like enable_shared) # are currently assumed to apply to all compilers on this platform, # and will be corrupted by setting them based on a non-working compiler. if test yes != "$_lt_caught_CXX_error"; then # Code to be used in simple compile tests lt_simple_compile_test_code="int some_variable = 0;" # Code to be used in simple link tests lt_simple_link_test_code='int main(int, char *[]) { return(0); }' # ltmain only uses $CC for tagged configurations so make sure $CC is set. # If no C compiler was specified, use CC. LTCC=${LTCC-"$CC"} # If no C compiler flags were specified, use CFLAGS. LTCFLAGS=${LTCFLAGS-"$CFLAGS"} # Allow CC to be a program name with arguments. compiler=$CC # save warnings/boilerplate of simple test code ac_outfile=conftest.$ac_objext echo "$lt_simple_compile_test_code" >conftest.$ac_ext eval "$ac_compile" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err _lt_compiler_boilerplate=`cat conftest.err` $RM conftest* ac_outfile=conftest.$ac_objext echo "$lt_simple_link_test_code" >conftest.$ac_ext eval "$ac_link" 2>&1 >/dev/null | $SED '/^$/d; /^ *+/d' >conftest.err _lt_linker_boilerplate=`cat conftest.err` $RM -r conftest* # Allow CC to be a program name with arguments. lt_save_CC=$CC lt_save_CFLAGS=$CFLAGS lt_save_LD=$LD lt_save_GCC=$GCC GCC=$GXX lt_save_with_gnu_ld=$with_gnu_ld lt_save_path_LD=$lt_cv_path_LD if test -n "${lt_cv_prog_gnu_ldcxx+set}"; then lt_cv_prog_gnu_ld=$lt_cv_prog_gnu_ldcxx else $as_unset lt_cv_prog_gnu_ld fi if test -n "${lt_cv_path_LDCXX+set}"; then lt_cv_path_LD=$lt_cv_path_LDCXX else $as_unset lt_cv_path_LD fi test -z "${LDCXX+set}" || LD=$LDCXX CC=${CXX-"c++"} CFLAGS=$CXXFLAGS compiler=$CC compiler_CXX=$CC func_cc_basename $compiler cc_basename=$func_cc_basename_result if test -n "$compiler"; then # We don't want -fno-exception when compiling C++ code, so set the # no_builtin_flag separately if test yes = "$GXX"; then lt_prog_compiler_no_builtin_flag_CXX=' -fno-builtin' else lt_prog_compiler_no_builtin_flag_CXX= fi if test yes = "$GXX"; then # Set up default GNU C++ configuration # Check whether --with-gnu-ld was given. if test "${with_gnu_ld+set}" = set; then : withval=$with_gnu_ld; test no = "$withval" || with_gnu_ld=yes else with_gnu_ld=no fi ac_prog=ld if test yes = "$GCC"; then # Check if gcc -print-prog-name=ld gives a path. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ld used by $CC" >&5 $as_echo_n "checking for ld used by $CC... " >&6; } case $host in *-*-mingw*) # gcc leaves a trailing carriage return, which upsets mingw ac_prog=`($CC -print-prog-name=ld) 2>&5 | tr -d '\015'` ;; *) ac_prog=`($CC -print-prog-name=ld) 2>&5` ;; esac case $ac_prog in # Accept absolute paths. [\\/]* | ?:[\\/]*) re_direlt='/[^/][^/]*/\.\./' # Canonicalize the pathname of ld ac_prog=`$ECHO "$ac_prog"| $SED 's%\\\\%/%g'` while $ECHO "$ac_prog" | $GREP "$re_direlt" > /dev/null 2>&1; do ac_prog=`$ECHO $ac_prog| $SED "s%$re_direlt%/%"` done test -z "$LD" && LD=$ac_prog ;; "") # If it fails, then pretend we aren't using GCC. ac_prog=ld ;; *) # If it is relative, then search for the first ld in PATH. with_gnu_ld=unknown ;; esac elif test yes = "$with_gnu_ld"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for GNU ld" >&5 $as_echo_n "checking for GNU ld... " >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for non-GNU ld" >&5 $as_echo_n "checking for non-GNU ld... " >&6; } fi if ${lt_cv_path_LD+:} false; then : $as_echo_n "(cached) " >&6 else if test -z "$LD"; then lt_save_ifs=$IFS; IFS=$PATH_SEPARATOR for ac_dir in $PATH; do IFS=$lt_save_ifs test -z "$ac_dir" && ac_dir=. if test -f "$ac_dir/$ac_prog" || test -f "$ac_dir/$ac_prog$ac_exeext"; then lt_cv_path_LD=$ac_dir/$ac_prog # Check to see if the program is GNU ld. I'd rather use --version, # but apparently some variants of GNU ld only accept -v. # Break only if it was the GNU/non-GNU ld that we prefer. case `"$lt_cv_path_LD" -v 2>&1 &5 $as_echo "$LD" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -z "$LD" && as_fn_error $? "no acceptable ld found in \$PATH" "$LINENO" 5 { $as_echo "$as_me:${as_lineno-$LINENO}: checking if the linker ($LD) is GNU ld" >&5 $as_echo_n "checking if the linker ($LD) is GNU ld... " >&6; } if ${lt_cv_prog_gnu_ld+:} false; then : $as_echo_n "(cached) " >&6 else # I'd rather use --version here, but apparently some GNU lds only accept -v. case `$LD -v 2>&1 &5 $as_echo "$lt_cv_prog_gnu_ld" >&6; } with_gnu_ld=$lt_cv_prog_gnu_ld # Check if GNU C++ uses GNU ld as the underlying linker, since the # archiving commands below assume that GNU ld is being used. if test yes = "$with_gnu_ld"; then archive_cmds_CXX='$CC $pic_flag -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib' archive_expsym_cmds_CXX='$CC $pic_flag -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' hardcode_libdir_flag_spec_CXX='$wl-rpath $wl$libdir' export_dynamic_flag_spec_CXX='$wl--export-dynamic' # If archive_cmds runs LD, not CC, wlarc should be empty # XXX I think wlarc can be eliminated in ltcf-cxx, but I need to # investigate it a little bit more. (MM) wlarc='$wl' # ancient GNU ld didn't support --whole-archive et. al. if eval "`$CC -print-prog-name=ld` --help 2>&1" | $GREP 'no-whole-archive' > /dev/null; then whole_archive_flag_spec_CXX=$wlarc'--whole-archive$convenience '$wlarc'--no-whole-archive' else whole_archive_flag_spec_CXX= fi else with_gnu_ld=no wlarc= # A generic and very simple default shared library creation # command for GNU C++ for the case where it uses the native # linker, instead of GNU ld. If possible, this setting should # overridden to take advantage of the native linker features on # the platform it is being used on. archive_cmds_CXX='$CC -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -o $lib' fi # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. output_verbose_link_cmd='$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP -v "^Configured with:" | $GREP "\-L"' else GXX=no with_gnu_ld=no wlarc= fi # PORTME: fill in a description of your system's C++ link characteristics { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the $compiler linker ($LD) supports shared libraries" >&5 $as_echo_n "checking whether the $compiler linker ($LD) supports shared libraries... " >&6; } ld_shlibs_CXX=yes case $host_os in aix3*) # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; aix[4-9]*) if test ia64 = "$host_cpu"; then # On IA64, the linker does run time linking by default, so we don't # have to do anything special. aix_use_runtimelinking=no exp_sym_flag='-Bexport' no_entry_flag= else aix_use_runtimelinking=no # Test if we are trying to use run time linking or normal # AIX style linking. If -brtl is somewhere in LDFLAGS, we # have runtime linking enabled, and use it for executables. # For shared libraries, we enable/disable runtime linking # depending on the kind of the shared library created - # when "with_aix_soname,aix_use_runtimelinking" is: # "aix,no" lib.a(lib.so.V) shared, rtl:no, for executables # "aix,yes" lib.so shared, rtl:yes, for executables # lib.a static archive # "both,no" lib.so.V(shr.o) shared, rtl:yes # lib.a(lib.so.V) shared, rtl:no, for executables # "both,yes" lib.so.V(shr.o) shared, rtl:yes, for executables # lib.a(lib.so.V) shared, rtl:no # "svr4,*" lib.so.V(shr.o) shared, rtl:yes, for executables # lib.a static archive case $host_os in aix4.[23]|aix4.[23].*|aix[5-9]*) for ld_flag in $LDFLAGS; do case $ld_flag in *-brtl*) aix_use_runtimelinking=yes break ;; esac done if test svr4,no = "$with_aix_soname,$aix_use_runtimelinking"; then # With aix-soname=svr4, we create the lib.so.V shared archives only, # so we don't have lib.a shared libs to link our executables. # We have to force runtime linking in this case. aix_use_runtimelinking=yes LDFLAGS="$LDFLAGS -Wl,-brtl" fi ;; esac exp_sym_flag='-bexport' no_entry_flag='-bnoentry' fi # When large executables or shared objects are built, AIX ld can # have problems creating the table of contents. If linking a library # or program results in "error TOC overflow" add -mminimal-toc to # CXXFLAGS/CFLAGS for g++/gcc. In the cases where that is not # enough to fix the problem, add -Wl,-bbigtoc to LDFLAGS. archive_cmds_CXX='' hardcode_direct_CXX=yes hardcode_direct_absolute_CXX=yes hardcode_libdir_separator_CXX=':' link_all_deplibs_CXX=yes file_list_spec_CXX='$wl-f,' case $with_aix_soname,$aix_use_runtimelinking in aix,*) ;; # no import file svr4,* | *,yes) # use import file # The Import File defines what to hardcode. hardcode_direct_CXX=no hardcode_direct_absolute_CXX=no ;; esac if test yes = "$GXX"; then case $host_os in aix4.[012]|aix4.[012].*) # We only want to do this on AIX 4.2 and lower, the check # below for broken collect2 doesn't work under 4.3+ collect2name=`$CC -print-prog-name=collect2` if test -f "$collect2name" && strings "$collect2name" | $GREP resolve_lib_name >/dev/null then # We have reworked collect2 : else # We have old collect2 hardcode_direct_CXX=unsupported # It fails to find uninstalled libraries when the uninstalled # path is not listed in the libpath. Setting hardcode_minus_L # to unsupported forces relinking hardcode_minus_L_CXX=yes hardcode_libdir_flag_spec_CXX='-L$libdir' hardcode_libdir_separator_CXX= fi esac shared_flag='-shared' if test yes = "$aix_use_runtimelinking"; then shared_flag=$shared_flag' $wl-G' fi # Need to ensure runtime linking is disabled for the traditional # shared library, or the linker may eventually find shared libraries # /with/ Import File - we do not want to mix them. shared_flag_aix='-shared' shared_flag_svr4='-shared $wl-G' else # not using gcc if test ia64 = "$host_cpu"; then # VisualAge C++, Version 5.5 for AIX 5L for IA-64, Beta 3 Release # chokes on -Wl,-G. The following line is correct: shared_flag='-G' else if test yes = "$aix_use_runtimelinking"; then shared_flag='$wl-G' else shared_flag='$wl-bM:SRE' fi shared_flag_aix='$wl-bM:SRE' shared_flag_svr4='$wl-G' fi fi export_dynamic_flag_spec_CXX='$wl-bexpall' # It seems that -bexpall does not export symbols beginning with # underscore (_), so it is better to generate a list of symbols to # export. always_export_symbols_CXX=yes if test aix,yes = "$with_aix_soname,$aix_use_runtimelinking"; then # Warning - without using the other runtime loading flags (-brtl), # -berok will link without error, but may produce a broken library. # The "-G" linker flag allows undefined symbols. no_undefined_flag_CXX='-bernotok' # Determine the default libpath from the value encoded in an empty # executable. if test set = "${lt_cv_aix_libpath+set}"; then aix_libpath=$lt_cv_aix_libpath else if ${lt_cv_aix_libpath__CXX+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_cxx_try_link "$LINENO"; then : lt_aix_libpath_sed=' /Import File Strings/,/^$/ { /^0/ { s/^0 *\([^ ]*\) *$/\1/ p } }' lt_cv_aix_libpath__CXX=`dump -H conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` # Check for a 64-bit object if we didn't find anything. if test -z "$lt_cv_aix_libpath__CXX"; then lt_cv_aix_libpath__CXX=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` fi fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext if test -z "$lt_cv_aix_libpath__CXX"; then lt_cv_aix_libpath__CXX=/usr/lib:/lib fi fi aix_libpath=$lt_cv_aix_libpath__CXX fi hardcode_libdir_flag_spec_CXX='$wl-blibpath:$libdir:'"$aix_libpath" archive_expsym_cmds_CXX='$CC -o $output_objdir/$soname $libobjs $deplibs $wl'$no_entry_flag' $compiler_flags `if test -n "$allow_undefined_flag"; then func_echo_all "$wl$allow_undefined_flag"; else :; fi` $wl'$exp_sym_flag:\$export_symbols' '$shared_flag else if test ia64 = "$host_cpu"; then hardcode_libdir_flag_spec_CXX='$wl-R $libdir:/usr/lib:/lib' allow_undefined_flag_CXX="-z nodefs" archive_expsym_cmds_CXX="\$CC $shared_flag"' -o $output_objdir/$soname $libobjs $deplibs '"\$wl$no_entry_flag"' $compiler_flags $wl$allow_undefined_flag '"\$wl$exp_sym_flag:\$export_symbols" else # Determine the default libpath from the value encoded in an # empty executable. if test set = "${lt_cv_aix_libpath+set}"; then aix_libpath=$lt_cv_aix_libpath else if ${lt_cv_aix_libpath__CXX+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_cxx_try_link "$LINENO"; then : lt_aix_libpath_sed=' /Import File Strings/,/^$/ { /^0/ { s/^0 *\([^ ]*\) *$/\1/ p } }' lt_cv_aix_libpath__CXX=`dump -H conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` # Check for a 64-bit object if we didn't find anything. if test -z "$lt_cv_aix_libpath__CXX"; then lt_cv_aix_libpath__CXX=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` fi fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext if test -z "$lt_cv_aix_libpath__CXX"; then lt_cv_aix_libpath__CXX=/usr/lib:/lib fi fi aix_libpath=$lt_cv_aix_libpath__CXX fi hardcode_libdir_flag_spec_CXX='$wl-blibpath:$libdir:'"$aix_libpath" # Warning - without using the other run time loading flags, # -berok will link without error, but may produce a broken library. no_undefined_flag_CXX=' $wl-bernotok' allow_undefined_flag_CXX=' $wl-berok' if test yes = "$with_gnu_ld"; then # We only use this code for GNU lds that support --whole-archive. whole_archive_flag_spec_CXX='$wl--whole-archive$convenience $wl--no-whole-archive' else # Exported symbols can be pulled into shared objects from archives whole_archive_flag_spec_CXX='$convenience' fi archive_cmds_need_lc_CXX=yes archive_expsym_cmds_CXX='$RM -r $output_objdir/$realname.d~$MKDIR $output_objdir/$realname.d' # -brtl affects multiple linker settings, -berok does not and is overridden later compiler_flags_filtered='`func_echo_all "$compiler_flags " | $SED -e "s%-brtl\\([, ]\\)%-berok\\1%g"`' if test svr4 != "$with_aix_soname"; then # This is similar to how AIX traditionally builds its shared # libraries. Need -bnortl late, we may have -brtl in LDFLAGS. archive_expsym_cmds_CXX="$archive_expsym_cmds_CXX"'~$CC '$shared_flag_aix' -o $output_objdir/$realname.d/$soname $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$realname.d/$soname' fi if test aix != "$with_aix_soname"; then archive_expsym_cmds_CXX="$archive_expsym_cmds_CXX"'~$CC '$shared_flag_svr4' -o $output_objdir/$realname.d/$shared_archive_member_spec.o $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$STRIP -e $output_objdir/$realname.d/$shared_archive_member_spec.o~( func_echo_all "#! $soname($shared_archive_member_spec.o)"; if test shr_64 = "$shared_archive_member_spec"; then func_echo_all "# 64"; else func_echo_all "# 32"; fi; cat $export_symbols ) > $output_objdir/$realname.d/$shared_archive_member_spec.imp~$AR $AR_FLAGS $output_objdir/$soname $output_objdir/$realname.d/$shared_archive_member_spec.o $output_objdir/$realname.d/$shared_archive_member_spec.imp' else # used by -dlpreopen to get the symbols archive_expsym_cmds_CXX="$archive_expsym_cmds_CXX"'~$MV $output_objdir/$realname.d/$soname $output_objdir' fi archive_expsym_cmds_CXX="$archive_expsym_cmds_CXX"'~$RM -r $output_objdir/$realname.d' fi fi ;; beos*) if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then allow_undefined_flag_CXX=unsupported # Joseph Beckenbach says some releases of gcc # support --undefined. This deserves some investigation. FIXME archive_cmds_CXX='$CC -nostart $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' else ld_shlibs_CXX=no fi ;; chorus*) case $cc_basename in *) # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; esac ;; cygwin* | mingw* | pw32* | cegcc*) case $GXX,$cc_basename in ,cl* | no,cl*) # Native MSVC # hardcode_libdir_flag_spec is actually meaningless, as there is # no search path for DLLs. hardcode_libdir_flag_spec_CXX=' ' allow_undefined_flag_CXX=unsupported always_export_symbols_CXX=yes file_list_spec_CXX='@' # Tell ltmain to make .lib files, not .a files. libext=lib # Tell ltmain to make .dll files, not .so files. shrext_cmds=.dll # FIXME: Setting linknames here is a bad hack. archive_cmds_CXX='$CC -o $output_objdir/$soname $libobjs $compiler_flags $deplibs -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~linknames=' archive_expsym_cmds_CXX='if test DEF = "`$SED -n -e '\''s/^[ ]*//'\'' -e '\''/^\(;.*\)*$/d'\'' -e '\''s/^\(EXPORTS\|LIBRARY\)\([ ].*\)*$/DEF/p'\'' -e q $export_symbols`" ; then cp "$export_symbols" "$output_objdir/$soname.def"; echo "$tool_output_objdir$soname.def" > "$output_objdir/$soname.exp"; else $SED -e '\''s/^/-link -EXPORT:/'\'' < $export_symbols > $output_objdir/$soname.exp; fi~ $CC -o $tool_output_objdir$soname $libobjs $compiler_flags $deplibs "@$tool_output_objdir$soname.exp" -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~ linknames=' # The linker will not automatically build a static lib if we build a DLL. # _LT_TAGVAR(old_archive_from_new_cmds, CXX)='true' enable_shared_with_static_runtimes_CXX=yes # Don't use ranlib old_postinstall_cmds_CXX='chmod 644 $oldlib' postlink_cmds_CXX='lt_outputfile="@OUTPUT@"~ lt_tool_outputfile="@TOOL_OUTPUT@"~ case $lt_outputfile in *.exe|*.EXE) ;; *) lt_outputfile=$lt_outputfile.exe lt_tool_outputfile=$lt_tool_outputfile.exe ;; esac~ func_to_tool_file "$lt_outputfile"~ if test : != "$MANIFEST_TOOL" && test -f "$lt_outputfile.manifest"; then $MANIFEST_TOOL -manifest "$lt_tool_outputfile.manifest" -outputresource:"$lt_tool_outputfile" || exit 1; $RM "$lt_outputfile.manifest"; fi' ;; *) # g++ # _LT_TAGVAR(hardcode_libdir_flag_spec, CXX) is actually meaningless, # as there is no search path for DLLs. hardcode_libdir_flag_spec_CXX='-L$libdir' export_dynamic_flag_spec_CXX='$wl--export-all-symbols' allow_undefined_flag_CXX=unsupported always_export_symbols_CXX=no enable_shared_with_static_runtimes_CXX=yes if $LD --help 2>&1 | $GREP 'auto-import' > /dev/null; then archive_cmds_CXX='$CC -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -o $output_objdir/$soname $wl--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib' # If the export-symbols file already is a .def file, use it as # is; otherwise, prepend EXPORTS... archive_expsym_cmds_CXX='if test DEF = "`$SED -n -e '\''s/^[ ]*//'\'' -e '\''/^\(;.*\)*$/d'\'' -e '\''s/^\(EXPORTS\|LIBRARY\)\([ ].*\)*$/DEF/p'\'' -e q $export_symbols`" ; then cp $export_symbols $output_objdir/$soname.def; else echo EXPORTS > $output_objdir/$soname.def; cat $export_symbols >> $output_objdir/$soname.def; fi~ $CC -shared -nostdlib $output_objdir/$soname.def $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -o $output_objdir/$soname $wl--enable-auto-image-base -Xlinker --out-implib -Xlinker $lib' else ld_shlibs_CXX=no fi ;; esac ;; darwin* | rhapsody*) archive_cmds_need_lc_CXX=no hardcode_direct_CXX=no hardcode_automatic_CXX=yes hardcode_shlibpath_var_CXX=unsupported if test yes = "$lt_cv_ld_force_load"; then whole_archive_flag_spec_CXX='`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience $wl-force_load,$conv\"; done; func_echo_all \"$new_convenience\"`' else whole_archive_flag_spec_CXX='' fi link_all_deplibs_CXX=yes allow_undefined_flag_CXX=$_lt_dar_allow_undefined case $cc_basename in ifort*|nagfor*) _lt_dar_can_shared=yes ;; *) _lt_dar_can_shared=$GCC ;; esac if test yes = "$_lt_dar_can_shared"; then output_verbose_link_cmd=func_echo_all archive_cmds_CXX="\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring $_lt_dar_single_mod$_lt_dsymutil" module_cmds_CXX="\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags$_lt_dsymutil" archive_expsym_cmds_CXX="sed 's|^|_|' < \$export_symbols > \$output_objdir/\$libname-symbols.expsym~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring $_lt_dar_single_mod$_lt_dar_export_syms$_lt_dsymutil" module_expsym_cmds_CXX="sed -e 's|^|_|' < \$export_symbols > \$output_objdir/\$libname-symbols.expsym~\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags$_lt_dar_export_syms$_lt_dsymutil" if test yes != "$lt_cv_apple_cc_single_mod"; then archive_cmds_CXX="\$CC -r -keep_private_externs -nostdlib -o \$lib-master.o \$libobjs~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$lib-master.o \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring$_lt_dsymutil" archive_expsym_cmds_CXX="sed 's|^|_|' < \$export_symbols > \$output_objdir/\$libname-symbols.expsym~\$CC -r -keep_private_externs -nostdlib -o \$lib-master.o \$libobjs~\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$lib-master.o \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring$_lt_dar_export_syms$_lt_dsymutil" fi else ld_shlibs_CXX=no fi ;; os2*) hardcode_libdir_flag_spec_CXX='-L$libdir' hardcode_minus_L_CXX=yes allow_undefined_flag_CXX=unsupported shrext_cmds=.dll archive_cmds_CXX='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ $ECHO EXPORTS >> $output_objdir/$libname.def~ emxexp $libobjs | $SED /"_DLL_InitTerm"/d >> $output_objdir/$libname.def~ $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ emximp -o $lib $output_objdir/$libname.def' archive_expsym_cmds_CXX='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ $ECHO EXPORTS >> $output_objdir/$libname.def~ prefix_cmds="$SED"~ if test EXPORTS = "`$SED 1q $export_symbols`"; then prefix_cmds="$prefix_cmds -e 1d"; fi~ prefix_cmds="$prefix_cmds -e \"s/^\(.*\)$/_\1/g\""~ cat $export_symbols | $prefix_cmds >> $output_objdir/$libname.def~ $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ emximp -o $lib $output_objdir/$libname.def' old_archive_From_new_cmds_CXX='emximp -o $output_objdir/${libname}_dll.a $output_objdir/$libname.def' enable_shared_with_static_runtimes_CXX=yes ;; dgux*) case $cc_basename in ec++*) # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; ghcx*) # Green Hills C++ Compiler # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; *) # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; esac ;; freebsd2.*) # C++ shared libraries reported to be fairly broken before # switch to ELF ld_shlibs_CXX=no ;; freebsd-elf*) archive_cmds_need_lc_CXX=no ;; freebsd* | dragonfly*) # FreeBSD 3 and later use GNU C++ and GNU ld with standard ELF # conventions ld_shlibs_CXX=yes ;; haiku*) archive_cmds_CXX='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' link_all_deplibs_CXX=yes ;; hpux9*) hardcode_libdir_flag_spec_CXX='$wl+b $wl$libdir' hardcode_libdir_separator_CXX=: export_dynamic_flag_spec_CXX='$wl-E' hardcode_direct_CXX=yes hardcode_minus_L_CXX=yes # Not in the search PATH, # but as the default # location of the library. case $cc_basename in CC*) # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; aCC*) archive_cmds_CXX='$RM $output_objdir/$soname~$CC -b $wl+b $wl$install_libdir -o $output_objdir/$soname $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~test "x$output_objdir/$soname" = "x$lib" || mv $output_objdir/$soname $lib' # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. # # There doesn't appear to be a way to prevent this compiler from # explicitly linking system object files so we need to strip them # from the output so that they don't get included in the library # dependencies. output_verbose_link_cmd='templist=`($CC -b $CFLAGS -v conftest.$objext 2>&1) | $EGREP "\-L"`; list= ; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "$list"' ;; *) if test yes = "$GXX"; then archive_cmds_CXX='$RM $output_objdir/$soname~$CC -shared -nostdlib $pic_flag $wl+b $wl$install_libdir -o $output_objdir/$soname $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~test "x$output_objdir/$soname" = "x$lib" || mv $output_objdir/$soname $lib' else # FIXME: insert proper C++ library support ld_shlibs_CXX=no fi ;; esac ;; hpux10*|hpux11*) if test no = "$with_gnu_ld"; then hardcode_libdir_flag_spec_CXX='$wl+b $wl$libdir' hardcode_libdir_separator_CXX=: case $host_cpu in hppa*64*|ia64*) ;; *) export_dynamic_flag_spec_CXX='$wl-E' ;; esac fi case $host_cpu in hppa*64*|ia64*) hardcode_direct_CXX=no hardcode_shlibpath_var_CXX=no ;; *) hardcode_direct_CXX=yes hardcode_direct_absolute_CXX=yes hardcode_minus_L_CXX=yes # Not in the search PATH, # but as the default # location of the library. ;; esac case $cc_basename in CC*) # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; aCC*) case $host_cpu in hppa*64*) archive_cmds_CXX='$CC -b $wl+h $wl$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' ;; ia64*) archive_cmds_CXX='$CC -b $wl+h $wl$soname $wl+nodefaultrpath -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' ;; *) archive_cmds_CXX='$CC -b $wl+h $wl$soname $wl+b $wl$install_libdir -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' ;; esac # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. # # There doesn't appear to be a way to prevent this compiler from # explicitly linking system object files so we need to strip them # from the output so that they don't get included in the library # dependencies. output_verbose_link_cmd='templist=`($CC -b $CFLAGS -v conftest.$objext 2>&1) | $GREP "\-L"`; list= ; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "$list"' ;; *) if test yes = "$GXX"; then if test no = "$with_gnu_ld"; then case $host_cpu in hppa*64*) archive_cmds_CXX='$CC -shared -nostdlib -fPIC $wl+h $wl$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' ;; ia64*) archive_cmds_CXX='$CC -shared -nostdlib $pic_flag $wl+h $wl$soname $wl+nodefaultrpath -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' ;; *) archive_cmds_CXX='$CC -shared -nostdlib $pic_flag $wl+h $wl$soname $wl+b $wl$install_libdir -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' ;; esac fi else # FIXME: insert proper C++ library support ld_shlibs_CXX=no fi ;; esac ;; interix[3-9]*) hardcode_direct_CXX=no hardcode_shlibpath_var_CXX=no hardcode_libdir_flag_spec_CXX='$wl-rpath,$libdir' export_dynamic_flag_spec_CXX='$wl-E' # Hack: On Interix 3.x, we cannot compile PIC because of a broken gcc. # Instead, shared libraries are loaded at an image base (0x10000000 by # default) and relocated if they conflict, which is a slow very memory # consuming and fragmenting process. To avoid this, we pick a random, # 256 KiB-aligned image base between 0x50000000 and 0x6FFC0000 at link # time. Moving up from 0x10000000 also allows more sbrk(2) space. archive_cmds_CXX='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-h,$soname $wl--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib' archive_expsym_cmds_CXX='sed "s|^|_|" $export_symbols >$output_objdir/$soname.expsym~$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-h,$soname $wl--retain-symbols-file,$output_objdir/$soname.expsym $wl--image-base,`expr ${RANDOM-$$} % 4096 / 2 \* 262144 + 1342177280` -o $lib' ;; irix5* | irix6*) case $cc_basename in CC*) # SGI C++ archive_cmds_CXX='$CC -shared -all -multigot $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' # Archives containing C++ object files must be created using # "CC -ar", where "CC" is the IRIX C++ compiler. This is # necessary to make sure instantiated templates are included # in the archive. old_archive_cmds_CXX='$CC -ar -WR,-u -o $oldlib $oldobjs' ;; *) if test yes = "$GXX"; then if test no = "$with_gnu_ld"; then archive_cmds_CXX='$CC -shared $pic_flag -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' else archive_cmds_CXX='$CC -shared $pic_flag -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` -o $lib' fi fi link_all_deplibs_CXX=yes ;; esac hardcode_libdir_flag_spec_CXX='$wl-rpath $wl$libdir' hardcode_libdir_separator_CXX=: inherit_rpath_CXX=yes ;; linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) case $cc_basename in KCC*) # Kuck and Associates, Inc. (KAI) C++ Compiler # KCC will only create a shared library if the output file # ends with ".so" (or ".sl" for HP-UX), so rename the library # to its proper name (with version) after linking. archive_cmds_CXX='tempext=`echo $shared_ext | $SED -e '\''s/\([^()0-9A-Za-z{}]\)/\\\\\1/g'\''`; templib=`echo $lib | $SED -e "s/\$tempext\..*/.so/"`; $CC $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags --soname $soname -o \$templib; mv \$templib $lib' archive_expsym_cmds_CXX='tempext=`echo $shared_ext | $SED -e '\''s/\([^()0-9A-Za-z{}]\)/\\\\\1/g'\''`; templib=`echo $lib | $SED -e "s/\$tempext\..*/.so/"`; $CC $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags --soname $soname -o \$templib $wl-retain-symbols-file,$export_symbols; mv \$templib $lib' # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. # # There doesn't appear to be a way to prevent this compiler from # explicitly linking system object files so we need to strip them # from the output so that they don't get included in the library # dependencies. output_verbose_link_cmd='templist=`$CC $CFLAGS -v conftest.$objext -o libconftest$shared_ext 2>&1 | $GREP "ld"`; rm -f libconftest$shared_ext; list= ; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "$list"' hardcode_libdir_flag_spec_CXX='$wl-rpath,$libdir' export_dynamic_flag_spec_CXX='$wl--export-dynamic' # Archives containing C++ object files must be created using # "CC -Bstatic", where "CC" is the KAI C++ compiler. old_archive_cmds_CXX='$CC -Bstatic -o $oldlib $oldobjs' ;; icpc* | ecpc* ) # Intel C++ with_gnu_ld=yes # version 8.0 and above of icpc choke on multiply defined symbols # if we add $predep_objects and $postdep_objects, however 7.1 and # earlier do not add the objects themselves. case `$CC -V 2>&1` in *"Version 7."*) archive_cmds_CXX='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib' archive_expsym_cmds_CXX='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' ;; *) # Version 8.0 or newer tmp_idyn= case $host_cpu in ia64*) tmp_idyn=' -i_dynamic';; esac archive_cmds_CXX='$CC -shared'"$tmp_idyn"' $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' archive_expsym_cmds_CXX='$CC -shared'"$tmp_idyn"' $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' ;; esac archive_cmds_need_lc_CXX=no hardcode_libdir_flag_spec_CXX='$wl-rpath,$libdir' export_dynamic_flag_spec_CXX='$wl--export-dynamic' whole_archive_flag_spec_CXX='$wl--whole-archive$convenience $wl--no-whole-archive' ;; pgCC* | pgcpp*) # Portland Group C++ compiler case `$CC -V` in *pgCC\ [1-5].* | *pgcpp\ [1-5].*) prelink_cmds_CXX='tpldir=Template.dir~ rm -rf $tpldir~ $CC --prelink_objects --instantiation_dir $tpldir $objs $libobjs $compile_deplibs~ compile_command="$compile_command `find $tpldir -name \*.o | sort | $NL2SP`"' old_archive_cmds_CXX='tpldir=Template.dir~ rm -rf $tpldir~ $CC --prelink_objects --instantiation_dir $tpldir $oldobjs$old_deplibs~ $AR $AR_FLAGS $oldlib$oldobjs$old_deplibs `find $tpldir -name \*.o | sort | $NL2SP`~ $RANLIB $oldlib' archive_cmds_CXX='tpldir=Template.dir~ rm -rf $tpldir~ $CC --prelink_objects --instantiation_dir $tpldir $predep_objects $libobjs $deplibs $convenience $postdep_objects~ $CC -shared $pic_flag $predep_objects $libobjs $deplibs `find $tpldir -name \*.o | sort | $NL2SP` $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib' archive_expsym_cmds_CXX='tpldir=Template.dir~ rm -rf $tpldir~ $CC --prelink_objects --instantiation_dir $tpldir $predep_objects $libobjs $deplibs $convenience $postdep_objects~ $CC -shared $pic_flag $predep_objects $libobjs $deplibs `find $tpldir -name \*.o | sort | $NL2SP` $postdep_objects $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' ;; *) # Version 6 and above use weak symbols archive_cmds_CXX='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib' archive_expsym_cmds_CXX='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' ;; esac hardcode_libdir_flag_spec_CXX='$wl--rpath $wl$libdir' export_dynamic_flag_spec_CXX='$wl--export-dynamic' whole_archive_flag_spec_CXX='$wl--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' ;; cxx*) # Compaq C++ archive_cmds_CXX='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib' archive_expsym_cmds_CXX='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib $wl-retain-symbols-file $wl$export_symbols' runpath_var=LD_RUN_PATH hardcode_libdir_flag_spec_CXX='-rpath $libdir' hardcode_libdir_separator_CXX=: # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. # # There doesn't appear to be a way to prevent this compiler from # explicitly linking system object files so we need to strip them # from the output so that they don't get included in the library # dependencies. output_verbose_link_cmd='templist=`$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP "ld"`; templist=`func_echo_all "$templist" | $SED "s/\(^.*ld.*\)\( .*ld .*$\)/\1/"`; list= ; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "X$list" | $Xsed' ;; xl* | mpixl* | bgxl*) # IBM XL 8.0 on PPC, with GNU ld hardcode_libdir_flag_spec_CXX='$wl-rpath $wl$libdir' export_dynamic_flag_spec_CXX='$wl--export-dynamic' archive_cmds_CXX='$CC -qmkshrobj $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' if test yes = "$supports_anon_versioning"; then archive_expsym_cmds_CXX='echo "{ global:" > $output_objdir/$libname.ver~ cat $export_symbols | sed -e "s/\(.*\)/\1;/" >> $output_objdir/$libname.ver~ echo "local: *; };" >> $output_objdir/$libname.ver~ $CC -qmkshrobj $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-version-script $wl$output_objdir/$libname.ver -o $lib' fi ;; *) case `$CC -V 2>&1 | sed 5q` in *Sun\ C*) # Sun C++ 5.9 no_undefined_flag_CXX=' -zdefs' archive_cmds_CXX='$CC -G$allow_undefined_flag -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' archive_expsym_cmds_CXX='$CC -G$allow_undefined_flag -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-retain-symbols-file $wl$export_symbols' hardcode_libdir_flag_spec_CXX='-R$libdir' whole_archive_flag_spec_CXX='$wl--whole-archive`new_convenience=; for conv in $convenience\"\"; do test -z \"$conv\" || new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' compiler_needs_object_CXX=yes # Not sure whether something based on # $CC $CFLAGS -v conftest.$objext -o libconftest$shared_ext 2>&1 # would be better. output_verbose_link_cmd='func_echo_all' # Archives containing C++ object files must be created using # "CC -xar", where "CC" is the Sun C++ compiler. This is # necessary to make sure instantiated templates are included # in the archive. old_archive_cmds_CXX='$CC -xar -o $oldlib $oldobjs' ;; esac ;; esac ;; lynxos*) # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; m88k*) # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; mvs*) case $cc_basename in cxx*) # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; *) # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; esac ;; netbsd*) if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then archive_cmds_CXX='$LD -Bshareable -o $lib $predep_objects $libobjs $deplibs $postdep_objects $linker_flags' wlarc= hardcode_libdir_flag_spec_CXX='-R$libdir' hardcode_direct_CXX=yes hardcode_shlibpath_var_CXX=no fi # Workaround some broken pre-1.5 toolchains output_verbose_link_cmd='$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP conftest.$objext | $SED -e "s:-lgcc -lc -lgcc::"' ;; *nto* | *qnx*) ld_shlibs_CXX=yes ;; openbsd* | bitrig*) if test -f /usr/libexec/ld.so; then hardcode_direct_CXX=yes hardcode_shlibpath_var_CXX=no hardcode_direct_absolute_CXX=yes archive_cmds_CXX='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -o $lib' hardcode_libdir_flag_spec_CXX='$wl-rpath,$libdir' if test -z "`echo __ELF__ | $CC -E - | grep __ELF__`"; then archive_expsym_cmds_CXX='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-retain-symbols-file,$export_symbols -o $lib' export_dynamic_flag_spec_CXX='$wl-E' whole_archive_flag_spec_CXX=$wlarc'--whole-archive$convenience '$wlarc'--no-whole-archive' fi output_verbose_link_cmd=func_echo_all else ld_shlibs_CXX=no fi ;; osf3* | osf4* | osf5*) case $cc_basename in KCC*) # Kuck and Associates, Inc. (KAI) C++ Compiler # KCC will only create a shared library if the output file # ends with ".so" (or ".sl" for HP-UX), so rename the library # to its proper name (with version) after linking. archive_cmds_CXX='tempext=`echo $shared_ext | $SED -e '\''s/\([^()0-9A-Za-z{}]\)/\\\\\1/g'\''`; templib=`echo "$lib" | $SED -e "s/\$tempext\..*/.so/"`; $CC $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags --soname $soname -o \$templib; mv \$templib $lib' hardcode_libdir_flag_spec_CXX='$wl-rpath,$libdir' hardcode_libdir_separator_CXX=: # Archives containing C++ object files must be created using # the KAI C++ compiler. case $host in osf3*) old_archive_cmds_CXX='$CC -Bstatic -o $oldlib $oldobjs' ;; *) old_archive_cmds_CXX='$CC -o $oldlib $oldobjs' ;; esac ;; RCC*) # Rational C++ 2.4.1 # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; cxx*) case $host in osf3*) allow_undefined_flag_CXX=' $wl-expect_unresolved $wl\*' archive_cmds_CXX='$CC -shared$allow_undefined_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $soname `test -n "$verstring" && func_echo_all "$wl-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' hardcode_libdir_flag_spec_CXX='$wl-rpath $wl$libdir' ;; *) allow_undefined_flag_CXX=' -expect_unresolved \*' archive_cmds_CXX='$CC -shared$allow_undefined_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -msym -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' archive_expsym_cmds_CXX='for i in `cat $export_symbols`; do printf "%s %s\\n" -exported_symbol "\$i" >> $lib.exp; done~ echo "-hidden">> $lib.exp~ $CC -shared$allow_undefined_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -msym -soname $soname $wl-input $wl$lib.exp `test -n "$verstring" && $ECHO "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib~ $RM $lib.exp' hardcode_libdir_flag_spec_CXX='-rpath $libdir' ;; esac hardcode_libdir_separator_CXX=: # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. # # There doesn't appear to be a way to prevent this compiler from # explicitly linking system object files so we need to strip them # from the output so that they don't get included in the library # dependencies. output_verbose_link_cmd='templist=`$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP "ld" | $GREP -v "ld:"`; templist=`func_echo_all "$templist" | $SED "s/\(^.*ld.*\)\( .*ld.*$\)/\1/"`; list= ; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "$list"' ;; *) if test yes,no = "$GXX,$with_gnu_ld"; then allow_undefined_flag_CXX=' $wl-expect_unresolved $wl\*' case $host in osf3*) archive_cmds_CXX='$CC -shared -nostdlib $allow_undefined_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' ;; *) archive_cmds_CXX='$CC -shared $pic_flag -nostdlib $allow_undefined_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-msym $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' ;; esac hardcode_libdir_flag_spec_CXX='$wl-rpath $wl$libdir' hardcode_libdir_separator_CXX=: # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. output_verbose_link_cmd='$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP -v "^Configured with:" | $GREP "\-L"' else # FIXME: insert proper C++ library support ld_shlibs_CXX=no fi ;; esac ;; psos*) # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; sunos4*) case $cc_basename in CC*) # Sun C++ 4.x # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; lcc*) # Lucid # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; *) # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; esac ;; solaris*) case $cc_basename in CC* | sunCC*) # Sun C++ 4.2, 5.x and Centerline C++ archive_cmds_need_lc_CXX=yes no_undefined_flag_CXX=' -zdefs' archive_cmds_CXX='$CC -G$allow_undefined_flag -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' archive_expsym_cmds_CXX='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ $CC -G$allow_undefined_flag $wl-M $wl$lib.exp -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~$RM $lib.exp' hardcode_libdir_flag_spec_CXX='-R$libdir' hardcode_shlibpath_var_CXX=no case $host_os in solaris2.[0-5] | solaris2.[0-5].*) ;; *) # The compiler driver will combine and reorder linker options, # but understands '-z linker_flag'. # Supported since Solaris 2.6 (maybe 2.5.1?) whole_archive_flag_spec_CXX='-z allextract$convenience -z defaultextract' ;; esac link_all_deplibs_CXX=yes output_verbose_link_cmd='func_echo_all' # Archives containing C++ object files must be created using # "CC -xar", where "CC" is the Sun C++ compiler. This is # necessary to make sure instantiated templates are included # in the archive. old_archive_cmds_CXX='$CC -xar -o $oldlib $oldobjs' ;; gcx*) # Green Hills C++ Compiler archive_cmds_CXX='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-h $wl$soname -o $lib' # The C++ compiler must be used to create the archive. old_archive_cmds_CXX='$CC $LDFLAGS -archive -o $oldlib $oldobjs' ;; *) # GNU C++ compiler with Solaris linker if test yes,no = "$GXX,$with_gnu_ld"; then no_undefined_flag_CXX=' $wl-z ${wl}defs' if $CC --version | $GREP -v '^2\.7' > /dev/null; then archive_cmds_CXX='$CC -shared $pic_flag -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-h $wl$soname -o $lib' archive_expsym_cmds_CXX='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ $CC -shared $pic_flag -nostdlib $wl-M $wl$lib.exp $wl-h $wl$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~$RM $lib.exp' # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. output_verbose_link_cmd='$CC -shared $CFLAGS -v conftest.$objext 2>&1 | $GREP -v "^Configured with:" | $GREP "\-L"' else # g++ 2.7 appears to require '-G' NOT '-shared' on this # platform. archive_cmds_CXX='$CC -G -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-h $wl$soname -o $lib' archive_expsym_cmds_CXX='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ $CC -G -nostdlib $wl-M $wl$lib.exp $wl-h $wl$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~$RM $lib.exp' # Commands to make compiler produce verbose output that lists # what "hidden" libraries, object files and flags are used when # linking a shared library. output_verbose_link_cmd='$CC -G $CFLAGS -v conftest.$objext 2>&1 | $GREP -v "^Configured with:" | $GREP "\-L"' fi hardcode_libdir_flag_spec_CXX='$wl-R $wl$libdir' case $host_os in solaris2.[0-5] | solaris2.[0-5].*) ;; *) whole_archive_flag_spec_CXX='$wl-z ${wl}allextract$convenience $wl-z ${wl}defaultextract' ;; esac fi ;; esac ;; sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[01].[10]* | unixware7* | sco3.2v5.0.[024]*) no_undefined_flag_CXX='$wl-z,text' archive_cmds_need_lc_CXX=no hardcode_shlibpath_var_CXX=no runpath_var='LD_RUN_PATH' case $cc_basename in CC*) archive_cmds_CXX='$CC -G $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds_CXX='$CC -G $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' ;; *) archive_cmds_CXX='$CC -shared $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds_CXX='$CC -shared $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' ;; esac ;; sysv5* | sco3.2v5* | sco5v6*) # Note: We CANNOT use -z defs as we might desire, because we do not # link with -lc, and that would cause any symbols used from libc to # always be unresolved, which means just about no library would # ever link correctly. If we're not using GNU ld we use -z text # though, which does catch some bad symbols but isn't as heavy-handed # as -z defs. no_undefined_flag_CXX='$wl-z,text' allow_undefined_flag_CXX='$wl-z,nodefs' archive_cmds_need_lc_CXX=no hardcode_shlibpath_var_CXX=no hardcode_libdir_flag_spec_CXX='$wl-R,$libdir' hardcode_libdir_separator_CXX=':' link_all_deplibs_CXX=yes export_dynamic_flag_spec_CXX='$wl-Bexport' runpath_var='LD_RUN_PATH' case $cc_basename in CC*) archive_cmds_CXX='$CC -G $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds_CXX='$CC -G $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' old_archive_cmds_CXX='$CC -Tprelink_objects $oldobjs~ '"$old_archive_cmds_CXX" reload_cmds_CXX='$CC -Tprelink_objects $reload_objs~ '"$reload_cmds_CXX" ;; *) archive_cmds_CXX='$CC -shared $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' archive_expsym_cmds_CXX='$CC -shared $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' ;; esac ;; tandem*) case $cc_basename in NCC*) # NonStop-UX NCC 3.20 # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; *) # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; esac ;; vxworks*) # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; *) # FIXME: insert proper C++ library support ld_shlibs_CXX=no ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ld_shlibs_CXX" >&5 $as_echo "$ld_shlibs_CXX" >&6; } test no = "$ld_shlibs_CXX" && can_build_shared=no GCC_CXX=$GXX LD_CXX=$LD ## CAVEAT EMPTOR: ## There is no encapsulation within the following macros, do not change ## the running order or otherwise move them around unless you know exactly ## what you are doing... # Dependencies to place before and after the object being linked: predep_objects_CXX= postdep_objects_CXX= predeps_CXX= postdeps_CXX= compiler_lib_search_path_CXX= cat > conftest.$ac_ext <<_LT_EOF class Foo { public: Foo (void) { a = 0; } private: int a; }; _LT_EOF _lt_libdeps_save_CFLAGS=$CFLAGS case "$CC $CFLAGS " in #( *\ -flto*\ *) CFLAGS="$CFLAGS -fno-lto" ;; *\ -fwhopr*\ *) CFLAGS="$CFLAGS -fno-whopr" ;; *\ -fuse-linker-plugin*\ *) CFLAGS="$CFLAGS -fno-use-linker-plugin" ;; esac if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 (eval $ac_compile) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then # Parse the compiler output and extract the necessary # objects, libraries and library flags. # Sentinel used to keep track of whether or not we are before # the conftest object file. pre_test_object_deps_done=no for p in `eval "$output_verbose_link_cmd"`; do case $prev$p in -L* | -R* | -l*) # Some compilers place space between "-{L,R}" and the path. # Remove the space. if test x-L = "$p" || test x-R = "$p"; then prev=$p continue fi # Expand the sysroot to ease extracting the directories later. if test -z "$prev"; then case $p in -L*) func_stripname_cnf '-L' '' "$p"; prev=-L; p=$func_stripname_result ;; -R*) func_stripname_cnf '-R' '' "$p"; prev=-R; p=$func_stripname_result ;; -l*) func_stripname_cnf '-l' '' "$p"; prev=-l; p=$func_stripname_result ;; esac fi case $p in =*) func_stripname_cnf '=' '' "$p"; p=$lt_sysroot$func_stripname_result ;; esac if test no = "$pre_test_object_deps_done"; then case $prev in -L | -R) # Internal compiler library paths should come after those # provided the user. The postdeps already come after the # user supplied libs so there is no need to process them. if test -z "$compiler_lib_search_path_CXX"; then compiler_lib_search_path_CXX=$prev$p else compiler_lib_search_path_CXX="${compiler_lib_search_path_CXX} $prev$p" fi ;; # The "-l" case would never come before the object being # linked, so don't bother handling this case. esac else if test -z "$postdeps_CXX"; then postdeps_CXX=$prev$p else postdeps_CXX="${postdeps_CXX} $prev$p" fi fi prev= ;; *.lto.$objext) ;; # Ignore GCC LTO objects *.$objext) # This assumes that the test object file only shows up # once in the compiler output. if test "$p" = "conftest.$objext"; then pre_test_object_deps_done=yes continue fi if test no = "$pre_test_object_deps_done"; then if test -z "$predep_objects_CXX"; then predep_objects_CXX=$p else predep_objects_CXX="$predep_objects_CXX $p" fi else if test -z "$postdep_objects_CXX"; then postdep_objects_CXX=$p else postdep_objects_CXX="$postdep_objects_CXX $p" fi fi ;; *) ;; # Ignore the rest. esac done # Clean up. rm -f a.out a.exe else echo "libtool.m4: error: problem compiling CXX test program" fi $RM -f confest.$objext CFLAGS=$_lt_libdeps_save_CFLAGS # PORTME: override above test on systems where it is broken case $host_os in interix[3-9]*) # Interix 3.5 installs completely hosed .la files for C++, so rather than # hack all around it, let's just trust "g++" to DTRT. predep_objects_CXX= postdep_objects_CXX= postdeps_CXX= ;; esac case " $postdeps_CXX " in *" -lc "*) archive_cmds_need_lc_CXX=no ;; esac compiler_lib_search_dirs_CXX= if test -n "${compiler_lib_search_path_CXX}"; then compiler_lib_search_dirs_CXX=`echo " ${compiler_lib_search_path_CXX}" | $SED -e 's! -L! !g' -e 's!^ !!'` fi lt_prog_compiler_wl_CXX= lt_prog_compiler_pic_CXX= lt_prog_compiler_static_CXX= # C++ specific cases for pic, static, wl, etc. if test yes = "$GXX"; then lt_prog_compiler_wl_CXX='-Wl,' lt_prog_compiler_static_CXX='-static' case $host_os in aix*) # All AIX code is PIC. if test ia64 = "$host_cpu"; then # AIX 5 now supports IA64 processor lt_prog_compiler_static_CXX='-Bstatic' fi lt_prog_compiler_pic_CXX='-fPIC' ;; amigaos*) case $host_cpu in powerpc) # see comment about AmigaOS4 .so support lt_prog_compiler_pic_CXX='-fPIC' ;; m68k) # FIXME: we need at least 68020 code to build shared libraries, but # adding the '-m68020' flag to GCC prevents building anything better, # like '-m68040'. lt_prog_compiler_pic_CXX='-m68020 -resident32 -malways-restore-a4' ;; esac ;; beos* | irix5* | irix6* | nonstopux* | osf3* | osf4* | osf5*) # PIC is the default for these OSes. ;; mingw* | cygwin* | os2* | pw32* | cegcc*) # This hack is so that the source file can tell whether it is being # built for inclusion in a dll (and should export symbols for example). # Although the cygwin gcc ignores -fPIC, still need this for old-style # (--disable-auto-import) libraries lt_prog_compiler_pic_CXX='-DDLL_EXPORT' case $host_os in os2*) lt_prog_compiler_static_CXX='$wl-static' ;; esac ;; darwin* | rhapsody*) # PIC is the default on this platform # Common symbols not allowed in MH_DYLIB files lt_prog_compiler_pic_CXX='-fno-common' ;; *djgpp*) # DJGPP does not support shared libraries at all lt_prog_compiler_pic_CXX= ;; haiku*) # PIC is the default for Haiku. # The "-static" flag exists, but is broken. lt_prog_compiler_static_CXX= ;; interix[3-9]*) # Interix 3.x gcc -fpic/-fPIC options generate broken code. # Instead, we relocate shared libraries at runtime. ;; sysv4*MP*) if test -d /usr/nec; then lt_prog_compiler_pic_CXX=-Kconform_pic fi ;; hpux*) # PIC is the default for 64-bit PA HP-UX, but not for 32-bit # PA HP-UX. On IA64 HP-UX, PIC is the default but the pic flag # sets the default TLS model and affects inlining. case $host_cpu in hppa*64*) ;; *) lt_prog_compiler_pic_CXX='-fPIC' ;; esac ;; *qnx* | *nto*) # QNX uses GNU C++, but need to define -shared option too, otherwise # it will coredump. lt_prog_compiler_pic_CXX='-fPIC -shared' ;; *) lt_prog_compiler_pic_CXX='-fPIC' ;; esac else case $host_os in aix[4-9]*) # All AIX code is PIC. if test ia64 = "$host_cpu"; then # AIX 5 now supports IA64 processor lt_prog_compiler_static_CXX='-Bstatic' else lt_prog_compiler_static_CXX='-bnso -bI:/lib/syscalls.exp' fi ;; chorus*) case $cc_basename in cxch68*) # Green Hills C++ Compiler # _LT_TAGVAR(lt_prog_compiler_static, CXX)="--no_auto_instantiation -u __main -u __premain -u _abort -r $COOL_DIR/lib/libOrb.a $MVME_DIR/lib/CC/libC.a $MVME_DIR/lib/classix/libcx.s.a" ;; esac ;; mingw* | cygwin* | os2* | pw32* | cegcc*) # This hack is so that the source file can tell whether it is being # built for inclusion in a dll (and should export symbols for example). lt_prog_compiler_pic_CXX='-DDLL_EXPORT' ;; dgux*) case $cc_basename in ec++*) lt_prog_compiler_pic_CXX='-KPIC' ;; ghcx*) # Green Hills C++ Compiler lt_prog_compiler_pic_CXX='-pic' ;; *) ;; esac ;; freebsd* | dragonfly*) # FreeBSD uses GNU C++ ;; hpux9* | hpux10* | hpux11*) case $cc_basename in CC*) lt_prog_compiler_wl_CXX='-Wl,' lt_prog_compiler_static_CXX='$wl-a ${wl}archive' if test ia64 != "$host_cpu"; then lt_prog_compiler_pic_CXX='+Z' fi ;; aCC*) lt_prog_compiler_wl_CXX='-Wl,' lt_prog_compiler_static_CXX='$wl-a ${wl}archive' case $host_cpu in hppa*64*|ia64*) # +Z the default ;; *) lt_prog_compiler_pic_CXX='+Z' ;; esac ;; *) ;; esac ;; interix*) # This is c89, which is MS Visual C++ (no shared libs) # Anyone wants to do a port? ;; irix5* | irix6* | nonstopux*) case $cc_basename in CC*) lt_prog_compiler_wl_CXX='-Wl,' lt_prog_compiler_static_CXX='-non_shared' # CC pic flag -KPIC is the default. ;; *) ;; esac ;; linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) case $cc_basename in KCC*) # KAI C++ Compiler lt_prog_compiler_wl_CXX='--backend -Wl,' lt_prog_compiler_pic_CXX='-fPIC' ;; ecpc* ) # old Intel C++ for x86_64, which still supported -KPIC. lt_prog_compiler_wl_CXX='-Wl,' lt_prog_compiler_pic_CXX='-KPIC' lt_prog_compiler_static_CXX='-static' ;; icpc* ) # Intel C++, used to be incompatible with GCC. # ICC 10 doesn't accept -KPIC any more. lt_prog_compiler_wl_CXX='-Wl,' lt_prog_compiler_pic_CXX='-fPIC' lt_prog_compiler_static_CXX='-static' ;; pgCC* | pgcpp*) # Portland Group C++ compiler lt_prog_compiler_wl_CXX='-Wl,' lt_prog_compiler_pic_CXX='-fpic' lt_prog_compiler_static_CXX='-Bstatic' ;; cxx*) # Compaq C++ # Make sure the PIC flag is empty. It appears that all Alpha # Linux and Compaq Tru64 Unix objects are PIC. lt_prog_compiler_pic_CXX= lt_prog_compiler_static_CXX='-non_shared' ;; xlc* | xlC* | bgxl[cC]* | mpixl[cC]*) # IBM XL 8.0, 9.0 on PPC and BlueGene lt_prog_compiler_wl_CXX='-Wl,' lt_prog_compiler_pic_CXX='-qpic' lt_prog_compiler_static_CXX='-qstaticlink' ;; *) case `$CC -V 2>&1 | sed 5q` in *Sun\ C*) # Sun C++ 5.9 lt_prog_compiler_pic_CXX='-KPIC' lt_prog_compiler_static_CXX='-Bstatic' lt_prog_compiler_wl_CXX='-Qoption ld ' ;; esac ;; esac ;; lynxos*) ;; m88k*) ;; mvs*) case $cc_basename in cxx*) lt_prog_compiler_pic_CXX='-W c,exportall' ;; *) ;; esac ;; netbsd* | netbsdelf*-gnu) ;; *qnx* | *nto*) # QNX uses GNU C++, but need to define -shared option too, otherwise # it will coredump. lt_prog_compiler_pic_CXX='-fPIC -shared' ;; osf3* | osf4* | osf5*) case $cc_basename in KCC*) lt_prog_compiler_wl_CXX='--backend -Wl,' ;; RCC*) # Rational C++ 2.4.1 lt_prog_compiler_pic_CXX='-pic' ;; cxx*) # Digital/Compaq C++ lt_prog_compiler_wl_CXX='-Wl,' # Make sure the PIC flag is empty. It appears that all Alpha # Linux and Compaq Tru64 Unix objects are PIC. lt_prog_compiler_pic_CXX= lt_prog_compiler_static_CXX='-non_shared' ;; *) ;; esac ;; psos*) ;; solaris*) case $cc_basename in CC* | sunCC*) # Sun C++ 4.2, 5.x and Centerline C++ lt_prog_compiler_pic_CXX='-KPIC' lt_prog_compiler_static_CXX='-Bstatic' lt_prog_compiler_wl_CXX='-Qoption ld ' ;; gcx*) # Green Hills C++ Compiler lt_prog_compiler_pic_CXX='-PIC' ;; *) ;; esac ;; sunos4*) case $cc_basename in CC*) # Sun C++ 4.x lt_prog_compiler_pic_CXX='-pic' lt_prog_compiler_static_CXX='-Bstatic' ;; lcc*) # Lucid lt_prog_compiler_pic_CXX='-pic' ;; *) ;; esac ;; sysv5* | unixware* | sco3.2v5* | sco5v6* | OpenUNIX*) case $cc_basename in CC*) lt_prog_compiler_wl_CXX='-Wl,' lt_prog_compiler_pic_CXX='-KPIC' lt_prog_compiler_static_CXX='-Bstatic' ;; esac ;; tandem*) case $cc_basename in NCC*) # NonStop-UX NCC 3.20 lt_prog_compiler_pic_CXX='-KPIC' ;; *) ;; esac ;; vxworks*) ;; *) lt_prog_compiler_can_build_shared_CXX=no ;; esac fi case $host_os in # For platforms that do not support PIC, -DPIC is meaningless: *djgpp*) lt_prog_compiler_pic_CXX= ;; *) lt_prog_compiler_pic_CXX="$lt_prog_compiler_pic_CXX -DPIC" ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $compiler option to produce PIC" >&5 $as_echo_n "checking for $compiler option to produce PIC... " >&6; } if ${lt_cv_prog_compiler_pic_CXX+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_prog_compiler_pic_CXX=$lt_prog_compiler_pic_CXX fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic_CXX" >&5 $as_echo "$lt_cv_prog_compiler_pic_CXX" >&6; } lt_prog_compiler_pic_CXX=$lt_cv_prog_compiler_pic_CXX # # Check to make sure the PIC flag actually works. # if test -n "$lt_prog_compiler_pic_CXX"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler PIC flag $lt_prog_compiler_pic_CXX works" >&5 $as_echo_n "checking if $compiler PIC flag $lt_prog_compiler_pic_CXX works... " >&6; } if ${lt_cv_prog_compiler_pic_works_CXX+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_prog_compiler_pic_works_CXX=no ac_outfile=conftest.$ac_objext echo "$lt_simple_compile_test_code" > conftest.$ac_ext lt_compiler_flag="$lt_prog_compiler_pic_CXX -DPIC" ## exclude from sc_useless_quotes_in_assignment # Insert the option either (1) after the last *FLAGS variable, or # (2) before a word containing "conftest.", or (3) at the end. # Note that $ac_compile itself does not contain backslashes and begins # with a dollar sign (not a hyphen), so the echo should work correctly. # The option is referenced via a variable to avoid confusing sed. lt_compile=`echo "$ac_compile" | $SED \ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5) (eval "$lt_compile" 2>conftest.err) ac_status=$? cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 if (exit $ac_status) && test -s "$ac_outfile"; then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings other than the usual output. $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' >conftest.exp $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 if test ! -s conftest.er2 || diff conftest.exp conftest.er2 >/dev/null; then lt_cv_prog_compiler_pic_works_CXX=yes fi fi $RM conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic_works_CXX" >&5 $as_echo "$lt_cv_prog_compiler_pic_works_CXX" >&6; } if test yes = "$lt_cv_prog_compiler_pic_works_CXX"; then case $lt_prog_compiler_pic_CXX in "" | " "*) ;; *) lt_prog_compiler_pic_CXX=" $lt_prog_compiler_pic_CXX" ;; esac else lt_prog_compiler_pic_CXX= lt_prog_compiler_can_build_shared_CXX=no fi fi # # Check to make sure the static flag actually works. # wl=$lt_prog_compiler_wl_CXX eval lt_tmp_static_flag=\"$lt_prog_compiler_static_CXX\" { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler static flag $lt_tmp_static_flag works" >&5 $as_echo_n "checking if $compiler static flag $lt_tmp_static_flag works... " >&6; } if ${lt_cv_prog_compiler_static_works_CXX+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_prog_compiler_static_works_CXX=no save_LDFLAGS=$LDFLAGS LDFLAGS="$LDFLAGS $lt_tmp_static_flag" echo "$lt_simple_link_test_code" > conftest.$ac_ext if (eval $ac_link 2>conftest.err) && test -s conftest$ac_exeext; then # The linker can only warn and ignore the option if not recognized # So say no if there are warnings if test -s conftest.err; then # Append any errors to the config.log. cat conftest.err 1>&5 $ECHO "$_lt_linker_boilerplate" | $SED '/^$/d' > conftest.exp $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 if diff conftest.exp conftest.er2 >/dev/null; then lt_cv_prog_compiler_static_works_CXX=yes fi else lt_cv_prog_compiler_static_works_CXX=yes fi fi $RM -r conftest* LDFLAGS=$save_LDFLAGS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_static_works_CXX" >&5 $as_echo "$lt_cv_prog_compiler_static_works_CXX" >&6; } if test yes = "$lt_cv_prog_compiler_static_works_CXX"; then : else lt_prog_compiler_static_CXX= fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -c -o file.$ac_objext" >&5 $as_echo_n "checking if $compiler supports -c -o file.$ac_objext... " >&6; } if ${lt_cv_prog_compiler_c_o_CXX+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_prog_compiler_c_o_CXX=no $RM -r conftest 2>/dev/null mkdir conftest cd conftest mkdir out echo "$lt_simple_compile_test_code" > conftest.$ac_ext lt_compiler_flag="-o out/conftest2.$ac_objext" # Insert the option either (1) after the last *FLAGS variable, or # (2) before a word containing "conftest.", or (3) at the end. # Note that $ac_compile itself does not contain backslashes and begins # with a dollar sign (not a hyphen), so the echo should work correctly. lt_compile=`echo "$ac_compile" | $SED \ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' > out/conftest.exp $SED '/^$/d; /^ *+/d' out/conftest.err >out/conftest.er2 if test ! -s out/conftest.er2 || diff out/conftest.exp out/conftest.er2 >/dev/null; then lt_cv_prog_compiler_c_o_CXX=yes fi fi chmod u+w . 2>&5 $RM conftest* # SGI C++ compiler will create directory out/ii_files/ for # template instantiation test -d out/ii_files && $RM out/ii_files/* && rmdir out/ii_files $RM out/* && rmdir out cd .. $RM -r conftest $RM conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_c_o_CXX" >&5 $as_echo "$lt_cv_prog_compiler_c_o_CXX" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler supports -c -o file.$ac_objext" >&5 $as_echo_n "checking if $compiler supports -c -o file.$ac_objext... " >&6; } if ${lt_cv_prog_compiler_c_o_CXX+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_prog_compiler_c_o_CXX=no $RM -r conftest 2>/dev/null mkdir conftest cd conftest mkdir out echo "$lt_simple_compile_test_code" > conftest.$ac_ext lt_compiler_flag="-o out/conftest2.$ac_objext" # Insert the option either (1) after the last *FLAGS variable, or # (2) before a word containing "conftest.", or (3) at the end. # Note that $ac_compile itself does not contain backslashes and begins # with a dollar sign (not a hyphen), so the echo should work correctly. lt_compile=`echo "$ac_compile" | $SED \ -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` (eval echo "\"\$as_me:$LINENO: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings $ECHO "$_lt_compiler_boilerplate" | $SED '/^$/d' > out/conftest.exp $SED '/^$/d; /^ *+/d' out/conftest.err >out/conftest.er2 if test ! -s out/conftest.er2 || diff out/conftest.exp out/conftest.er2 >/dev/null; then lt_cv_prog_compiler_c_o_CXX=yes fi fi chmod u+w . 2>&5 $RM conftest* # SGI C++ compiler will create directory out/ii_files/ for # template instantiation test -d out/ii_files && $RM out/ii_files/* && rmdir out/ii_files $RM out/* && rmdir out cd .. $RM -r conftest $RM conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_c_o_CXX" >&5 $as_echo "$lt_cv_prog_compiler_c_o_CXX" >&6; } hard_links=nottested if test no = "$lt_cv_prog_compiler_c_o_CXX" && test no != "$need_locks"; then # do not overwrite the value of need_locks provided by the user { $as_echo "$as_me:${as_lineno-$LINENO}: checking if we can lock with hard links" >&5 $as_echo_n "checking if we can lock with hard links... " >&6; } hard_links=yes $RM conftest* ln conftest.a conftest.b 2>/dev/null && hard_links=no touch conftest.a ln conftest.a conftest.b 2>&5 || hard_links=no ln conftest.a conftest.b 2>/dev/null && hard_links=no { $as_echo "$as_me:${as_lineno-$LINENO}: result: $hard_links" >&5 $as_echo "$hard_links" >&6; } if test no = "$hard_links"; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: '$CC' does not support '-c -o', so 'make -j' may be unsafe" >&5 $as_echo "$as_me: WARNING: '$CC' does not support '-c -o', so 'make -j' may be unsafe" >&2;} need_locks=warn fi else need_locks=no fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the $compiler linker ($LD) supports shared libraries" >&5 $as_echo_n "checking whether the $compiler linker ($LD) supports shared libraries... " >&6; } export_symbols_cmds_CXX='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols' exclude_expsyms_CXX='_GLOBAL_OFFSET_TABLE_|_GLOBAL__F[ID]_.*' case $host_os in aix[4-9]*) # If we're using GNU nm, then we don't want the "-C" option. # -C means demangle to GNU nm, but means don't demangle to AIX nm. # Without the "-l" option, or with the "-B" option, AIX nm treats # weak defined symbols like other global defined symbols, whereas # GNU nm marks them as "W". # While the 'weak' keyword is ignored in the Export File, we need # it in the Import File for the 'aix-soname' feature, so we have # to replace the "-B" option with "-P" for AIX nm. if $NM -V 2>&1 | $GREP 'GNU' > /dev/null; then export_symbols_cmds_CXX='$NM -Bpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W")) && (substr(\$ 3,1,1) != ".")) { if (\$ 2 == "W") { print \$ 3 " weak" } else { print \$ 3 } } }'\'' | sort -u > $export_symbols' else export_symbols_cmds_CXX='`func_echo_all $NM | $SED -e '\''s/B\([^B]*\)$/P\1/'\''` -PCpgl $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) && (substr(\$ 1,1,1) != ".")) { if ((\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) { print \$ 1 " weak" } else { print \$ 1 } } }'\'' | sort -u > $export_symbols' fi ;; pw32*) export_symbols_cmds_CXX=$ltdll_cmds ;; cygwin* | mingw* | cegcc*) case $cc_basename in cl*) exclude_expsyms_CXX='_NULL_IMPORT_DESCRIPTOR|_IMPORT_DESCRIPTOR_.*' ;; *) export_symbols_cmds_CXX='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[BCDGRS][ ]/s/.*[ ]\([^ ]*\)/\1 DATA/;s/^.*[ ]__nm__\([^ ]*\)[ ][^ ]*/\1 DATA/;/^I[ ]/d;/^[AITW][ ]/s/.* //'\'' | sort | uniq > $export_symbols' exclude_expsyms_CXX='[_]+GLOBAL_OFFSET_TABLE_|[_]+GLOBAL__[FID]_.*|[_]+head_[A-Za-z0-9_]+_dll|[A-Za-z0-9_]+_dll_iname' ;; esac ;; linux* | k*bsd*-gnu | gnu*) link_all_deplibs_CXX=no ;; *) export_symbols_cmds_CXX='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols' ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ld_shlibs_CXX" >&5 $as_echo "$ld_shlibs_CXX" >&6; } test no = "$ld_shlibs_CXX" && can_build_shared=no with_gnu_ld_CXX=$with_gnu_ld # # Do we need to explicitly link libc? # case "x$archive_cmds_need_lc_CXX" in x|xyes) # Assume -lc should be added archive_cmds_need_lc_CXX=yes if test yes,yes = "$GCC,$enable_shared"; then case $archive_cmds_CXX in *'~'*) # FIXME: we may have to deal with multi-command sequences. ;; '$CC '*) # Test whether the compiler implicitly links with -lc since on some # systems, -lgcc has to come before -lc. If gcc already passes -lc # to ld, don't add -lc before -lgcc. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether -lc should be explicitly linked in" >&5 $as_echo_n "checking whether -lc should be explicitly linked in... " >&6; } if ${lt_cv_archive_cmds_need_lc_CXX+:} false; then : $as_echo_n "(cached) " >&6 else $RM conftest* echo "$lt_simple_compile_test_code" > conftest.$ac_ext if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 (eval $ac_compile) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } 2>conftest.err; then soname=conftest lib=conftest libobjs=conftest.$ac_objext deplibs= wl=$lt_prog_compiler_wl_CXX pic_flag=$lt_prog_compiler_pic_CXX compiler_flags=-v linker_flags=-v verstring= output_objdir=. libname=conftest lt_save_allow_undefined_flag=$allow_undefined_flag_CXX allow_undefined_flag_CXX= if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$archive_cmds_CXX 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1\""; } >&5 (eval $archive_cmds_CXX 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then lt_cv_archive_cmds_need_lc_CXX=no else lt_cv_archive_cmds_need_lc_CXX=yes fi allow_undefined_flag_CXX=$lt_save_allow_undefined_flag else cat conftest.err 1>&5 fi $RM conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_archive_cmds_need_lc_CXX" >&5 $as_echo "$lt_cv_archive_cmds_need_lc_CXX" >&6; } archive_cmds_need_lc_CXX=$lt_cv_archive_cmds_need_lc_CXX ;; esac fi ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking dynamic linker characteristics" >&5 $as_echo_n "checking dynamic linker characteristics... " >&6; } library_names_spec= libname_spec='lib$name' soname_spec= shrext_cmds=.so postinstall_cmds= postuninstall_cmds= finish_cmds= finish_eval= shlibpath_var= shlibpath_overrides_runpath=unknown version_type=none dynamic_linker="$host_os ld.so" sys_lib_dlsearch_path_spec="/lib /usr/lib" need_lib_prefix=unknown hardcode_into_libs=no # when you set need_version to no, make sure it does not cause -set_version # flags to be left without arguments need_version=unknown case $host_os in aix3*) version_type=linux # correct to gnu/linux during the next big refactor library_names_spec='$libname$release$shared_ext$versuffix $libname.a' shlibpath_var=LIBPATH # AIX 3 has no versioning support, so we append a major version to the name. soname_spec='$libname$release$shared_ext$major' ;; aix[4-9]*) version_type=linux # correct to gnu/linux during the next big refactor need_lib_prefix=no need_version=no hardcode_into_libs=yes if test ia64 = "$host_cpu"; then # AIX 5 supports IA64 library_names_spec='$libname$release$shared_ext$major $libname$release$shared_ext$versuffix $libname$shared_ext' shlibpath_var=LD_LIBRARY_PATH else # With GCC up to 2.95.x, collect2 would create an import file # for dependence libraries. The import file would start with # the line '#! .'. This would cause the generated library to # depend on '.', always an invalid library. This was fixed in # development snapshots of GCC prior to 3.0. case $host_os in aix4 | aix4.[01] | aix4.[01].*) if { echo '#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 97)' echo ' yes ' echo '#endif'; } | $CC -E - | $GREP yes > /dev/null; then : else can_build_shared=no fi ;; esac # Using Import Files as archive members, it is possible to support # filename-based versioning of shared library archives on AIX. While # this would work for both with and without runtime linking, it will # prevent static linking of such archives. So we do filename-based # shared library versioning with .so extension only, which is used # when both runtime linking and shared linking is enabled. # Unfortunately, runtime linking may impact performance, so we do # not want this to be the default eventually. Also, we use the # versioned .so libs for executables only if there is the -brtl # linker flag in LDFLAGS as well, or --with-aix-soname=svr4 only. # To allow for filename-based versioning support, we need to create # libNAME.so.V as an archive file, containing: # *) an Import File, referring to the versioned filename of the # archive as well as the shared archive member, telling the # bitwidth (32 or 64) of that shared object, and providing the # list of exported symbols of that shared object, eventually # decorated with the 'weak' keyword # *) the shared object with the F_LOADONLY flag set, to really avoid # it being seen by the linker. # At run time we better use the real file rather than another symlink, # but for link time we create the symlink libNAME.so -> libNAME.so.V case $with_aix_soname,$aix_use_runtimelinking in # AIX (on Power*) has no versioning support, so currently we cannot hardcode correct # soname into executable. Probably we can add versioning support to # collect2, so additional links can be useful in future. aix,yes) # traditional libtool dynamic_linker='AIX unversionable lib.so' # If using run time linking (on AIX 4.2 or later) use lib.so # instead of lib.a to let people know that these are not # typical AIX shared libraries. library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' ;; aix,no) # traditional AIX only dynamic_linker='AIX lib.a(lib.so.V)' # We preserve .a as extension for shared libraries through AIX4.2 # and later when we are not doing run time linking. library_names_spec='$libname$release.a $libname.a' soname_spec='$libname$release$shared_ext$major' ;; svr4,*) # full svr4 only dynamic_linker="AIX lib.so.V($shared_archive_member_spec.o)" library_names_spec='$libname$release$shared_ext$major $libname$shared_ext' # We do not specify a path in Import Files, so LIBPATH fires. shlibpath_overrides_runpath=yes ;; *,yes) # both, prefer svr4 dynamic_linker="AIX lib.so.V($shared_archive_member_spec.o), lib.a(lib.so.V)" library_names_spec='$libname$release$shared_ext$major $libname$shared_ext' # unpreferred sharedlib libNAME.a needs extra handling postinstall_cmds='test -n "$linkname" || linkname="$realname"~func_stripname "" ".so" "$linkname"~$install_shared_prog "$dir/$func_stripname_result.$libext" "$destdir/$func_stripname_result.$libext"~test -z "$tstripme" || test -z "$striplib" || $striplib "$destdir/$func_stripname_result.$libext"' postuninstall_cmds='for n in $library_names $old_library; do :; done~func_stripname "" ".so" "$n"~test "$func_stripname_result" = "$n" || func_append rmfiles " $odir/$func_stripname_result.$libext"' # We do not specify a path in Import Files, so LIBPATH fires. shlibpath_overrides_runpath=yes ;; *,no) # both, prefer aix dynamic_linker="AIX lib.a(lib.so.V), lib.so.V($shared_archive_member_spec.o)" library_names_spec='$libname$release.a $libname.a' soname_spec='$libname$release$shared_ext$major' # unpreferred sharedlib libNAME.so.V and symlink libNAME.so need extra handling postinstall_cmds='test -z "$dlname" || $install_shared_prog $dir/$dlname $destdir/$dlname~test -z "$tstripme" || test -z "$striplib" || $striplib $destdir/$dlname~test -n "$linkname" || linkname=$realname~func_stripname "" ".a" "$linkname"~(cd "$destdir" && $LN_S -f $dlname $func_stripname_result.so)' postuninstall_cmds='test -z "$dlname" || func_append rmfiles " $odir/$dlname"~for n in $old_library $library_names; do :; done~func_stripname "" ".a" "$n"~func_append rmfiles " $odir/$func_stripname_result.so"' ;; esac shlibpath_var=LIBPATH fi ;; amigaos*) case $host_cpu in powerpc) # Since July 2007 AmigaOS4 officially supports .so libraries. # When compiling the executable, add -use-dynld -Lsobjs: to the compileline. library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' ;; m68k) library_names_spec='$libname.ixlibrary $libname.a' # Create ${libname}_ixlibrary.a entries in /sys/libs. finish_eval='for lib in `ls $libdir/*.ixlibrary 2>/dev/null`; do libname=`func_echo_all "$lib" | $SED '\''s%^.*/\([^/]*\)\.ixlibrary$%\1%'\''`; $RM /sys/libs/${libname}_ixlibrary.a; $show "cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a"; cd /sys/libs && $LN_S $lib ${libname}_ixlibrary.a || exit 1; done' ;; esac ;; beos*) library_names_spec='$libname$shared_ext' dynamic_linker="$host_os ld.so" shlibpath_var=LIBRARY_PATH ;; bsdi[45]*) version_type=linux # correct to gnu/linux during the next big refactor need_version=no library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' finish_cmds='PATH="\$PATH:/sbin" ldconfig $libdir' shlibpath_var=LD_LIBRARY_PATH sys_lib_search_path_spec="/shlib /usr/lib /usr/X11/lib /usr/contrib/lib /lib /usr/local/lib" sys_lib_dlsearch_path_spec="/shlib /usr/lib /usr/local/lib" # the default ld.so.conf also contains /usr/contrib/lib and # /usr/X11R6/lib (/usr/X11 is a link to /usr/X11R6), but let us allow # libtool to hard-code these into programs ;; cygwin* | mingw* | pw32* | cegcc*) version_type=windows shrext_cmds=.dll need_version=no need_lib_prefix=no case $GCC,$cc_basename in yes,*) # gcc library_names_spec='$libname.dll.a' # DLL is installed to $(libdir)/../bin by postinstall_cmds postinstall_cmds='base_file=`basename \$file`~ dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\$base_file'\''i; echo \$dlname'\''`~ dldir=$destdir/`dirname \$dlpath`~ test -d \$dldir || mkdir -p \$dldir~ $install_prog $dir/$dlname \$dldir/$dlname~ chmod a+x \$dldir/$dlname~ if test -n '\''$stripme'\'' && test -n '\''$striplib'\''; then eval '\''$striplib \$dldir/$dlname'\'' || exit \$?; fi' postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~ dlpath=$dir/\$dldll~ $RM \$dlpath' shlibpath_overrides_runpath=yes case $host_os in cygwin*) # Cygwin DLLs use 'cyg' prefix rather than 'lib' soname_spec='`echo $libname | sed -e 's/^lib/cyg/'``echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' ;; mingw* | cegcc*) # MinGW DLLs use traditional 'lib' prefix soname_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' ;; pw32*) # pw32 DLLs use 'pw' prefix rather than 'lib' library_names_spec='`echo $libname | sed -e 's/^lib/pw/'``echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' ;; esac dynamic_linker='Win32 ld.exe' ;; *,cl*) # Native MSVC libname_spec='$name' soname_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' library_names_spec='$libname.dll.lib' case $build_os in mingw*) sys_lib_search_path_spec= lt_save_ifs=$IFS IFS=';' for lt_path in $LIB do IFS=$lt_save_ifs # Let DOS variable expansion print the short 8.3 style file name. lt_path=`cd "$lt_path" 2>/dev/null && cmd //C "for %i in (".") do @echo %~si"` sys_lib_search_path_spec="$sys_lib_search_path_spec $lt_path" done IFS=$lt_save_ifs # Convert to MSYS style. sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | sed -e 's|\\\\|/|g' -e 's| \\([a-zA-Z]\\):| /\\1|g' -e 's|^ ||'` ;; cygwin*) # Convert to unix form, then to dos form, then back to unix form # but this time dos style (no spaces!) so that the unix form looks # like /cygdrive/c/PROGRA~1:/cygdr... sys_lib_search_path_spec=`cygpath --path --unix "$LIB"` sys_lib_search_path_spec=`cygpath --path --dos "$sys_lib_search_path_spec" 2>/dev/null` sys_lib_search_path_spec=`cygpath --path --unix "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"` ;; *) sys_lib_search_path_spec=$LIB if $ECHO "$sys_lib_search_path_spec" | $GREP ';[c-zC-Z]:/' >/dev/null; then # It is most probably a Windows format PATH. sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e 's/;/ /g'` else sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"` fi # FIXME: find the short name or the path components, as spaces are # common. (e.g. "Program Files" -> "PROGRA~1") ;; esac # DLL is installed to $(libdir)/../bin by postinstall_cmds postinstall_cmds='base_file=`basename \$file`~ dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\$base_file'\''i; echo \$dlname'\''`~ dldir=$destdir/`dirname \$dlpath`~ test -d \$dldir || mkdir -p \$dldir~ $install_prog $dir/$dlname \$dldir/$dlname' postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~ dlpath=$dir/\$dldll~ $RM \$dlpath' shlibpath_overrides_runpath=yes dynamic_linker='Win32 link.exe' ;; *) # Assume MSVC wrapper library_names_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext $libname.lib' dynamic_linker='Win32 ld.exe' ;; esac # FIXME: first we should search . and the directory the executable is in shlibpath_var=PATH ;; darwin* | rhapsody*) dynamic_linker="$host_os dyld" version_type=darwin need_lib_prefix=no need_version=no library_names_spec='$libname$release$major$shared_ext $libname$shared_ext' soname_spec='$libname$release$major$shared_ext' shlibpath_overrides_runpath=yes shlibpath_var=DYLD_LIBRARY_PATH shrext_cmds='`test .$module = .yes && echo .so || echo .dylib`' sys_lib_dlsearch_path_spec='/usr/local/lib /lib /usr/lib' ;; dgux*) version_type=linux # correct to gnu/linux during the next big refactor need_lib_prefix=no need_version=no library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' shlibpath_var=LD_LIBRARY_PATH ;; freebsd* | dragonfly*) # DragonFly does not have aout. When/if they implement a new # versioning mechanism, adjust this. if test -x /usr/bin/objformat; then objformat=`/usr/bin/objformat` else case $host_os in freebsd[23].*) objformat=aout ;; *) objformat=elf ;; esac fi version_type=freebsd-$objformat case $version_type in freebsd-elf*) library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' need_version=no need_lib_prefix=no ;; freebsd-*) library_names_spec='$libname$release$shared_ext$versuffix $libname$shared_ext$versuffix' need_version=yes ;; esac shlibpath_var=LD_LIBRARY_PATH case $host_os in freebsd2.*) shlibpath_overrides_runpath=yes ;; freebsd3.[01]* | freebsdelf3.[01]*) shlibpath_overrides_runpath=yes hardcode_into_libs=yes ;; freebsd3.[2-9]* | freebsdelf3.[2-9]* | \ freebsd4.[0-5] | freebsdelf4.[0-5] | freebsd4.1.1 | freebsdelf4.1.1) shlibpath_overrides_runpath=no hardcode_into_libs=yes ;; *) # from 4.6 on, and DragonFly shlibpath_overrides_runpath=yes hardcode_into_libs=yes ;; esac ;; haiku*) version_type=linux # correct to gnu/linux during the next big refactor need_lib_prefix=no need_version=no dynamic_linker="$host_os runtime_loader" library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' shlibpath_var=LIBRARY_PATH shlibpath_overrides_runpath=no sys_lib_dlsearch_path_spec='/boot/home/config/lib /boot/common/lib /boot/system/lib' hardcode_into_libs=yes ;; hpux9* | hpux10* | hpux11*) # Give a soname corresponding to the major version so that dld.sl refuses to # link against other versions. version_type=sunos need_lib_prefix=no need_version=no case $host_cpu in ia64*) shrext_cmds='.so' hardcode_into_libs=yes dynamic_linker="$host_os dld.so" shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes # Unless +noenvvar is specified. library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' if test 32 = "$HPUX_IA64_MODE"; then sys_lib_search_path_spec="/usr/lib/hpux32 /usr/local/lib/hpux32 /usr/local/lib" sys_lib_dlsearch_path_spec=/usr/lib/hpux32 else sys_lib_search_path_spec="/usr/lib/hpux64 /usr/local/lib/hpux64" sys_lib_dlsearch_path_spec=/usr/lib/hpux64 fi ;; hppa*64*) shrext_cmds='.sl' hardcode_into_libs=yes dynamic_linker="$host_os dld.sl" shlibpath_var=LD_LIBRARY_PATH # How should we handle SHLIB_PATH shlibpath_overrides_runpath=yes # Unless +noenvvar is specified. library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' sys_lib_search_path_spec="/usr/lib/pa20_64 /usr/ccs/lib/pa20_64" sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec ;; *) shrext_cmds='.sl' dynamic_linker="$host_os dld.sl" shlibpath_var=SHLIB_PATH shlibpath_overrides_runpath=no # +s is required to enable SHLIB_PATH library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' ;; esac # HP-UX runs *really* slowly unless shared libraries are mode 555, ... postinstall_cmds='chmod 555 $lib' # or fails outright, so override atomically: install_override_mode=555 ;; interix[3-9]*) version_type=linux # correct to gnu/linux during the next big refactor need_lib_prefix=no need_version=no library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' dynamic_linker='Interix 3.x ld.so.1 (PE, like ELF)' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no hardcode_into_libs=yes ;; irix5* | irix6* | nonstopux*) case $host_os in nonstopux*) version_type=nonstopux ;; *) if test yes = "$lt_cv_prog_gnu_ld"; then version_type=linux # correct to gnu/linux during the next big refactor else version_type=irix fi ;; esac need_lib_prefix=no need_version=no soname_spec='$libname$release$shared_ext$major' library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$release$shared_ext $libname$shared_ext' case $host_os in irix5* | nonstopux*) libsuff= shlibsuff= ;; *) case $LD in # libtool.m4 will add one of these switches to LD *-32|*"-32 "|*-melf32bsmip|*"-melf32bsmip ") libsuff= shlibsuff= libmagic=32-bit;; *-n32|*"-n32 "|*-melf32bmipn32|*"-melf32bmipn32 ") libsuff=32 shlibsuff=N32 libmagic=N32;; *-64|*"-64 "|*-melf64bmip|*"-melf64bmip ") libsuff=64 shlibsuff=64 libmagic=64-bit;; *) libsuff= shlibsuff= libmagic=never-match;; esac ;; esac shlibpath_var=LD_LIBRARY${shlibsuff}_PATH shlibpath_overrides_runpath=no sys_lib_search_path_spec="/usr/lib$libsuff /lib$libsuff /usr/local/lib$libsuff" sys_lib_dlsearch_path_spec="/usr/lib$libsuff /lib$libsuff" hardcode_into_libs=yes ;; # No shared lib support for Linux oldld, aout, or coff. linux*oldld* | linux*aout* | linux*coff*) dynamic_linker=no ;; linux*android*) version_type=none # Android doesn't support versioned libraries. need_lib_prefix=no need_version=no library_names_spec='$libname$release$shared_ext' soname_spec='$libname$release$shared_ext' finish_cmds= shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes # This implies no fast_install, which is unacceptable. # Some rework will be needed to allow for fast_install # before this can be enabled. hardcode_into_libs=yes dynamic_linker='Android linker' # Don't embed -rpath directories since the linker doesn't support them. hardcode_libdir_flag_spec_CXX='-L$libdir' ;; # This must be glibc/ELF. linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) version_type=linux # correct to gnu/linux during the next big refactor need_lib_prefix=no need_version=no library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' finish_cmds='PATH="\$PATH:/sbin" ldconfig -n $libdir' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no # Some binutils ld are patched to set DT_RUNPATH if ${lt_cv_shlibpath_overrides_runpath+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_shlibpath_overrides_runpath=no save_LDFLAGS=$LDFLAGS save_libdir=$libdir eval "libdir=/foo; wl=\"$lt_prog_compiler_wl_CXX\"; \ LDFLAGS=\"\$LDFLAGS $hardcode_libdir_flag_spec_CXX\"" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_cxx_try_link "$LINENO"; then : if ($OBJDUMP -p conftest$ac_exeext) 2>/dev/null | grep "RUNPATH.*$libdir" >/dev/null; then : lt_cv_shlibpath_overrides_runpath=yes fi fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$save_LDFLAGS libdir=$save_libdir fi shlibpath_overrides_runpath=$lt_cv_shlibpath_overrides_runpath # This implies no fast_install, which is unacceptable. # Some rework will be needed to allow for fast_install # before this can be enabled. hardcode_into_libs=yes # Ideally, we could use ldconfig to report *all* directores which are # searched for libraries, however this is still not possible. Aside from not # being certain /sbin/ldconfig is available, command # 'ldconfig -N -X -v | grep ^/' on 64bit Fedora does not report /usr/lib64, # even though it is searched at run-time. Try to do the best guess by # appending ld.so.conf contents (and includes) to the search path. if test -f /etc/ld.so.conf; then lt_ld_extra=`awk '/^include / { system(sprintf("cd /etc; cat %s 2>/dev/null", \$2)); skip = 1; } { if (!skip) print \$0; skip = 0; }' < /etc/ld.so.conf | $SED -e 's/#.*//;/^[ ]*hwcap[ ]/d;s/[:, ]/ /g;s/=[^=]*$//;s/=[^= ]* / /g;s/"//g;/^$/d' | tr '\n' ' '` sys_lib_dlsearch_path_spec="/lib /usr/lib $lt_ld_extra" fi # We used to test for /lib/ld.so.1 and disable shared libraries on # powerpc, because MkLinux only supported shared libraries with the # GNU dynamic linker. Since this was broken with cross compilers, # most powerpc-linux boxes support dynamic linking these days and # people can always --disable-shared, the test was removed, and we # assume the GNU/Linux dynamic linker is in use. dynamic_linker='GNU/Linux ld.so' ;; netbsdelf*-gnu) version_type=linux need_lib_prefix=no need_version=no library_names_spec='${libname}${release}${shared_ext}$versuffix ${libname}${release}${shared_ext}$major ${libname}${shared_ext}' soname_spec='${libname}${release}${shared_ext}$major' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no hardcode_into_libs=yes dynamic_linker='NetBSD ld.elf_so' ;; netbsd*) version_type=sunos need_lib_prefix=no need_version=no if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then library_names_spec='$libname$release$shared_ext$versuffix $libname$shared_ext$versuffix' finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir' dynamic_linker='NetBSD (a.out) ld.so' else library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' dynamic_linker='NetBSD ld.elf_so' fi shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes hardcode_into_libs=yes ;; newsos6) version_type=linux # correct to gnu/linux during the next big refactor library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes ;; *nto* | *qnx*) version_type=qnx need_lib_prefix=no need_version=no library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no hardcode_into_libs=yes dynamic_linker='ldqnx.so' ;; openbsd* | bitrig*) version_type=sunos sys_lib_dlsearch_path_spec=/usr/lib need_lib_prefix=no if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`"; then need_version=no else need_version=yes fi library_names_spec='$libname$release$shared_ext$versuffix $libname$shared_ext$versuffix' finish_cmds='PATH="\$PATH:/sbin" ldconfig -m $libdir' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes ;; os2*) libname_spec='$name' version_type=windows shrext_cmds=.dll need_version=no need_lib_prefix=no # OS/2 can only load a DLL with a base name of 8 characters or less. soname_spec='`test -n "$os2dllname" && libname="$os2dllname"; v=$($ECHO $release$versuffix | tr -d .-); n=$($ECHO $libname | cut -b -$((8 - ${#v})) | tr . _); $ECHO $n$v`$shared_ext' library_names_spec='${libname}_dll.$libext' dynamic_linker='OS/2 ld.exe' shlibpath_var=BEGINLIBPATH sys_lib_search_path_spec="/lib /usr/lib /usr/local/lib" sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec postinstall_cmds='base_file=`basename \$file`~ dlpath=`$SHELL 2>&1 -c '\''. $dir/'\''\$base_file'\''i; $ECHO \$dlname'\''`~ dldir=$destdir/`dirname \$dlpath`~ test -d \$dldir || mkdir -p \$dldir~ $install_prog $dir/$dlname \$dldir/$dlname~ chmod a+x \$dldir/$dlname~ if test -n '\''$stripme'\'' && test -n '\''$striplib'\''; then eval '\''$striplib \$dldir/$dlname'\'' || exit \$?; fi' postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; $ECHO \$dlname'\''`~ dlpath=$dir/\$dldll~ $RM \$dlpath' ;; osf3* | osf4* | osf5*) version_type=osf need_lib_prefix=no need_version=no soname_spec='$libname$release$shared_ext$major' library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' shlibpath_var=LD_LIBRARY_PATH sys_lib_search_path_spec="/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc /usr/lib /usr/local/lib /var/shlib" sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec ;; rdos*) dynamic_linker=no ;; solaris*) version_type=linux # correct to gnu/linux during the next big refactor need_lib_prefix=no need_version=no library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes hardcode_into_libs=yes # ldd complains unless libraries are executable postinstall_cmds='chmod +x $lib' ;; sunos4*) version_type=sunos library_names_spec='$libname$release$shared_ext$versuffix $libname$shared_ext$versuffix' finish_cmds='PATH="\$PATH:/usr/etc" ldconfig $libdir' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes if test yes = "$with_gnu_ld"; then need_lib_prefix=no fi need_version=yes ;; sysv4 | sysv4.3*) version_type=linux # correct to gnu/linux during the next big refactor library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' shlibpath_var=LD_LIBRARY_PATH case $host_vendor in sni) shlibpath_overrides_runpath=no need_lib_prefix=no runpath_var=LD_RUN_PATH ;; siemens) need_lib_prefix=no ;; motorola) need_lib_prefix=no need_version=no shlibpath_overrides_runpath=no sys_lib_search_path_spec='/lib /usr/lib /usr/ccs/lib' ;; esac ;; sysv4*MP*) if test -d /usr/nec; then version_type=linux # correct to gnu/linux during the next big refactor library_names_spec='$libname$shared_ext.$versuffix $libname$shared_ext.$major $libname$shared_ext' soname_spec='$libname$shared_ext.$major' shlibpath_var=LD_LIBRARY_PATH fi ;; sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*) version_type=sco need_lib_prefix=no need_version=no library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=yes hardcode_into_libs=yes if test yes = "$with_gnu_ld"; then sys_lib_search_path_spec='/usr/local/lib /usr/gnu/lib /usr/ccs/lib /usr/lib /lib' else sys_lib_search_path_spec='/usr/ccs/lib /usr/lib' case $host_os in sco3.2v5*) sys_lib_search_path_spec="$sys_lib_search_path_spec /lib" ;; esac fi sys_lib_dlsearch_path_spec='/usr/lib' ;; tpf*) # TPF is a cross-target only. Preferred cross-host = GNU/Linux. version_type=linux # correct to gnu/linux during the next big refactor need_lib_prefix=no need_version=no library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' shlibpath_var=LD_LIBRARY_PATH shlibpath_overrides_runpath=no hardcode_into_libs=yes ;; uts4*) version_type=linux # correct to gnu/linux during the next big refactor library_names_spec='$libname$release$shared_ext$versuffix $libname$release$shared_ext$major $libname$shared_ext' soname_spec='$libname$release$shared_ext$major' shlibpath_var=LD_LIBRARY_PATH ;; *) dynamic_linker=no ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: result: $dynamic_linker" >&5 $as_echo "$dynamic_linker" >&6; } test no = "$dynamic_linker" && can_build_shared=no variables_saved_for_relink="PATH $shlibpath_var $runpath_var" if test yes = "$GCC"; then variables_saved_for_relink="$variables_saved_for_relink GCC_EXEC_PREFIX COMPILER_PATH LIBRARY_PATH" fi if test set = "${lt_cv_sys_lib_search_path_spec+set}"; then sys_lib_search_path_spec=$lt_cv_sys_lib_search_path_spec fi if test set = "${lt_cv_sys_lib_dlsearch_path_spec+set}"; then sys_lib_dlsearch_path_spec=$lt_cv_sys_lib_dlsearch_path_spec fi # remember unaugmented sys_lib_dlsearch_path content for libtool script decls... configure_time_dlsearch_path=$sys_lib_dlsearch_path_spec # ... but it needs LT_SYS_LIBRARY_PATH munging for other configure-time code func_munge_path_list sys_lib_dlsearch_path_spec "$LT_SYS_LIBRARY_PATH" # to be used as default LT_SYS_LIBRARY_PATH value in generated libtool configure_time_lt_sys_library_path=$LT_SYS_LIBRARY_PATH { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to hardcode library paths into programs" >&5 $as_echo_n "checking how to hardcode library paths into programs... " >&6; } hardcode_action_CXX= if test -n "$hardcode_libdir_flag_spec_CXX" || test -n "$runpath_var_CXX" || test yes = "$hardcode_automatic_CXX"; then # We can hardcode non-existent directories. if test no != "$hardcode_direct_CXX" && # If the only mechanism to avoid hardcoding is shlibpath_var, we # have to relink, otherwise we might link with an installed library # when we should be linking with a yet-to-be-installed one ## test no != "$_LT_TAGVAR(hardcode_shlibpath_var, CXX)" && test no != "$hardcode_minus_L_CXX"; then # Linking always hardcodes the temporary library directory. hardcode_action_CXX=relink else # We can link without hardcoding, and we can hardcode nonexisting dirs. hardcode_action_CXX=immediate fi else # We cannot hardcode anything, or else we can only hardcode existing # directories. hardcode_action_CXX=unsupported fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $hardcode_action_CXX" >&5 $as_echo "$hardcode_action_CXX" >&6; } if test relink = "$hardcode_action_CXX" || test yes = "$inherit_rpath_CXX"; then # Fast installation is not supported enable_fast_install=no elif test yes = "$shlibpath_overrides_runpath" || test no = "$enable_shared"; then # Fast installation is not necessary enable_fast_install=needless fi fi # test -n "$compiler" CC=$lt_save_CC CFLAGS=$lt_save_CFLAGS LDCXX=$LD LD=$lt_save_LD GCC=$lt_save_GCC with_gnu_ld=$lt_save_with_gnu_ld lt_cv_path_LDCXX=$lt_cv_path_LD lt_cv_path_LD=$lt_save_path_LD lt_cv_prog_gnu_ldcxx=$lt_cv_prog_gnu_ld lt_cv_prog_gnu_ld=$lt_save_with_gnu_ld fi # test yes != "$_lt_caught_CXX_error" ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # The following check was supposed to check that there was actually a # C++ compiler but doesn't work properly if CXX is set by the user. #AC_CHECK_PROG(check_cpp, $CXX, "yes", "no") #if test "$check_cpp" != "yes"; then # AC_MSG_ERROR([No C++ compiler found. Unable to build Poly/ML.]) #fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. set dummy ${ac_tool_prefix}gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. set dummy ${ac_tool_prefix}cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}cc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue fi ac_cv_prog_CC="cc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS if test $ac_prog_rejected = yes; then # We found a bogon in the path, so make sure we never use it. set dummy $ac_cv_prog_CC shift if test $# != 0; then # We chose a different compiler from the bogus one. # However, it has the same basename, so the bogon will be chosen # first if we set CC to just the basename; use the full file name. shift ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" fi fi fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then for ac_prog in cl.exe do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC for ac_prog in cl.exe do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$ac_ct_CC" && break done if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi fi test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "no acceptable C compiler found in \$PATH See \`config.log' for more details" "$LINENO" 5; } # Provide some information about the compiler. $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 $as_echo_n "checking whether we are using the GNU C compiler... " >&6; } if ${ac_cv_c_compiler_gnu+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_compiler_gnu=yes else ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 $as_echo "$ac_cv_c_compiler_gnu" >&6; } if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+set} ac_save_CFLAGS=$CFLAGS { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 $as_echo_n "checking whether $CC accepts -g... " >&6; } if ${ac_cv_prog_cc_g+:} false; then : $as_echo_n "(cached) " >&6 else ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes else CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : else ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 $as_echo "$ac_cv_prog_cc_g" >&6; } if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" else CFLAGS="-g" fi else if test "$GCC" = yes; then CFLAGS="-O2" else CFLAGS= fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 $as_echo_n "checking for $CC option to accept ISO C89... " >&6; } if ${ac_cv_prog_cc_c89+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include struct stat; /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); static char *e (p, i) char **p; int i; { return p[i]; } static char *f (char * (*g) (char **, int), char **p, ...) { char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not '\xHH' hex character constants. These don't provoke an error unfortunately, instead are silently treated as 'x'. The following induces an error, until -std is added to get proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an array size at least. It's necessary to write '\x00'==0 to get something that's true only with -std. */ int osf4_cc_array ['\x00' == 0 ? 1 : -1]; /* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters inside strings and character constants. */ #define FOO(x) 'x' int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; char **argv; int main () { return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; ; return 0; } _ACEOF for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_c89=$ac_arg fi rm -f core conftest.err conftest.$ac_objext test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi # AC_CACHE_VAL case "x$ac_cv_prog_cc_c89" in x) { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c89" { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 $as_echo "$ac_cv_prog_cc_c89" >&6; } ;; esac if test "x$ac_cv_prog_cc_c89" != xno; then : fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC understands -c and -o together" >&5 $as_echo_n "checking whether $CC understands -c and -o together... " >&6; } if ${am_cv_prog_cc_c_o+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF # Make sure it works both with $CC and with simple cc. # Following AC_PROG_CC_C_O, we do the test twice because some # compilers refuse to overwrite an existing .o file with -o, # though they will create one. am_cv_prog_cc_c_o=yes for am_i in 1 2; do if { echo "$as_me:$LINENO: $CC -c conftest.$ac_ext -o conftest2.$ac_objext" >&5 ($CC -c conftest.$ac_ext -o conftest2.$ac_objext) >&5 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } \ && test -f conftest2.$ac_objext; then : OK else am_cv_prog_cc_c_o=no break fi done rm -f core conftest* unset am_i fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_prog_cc_c_o" >&5 $as_echo "$am_cv_prog_cc_c_o" >&6; } if test "$am_cv_prog_cc_c_o" != yes; then # Losing compiler, so override with the script. # FIXME: It is wrong to rewrite CC. # But if we don't then we get into trouble of one sort or another. # A longer-term fix would be to have automake use am__CC in this case, # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" CC="$am_aux_dir/compile $CC" fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu depcc="$CC" am_compiler_list= { $as_echo "$as_me:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5 $as_echo_n "checking dependency style of $depcc... " >&6; } if ${am_cv_CC_dependencies_compiler_type+:} false; then : $as_echo_n "(cached) " >&6 else if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then # We make a subdir and do the tests there. Otherwise we can end up # making bogus files that we don't know about and never remove. For # instance it was reported that on HP-UX the gcc test will end up # making a dummy file named 'D' -- because '-MD' means "put the output # in D". rm -rf conftest.dir mkdir conftest.dir # Copy depcomp to subdir because otherwise we won't find it if we're # using a relative directory. cp "$am_depcomp" conftest.dir cd conftest.dir # We will build objects and dependencies in a subdirectory because # it helps to detect inapplicable dependency modes. For instance # both Tru64's cc and ICC support -MD to output dependencies as a # side effect of compilation, but ICC will put the dependencies in # the current directory while Tru64 will put them in the object # directory. mkdir sub am_cv_CC_dependencies_compiler_type=none if test "$am_compiler_list" = ""; then am_compiler_list=`sed -n 's/^#*\([a-zA-Z0-9]*\))$/\1/p' < ./depcomp` fi am__universal=false case " $depcc " in #( *\ -arch\ *\ -arch\ *) am__universal=true ;; esac for depmode in $am_compiler_list; do # Setup a source with many dependencies, because some compilers # like to wrap large dependency lists on column 80 (with \), and # we should not choose a depcomp mode which is confused by this. # # We need to recreate these files for each test, as the compiler may # overwrite some of them when testing with obscure command lines. # This happens at least with the AIX C compiler. : > sub/conftest.c for i in 1 2 3 4 5 6; do echo '#include "conftst'$i'.h"' >> sub/conftest.c # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with # Solaris 10 /bin/sh. echo '/* dummy */' > sub/conftst$i.h done echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf # We check with '-c' and '-o' for the sake of the "dashmstdout" # mode. It turns out that the SunPro C++ compiler does not properly # handle '-M -o', and we need to detect this. Also, some Intel # versions had trouble with output in subdirs. am__obj=sub/conftest.${OBJEXT-o} am__minus_obj="-o $am__obj" case $depmode in gcc) # This depmode causes a compiler race in universal mode. test "$am__universal" = false || continue ;; nosideeffect) # After this tag, mechanisms are not by side-effect, so they'll # only be used when explicitly requested. if test "x$enable_dependency_tracking" = xyes; then continue else break fi ;; msvc7 | msvc7msys | msvisualcpp | msvcmsys) # This compiler won't grok '-c -o', but also, the minuso test has # not run yet. These depmodes are late enough in the game, and # so weak that their functioning should not be impacted. am__obj=conftest.${OBJEXT-o} am__minus_obj= ;; none) break ;; esac if depmode=$depmode \ source=sub/conftest.c object=$am__obj \ depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ >/dev/null 2>conftest.err && grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && grep $am__obj sub/conftest.Po > /dev/null 2>&1 && ${MAKE-make} -s -f confmf > /dev/null 2>&1; then # icc doesn't choke on unknown options, it will just issue warnings # or remarks (even with -Werror). So we grep stderr for any message # that says an option was ignored or not supported. # When given -MP, icc 7.0 and 7.1 complain thusly: # icc: Command line warning: ignoring option '-M'; no argument required # The diagnosis changed in icc 8.0: # icc: Command line remark: option '-MP' not supported if (grep 'ignoring option' conftest.err || grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else am_cv_CC_dependencies_compiler_type=$depmode break fi fi done cd .. rm -rf conftest.dir else am_cv_CC_dependencies_compiler_type=none fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_CC_dependencies_compiler_type" >&5 $as_echo "$am_cv_CC_dependencies_compiler_type" >&6; } CCDEPMODE=depmode=$am_cv_CC_dependencies_compiler_type if test "x$enable_dependency_tracking" != xno \ && test "$am_cv_CC_dependencies_compiler_type" = gcc3; then am__fastdepCC_TRUE= am__fastdepCC_FALSE='#' else am__fastdepCC_TRUE='#' am__fastdepCC_FALSE= fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5 $as_echo_n "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; } set x ${MAKE-make} ac_make=`$as_echo "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'` if eval \${ac_cv_prog_make_${ac_make}_set+:} false; then : $as_echo_n "(cached) " >&6 else cat >conftest.make <<\_ACEOF SHELL = /bin/sh all: @echo '@@@%%%=$(MAKE)=@@@%%%' _ACEOF # GNU make sometimes prints "make[1]: Entering ...", which would confuse us. case `${MAKE-make} -f conftest.make 2>/dev/null` in *@@@%%%=?*=@@@%%%*) eval ac_cv_prog_make_${ac_make}_set=yes;; *) eval ac_cv_prog_make_${ac_make}_set=no;; esac rm -f conftest.make fi if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } SET_MAKE= else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } SET_MAKE="MAKE=${MAKE-make}" fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 $as_echo_n "checking how to run the C preprocessor... " >&6; } # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then if ${ac_cv_prog_CPP+:} false; then : $as_echo_n "(cached) " >&6 else # Double quotes because CPP needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" do ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok; then : break fi done ac_cv_prog_CPP=$CPP fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 $as_echo "$CPP" >&6; } ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok; then : else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details" "$LINENO" 5; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # By default we simply use the C compiler to build assembly code. test "${CCAS+set}" = set || CCAS=$CC test "${CCASFLAGS+set}" = set || CCASFLAGS=$CFLAGS depcc="$CCAS" am_compiler_list= { $as_echo "$as_me:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5 $as_echo_n "checking dependency style of $depcc... " >&6; } if ${am_cv_CCAS_dependencies_compiler_type+:} false; then : $as_echo_n "(cached) " >&6 else if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then # We make a subdir and do the tests there. Otherwise we can end up # making bogus files that we don't know about and never remove. For # instance it was reported that on HP-UX the gcc test will end up # making a dummy file named 'D' -- because '-MD' means "put the output # in D". rm -rf conftest.dir mkdir conftest.dir # Copy depcomp to subdir because otherwise we won't find it if we're # using a relative directory. cp "$am_depcomp" conftest.dir cd conftest.dir # We will build objects and dependencies in a subdirectory because # it helps to detect inapplicable dependency modes. For instance # both Tru64's cc and ICC support -MD to output dependencies as a # side effect of compilation, but ICC will put the dependencies in # the current directory while Tru64 will put them in the object # directory. mkdir sub am_cv_CCAS_dependencies_compiler_type=none if test "$am_compiler_list" = ""; then am_compiler_list=`sed -n 's/^#*\([a-zA-Z0-9]*\))$/\1/p' < ./depcomp` fi am__universal=false for depmode in $am_compiler_list; do # Setup a source with many dependencies, because some compilers # like to wrap large dependency lists on column 80 (with \), and # we should not choose a depcomp mode which is confused by this. # # We need to recreate these files for each test, as the compiler may # overwrite some of them when testing with obscure command lines. # This happens at least with the AIX C compiler. : > sub/conftest.c for i in 1 2 3 4 5 6; do echo '#include "conftst'$i'.h"' >> sub/conftest.c # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with # Solaris 10 /bin/sh. echo '/* dummy */' > sub/conftst$i.h done echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf # We check with '-c' and '-o' for the sake of the "dashmstdout" # mode. It turns out that the SunPro C++ compiler does not properly # handle '-M -o', and we need to detect this. Also, some Intel # versions had trouble with output in subdirs. am__obj=sub/conftest.${OBJEXT-o} am__minus_obj="-o $am__obj" case $depmode in gcc) # This depmode causes a compiler race in universal mode. test "$am__universal" = false || continue ;; nosideeffect) # After this tag, mechanisms are not by side-effect, so they'll # only be used when explicitly requested. if test "x$enable_dependency_tracking" = xyes; then continue else break fi ;; msvc7 | msvc7msys | msvisualcpp | msvcmsys) # This compiler won't grok '-c -o', but also, the minuso test has # not run yet. These depmodes are late enough in the game, and # so weak that their functioning should not be impacted. am__obj=conftest.${OBJEXT-o} am__minus_obj= ;; none) break ;; esac if depmode=$depmode \ source=sub/conftest.c object=$am__obj \ depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ >/dev/null 2>conftest.err && grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && grep $am__obj sub/conftest.Po > /dev/null 2>&1 && ${MAKE-make} -s -f confmf > /dev/null 2>&1; then # icc doesn't choke on unknown options, it will just issue warnings # or remarks (even with -Werror). So we grep stderr for any message # that says an option was ignored or not supported. # When given -MP, icc 7.0 and 7.1 complain thusly: # icc: Command line warning: ignoring option '-M'; no argument required # The diagnosis changed in icc 8.0: # icc: Command line remark: option '-MP' not supported if (grep 'ignoring option' conftest.err || grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else am_cv_CCAS_dependencies_compiler_type=$depmode break fi fi done cd .. rm -rf conftest.dir else am_cv_CCAS_dependencies_compiler_type=none fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_CCAS_dependencies_compiler_type" >&5 $as_echo "$am_cv_CCAS_dependencies_compiler_type" >&6; } CCASDEPMODE=depmode=$am_cv_CCAS_dependencies_compiler_type if test "x$enable_dependency_tracking" != xno \ && test "$am_cv_CCAS_dependencies_compiler_type" = gcc3; then am__fastdepCCAS_TRUE= am__fastdepCCAS_FALSE='#' else am__fastdepCCAS_TRUE='#' am__fastdepCCAS_FALSE= fi # Activate large file mode if needed # Check whether --enable-largefile was given. if test "${enable_largefile+set}" = set; then : enableval=$enable_largefile; fi if test "$enable_largefile" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for special C compiler options needed for large files" >&5 $as_echo_n "checking for special C compiler options needed for large files... " >&6; } if ${ac_cv_sys_largefile_CC+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_sys_largefile_CC=no if test "$GCC" != yes; then ac_save_CC=$CC while :; do # IRIX 6.2 and later do not support large files by default, # so use the C compiler's -n32 option if that helps. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include /* Check that off_t can represent 2**63 - 1 correctly. We can't simply define LARGE_OFF_T to be 9223372036854775807, since some C++ compilers masquerading as C compilers incorrectly reject 9223372036854775807. */ #define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31)) int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 && LARGE_OFF_T % 2147483647 == 1) ? 1 : -1]; int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : break fi rm -f core conftest.err conftest.$ac_objext CC="$CC -n32" if ac_fn_c_try_compile "$LINENO"; then : ac_cv_sys_largefile_CC=' -n32'; break fi rm -f core conftest.err conftest.$ac_objext break done CC=$ac_save_CC rm -f conftest.$ac_ext fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sys_largefile_CC" >&5 $as_echo "$ac_cv_sys_largefile_CC" >&6; } if test "$ac_cv_sys_largefile_CC" != no; then CC=$CC$ac_cv_sys_largefile_CC fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for _FILE_OFFSET_BITS value needed for large files" >&5 $as_echo_n "checking for _FILE_OFFSET_BITS value needed for large files... " >&6; } if ${ac_cv_sys_file_offset_bits+:} false; then : $as_echo_n "(cached) " >&6 else while :; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include /* Check that off_t can represent 2**63 - 1 correctly. We can't simply define LARGE_OFF_T to be 9223372036854775807, since some C++ compilers masquerading as C compilers incorrectly reject 9223372036854775807. */ #define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31)) int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 && LARGE_OFF_T % 2147483647 == 1) ? 1 : -1]; int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_sys_file_offset_bits=no; break fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define _FILE_OFFSET_BITS 64 #include /* Check that off_t can represent 2**63 - 1 correctly. We can't simply define LARGE_OFF_T to be 9223372036854775807, since some C++ compilers masquerading as C compilers incorrectly reject 9223372036854775807. */ #define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31)) int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 && LARGE_OFF_T % 2147483647 == 1) ? 1 : -1]; int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_sys_file_offset_bits=64; break fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_sys_file_offset_bits=unknown break done fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sys_file_offset_bits" >&5 $as_echo "$ac_cv_sys_file_offset_bits" >&6; } case $ac_cv_sys_file_offset_bits in #( no | unknown) ;; *) cat >>confdefs.h <<_ACEOF #define _FILE_OFFSET_BITS $ac_cv_sys_file_offset_bits _ACEOF ;; esac rm -rf conftest* if test $ac_cv_sys_file_offset_bits = unknown; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for _LARGE_FILES value needed for large files" >&5 $as_echo_n "checking for _LARGE_FILES value needed for large files... " >&6; } if ${ac_cv_sys_large_files+:} false; then : $as_echo_n "(cached) " >&6 else while :; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include /* Check that off_t can represent 2**63 - 1 correctly. We can't simply define LARGE_OFF_T to be 9223372036854775807, since some C++ compilers masquerading as C compilers incorrectly reject 9223372036854775807. */ #define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31)) int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 && LARGE_OFF_T % 2147483647 == 1) ? 1 : -1]; int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_sys_large_files=no; break fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define _LARGE_FILES 1 #include /* Check that off_t can represent 2**63 - 1 correctly. We can't simply define LARGE_OFF_T to be 9223372036854775807, since some C++ compilers masquerading as C compilers incorrectly reject 9223372036854775807. */ #define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31)) int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 && LARGE_OFF_T % 2147483647 == 1) ? 1 : -1]; int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_sys_large_files=1; break fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_sys_large_files=unknown break done fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sys_large_files" >&5 $as_echo "$ac_cv_sys_large_files" >&6; } case $ac_cv_sys_large_files in #( no | unknown) ;; *) cat >>confdefs.h <<_ACEOF #define _LARGE_FILES $ac_cv_sys_large_files _ACEOF ;; esac rm -rf conftest* fi fi # Checks for libraries. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -lgcc" >&5 $as_echo_n "checking for main in -lgcc... " >&6; } if ${ac_cv_lib_gcc_main+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgcc $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_gcc_main=yes else ac_cv_lib_gcc_main=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gcc_main" >&5 $as_echo "$ac_cv_lib_gcc_main" >&6; } if test "x$ac_cv_lib_gcc_main" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBGCC 1 _ACEOF LIBS="-lgcc $LIBS" fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -lgcc_s" >&5 $as_echo_n "checking for main in -lgcc_s... " >&6; } if ${ac_cv_lib_gcc_s_main+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgcc_s $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_gcc_s_main=yes else ac_cv_lib_gcc_s_main=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gcc_s_main" >&5 $as_echo "$ac_cv_lib_gcc_s_main" >&6; } if test "x$ac_cv_lib_gcc_s_main" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBGCC_S 1 _ACEOF LIBS="-lgcc_s $LIBS" fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -lstdc++" >&5 $as_echo_n "checking for main in -lstdc++... " >&6; } if ${ac_cv_lib_stdcpp_main+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lstdc++ $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_stdcpp_main=yes else ac_cv_lib_stdcpp_main=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_stdcpp_main" >&5 $as_echo "$ac_cv_lib_stdcpp_main" >&6; } if test "x$ac_cv_lib_stdcpp_main" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBSTDC__ 1 _ACEOF LIBS="-lstdc++ $LIBS" fi # These can sometimes be in the standard libraries { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing dlopen" >&5 $as_echo_n "checking for library containing dlopen... " >&6; } if ${ac_cv_search_dlopen+:} false; then : $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlopen (); int main () { return dlopen (); ; return 0; } _ACEOF for ac_lib in '' dl dld; do if test -z "$ac_lib"; then ac_res="none required" else ac_res=-l$ac_lib LIBS="-l$ac_lib $ac_func_search_save_LIBS" fi if ac_fn_c_try_link "$LINENO"; then : ac_cv_search_dlopen=$ac_res fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext if ${ac_cv_search_dlopen+:} false; then : break fi done if ${ac_cv_search_dlopen+:} false; then : else ac_cv_search_dlopen=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dlopen" >&5 $as_echo "$ac_cv_search_dlopen" >&6; } ac_res=$ac_cv_search_dlopen if test "$ac_res" != no; then : test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing floor" >&5 $as_echo_n "checking for library containing floor... " >&6; } if ${ac_cv_search_floor+:} false; then : $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char floor (); int main () { return floor (); ; return 0; } _ACEOF for ac_lib in '' m; do if test -z "$ac_lib"; then ac_res="none required" else ac_res=-l$ac_lib LIBS="-l$ac_lib $ac_func_search_save_LIBS" fi if ac_fn_c_try_link "$LINENO"; then : ac_cv_search_floor=$ac_res fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext if ${ac_cv_search_floor+:} false; then : break fi done if ${ac_cv_search_floor+:} false; then : else ac_cv_search_floor=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_floor" >&5 $as_echo "$ac_cv_search_floor" >&6; } ac_res=$ac_cv_search_floor if test "$ac_res" != no; then : test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" fi ## External names on Win64. They have no leading underscores as per ## the X64 ABI published by MS. Earlier versions of GCC (anything ## prior to 4.5.0) were faulty. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for _ prefix in compiled symbols" >&5 $as_echo_n "checking for _ prefix in compiled symbols... " >&6; } if ${lt_cv_sys_symbol_underscore+:} false; then : $as_echo_n "(cached) " >&6 else lt_cv_sys_symbol_underscore=no cat > conftest.$ac_ext <<_LT_EOF void nm_test_func(){} int main(){nm_test_func;return 0;} _LT_EOF if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 (eval $ac_compile) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then # Now try to grab the symbols. ac_nlist=conftest.nm if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$NM conftest.$ac_objext \| $lt_cv_sys_global_symbol_pipe \> $ac_nlist\""; } >&5 (eval $NM conftest.$ac_objext \| $lt_cv_sys_global_symbol_pipe \> $ac_nlist) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && test -s "$ac_nlist"; then # See whether the symbols have a leading underscore. if grep '^. _nm_test_func' "$ac_nlist" >/dev/null; then lt_cv_sys_symbol_underscore=yes else if grep '^. nm_test_func ' "$ac_nlist" >/dev/null; then : else echo "configure: cannot find nm_test_func in $ac_nlist" >&5 fi fi else echo "configure: cannot run $lt_cv_sys_global_symbol_pipe" >&5 fi else echo "configure: failed program was:" >&5 cat conftest.c >&5 fi rm -rf conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_sys_symbol_underscore" >&5 $as_echo "$lt_cv_sys_symbol_underscore" >&6; } sys_symbol_underscore=$lt_cv_sys_symbol_underscore if test x$sys_symbol_underscore = xyes; then $as_echo "#define SYMBOLS_REQUIRE_UNDERSCORE 1" >>confdefs.h fi # Check for headers ac_fn_c_check_type "$LINENO" "size_t" "ac_cv_type_size_t" "$ac_includes_default" if test "x$ac_cv_type_size_t" = xyes; then : else cat >>confdefs.h <<_ACEOF #define size_t unsigned int _ACEOF fi # The Ultrix 4.2 mips builtin alloca declared by alloca.h only works # for constant arguments. Useless! { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working alloca.h" >&5 $as_echo_n "checking for working alloca.h... " >&6; } if ${ac_cv_working_alloca_h+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { char *p = (char *) alloca (2 * sizeof (int)); if (p) return 0; ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_working_alloca_h=yes else ac_cv_working_alloca_h=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_working_alloca_h" >&5 $as_echo "$ac_cv_working_alloca_h" >&6; } if test $ac_cv_working_alloca_h = yes; then $as_echo "#define HAVE_ALLOCA_H 1" >>confdefs.h fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for alloca" >&5 $as_echo_n "checking for alloca... " >&6; } if ${ac_cv_func_alloca_works+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __GNUC__ # define alloca __builtin_alloca #else # ifdef _MSC_VER # include # define alloca _alloca # else # ifdef HAVE_ALLOCA_H # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca /* predefined by HP cc +Olibcalls */ void *alloca (size_t); # endif # endif # endif # endif #endif int main () { char *p = (char *) alloca (1); if (p) return 0; ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_func_alloca_works=yes else ac_cv_func_alloca_works=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_alloca_works" >&5 $as_echo "$ac_cv_func_alloca_works" >&6; } if test $ac_cv_func_alloca_works = yes; then $as_echo "#define HAVE_ALLOCA 1" >>confdefs.h else # The SVR3 libPW and SVR4 libucb both contain incompatible functions # that cause trouble. Some versions do not even contain alloca or # contain a buggy version. If you still want to use their alloca, # use ar to extract alloca.o from them instead of compiling alloca.c. ALLOCA=\${LIBOBJDIR}alloca.$ac_objext $as_echo "#define C_ALLOCA 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether \`alloca.c' needs Cray hooks" >&5 $as_echo_n "checking whether \`alloca.c' needs Cray hooks... " >&6; } if ${ac_cv_os_cray+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #if defined CRAY && ! defined CRAY2 webecray #else wenotbecray #endif _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "webecray" >/dev/null 2>&1; then : ac_cv_os_cray=yes else ac_cv_os_cray=no fi rm -f conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_os_cray" >&5 $as_echo "$ac_cv_os_cray" >&6; } if test $ac_cv_os_cray = yes; then for ac_func in _getb67 GETB67 getb67; do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" if eval test \"x\$"$as_ac_var"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define CRAY_STACKSEG_END $ac_func _ACEOF break fi done fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking stack direction for C alloca" >&5 $as_echo_n "checking stack direction for C alloca... " >&6; } if ${ac_cv_c_stack_direction+:} false; then : $as_echo_n "(cached) " >&6 else if test "$cross_compiling" = yes; then : ac_cv_c_stack_direction=0 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default int find_stack_direction (int *addr, int depth) { int dir, dummy = 0; if (! addr) addr = &dummy; *addr = addr < &dummy ? 1 : addr == &dummy ? 0 : -1; dir = depth ? find_stack_direction (addr, depth - 1) : 0; return dir + dummy; } int main (int argc, char **argv) { return find_stack_direction (0, argc + !argv + 20) < 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : ac_cv_c_stack_direction=1 else ac_cv_c_stack_direction=-1 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_stack_direction" >&5 $as_echo "$ac_cv_c_stack_direction" >&6; } cat >>confdefs.h <<_ACEOF #define STACK_DIRECTION $ac_cv_c_stack_direction _ACEOF fi ac_header_dirent=no for ac_hdr in dirent.h sys/ndir.h sys/dir.h ndir.h; do as_ac_Header=`$as_echo "ac_cv_header_dirent_$ac_hdr" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_hdr that defines DIR" >&5 $as_echo_n "checking for $ac_hdr that defines DIR... " >&6; } if eval \${$as_ac_Header+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include <$ac_hdr> int main () { if ((DIR *) 0) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : eval "$as_ac_Header=yes" else eval "$as_ac_Header=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$as_ac_Header { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_hdr" | $as_tr_cpp` 1 _ACEOF ac_header_dirent=$ac_hdr; break fi done # Two versions of opendir et al. are in -ldir and -lx on SCO Xenix. if test $ac_header_dirent = dirent.h; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing opendir" >&5 $as_echo_n "checking for library containing opendir... " >&6; } if ${ac_cv_search_opendir+:} false; then : $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char opendir (); int main () { return opendir (); ; return 0; } _ACEOF for ac_lib in '' dir; do if test -z "$ac_lib"; then ac_res="none required" else ac_res=-l$ac_lib LIBS="-l$ac_lib $ac_func_search_save_LIBS" fi if ac_fn_c_try_link "$LINENO"; then : ac_cv_search_opendir=$ac_res fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext if ${ac_cv_search_opendir+:} false; then : break fi done if ${ac_cv_search_opendir+:} false; then : else ac_cv_search_opendir=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_opendir" >&5 $as_echo "$ac_cv_search_opendir" >&6; } ac_res=$ac_cv_search_opendir if test "$ac_res" != no; then : test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" fi else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing opendir" >&5 $as_echo_n "checking for library containing opendir... " >&6; } if ${ac_cv_search_opendir+:} false; then : $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char opendir (); int main () { return opendir (); ; return 0; } _ACEOF for ac_lib in '' x; do if test -z "$ac_lib"; then ac_res="none required" else ac_res=-l$ac_lib LIBS="-l$ac_lib $ac_func_search_save_LIBS" fi if ac_fn_c_try_link "$LINENO"; then : ac_cv_search_opendir=$ac_res fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext if ${ac_cv_search_opendir+:} false; then : break fi done if ${ac_cv_search_opendir+:} false; then : else ac_cv_search_opendir=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_opendir" >&5 $as_echo "$ac_cv_search_opendir" >&6; } ac_res=$ac_cv_search_opendir if test "$ac_res" != no; then : test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; } if ${ac_cv_header_stdc+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_stdc=yes else ac_cv_header_stdc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "memchr" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "free" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then : : else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ (('a' <= (c) && (c) <= 'i') \ || ('j' <= (c) && (c) <= 'r') \ || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) return 2; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : else ac_cv_header_stdc=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 $as_echo "$ac_cv_header_stdc" >&6; } if test $ac_cv_header_stdc = yes; then $as_echo "#define STDC_HEADERS 1" >>confdefs.h fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sys/wait.h that is POSIX.1 compatible" >&5 $as_echo_n "checking for sys/wait.h that is POSIX.1 compatible... " >&6; } if ${ac_cv_header_sys_wait_h+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #ifndef WEXITSTATUS # define WEXITSTATUS(stat_val) ((unsigned int) (stat_val) >> 8) #endif #ifndef WIFEXITED # define WIFEXITED(stat_val) (((stat_val) & 255) == 0) #endif int main () { int s; wait (&s); s = WIFEXITED (s) ? WEXITSTATUS (s) : 1; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_sys_wait_h=yes else ac_cv_header_sys_wait_h=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_sys_wait_h" >&5 $as_echo "$ac_cv_header_sys_wait_h" >&6; } if test $ac_cv_header_sys_wait_h = yes; then $as_echo "#define HAVE_SYS_WAIT_H 1" >>confdefs.h fi for ac_header in stdio.h time.h fcntl.h float.h limits.h locale.h malloc.h netdb.h netinet/in.h stddef.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done for ac_header in stdlib.h string.h sys/file.h sys/ioctl.h sys/param.h sys/socket.h sys/systeminfo.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done for ac_header in sys/time.h unistd.h values.h dlfcn.h signal.h ucontext.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done for ac_header in assert.h ctype.h direct.h errno.h excpt.h fenv.h fpu_control.h grp.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done -for ac_header in ieeefp.h io.h math.h memory.h netinet/tcp.h poll.h pwd.h siginfo.h +for ac_header in ieeefp.h io.h math.h memory.h netinet/tcp.h arpa/inet.h poll.h pwd.h siginfo.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done for ac_header in stdarg.h sys/errno.h sys/filio.h sys/mman.h sys/resource.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done for ac_header in sys/signal.h sys/sockio.h sys/stat.h termios.h sys/termios.h sys/times.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done for ac_header in sys/types.h sys/uio.h sys/un.h sys/utsname.h sys/select.h sys/sysctl.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done for ac_header in sys/elf_SPARC.h sys/elf_386.h sys/elf_amd64.h asm/elf.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done for ac_header in windows.h tchar.h semaphore.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done for ac_header in stdint.h inttypes.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done # Only check for the X headers if the user said --with-x. if test "${with_x+set}" = set; then for ac_header in X11/Xlib.h Xm/Xm.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done fi if test "x$ac_cv_env_PKG_CONFIG_set" != "xset"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}pkg-config", so it can be a program name with args. set dummy ${ac_tool_prefix}pkg-config; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_PKG_CONFIG+:} false; then : $as_echo_n "(cached) " >&6 else case $PKG_CONFIG in [\\/]* | ?:[\\/]*) ac_cv_path_PKG_CONFIG="$PKG_CONFIG" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_PKG_CONFIG="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi PKG_CONFIG=$ac_cv_path_PKG_CONFIG if test -n "$PKG_CONFIG"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $PKG_CONFIG" >&5 $as_echo "$PKG_CONFIG" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_path_PKG_CONFIG"; then ac_pt_PKG_CONFIG=$PKG_CONFIG # Extract the first word of "pkg-config", so it can be a program name with args. set dummy pkg-config; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_ac_pt_PKG_CONFIG+:} false; then : $as_echo_n "(cached) " >&6 else case $ac_pt_PKG_CONFIG in [\\/]* | ?:[\\/]*) ac_cv_path_ac_pt_PKG_CONFIG="$ac_pt_PKG_CONFIG" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_ac_pt_PKG_CONFIG="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi ac_pt_PKG_CONFIG=$ac_cv_path_ac_pt_PKG_CONFIG if test -n "$ac_pt_PKG_CONFIG"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_pt_PKG_CONFIG" >&5 $as_echo "$ac_pt_PKG_CONFIG" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_pt_PKG_CONFIG" = x; then PKG_CONFIG="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac PKG_CONFIG=$ac_pt_PKG_CONFIG fi else PKG_CONFIG="$ac_cv_path_PKG_CONFIG" fi fi if test -n "$PKG_CONFIG"; then _pkg_min_version=0.9.0 { $as_echo "$as_me:${as_lineno-$LINENO}: checking pkg-config is at least version $_pkg_min_version" >&5 $as_echo_n "checking pkg-config is at least version $_pkg_min_version... " >&6; } if $PKG_CONFIG --atleast-pkgconfig-version $_pkg_min_version; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } PKG_CONFIG="" fi fi # Check for GMP # Check whether --with-gmp was given. if test "${with_gmp+set}" = set; then : withval=$with_gmp; else with_gmp=check fi # If we want GMP check that the library and headers are installed. if test "x$with_gmp" != "xno"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for __gmpn_tdiv_qr in -lgmp" >&5 $as_echo_n "checking for __gmpn_tdiv_qr in -lgmp... " >&6; } if ${ac_cv_lib_gmp___gmpn_tdiv_qr+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgmp $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char __gmpn_tdiv_qr (); int main () { return __gmpn_tdiv_qr (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_gmp___gmpn_tdiv_qr=yes else ac_cv_lib_gmp___gmpn_tdiv_qr=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gmp___gmpn_tdiv_qr" >&5 $as_echo "$ac_cv_lib_gmp___gmpn_tdiv_qr" >&6; } if test "x$ac_cv_lib_gmp___gmpn_tdiv_qr" = xyes; then : $as_echo "#define HAVE_LIBGMP 1" >>confdefs.h LIBS="-lgmp $LIBS" ac_fn_c_check_header_mongrel "$LINENO" "gmp.h" "ac_cv_header_gmp_h" "$ac_includes_default" if test "x$ac_cv_header_gmp_h" = xyes; then : $as_echo "#define HAVE_GMP_H 1" >>confdefs.h else if test "x$with_gmp" != "xcheck"; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "--with-gmp was given, but gmp.h header file is not installed See \`config.log' for more details" "$LINENO" 5; } fi fi else if test "x$with_gmp" != "xcheck"; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "--with-gmp was given, but gmp library (version 4 or later) is not installed See \`config.log' for more details" "$LINENO" 5; } fi fi fi # libffi # libffi must be configured even if we are not building with it so that things like "make dist" work. subdirs="$subdirs libpolyml/libffi" # Use the internal version unless --with-system-libffi is given. # Check whether --with-system-libffi was given. if test "${with_system_libffi+set}" = set; then : withval=$with_system_libffi; else with_system_libffi=no fi # Libffi uses pkg-config. if test "x$with_system_libffi" = "xyes"; then pkg_failed=no { $as_echo "$as_me:${as_lineno-$LINENO}: checking for FFI" >&5 $as_echo_n "checking for FFI... " >&6; } if test -n "$FFI_CFLAGS"; then pkg_cv_FFI_CFLAGS="$FFI_CFLAGS" elif test -n "$PKG_CONFIG"; then if test -n "$PKG_CONFIG" && \ { { $as_echo "$as_me:${as_lineno-$LINENO}: \$PKG_CONFIG --exists --print-errors \"libffi\""; } >&5 ($PKG_CONFIG --exists --print-errors "libffi") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then pkg_cv_FFI_CFLAGS=`$PKG_CONFIG --cflags "libffi" 2>/dev/null` test "x$?" != "x0" && pkg_failed=yes else pkg_failed=yes fi else pkg_failed=untried fi if test -n "$FFI_LIBS"; then pkg_cv_FFI_LIBS="$FFI_LIBS" elif test -n "$PKG_CONFIG"; then if test -n "$PKG_CONFIG" && \ { { $as_echo "$as_me:${as_lineno-$LINENO}: \$PKG_CONFIG --exists --print-errors \"libffi\""; } >&5 ($PKG_CONFIG --exists --print-errors "libffi") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then pkg_cv_FFI_LIBS=`$PKG_CONFIG --libs "libffi" 2>/dev/null` test "x$?" != "x0" && pkg_failed=yes else pkg_failed=yes fi else pkg_failed=untried fi if test $pkg_failed = yes; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } if $PKG_CONFIG --atleast-pkgconfig-version 0.20; then _pkg_short_errors_supported=yes else _pkg_short_errors_supported=no fi if test $_pkg_short_errors_supported = yes; then FFI_PKG_ERRORS=`$PKG_CONFIG --short-errors --print-errors --cflags --libs "libffi" 2>&1` else FFI_PKG_ERRORS=`$PKG_CONFIG --print-errors --cflags --libs "libffi" 2>&1` fi # Put the nasty error message in config.log where it belongs echo "$FFI_PKG_ERRORS" >&5 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ffi_prep_closure_loc in -lffi" >&5 $as_echo_n "checking for ffi_prep_closure_loc in -lffi... " >&6; } if ${ac_cv_lib_ffi_ffi_prep_closure_loc+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lffi $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char ffi_prep_closure_loc (); int main () { return ffi_prep_closure_loc (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_ffi_ffi_prep_closure_loc=yes else ac_cv_lib_ffi_ffi_prep_closure_loc=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_ffi_ffi_prep_closure_loc" >&5 $as_echo "$ac_cv_lib_ffi_ffi_prep_closure_loc" >&6; } if test "x$ac_cv_lib_ffi_ffi_prep_closure_loc" = xyes; then : LIBS="-lffi $LIBS" ac_fn_c_check_header_mongrel "$LINENO" "ffi.h" "ac_cv_header_ffi_h" "$ac_includes_default" if test "x$ac_cv_header_ffi_h" = xyes; then : else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "--with-system-libffi was given, but ffi.h header file cannot be found See \`config.log' for more details" "$LINENO" 5; } fi else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "--with-system-libffi was given, but the ffi library is not installed See \`config.log' for more details" "$LINENO" 5; } fi elif test $pkg_failed = untried; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ffi_prep_closure_loc in -lffi" >&5 $as_echo_n "checking for ffi_prep_closure_loc in -lffi... " >&6; } if ${ac_cv_lib_ffi_ffi_prep_closure_loc+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lffi $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char ffi_prep_closure_loc (); int main () { return ffi_prep_closure_loc (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_ffi_ffi_prep_closure_loc=yes else ac_cv_lib_ffi_ffi_prep_closure_loc=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_ffi_ffi_prep_closure_loc" >&5 $as_echo "$ac_cv_lib_ffi_ffi_prep_closure_loc" >&6; } if test "x$ac_cv_lib_ffi_ffi_prep_closure_loc" = xyes; then : LIBS="-lffi $LIBS" ac_fn_c_check_header_mongrel "$LINENO" "ffi.h" "ac_cv_header_ffi_h" "$ac_includes_default" if test "x$ac_cv_header_ffi_h" = xyes; then : else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "--with-system-libffi was given, but ffi.h header file cannot be found See \`config.log' for more details" "$LINENO" 5; } fi else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "--with-system-libffi was given, but the ffi library is not installed See \`config.log' for more details" "$LINENO" 5; } fi else FFI_CFLAGS=$pkg_cv_FFI_CFLAGS FFI_LIBS=$pkg_cv_FFI_LIBS { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } LIBS="$FFI_LIBS $LIBS" CFLAGS="$FFI_CFLAGS $CFLAGS" fi else # Use internal libffi CFLAGS="$CFLAGS -Ilibffi/include" CXXFLAGS="$CXXFLAGS -Ilibffi/include" fi if test "x$with_system_libffi" != "xyes"; then INTERNAL_LIBFFI_TRUE= INTERNAL_LIBFFI_FALSE='#' else INTERNAL_LIBFFI_TRUE='#' INTERNAL_LIBFFI_FALSE= fi # Special configuration for Windows or Unix. poly_windows_enablegui=false if test "x$poly_native_windows" = xyes; then # The next two are only used with mingw. We mustn't include ws2_32 in Cygwin64 because # the "select" function gets used instead of Cygwin's own. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -lws2_32" >&5 $as_echo_n "checking for main in -lws2_32... " >&6; } if ${ac_cv_lib_ws2_32_main+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lws2_32 $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_ws2_32_main=yes else ac_cv_lib_ws2_32_main=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_ws2_32_main" >&5 $as_echo "$ac_cv_lib_ws2_32_main" >&6; } if test "x$ac_cv_lib_ws2_32_main" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBWS2_32 1 _ACEOF LIBS="-lws2_32 $LIBS" fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -lgdi32" >&5 $as_echo_n "checking for main in -lgdi32... " >&6; } if ${ac_cv_lib_gdi32_main+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgdi32 $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_gdi32_main=yes else ac_cv_lib_gdi32_main=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gdi32_main" >&5 $as_echo "$ac_cv_lib_gdi32_main" >&6; } if test "x$ac_cv_lib_gdi32_main" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBGDI32 1 _ACEOF LIBS="-lgdi32 $LIBS" fi CFLAGS="$CFLAGS -mthreads" CXXFLAGS="$CXXFLAGS -mthreads" OSFLAG="-DUNICODE -D_UNICODE -D_WIN32_WINNT=0x600" if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}windres", so it can be a program name with args. set dummy ${ac_tool_prefix}windres; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_WINDRES+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$WINDRES"; then ac_cv_prog_WINDRES="$WINDRES" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_WINDRES="${ac_tool_prefix}windres" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi WINDRES=$ac_cv_prog_WINDRES if test -n "$WINDRES"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $WINDRES" >&5 $as_echo "$WINDRES" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_WINDRES"; then ac_ct_WINDRES=$WINDRES # Extract the first word of "windres", so it can be a program name with args. set dummy windres; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_WINDRES+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_WINDRES"; then ac_cv_prog_ac_ct_WINDRES="$ac_ct_WINDRES" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_WINDRES="windres" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_WINDRES=$ac_cv_prog_ac_ct_WINDRES if test -n "$ac_ct_WINDRES"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_WINDRES" >&5 $as_echo "$ac_ct_WINDRES" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_WINDRES" = x; then WINDRES="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac WINDRES=$ac_ct_WINDRES fi else WINDRES="$ac_cv_prog_WINDRES" fi # Enable/Disable the GUI in Windows. # Check whether --enable-windows-gui was given. if test "${enable_windows_gui+set}" = set; then : enableval=$enable_windows_gui; case "${enableval}" in yes) poly_windows_enablegui=true ;; no) poly_windows_enablegui=false ;; *) as_fn_error $? "bad value ${enableval} for --enable-windows-gui" "$LINENO" 5 ;; esac else poly_windows_enablegui=true fi else # Unix or similar e.g. Cygwin. We need pthreads. # On Android pthread_create is in the standard library { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing pthread_create" >&5 $as_echo_n "checking for library containing pthread_create... " >&6; } if ${ac_cv_search_pthread_create+:} false; then : $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_create (); int main () { return pthread_create (); ; return 0; } _ACEOF for ac_lib in '' pthread; do if test -z "$ac_lib"; then ac_res="none required" else ac_res=-l$ac_lib LIBS="-l$ac_lib $ac_func_search_save_LIBS" fi if ac_fn_c_try_link "$LINENO"; then : ac_cv_search_pthread_create=$ac_res fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext if ${ac_cv_search_pthread_create+:} false; then : break fi done if ${ac_cv_search_pthread_create+:} false; then : else ac_cv_search_pthread_create=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_pthread_create" >&5 $as_echo "$ac_cv_search_pthread_create" >&6; } ac_res=$ac_cv_search_pthread_create if test "$ac_res" != no; then : test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" $as_echo "#define HAVE_LIBPTHREAD 1" >>confdefs.h ac_fn_c_check_header_mongrel "$LINENO" "pthread.h" "ac_cv_header_pthread_h" "$ac_includes_default" if test "x$ac_cv_header_pthread_h" = xyes; then : $as_echo "#define HAVE_PTHREAD_H 1" >>confdefs.h else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "pthread.h header file is not installed See \`config.log' for more details" "$LINENO" 5; } fi else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "pthread library is not installed See \`config.log' for more details" "$LINENO" 5; } fi # Solaris needs -lsocket, -lnsl and -lrt { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing gethostbyname" >&5 $as_echo_n "checking for library containing gethostbyname... " >&6; } if ${ac_cv_search_gethostbyname+:} false; then : $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gethostbyname (); int main () { return gethostbyname (); ; return 0; } _ACEOF for ac_lib in '' nsl; do if test -z "$ac_lib"; then ac_res="none required" else ac_res=-l$ac_lib LIBS="-l$ac_lib $ac_func_search_save_LIBS" fi if ac_fn_c_try_link "$LINENO"; then : ac_cv_search_gethostbyname=$ac_res fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext if ${ac_cv_search_gethostbyname+:} false; then : break fi done if ${ac_cv_search_gethostbyname+:} false; then : else ac_cv_search_gethostbyname=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_gethostbyname" >&5 $as_echo "$ac_cv_search_gethostbyname" >&6; } ac_res=$ac_cv_search_gethostbyname if test "$ac_res" != no; then : test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing getsockopt" >&5 $as_echo_n "checking for library containing getsockopt... " >&6; } if ${ac_cv_search_getsockopt+:} false; then : $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char getsockopt (); int main () { return getsockopt (); ; return 0; } _ACEOF for ac_lib in '' socket; do if test -z "$ac_lib"; then ac_res="none required" else ac_res=-l$ac_lib LIBS="-l$ac_lib $ac_func_search_save_LIBS" fi if ac_fn_c_try_link "$LINENO"; then : ac_cv_search_getsockopt=$ac_res fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext if ${ac_cv_search_getsockopt+:} false; then : break fi done if ${ac_cv_search_getsockopt+:} false; then : else ac_cv_search_getsockopt=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_getsockopt" >&5 $as_echo "$ac_cv_search_getsockopt" >&6; } ac_res=$ac_cv_search_getsockopt if test "$ac_res" != no; then : test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing sem_wait" >&5 $as_echo_n "checking for library containing sem_wait... " >&6; } if ${ac_cv_search_sem_wait+:} false; then : $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char sem_wait (); int main () { return sem_wait (); ; return 0; } _ACEOF for ac_lib in '' rt; do if test -z "$ac_lib"; then ac_res="none required" else ac_res=-l$ac_lib LIBS="-l$ac_lib $ac_func_search_save_LIBS" fi if ac_fn_c_try_link "$LINENO"; then : ac_cv_search_sem_wait=$ac_res fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext if ${ac_cv_search_sem_wait+:} false; then : break fi done if ${ac_cv_search_sem_wait+:} false; then : else ac_cv_search_sem_wait=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_sem_wait" >&5 $as_echo "$ac_cv_search_sem_wait" >&6; } ac_res=$ac_cv_search_sem_wait if test "$ac_res" != no; then : test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" fi # Check for X and Motif headers and libraries { $as_echo "$as_me:${as_lineno-$LINENO}: checking for X" >&5 $as_echo_n "checking for X... " >&6; } # Check whether --with-x was given. if test "${with_x+set}" = set; then : withval=$with_x; fi # $have_x is `yes', `no', `disabled', or empty when we do not yet know. if test "x$with_x" = xno; then # The user explicitly disabled X. have_x=disabled else case $x_includes,$x_libraries in #( *\'*) as_fn_error $? "cannot use X directory names containing '" "$LINENO" 5;; #( *,NONE | NONE,*) if ${ac_cv_have_x+:} false; then : $as_echo_n "(cached) " >&6 else # One or both of the vars are not set, and there is no cached value. ac_x_includes=no ac_x_libraries=no rm -f -r conftest.dir if mkdir conftest.dir; then cd conftest.dir cat >Imakefile <<'_ACEOF' incroot: @echo incroot='${INCROOT}' usrlibdir: @echo usrlibdir='${USRLIBDIR}' libdir: @echo libdir='${LIBDIR}' _ACEOF if (export CC; ${XMKMF-xmkmf}) >/dev/null 2>/dev/null && test -f Makefile; then # GNU make sometimes prints "make[1]: Entering ...", which would confuse us. for ac_var in incroot usrlibdir libdir; do eval "ac_im_$ac_var=\`\${MAKE-make} $ac_var 2>/dev/null | sed -n 's/^$ac_var=//p'\`" done # Open Windows xmkmf reportedly sets LIBDIR instead of USRLIBDIR. for ac_extension in a so sl dylib la dll; do if test ! -f "$ac_im_usrlibdir/libX11.$ac_extension" && test -f "$ac_im_libdir/libX11.$ac_extension"; then ac_im_usrlibdir=$ac_im_libdir; break fi done # Screen out bogus values from the imake configuration. They are # bogus both because they are the default anyway, and because # using them would break gcc on systems where it needs fixed includes. case $ac_im_incroot in /usr/include) ac_x_includes= ;; *) test -f "$ac_im_incroot/X11/Xos.h" && ac_x_includes=$ac_im_incroot;; esac case $ac_im_usrlibdir in /usr/lib | /usr/lib64 | /lib | /lib64) ;; *) test -d "$ac_im_usrlibdir" && ac_x_libraries=$ac_im_usrlibdir ;; esac fi cd .. rm -f -r conftest.dir fi # Standard set of common directories for X headers. # Check X11 before X11Rn because it is often a symlink to the current release. ac_x_header_dirs=' /usr/X11/include /usr/X11R7/include /usr/X11R6/include /usr/X11R5/include /usr/X11R4/include /usr/include/X11 /usr/include/X11R7 /usr/include/X11R6 /usr/include/X11R5 /usr/include/X11R4 /usr/local/X11/include /usr/local/X11R7/include /usr/local/X11R6/include /usr/local/X11R5/include /usr/local/X11R4/include /usr/local/include/X11 /usr/local/include/X11R7 /usr/local/include/X11R6 /usr/local/include/X11R5 /usr/local/include/X11R4 /usr/X386/include /usr/x386/include /usr/XFree86/include/X11 /usr/include /usr/local/include /usr/unsupported/include /usr/athena/include /usr/local/x11r5/include /usr/lpp/Xamples/include /usr/openwin/include /usr/openwin/share/include' if test "$ac_x_includes" = no; then # Guess where to find include files, by looking for Xlib.h. # First, try using that file with no special directory specified. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # We can compile using X headers with no special include directory. ac_x_includes= else for ac_dir in $ac_x_header_dirs; do if test -r "$ac_dir/X11/Xlib.h"; then ac_x_includes=$ac_dir break fi done fi rm -f conftest.err conftest.i conftest.$ac_ext fi # $ac_x_includes = no if test "$ac_x_libraries" = no; then # Check for the libraries. # See if we find them without any special options. # Don't add to $LIBS permanently. ac_save_LIBS=$LIBS LIBS="-lX11 $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { XrmInitialize () ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : LIBS=$ac_save_LIBS # We can link X programs with no special library path. ac_x_libraries= else LIBS=$ac_save_LIBS for ac_dir in `$as_echo "$ac_x_includes $ac_x_header_dirs" | sed s/include/lib/g` do # Don't even attempt the hair of trying to link an X program! for ac_extension in a so sl dylib la dll; do if test -r "$ac_dir/libX11.$ac_extension"; then ac_x_libraries=$ac_dir break 2 fi done done fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi # $ac_x_libraries = no case $ac_x_includes,$ac_x_libraries in #( no,* | *,no | *\'*) # Didn't find X, or a directory has "'" in its name. ac_cv_have_x="have_x=no";; #( *) # Record where we found X for the cache. ac_cv_have_x="have_x=yes\ ac_x_includes='$ac_x_includes'\ ac_x_libraries='$ac_x_libraries'" esac fi ;; #( *) have_x=yes;; esac eval "$ac_cv_have_x" fi # $with_x != no if test "$have_x" != yes; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $have_x" >&5 $as_echo "$have_x" >&6; } no_x=yes else # If each of the values was on the command line, it overrides each guess. test "x$x_includes" = xNONE && x_includes=$ac_x_includes test "x$x_libraries" = xNONE && x_libraries=$ac_x_libraries # Update the cache value to reflect the command line values. ac_cv_have_x="have_x=yes\ ac_x_includes='$x_includes'\ ac_x_libraries='$x_libraries'" { $as_echo "$as_me:${as_lineno-$LINENO}: result: libraries $x_libraries, headers $x_includes" >&5 $as_echo "libraries $x_libraries, headers $x_includes" >&6; } fi if test "x${with_x}" = "xyes"; then $as_echo "#define WITH_XWINDOWS 1" >>confdefs.h if test "$x_includes" != "" ; then if test "$x_includes" != "NONE" ; then CFLAGS="$CFLAGS -I$x_includes" CXXFLAGS="$CXXFLAGS -I$x_includes" CPPFLAGS="$CPPFLAGS -I$x_includes" fi fi if test "$x_libraries" != "" ; then if test "$x_libraries" != "NONE" ; then LIBS="-L$x_libraries $LIBS" fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for XCreateGC in -lX11" >&5 $as_echo_n "checking for XCreateGC in -lX11... " >&6; } if ${ac_cv_lib_X11_XCreateGC+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lX11 $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char XCreateGC (); int main () { return XCreateGC (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_X11_XCreateGC=yes else ac_cv_lib_X11_XCreateGC=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_X11_XCreateGC" >&5 $as_echo "$ac_cv_lib_X11_XCreateGC" >&6; } if test "x$ac_cv_lib_X11_XCreateGC" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBX11 1 _ACEOF LIBS="-lX11 $LIBS" fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for XtMalloc in -lXt" >&5 $as_echo_n "checking for XtMalloc in -lXt... " >&6; } if ${ac_cv_lib_Xt_XtMalloc+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lXt $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char XtMalloc (); int main () { return XtMalloc (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_Xt_XtMalloc=yes else ac_cv_lib_Xt_XtMalloc=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_Xt_XtMalloc" >&5 $as_echo "$ac_cv_lib_Xt_XtMalloc" >&6; } if test "x$ac_cv_lib_Xt_XtMalloc" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBXT 1 _ACEOF LIBS="-lXt $LIBS" fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for XextAddDisplay in -lXext" >&5 $as_echo_n "checking for XextAddDisplay in -lXext... " >&6; } if ${ac_cv_lib_Xext_XextAddDisplay+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lXext $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char XextAddDisplay (); int main () { return XextAddDisplay (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_Xext_XextAddDisplay=yes else ac_cv_lib_Xext_XextAddDisplay=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_Xext_XextAddDisplay" >&5 $as_echo "$ac_cv_lib_Xext_XextAddDisplay" >&6; } if test "x$ac_cv_lib_Xext_XextAddDisplay" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBXEXT 1 _ACEOF LIBS="-lXext $LIBS" fi if test "$xm_includes" != "" ; then if test "$xm_includes" != "NONE" ; then CFLAGS="$CFLAGS -I$xm_includes" CXXFLAGS="$CXXFLAGS -I$xm_includes" CPPFLAGS="$CPPFLAGS -I$xm_includes" fi fi if test "$xm_libraries" != "" ; then if test "$xm_libraries" != "NONE" ; then LIBS="-L$xm_libraries $LIBS" fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for XmGetDestination in -lXm" >&5 $as_echo_n "checking for XmGetDestination in -lXm... " >&6; } if ${ac_cv_lib_Xm_XmGetDestination+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lXm $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char XmGetDestination (); int main () { return XmGetDestination (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_Xm_XmGetDestination=yes else ac_cv_lib_Xm_XmGetDestination=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_Xm_XmGetDestination" >&5 $as_echo "$ac_cv_lib_Xm_XmGetDestination" >&6; } if test "x$ac_cv_lib_Xm_XmGetDestination" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBXM 1 _ACEOF LIBS="-lXm $LIBS" fi fi # TODO: May need AC_PATH_XTRA for Solaris fi # End of Windows/Unix configuration. # Find out which type of object code exporter to use. # If we have winnt use PECOFF. This really only applies to cygwin here. # If we have elf.h use ELF. # If we have mach-o/reloc.h use Mach-O # Otherwise use the C source code exporter. ac_fn_c_check_type "$LINENO" "IMAGE_FILE_HEADER" "ac_cv_type_IMAGE_FILE_HEADER" "#include " if test "x$ac_cv_type_IMAGE_FILE_HEADER" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_IMAGE_FILE_HEADER 1 _ACEOF $as_echo "#define HAVE_PECOFF /**/" >>confdefs.h polyexport=pecoff else ac_fn_c_check_header_mongrel "$LINENO" "elf.h" "ac_cv_header_elf_h" "$ac_includes_default" if test "x$ac_cv_header_elf_h" = xyes; then : $as_echo "#define HAVE_ELF_H /**/" >>confdefs.h polyexport=elf else ac_fn_c_check_header_mongrel "$LINENO" "mach-o/reloc.h" "ac_cv_header_mach_o_reloc_h" "$ac_includes_default" if test "x$ac_cv_header_mach_o_reloc_h" = xyes; then : $as_echo "#define HAVE_MACH_O_RELOC_H /**/" >>confdefs.h polyexport=macho else for ac_header in elf_abi.h machine/reloc.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF $as_echo "#define HAVE_ELF_ABI_H /**/" >>confdefs.h polyexport=elf fi done fi fi fi if test "$polyexport" = pecoff; then EXPPECOFF_TRUE= EXPPECOFF_FALSE='#' else EXPPECOFF_TRUE='#' EXPPECOFF_FALSE= fi if test "$polyexport" = elf; then EXPELF_TRUE= EXPELF_FALSE='#' else EXPELF_TRUE='#' EXPELF_FALSE= fi if test "$polyexport" = macho; then EXPMACHO_TRUE= EXPMACHO_FALSE='#' else EXPMACHO_TRUE='#' EXPMACHO_FALSE= fi # Checks for typedefs, structures, and compiler characteristics. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for stdbool.h that conforms to C99" >&5 $as_echo_n "checking for stdbool.h that conforms to C99... " >&6; } if ${ac_cv_header_stdbool_h+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #ifndef bool "error: bool is not defined" #endif #ifndef false "error: false is not defined" #endif #if false "error: false is not 0" #endif #ifndef true "error: true is not defined" #endif #if true != 1 "error: true is not 1" #endif #ifndef __bool_true_false_are_defined "error: __bool_true_false_are_defined is not defined" #endif struct s { _Bool s: 1; _Bool t; } s; char a[true == 1 ? 1 : -1]; char b[false == 0 ? 1 : -1]; char c[__bool_true_false_are_defined == 1 ? 1 : -1]; char d[(bool) 0.5 == true ? 1 : -1]; /* See body of main program for 'e'. */ char f[(_Bool) 0.0 == false ? 1 : -1]; char g[true]; char h[sizeof (_Bool)]; char i[sizeof s.t]; enum { j = false, k = true, l = false * true, m = true * 256 }; /* The following fails for HP aC++/ANSI C B3910B A.05.55 [Dec 04 2003]. */ _Bool n[m]; char o[sizeof n == m * sizeof n[0] ? 1 : -1]; char p[-1 - (_Bool) 0 < 0 && -1 - (bool) 0 < 0 ? 1 : -1]; /* Catch a bug in an HP-UX C compiler. See http://gcc.gnu.org/ml/gcc-patches/2003-12/msg02303.html http://lists.gnu.org/archive/html/bug-coreutils/2005-11/msg00161.html */ _Bool q = true; _Bool *pq = &q; int main () { bool e = &s; *pq |= q; *pq |= ! q; /* Refer to every declared value, to avoid compiler optimizations. */ return (!a + !b + !c + !d + !e + !f + !g + !h + !i + !!j + !k + !!l + !m + !n + !o + !p + !q + !pq); ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_stdbool_h=yes else ac_cv_header_stdbool_h=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdbool_h" >&5 $as_echo "$ac_cv_header_stdbool_h" >&6; } ac_fn_c_check_type "$LINENO" "_Bool" "ac_cv_type__Bool" "$ac_includes_default" if test "x$ac_cv_type__Bool" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE__BOOL 1 _ACEOF fi if test $ac_cv_header_stdbool_h = yes; then $as_echo "#define HAVE_STDBOOL_H 1" >>confdefs.h fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for an ANSI C-conforming const" >&5 $as_echo_n "checking for an ANSI C-conforming const... " >&6; } if ${ac_cv_c_const+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { #ifndef __cplusplus /* Ultrix mips cc rejects this sort of thing. */ typedef int charset[2]; const charset cs = { 0, 0 }; /* SunOS 4.1.1 cc rejects this. */ char const *const *pcpcc; char **ppc; /* NEC SVR4.0.2 mips cc rejects this. */ struct point {int x, y;}; static struct point const zero = {0,0}; /* AIX XL C 1.02.0.0 rejects this. It does not let you subtract one const X* pointer from another in an arm of an if-expression whose if-part is not a constant expression */ const char *g = "string"; pcpcc = &g + (g ? g-g : 0); /* HPUX 7.0 cc rejects these. */ ++pcpcc; ppc = (char**) pcpcc; pcpcc = (char const *const *) ppc; { /* SCO 3.2v4 cc rejects this sort of thing. */ char tx; char *t = &tx; char const *s = 0 ? (char *) 0 : (char const *) 0; *t++ = 0; if (s) return 0; } { /* Someone thinks the Sun supposedly-ANSI compiler will reject this. */ int x[] = {25, 17}; const int *foo = &x[0]; ++foo; } { /* Sun SC1.0 ANSI compiler rejects this -- but not the above. */ typedef const int *iptr; iptr p = 0; ++p; } { /* AIX XL C 1.02.0.0 rejects this sort of thing, saying "k.c", line 2.27: 1506-025 (S) Operand must be a modifiable lvalue. */ struct s { int j; const int *ap[3]; } bx; struct s *b = &bx; b->j = 5; } { /* ULTRIX-32 V3.1 (Rev 9) vcc rejects this */ const int foo = 10; if (!foo) return 0; } return !cs[0] && !zero.x; #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_c_const=yes else ac_cv_c_const=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_const" >&5 $as_echo "$ac_cv_c_const" >&6; } if test $ac_cv_c_const = no; then $as_echo "#define const /**/" >>confdefs.h fi ac_fn_c_find_intX_t "$LINENO" "16" "ac_cv_c_int16_t" case $ac_cv_c_int16_t in #( no|yes) ;; #( *) cat >>confdefs.h <<_ACEOF #define int16_t $ac_cv_c_int16_t _ACEOF ;; esac ac_fn_c_find_uintX_t "$LINENO" "16" "ac_cv_c_uint16_t" case $ac_cv_c_uint16_t in #( no|yes) ;; #( *) cat >>confdefs.h <<_ACEOF #define uint16_t $ac_cv_c_uint16_t _ACEOF ;; esac ac_fn_c_find_intX_t "$LINENO" "32" "ac_cv_c_int32_t" case $ac_cv_c_int32_t in #( no|yes) ;; #( *) cat >>confdefs.h <<_ACEOF #define int32_t $ac_cv_c_int32_t _ACEOF ;; esac ac_fn_c_find_uintX_t "$LINENO" "32" "ac_cv_c_uint32_t" case $ac_cv_c_uint32_t in #( no|yes) ;; #( *) $as_echo "#define _UINT32_T 1" >>confdefs.h cat >>confdefs.h <<_ACEOF #define uint32_t $ac_cv_c_uint32_t _ACEOF ;; esac ac_fn_c_find_intX_t "$LINENO" "64" "ac_cv_c_int64_t" case $ac_cv_c_int64_t in #( no|yes) ;; #( *) cat >>confdefs.h <<_ACEOF #define int64_t $ac_cv_c_int64_t _ACEOF ;; esac ac_fn_c_find_uintX_t "$LINENO" "64" "ac_cv_c_uint64_t" case $ac_cv_c_uint64_t in #( no|yes) ;; #( *) $as_echo "#define _UINT64_T 1" >>confdefs.h cat >>confdefs.h <<_ACEOF #define uint64_t $ac_cv_c_uint64_t _ACEOF ;; esac ac_fn_c_check_type "$LINENO" "intptr_t" "ac_cv_type_intptr_t" "$ac_includes_default" if test "x$ac_cv_type_intptr_t" = xyes; then : $as_echo "#define HAVE_INTPTR_T 1" >>confdefs.h else for ac_type in 'int' 'long int' 'long long int'; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !(sizeof (void *) <= sizeof ($ac_type))]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : cat >>confdefs.h <<_ACEOF #define intptr_t $ac_type _ACEOF ac_type= fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext test -z "$ac_type" && break done fi ac_fn_c_check_type "$LINENO" "uintptr_t" "ac_cv_type_uintptr_t" "$ac_includes_default" if test "x$ac_cv_type_uintptr_t" = xyes; then : $as_echo "#define HAVE_UINTPTR_T 1" >>confdefs.h else for ac_type in 'unsigned int' 'unsigned long int' \ 'unsigned long long int'; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !(sizeof (void *) <= sizeof ($ac_type))]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : cat >>confdefs.h <<_ACEOF #define uintptr_t $ac_type _ACEOF ac_type= fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext test -z "$ac_type" && break done fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for uid_t in sys/types.h" >&5 $as_echo_n "checking for uid_t in sys/types.h... " >&6; } if ${ac_cv_type_uid_t+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "uid_t" >/dev/null 2>&1; then : ac_cv_type_uid_t=yes else ac_cv_type_uid_t=no fi rm -f conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_type_uid_t" >&5 $as_echo "$ac_cv_type_uid_t" >&6; } if test $ac_cv_type_uid_t = no; then $as_echo "#define uid_t int" >>confdefs.h $as_echo "#define gid_t int" >>confdefs.h fi ac_fn_c_check_type "$LINENO" "mode_t" "ac_cv_type_mode_t" "$ac_includes_default" if test "x$ac_cv_type_mode_t" = xyes; then : else cat >>confdefs.h <<_ACEOF #define mode_t int _ACEOF fi ac_fn_c_check_type "$LINENO" "off_t" "ac_cv_type_off_t" "$ac_includes_default" if test "x$ac_cv_type_off_t" = xyes; then : else cat >>confdefs.h <<_ACEOF #define off_t long int _ACEOF fi ac_fn_c_check_type "$LINENO" "pid_t" "ac_cv_type_pid_t" "$ac_includes_default" if test "x$ac_cv_type_pid_t" = xyes; then : else cat >>confdefs.h <<_ACEOF #define pid_t int _ACEOF fi ac_fn_c_check_type "$LINENO" "size_t" "ac_cv_type_size_t" "$ac_includes_default" if test "x$ac_cv_type_size_t" = xyes; then : else cat >>confdefs.h <<_ACEOF #define size_t unsigned int _ACEOF fi ac_fn_c_check_type "$LINENO" "ssize_t" "ac_cv_type_ssize_t" "$ac_includes_default" if test "x$ac_cv_type_ssize_t" = xyes; then : else cat >>confdefs.h <<_ACEOF #define ssize_t int _ACEOF fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether time.h and sys/time.h may both be included" >&5 $as_echo_n "checking whether time.h and sys/time.h may both be included... " >&6; } if ${ac_cv_header_time+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include int main () { if ((struct tm *) 0) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_time=yes else ac_cv_header_time=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_time" >&5 $as_echo "$ac_cv_header_time" >&6; } if test $ac_cv_header_time = yes; then $as_echo "#define TIME_WITH_SYS_TIME 1" >>confdefs.h fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether struct tm is in sys/time.h or time.h" >&5 $as_echo_n "checking whether struct tm is in sys/time.h or time.h... " >&6; } if ${ac_cv_struct_tm+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main () { struct tm tm; int *p = &tm.tm_sec; return !p; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_struct_tm=time.h else ac_cv_struct_tm=sys/time.h fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_struct_tm" >&5 $as_echo "$ac_cv_struct_tm" >&6; } if test $ac_cv_struct_tm = sys/time.h; then $as_echo "#define TM_IN_SYS_TIME 1" >>confdefs.h fi # Check for the various sub-second fields of the stat structure. ac_fn_c_check_member "$LINENO" "struct stat" "st_atim" "ac_cv_member_struct_stat_st_atim" "$ac_includes_default" if test "x$ac_cv_member_struct_stat_st_atim" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT_STAT_ST_ATIM 1 _ACEOF fi ac_fn_c_check_member "$LINENO" "struct stat" "st_atimespec" "ac_cv_member_struct_stat_st_atimespec" "$ac_includes_default" if test "x$ac_cv_member_struct_stat_st_atimespec" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT_STAT_ST_ATIMESPEC 1 _ACEOF fi ac_fn_c_check_member "$LINENO" "struct stat" "st_atimensec" "ac_cv_member_struct_stat_st_atimensec" "$ac_includes_default" if test "x$ac_cv_member_struct_stat_st_atimensec" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT_STAT_ST_ATIMENSEC 1 _ACEOF fi ac_fn_c_check_member "$LINENO" "struct stat" "st_atime_n" "ac_cv_member_struct_stat_st_atime_n" "$ac_includes_default" if test "x$ac_cv_member_struct_stat_st_atime_n" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT_STAT_ST_ATIME_N 1 _ACEOF fi ac_fn_c_check_member "$LINENO" "struct stat" "st_uatime" "ac_cv_member_struct_stat_st_uatime" "$ac_includes_default" if test "x$ac_cv_member_struct_stat_st_uatime" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT_STAT_ST_UATIME 1 _ACEOF fi # Mac OS X, at any rate, needs signal.h to be included first. ac_fn_c_check_type "$LINENO" "ucontext_t" "ac_cv_type_ucontext_t" "#include \"signal.h\" #include \"ucontext.h\" " if test "x$ac_cv_type_ucontext_t" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_UCONTEXT_T 1 _ACEOF fi ac_fn_c_check_type "$LINENO" "struct sigcontext" "ac_cv_type_struct_sigcontext" "#include \"signal.h\" " if test "x$ac_cv_type_struct_sigcontext" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT_SIGCONTEXT 1 _ACEOF fi ac_fn_c_check_type "$LINENO" "stack_t" "ac_cv_type_stack_t" "#include \"signal.h\" " if test "x$ac_cv_type_stack_t" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STACK_T 1 _ACEOF fi ac_fn_c_check_type "$LINENO" "sighandler_t" "ac_cv_type_sighandler_t" "#include \"signal.h\" " if test "x$ac_cv_type_sighandler_t" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_SIGHANDLER_T 1 _ACEOF fi ac_fn_c_check_type "$LINENO" "sig_t" "ac_cv_type_sig_t" "#include \"signal.h\" " if test "x$ac_cv_type_sig_t" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_SIG_T 1 _ACEOF fi ac_fn_c_check_type "$LINENO" "socklen_t" "ac_cv_type_socklen_t" "#include \"sys/types.h\" #include \"sys/socket.h\" " if test "x$ac_cv_type_socklen_t" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_SOCKLEN_T 1 _ACEOF fi ac_fn_c_check_type "$LINENO" "SYSTEM_LOGICAL_PROCESSOR_INFORMATION" "ac_cv_type_SYSTEM_LOGICAL_PROCESSOR_INFORMATION" "#include \"windows.h\" " if test "x$ac_cv_type_SYSTEM_LOGICAL_PROCESSOR_INFORMATION" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_SYSTEM_LOGICAL_PROCESSOR_INFORMATION 1 _ACEOF fi ac_fn_c_check_type "$LINENO" "long long" "ac_cv_type_long_long" "$ac_includes_default" if test "x$ac_cv_type_long_long" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LONG_LONG 1 _ACEOF fi ac_fn_c_check_type "$LINENO" "ssize_t" "ac_cv_type_ssize_t" "$ac_includes_default" if test "x$ac_cv_type_ssize_t" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_SSIZE_T 1 _ACEOF fi # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of void*" >&5 $as_echo_n "checking size of void*... " >&6; } if ${ac_cv_sizeof_voidp+:} false; then : $as_echo_n "(cached) " >&6 else if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (void*))" "ac_cv_sizeof_voidp" "$ac_includes_default"; then : else if test "$ac_cv_type_voidp" = yes; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (void*) See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_voidp=0 fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_voidp" >&5 $as_echo "$ac_cv_sizeof_voidp" >&6; } cat >>confdefs.h <<_ACEOF #define SIZEOF_VOIDP $ac_cv_sizeof_voidp _ACEOF # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of long" >&5 $as_echo_n "checking size of long... " >&6; } if ${ac_cv_sizeof_long+:} false; then : $as_echo_n "(cached) " >&6 else if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long))" "ac_cv_sizeof_long" "$ac_includes_default"; then : else if test "$ac_cv_type_long" = yes; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (long) See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_long=0 fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_long" >&5 $as_echo "$ac_cv_sizeof_long" >&6; } cat >>confdefs.h <<_ACEOF #define SIZEOF_LONG $ac_cv_sizeof_long _ACEOF # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of int" >&5 $as_echo_n "checking size of int... " >&6; } if ${ac_cv_sizeof_int+:} false; then : $as_echo_n "(cached) " >&6 else if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (int))" "ac_cv_sizeof_int" "$ac_includes_default"; then : else if test "$ac_cv_type_int" = yes; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (int) See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_int=0 fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_int" >&5 $as_echo "$ac_cv_sizeof_int" >&6; } cat >>confdefs.h <<_ACEOF #define SIZEOF_INT $ac_cv_sizeof_int _ACEOF # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of long long" >&5 $as_echo_n "checking size of long long... " >&6; } if ${ac_cv_sizeof_long_long+:} false; then : $as_echo_n "(cached) " >&6 else if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long long))" "ac_cv_sizeof_long_long" "$ac_includes_default"; then : else if test "$ac_cv_type_long_long" = yes; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (long long) See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_long_long=0 fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_long_long" >&5 $as_echo "$ac_cv_sizeof_long_long" >&6; } cat >>confdefs.h <<_ACEOF #define SIZEOF_LONG_LONG $ac_cv_sizeof_long_long _ACEOF # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of double" >&5 $as_echo_n "checking size of double... " >&6; } if ${ac_cv_sizeof_double+:} false; then : $as_echo_n "(cached) " >&6 else if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (double))" "ac_cv_sizeof_double" "$ac_includes_default"; then : else if test "$ac_cv_type_double" = yes; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (double) See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_double=0 fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_double" >&5 $as_echo "$ac_cv_sizeof_double" >&6; } cat >>confdefs.h <<_ACEOF #define SIZEOF_DOUBLE $ac_cv_sizeof_double _ACEOF # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of float" >&5 $as_echo_n "checking size of float... " >&6; } if ${ac_cv_sizeof_float+:} false; then : $as_echo_n "(cached) " >&6 else if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (float))" "ac_cv_sizeof_float" "$ac_includes_default"; then : else if test "$ac_cv_type_float" = yes; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (float) See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_float=0 fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_float" >&5 $as_echo "$ac_cv_sizeof_float" >&6; } cat >>confdefs.h <<_ACEOF #define SIZEOF_FLOAT $ac_cv_sizeof_float _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether byte ordering is bigendian" >&5 $as_echo_n "checking whether byte ordering is bigendian... " >&6; } if ${ac_cv_c_bigendian+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_c_bigendian=unknown # See if we're dealing with a universal compiler. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifndef __APPLE_CC__ not a universal capable compiler #endif typedef int dummy; _ACEOF if ac_fn_c_try_compile "$LINENO"; then : # Check for potential -arch flags. It is not universal unless # there are at least two -arch flags with different values. ac_arch= ac_prev= for ac_word in $CC $CFLAGS $CPPFLAGS $LDFLAGS; do if test -n "$ac_prev"; then case $ac_word in i?86 | x86_64 | ppc | ppc64) if test -z "$ac_arch" || test "$ac_arch" = "$ac_word"; then ac_arch=$ac_word else ac_cv_c_bigendian=universal break fi ;; esac ac_prev= elif test "x$ac_word" = "x-arch"; then ac_prev=arch fi done fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_c_bigendian = unknown; then # See if sys/param.h defines the BYTE_ORDER macro. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main () { #if ! (defined BYTE_ORDER && defined BIG_ENDIAN \ && defined LITTLE_ENDIAN && BYTE_ORDER && BIG_ENDIAN \ && LITTLE_ENDIAN) bogus endian macros #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : # It does; now see whether it defined to BIG_ENDIAN or not. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main () { #if BYTE_ORDER != BIG_ENDIAN not big endian #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_c_bigendian=yes else ac_cv_c_bigendian=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi if test $ac_cv_c_bigendian = unknown; then # See if defines _LITTLE_ENDIAN or _BIG_ENDIAN (e.g., Solaris). cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { #if ! (defined _LITTLE_ENDIAN || defined _BIG_ENDIAN) bogus endian macros #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : # It does; now see whether it defined to _BIG_ENDIAN or not. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { #ifndef _BIG_ENDIAN not big endian #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_c_bigendian=yes else ac_cv_c_bigendian=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi if test $ac_cv_c_bigendian = unknown; then # Compile a test program. if test "$cross_compiling" = yes; then : # Try to guess by grepping values from an object file. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ short int ascii_mm[] = { 0x4249, 0x4765, 0x6E44, 0x6961, 0x6E53, 0x7953, 0 }; short int ascii_ii[] = { 0x694C, 0x5454, 0x656C, 0x6E45, 0x6944, 0x6E61, 0 }; int use_ascii (int i) { return ascii_mm[i] + ascii_ii[i]; } short int ebcdic_ii[] = { 0x89D3, 0xE3E3, 0x8593, 0x95C5, 0x89C4, 0x9581, 0 }; short int ebcdic_mm[] = { 0xC2C9, 0xC785, 0x95C4, 0x8981, 0x95E2, 0xA8E2, 0 }; int use_ebcdic (int i) { return ebcdic_mm[i] + ebcdic_ii[i]; } extern int foo; int main () { return use_ascii (foo) == use_ebcdic (foo); ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : if grep BIGenDianSyS conftest.$ac_objext >/dev/null; then ac_cv_c_bigendian=yes fi if grep LiTTleEnDian conftest.$ac_objext >/dev/null ; then if test "$ac_cv_c_bigendian" = unknown; then ac_cv_c_bigendian=no else # finding both strings is unlikely to happen, but who knows? ac_cv_c_bigendian=unknown fi fi fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default int main () { /* Are we little or big endian? From Harbison&Steele. */ union { long int l; char c[sizeof (long int)]; } u; u.l = 1; return u.c[sizeof (long int) - 1] == 1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : ac_cv_c_bigendian=no else ac_cv_c_bigendian=yes fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_bigendian" >&5 $as_echo "$ac_cv_c_bigendian" >&6; } case $ac_cv_c_bigendian in #( yes) $as_echo "#define WORDS_BIGENDIAN 1" >>confdefs.h ;; #( no) ;; #( universal) $as_echo "#define AC_APPLE_UNIVERSAL_BUILD 1" >>confdefs.h ;; #( *) as_fn_error $? "unknown endianness presetting ac_cv_c_bigendian=no (or yes) will help" "$LINENO" 5 ;; esac # Checks for library functions. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for error_at_line" >&5 $as_echo_n "checking for error_at_line... " >&6; } if ${ac_cv_lib_error_at_line+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { error_at_line (0, 0, "", 0, "an error occurred"); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_error_at_line=yes else ac_cv_lib_error_at_line=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_error_at_line" >&5 $as_echo "$ac_cv_lib_error_at_line" >&6; } if test $ac_cv_lib_error_at_line = no; then case " $LIBOBJS " in *" error.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS error.$ac_objext" ;; esac fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking type of array argument to getgroups" >&5 $as_echo_n "checking type of array argument to getgroups... " >&6; } if ${ac_cv_type_getgroups+:} false; then : $as_echo_n "(cached) " >&6 else if test "$cross_compiling" = yes; then : ac_cv_type_getgroups=cross else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Thanks to Mike Rendell for this test. */ $ac_includes_default #define NGID 256 #undef MAX #define MAX(x, y) ((x) > (y) ? (x) : (y)) int main () { gid_t gidset[NGID]; int i, n; union { gid_t gval; long int lval; } val; val.lval = -1; for (i = 0; i < NGID; i++) gidset[i] = val.gval; n = getgroups (sizeof (gidset) / MAX (sizeof (int), sizeof (gid_t)) - 1, gidset); /* Exit non-zero if getgroups seems to require an array of ints. This happens when gid_t is short int but getgroups modifies an array of ints. */ return n > 0 && gidset[n] != val.gval; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : ac_cv_type_getgroups=gid_t else ac_cv_type_getgroups=int fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi if test $ac_cv_type_getgroups = cross; then cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "getgroups.*int.*gid_t" >/dev/null 2>&1; then : ac_cv_type_getgroups=gid_t else ac_cv_type_getgroups=int fi rm -f conftest* fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_type_getgroups" >&5 $as_echo "$ac_cv_type_getgroups" >&6; } cat >>confdefs.h <<_ACEOF #define GETGROUPS_T $ac_cv_type_getgroups _ACEOF ac_fn_c_check_func "$LINENO" "getgroups" "ac_cv_func_getgroups" if test "x$ac_cv_func_getgroups" = xyes; then : fi # If we don't yet have getgroups, see if it's in -lbsd. # This is reported to be necessary on an ITOS 3000WS running SEIUX 3.1. ac_save_LIBS=$LIBS if test $ac_cv_func_getgroups = no; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getgroups in -lbsd" >&5 $as_echo_n "checking for getgroups in -lbsd... " >&6; } if ${ac_cv_lib_bsd_getgroups+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lbsd $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char getgroups (); int main () { return getgroups (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_bsd_getgroups=yes else ac_cv_lib_bsd_getgroups=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bsd_getgroups" >&5 $as_echo "$ac_cv_lib_bsd_getgroups" >&6; } if test "x$ac_cv_lib_bsd_getgroups" = xyes; then : GETGROUPS_LIB=-lbsd fi fi # Run the program to test the functionality of the system-supplied # getgroups function only if there is such a function. if test $ac_cv_func_getgroups = yes; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working getgroups" >&5 $as_echo_n "checking for working getgroups... " >&6; } if ${ac_cv_func_getgroups_works+:} false; then : $as_echo_n "(cached) " >&6 else if test "$cross_compiling" = yes; then : ac_cv_func_getgroups_works=no else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default int main () { /* On Ultrix 4.3, getgroups (0, 0) always fails. */ return getgroups (0, 0) == -1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : ac_cv_func_getgroups_works=yes else ac_cv_func_getgroups_works=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_getgroups_works" >&5 $as_echo "$ac_cv_func_getgroups_works" >&6; } else ac_cv_func_getgroups_works=no fi if test $ac_cv_func_getgroups_works = yes; then $as_echo "#define HAVE_GETGROUPS 1" >>confdefs.h fi LIBS=$ac_save_LIBS { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether getpgrp requires zero arguments" >&5 $as_echo_n "checking whether getpgrp requires zero arguments... " >&6; } if ${ac_cv_func_getpgrp_void+:} false; then : $as_echo_n "(cached) " >&6 else # Use it with a single arg. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default int main () { getpgrp (0); ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_func_getpgrp_void=no else ac_cv_func_getpgrp_void=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_getpgrp_void" >&5 $as_echo "$ac_cv_func_getpgrp_void" >&6; } if test $ac_cv_func_getpgrp_void = yes; then $as_echo "#define GETPGRP_VOID 1" >>confdefs.h fi if test $ac_cv_c_compiler_gnu = yes; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC needs -traditional" >&5 $as_echo_n "checking whether $CC needs -traditional... " >&6; } if ${ac_cv_prog_gcc_traditional+:} false; then : $as_echo_n "(cached) " >&6 else ac_pattern="Autoconf.*'x'" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include Autoconf TIOCGETP _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "$ac_pattern" >/dev/null 2>&1; then : ac_cv_prog_gcc_traditional=yes else ac_cv_prog_gcc_traditional=no fi rm -f conftest* if test $ac_cv_prog_gcc_traditional = no; then cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include Autoconf TCGETA _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "$ac_pattern" >/dev/null 2>&1; then : ac_cv_prog_gcc_traditional=yes fi rm -f conftest* fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_gcc_traditional" >&5 $as_echo "$ac_cv_prog_gcc_traditional" >&6; } if test $ac_cv_prog_gcc_traditional = yes; then CC="$CC -traditional" fi fi for ac_header in sys/select.h sys/socket.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done { $as_echo "$as_me:${as_lineno-$LINENO}: checking types of arguments for select" >&5 $as_echo_n "checking types of arguments for select... " >&6; } if ${ac_cv_func_select_args+:} false; then : $as_echo_n "(cached) " >&6 else for ac_arg234 in 'fd_set *' 'int *' 'void *'; do for ac_arg1 in 'int' 'size_t' 'unsigned long int' 'unsigned int'; do for ac_arg5 in 'struct timeval *' 'const struct timeval *'; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default #ifdef HAVE_SYS_SELECT_H # include #endif #ifdef HAVE_SYS_SOCKET_H # include #endif int main () { extern int select ($ac_arg1, $ac_arg234, $ac_arg234, $ac_arg234, $ac_arg5); ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_func_select_args="$ac_arg1,$ac_arg234,$ac_arg5"; break 3 fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext done done done # Provide a safe default value. : "${ac_cv_func_select_args=int,int *,struct timeval *}" fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_select_args" >&5 $as_echo "$ac_cv_func_select_args" >&6; } ac_save_IFS=$IFS; IFS=',' set dummy `echo "$ac_cv_func_select_args" | sed 's/\*/\*/g'` IFS=$ac_save_IFS shift cat >>confdefs.h <<_ACEOF #define SELECT_TYPE_ARG1 $1 _ACEOF cat >>confdefs.h <<_ACEOF #define SELECT_TYPE_ARG234 ($2) _ACEOF cat >>confdefs.h <<_ACEOF #define SELECT_TYPE_ARG5 ($3) _ACEOF rm -f conftest* { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether lstat correctly handles trailing slash" >&5 $as_echo_n "checking whether lstat correctly handles trailing slash... " >&6; } if ${ac_cv_func_lstat_dereferences_slashed_symlink+:} false; then : $as_echo_n "(cached) " >&6 else rm -f conftest.sym conftest.file echo >conftest.file if test "$as_ln_s" = "ln -s" && ln -s conftest.file conftest.sym; then if test "$cross_compiling" = yes; then : ac_cv_func_lstat_dereferences_slashed_symlink=no else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default int main () { struct stat sbuf; /* Linux will dereference the symlink and fail, as required by POSIX. That is better in the sense that it means we will not have to compile and use the lstat wrapper. */ return lstat ("conftest.sym/", &sbuf) == 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : ac_cv_func_lstat_dereferences_slashed_symlink=yes else ac_cv_func_lstat_dereferences_slashed_symlink=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi else # If the `ln -s' command failed, then we probably don't even # have an lstat function. ac_cv_func_lstat_dereferences_slashed_symlink=no fi rm -f conftest.sym conftest.file fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_lstat_dereferences_slashed_symlink" >&5 $as_echo "$ac_cv_func_lstat_dereferences_slashed_symlink" >&6; } test $ac_cv_func_lstat_dereferences_slashed_symlink = yes && cat >>confdefs.h <<_ACEOF #define LSTAT_FOLLOWS_SLASHED_SYMLINK 1 _ACEOF if test "x$ac_cv_func_lstat_dereferences_slashed_symlink" = xno; then case " $LIBOBJS " in *" lstat.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS lstat.$ac_objext" ;; esac fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether stat accepts an empty string" >&5 $as_echo_n "checking whether stat accepts an empty string... " >&6; } if ${ac_cv_func_stat_empty_string_bug+:} false; then : $as_echo_n "(cached) " >&6 else if test "$cross_compiling" = yes; then : ac_cv_func_stat_empty_string_bug=yes else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default int main () { struct stat sbuf; return stat ("", &sbuf) == 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : ac_cv_func_stat_empty_string_bug=no else ac_cv_func_stat_empty_string_bug=yes fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_stat_empty_string_bug" >&5 $as_echo "$ac_cv_func_stat_empty_string_bug" >&6; } if test $ac_cv_func_stat_empty_string_bug = yes; then case " $LIBOBJS " in *" stat.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS stat.$ac_objext" ;; esac cat >>confdefs.h <<_ACEOF #define HAVE_STAT_EMPTY_STRING_BUG 1 _ACEOF fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working strtod" >&5 $as_echo_n "checking for working strtod... " >&6; } if ${ac_cv_func_strtod+:} false; then : $as_echo_n "(cached) " >&6 else if test "$cross_compiling" = yes; then : ac_cv_func_strtod=no else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default #ifndef strtod double strtod (); #endif int main() { { /* Some versions of Linux strtod mis-parse strings with leading '+'. */ char *string = " +69"; char *term; double value; value = strtod (string, &term); if (value != 69 || term != (string + 4)) return 1; } { /* Under Solaris 2.4, strtod returns the wrong value for the terminating character under some conditions. */ char *string = "NaN"; char *term; strtod (string, &term); if (term != string && *(term - 1) == 0) return 1; } return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : ac_cv_func_strtod=yes else ac_cv_func_strtod=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_strtod" >&5 $as_echo "$ac_cv_func_strtod" >&6; } if test $ac_cv_func_strtod = no; then case " $LIBOBJS " in *" strtod.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS strtod.$ac_objext" ;; esac ac_fn_c_check_func "$LINENO" "pow" "ac_cv_func_pow" if test "x$ac_cv_func_pow" = xyes; then : fi if test $ac_cv_func_pow = no; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pow in -lm" >&5 $as_echo_n "checking for pow in -lm... " >&6; } if ${ac_cv_lib_m_pow+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lm $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pow (); int main () { return pow (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_m_pow=yes else ac_cv_lib_m_pow=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_m_pow" >&5 $as_echo "$ac_cv_lib_m_pow" >&6; } if test "x$ac_cv_lib_m_pow" = xyes; then : POW_LIB=-lm else { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cannot find library containing definition of pow" >&5 $as_echo "$as_me: WARNING: cannot find library containing definition of pow" >&2;} fi fi fi for ac_func in dlopen strtod dtoa getpagesize sigaltstack mmap mkstemp do : as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" if eval test \"x\$"$as_ac_var"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done ## There does not seem to be a declaration for fpsetmask in mingw64. ac_fn_c_check_decl "$LINENO" "fpsetmask" "ac_cv_have_decl_fpsetmask" "#include " if test "x$ac_cv_have_decl_fpsetmask" = xyes; then : ac_have_decl=1 else ac_have_decl=0 fi cat >>confdefs.h <<_ACEOF #define HAVE_DECL_FPSETMASK $ac_have_decl _ACEOF for ac_func in sysctl sysctlbyname do : as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" if eval test \"x\$"$as_ac_var"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in localtime_r gmtime_r do : as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" if eval test \"x\$"$as_ac_var"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in ctermid tcdrain do : as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" if eval test \"x\$"$as_ac_var"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done # Where are the registers when we get a signal? Used in time profiling. #Linux: ac_fn_c_check_member "$LINENO" "mcontext_t" "gregs" "ac_cv_member_mcontext_t_gregs" "#include \"ucontext.h\" " if test "x$ac_cv_member_mcontext_t_gregs" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_MCONTEXT_T_GREGS 1 _ACEOF fi ac_fn_c_check_member "$LINENO" "mcontext_t" "regs" "ac_cv_member_mcontext_t_regs" "#include \"ucontext.h\" " if test "x$ac_cv_member_mcontext_t_regs" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_MCONTEXT_T_REGS 1 _ACEOF fi ac_fn_c_check_member "$LINENO" "mcontext_t" "mc_esp" "ac_cv_member_mcontext_t_mc_esp" "#include \"ucontext.h\" " if test "x$ac_cv_member_mcontext_t_mc_esp" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_MCONTEXT_T_MC_ESP 1 _ACEOF fi #Mac OS X: ac_fn_c_check_member "$LINENO" "struct mcontext" "ss" "ac_cv_member_struct_mcontext_ss" "#include \"signal.h\" #include \"ucontext.h\" " if test "x$ac_cv_member_struct_mcontext_ss" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT_MCONTEXT_SS 1 _ACEOF fi ac_fn_c_check_member "$LINENO" "struct __darwin_mcontext" "ss" "ac_cv_member_struct___darwin_mcontext_ss" "#include \"signal.h\" #include \"ucontext.h\" " if test "x$ac_cv_member_struct___darwin_mcontext_ss" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT___DARWIN_MCONTEXT_SS 1 _ACEOF fi ac_fn_c_check_member "$LINENO" "struct __darwin_mcontext" "__ss" "ac_cv_member_struct___darwin_mcontext___ss" "#include \"signal.h\" #include \"ucontext.h\" " if test "x$ac_cv_member_struct___darwin_mcontext___ss" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT___DARWIN_MCONTEXT___SS 1 _ACEOF fi ac_fn_c_check_member "$LINENO" "struct __darwin_mcontext32" "ss" "ac_cv_member_struct___darwin_mcontext32_ss" "#include \"signal.h\" #include \"ucontext.h\" " if test "x$ac_cv_member_struct___darwin_mcontext32_ss" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT___DARWIN_MCONTEXT32_SS 1 _ACEOF fi ac_fn_c_check_member "$LINENO" "struct __darwin_mcontext32" "__ss" "ac_cv_member_struct___darwin_mcontext32___ss" "#include \"signal.h\" #include \"ucontext.h\" " if test "x$ac_cv_member_struct___darwin_mcontext32___ss" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT___DARWIN_MCONTEXT32___SS 1 _ACEOF fi ac_fn_c_check_member "$LINENO" "struct __darwin_mcontext64" "ss" "ac_cv_member_struct___darwin_mcontext64_ss" "#include \"signal.h\" #include \"ucontext.h\" " if test "x$ac_cv_member_struct___darwin_mcontext64_ss" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT___DARWIN_MCONTEXT64_SS 1 _ACEOF fi ac_fn_c_check_member "$LINENO" "struct __darwin_mcontext64" "__ss" "ac_cv_member_struct___darwin_mcontext64___ss" "#include \"signal.h\" #include \"ucontext.h\" " if test "x$ac_cv_member_struct___darwin_mcontext64___ss" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT___DARWIN_MCONTEXT64___SS 1 _ACEOF fi # FreeBSD includes a sun_len member in struct sockaddr_un ac_fn_c_check_member "$LINENO" "struct sockaddr_un" "sun_len" "ac_cv_member_struct_sockaddr_un_sun_len" "#include " if test "x$ac_cv_member_struct_sockaddr_un_sun_len" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT_SOCKADDR_UN_SUN_LEN 1 _ACEOF fi # This option enables the native code generator. More precisely it allows # the byte code interpreter to be built on X86. # Check whether --enable-native-codegeneration was given. if test "${enable_native_codegeneration+set}" = set; then : enableval=$enable_native_codegeneration; case "${enableval}" in no) with_portable=yes ;; yes) with_portable=no ;; *) as_fn_error $? "bad value ${enableval} for --enable-native-codegeneration" "$LINENO" 5 ;; esac else with_portable=check fi # Check which CPU we're building for. Can we use a native pre-built compiler # or do we need to fall back to the interpreter? Most of these settings are to tweak # the ELF exporter. case "${host_cpu}" in i[3456]86*) $as_echo "#define HOSTARCHITECTURE_X86 1" >>confdefs.h polyarch=i386 ;; x86_64* | amd64*) if test X"$ac_cv_sizeof_voidp" = X8; then $as_echo "#define HOSTARCHITECTURE_X86_64 1" >>confdefs.h polyarch=x86_64 else $as_echo "#define HOSTARCHITECTURE_X32 1" >>confdefs.h polyarch=interpret fi ;; sparc64*) $as_echo "#define HOSTARCHITECTURE_SPARC64 1" >>confdefs.h polyarch=interpret ;; sparc*) $as_echo "#define HOSTARCHITECTURE_SPARC 1" >>confdefs.h polyarch=interpret ;; powerpc64* | ppc64*) $as_echo "#define HOSTARCHITECTURE_PPC64 1" >>confdefs.h polyarch=interpret ;; power* | ppc*) $as_echo "#define HOSTARCHITECTURE_PPC 1" >>confdefs.h polyarch=interpret ;; arm*) $as_echo "#define HOSTARCHITECTURE_ARM 1" >>confdefs.h polyarch=interpret ;; aarch64*) $as_echo "#define HOSTARCHITECTURE_AARCH64 1" >>confdefs.h polyarch=interpret ;; hppa*) $as_echo "#define HOSTARCHITECTURE_HPPA 1" >>confdefs.h polyarch=interpret ;; ia64*) $as_echo "#define HOSTARCHITECTURE_IA64 1" >>confdefs.h polyarch=interpret ;; m68k*) $as_echo "#define HOSTARCHITECTURE_M68K 1" >>confdefs.h polyarch=interpret ;; mips64*) $as_echo "#define HOSTARCHITECTURE_MIPS64 1" >>confdefs.h polyarch=interpret ;; mips*) $as_echo "#define HOSTARCHITECTURE_MIPS 1" >>confdefs.h polyarch=interpret ;; s390x*) $as_echo "#define HOSTARCHITECTURE_S390X 1" >>confdefs.h polyarch=interpret ;; s390*) $as_echo "#define HOSTARCHITECTURE_S390 1" >>confdefs.h polyarch=interpret ;; sh*) $as_echo "#define HOSTARCHITECTURE_SH 1" >>confdefs.h polyarch=interpret ;; alpha*) $as_echo "#define HOSTARCHITECTURE_ALPHA 1" >>confdefs.h polyarch=interpret # GCC defaults to non-conforming floating-point, and does not respect the rounding mode # in the floating-point control register, so we force it to conform to IEEE and use the # dynamic suffix on the floating-point instructions it produces. CFLAGS="$CFLAGS -mieee -mfp-rounding-mode=d" CXXFLAGS="$CXXFLAGS -mieee -mfp-rounding-mode=d" ;; riscv32) $as_echo "#define HOSTARCHITECTURE_RISCV32 1" >>confdefs.h polyarch=interpret ;; riscv64) $as_echo "#define HOSTARCHITECTURE_RISCV64 1" >>confdefs.h polyarch=interpret ;; *) as_fn_error $? "Poly/ML is not supported for this architecture" "$LINENO" 5 ;; esac # If we explicitly asked to use the interpreter set the architecture to interpreted. if test "x$with_portable" = "xyes" ; then if test "x$polyarch" != "xinterpret" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: *******You have disabled native code generation. Are you really sure you want to do that?*******" >&5 $as_echo "$as_me: WARNING: *******You have disabled native code generation. Are you really sure you want to do that?*******" >&2;} fi polyarch=interpret fi # If we asked not to use the interpreter check we have native code support. if test "x$with_portable" = "xno" ; then if test "x$polyarch" = "xinterpret" ; then as_fn_error $? "--enable-native-codegeneration was given but native code is not supported on this platform" "$LINENO" 5 fi fi if test "x$polyarch" != "xinterpret" ; then # Check for .note.GNU-stack support, used for marking the stack as non-executable. # Only do this check if we're using the native X86 versions. We don't need this if # we're using the interpreter and the assembler on other architectures may choke. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether as supports .note.GNU-stack" >&5 $as_echo_n "checking whether as supports .note.GNU-stack... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ __asm__(".section .note.GNU-stack,\"\",@progbits"); int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } $as_echo "#define HAVE_GNU_STACK 1" >>confdefs.h else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi # Build 32-bit in 64-bits. This is only allowed when building on native 64-bit X86. # Check whether --enable-compact32bit was given. if test "${enable_compact32bit+set}" = set; then : enableval=$enable_compact32bit; fi if test "x$enable_compact32bit" = "xyes"; then if test X"$polyarch" = "Xx86_64" ; then $as_echo "#define POLYML32IN64 1" >>confdefs.h polyarch=x86_32in64 else as_fn_error $? "--enable-compact32bit is only available on X86/64" "$LINENO" 5 fi fi # Put this test at the end where it's less likely to be missed. # If we're compiling on Cygwin (and mingw?) and /usr/bin/file is not present # the link step will produce some strange warning messages of the form: # "Warning: linker path does not have real file for library -lXXX". I think # that's really a bug in autoconf but to explain what's happening to the user # add a test here. if test "$lt_cv_file_magic_cmd" = "func_win32_libid"; then if test \! -x /usr/bin/file; then echo "" echo "*** Warning: You are building Poly/ML on Cygwin/Mingw but '/usr/bin/file' cannot be found." echo "*** You can still go ahead and build Poly/ML but libpolyml will not be built as a" echo "*** shared library and you may get strange warning messages from the linker step." echo "*** Install the 'file' package to correct this problem." echo "" fi fi if test "$polyarch" = i386; then ARCHI386_TRUE= ARCHI386_FALSE='#' else ARCHI386_TRUE='#' ARCHI386_FALSE= fi if test "$polyarch" = x86_64; then ARCHX86_64_TRUE= ARCHX86_64_FALSE='#' else ARCHX86_64_TRUE='#' ARCHX86_64_FALSE= fi if test "$polyarch" = interpret -a X"$ac_cv_sizeof_voidp" = X4; then ARCHINTERPRET_TRUE= ARCHINTERPRET_FALSE='#' else ARCHINTERPRET_TRUE='#' ARCHINTERPRET_FALSE= fi if test "$polyarch" = interpret -a X"$ac_cv_sizeof_voidp" = X8; then ARCHINTERPRET64_TRUE= ARCHINTERPRET64_FALSE='#' else ARCHINTERPRET64_TRUE='#' ARCHINTERPRET64_FALSE= fi if test "$polyarch" = x86_32in64; then ARCHX8632IN64_TRUE= ARCHX8632IN64_FALSE='#' else ARCHX8632IN64_TRUE='#' ARCHX8632IN64_FALSE= fi # If we are targeting Windows rather than *nix we need the pre=built compiler with Windows conventions. if test "$poly_use_windowscc" = yes; then WINDOWSCALLCONV_TRUE= WINDOWSCALLCONV_FALSE='#' else WINDOWSCALLCONV_TRUE='#' WINDOWSCALLCONV_FALSE= fi # This is true if we are building for native Windows rather than Cygwin if test "$poly_native_windows" = yes; then NATIVE_WINDOWS_TRUE= NATIVE_WINDOWS_FALSE='#' else NATIVE_WINDOWS_TRUE='#' NATIVE_WINDOWS_FALSE= fi if test "$poly_no_undefined" = yes; then NO_UNDEFINED_TRUE= NO_UNDEFINED_FALSE='#' else NO_UNDEFINED_TRUE='#' NO_UNDEFINED_FALSE= fi if test x$poly_windows_enablegui = xtrue; then WINDOWSGUI_TRUE= WINDOWSGUI_FALSE='#' else WINDOWSGUI_TRUE='#' WINDOWSGUI_FALSE= fi if test "$poly_need_macosopt" = yes ; then MACOSLDOPTS_TRUE= MACOSLDOPTS_FALSE='#' else MACOSLDOPTS_TRUE='#' MACOSLDOPTS_FALSE= fi # If we're building only the static version of libpolyml # then polyc and polyml.pc have to include the dependent libraries. dependentlibs="" if test "${enable_shared}" != yes; then dependentlibs=${LIBS} fi dependentlibs="$dependentlibs" # Test whether this is a git directory and set the version if possible # Extract the first word of "git", so it can be a program name with args. set dummy git; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_gitinstalled+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$gitinstalled"; then ac_cv_prog_gitinstalled="$gitinstalled" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_gitinstalled="yes" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_gitinstalled" && ac_cv_prog_gitinstalled="no" fi fi gitinstalled=$ac_cv_prog_gitinstalled if test -n "$gitinstalled"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $gitinstalled" >&5 $as_echo "$gitinstalled" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test X"$gitinstalled" = "Xyes" -a -d ".git"; then GIT_VERSION='-DGIT_VERSION=\"$(shell git describe --tags --always)\"' fi # Strip -fdebug-prefix-map= from CFLAGS; it's meaningless for users of polyc, # and hurts reproducibility. polyc_CFLAGS= for cflag in $CFLAGS; do cflag="${cflag##-fdebug-prefix-map=*}" if test -n "$cflag"; then if test -n "$polyc_CFLAGS"; then polyc_CFLAGS="$polyc_CFLAGS $cflag" else polyc_CFLAGS="$cflag" fi fi done polyc_CFLAGS="$polyc_CFLAGS" # Modules directory # Check whether --with-moduledir was given. if test "${with_moduledir+set}" = set; then : withval=$with_moduledir; moduledir=$withval else moduledir="\${libdir}/polyml/modules" fi moduledir=$moduledir # Control whether to build the basis library with arbitrary precision as the default int # Check whether --enable-intinf-as-int was given. if test "${enable_intinf_as_int+set}" = set; then : enableval=$enable_intinf_as_int; case "${enableval}" in no) intisintinf=no ;; yes) intisintinf=yes ;; *) as_fn_error $? "bad value ${enableval} for --enable-intinf-as-int" "$LINENO" 5 ;; esac else intisintinf=no fi if test "$intisintinf" = "yes"; then INTINFISINT_TRUE= INTINFISINT_FALSE='#' else INTINFISINT_TRUE='#' INTINFISINT_FALSE= fi # These are needed for building in a separate build directory, as they are # referenced from exportPoly.sml. ac_config_commands="$ac_config_commands basis" ac_config_commands="$ac_config_commands mlsource" ac_config_files="$ac_config_files Makefile libpolyml/Makefile libpolyml/polyml.pc libpolymain/Makefile modules/Makefile modules/IntInfAsInt/Makefile" ac_config_files="$ac_config_files polyc" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # `set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then if test "x$cache_file" != "x/dev/null"; then { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' DEFS=-DHAVE_CONFIG_H ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs { $as_echo "$as_me:${as_lineno-$LINENO}: checking that generated files are newer than configure" >&5 $as_echo_n "checking that generated files are newer than configure... " >&6; } if test -n "$am_sleep_pid"; then # Hide warnings about reused PIDs. wait $am_sleep_pid 2>/dev/null fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: done" >&5 $as_echo "done" >&6; } if test -n "$EXEEXT"; then am__EXEEXT_TRUE= am__EXEEXT_FALSE='#' else am__EXEEXT_TRUE='#' am__EXEEXT_FALSE= fi if test -z "${AMDEP_TRUE}" && test -z "${AMDEP_FALSE}"; then as_fn_error $? "conditional \"AMDEP\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${am__fastdepCC_TRUE}" && test -z "${am__fastdepCC_FALSE}"; then as_fn_error $? "conditional \"am__fastdepCC\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${MAINTAINER_MODE_TRUE}" && test -z "${MAINTAINER_MODE_FALSE}"; then as_fn_error $? "conditional \"MAINTAINER_MODE\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${am__fastdepCXX_TRUE}" && test -z "${am__fastdepCXX_FALSE}"; then as_fn_error $? "conditional \"am__fastdepCXX\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${am__fastdepCC_TRUE}" && test -z "${am__fastdepCC_FALSE}"; then as_fn_error $? "conditional \"am__fastdepCC\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${am__fastdepCCAS_TRUE}" && test -z "${am__fastdepCCAS_FALSE}"; then as_fn_error $? "conditional \"am__fastdepCCAS\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${INTERNAL_LIBFFI_TRUE}" && test -z "${INTERNAL_LIBFFI_FALSE}"; then as_fn_error $? "conditional \"INTERNAL_LIBFFI\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${EXPPECOFF_TRUE}" && test -z "${EXPPECOFF_FALSE}"; then as_fn_error $? "conditional \"EXPPECOFF\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${EXPELF_TRUE}" && test -z "${EXPELF_FALSE}"; then as_fn_error $? "conditional \"EXPELF\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${EXPMACHO_TRUE}" && test -z "${EXPMACHO_FALSE}"; then as_fn_error $? "conditional \"EXPMACHO\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${ARCHI386_TRUE}" && test -z "${ARCHI386_FALSE}"; then as_fn_error $? "conditional \"ARCHI386\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${ARCHX86_64_TRUE}" && test -z "${ARCHX86_64_FALSE}"; then as_fn_error $? "conditional \"ARCHX86_64\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${ARCHINTERPRET_TRUE}" && test -z "${ARCHINTERPRET_FALSE}"; then as_fn_error $? "conditional \"ARCHINTERPRET\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${ARCHINTERPRET64_TRUE}" && test -z "${ARCHINTERPRET64_FALSE}"; then as_fn_error $? "conditional \"ARCHINTERPRET64\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${ARCHX8632IN64_TRUE}" && test -z "${ARCHX8632IN64_FALSE}"; then as_fn_error $? "conditional \"ARCHX8632IN64\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${WINDOWSCALLCONV_TRUE}" && test -z "${WINDOWSCALLCONV_FALSE}"; then as_fn_error $? "conditional \"WINDOWSCALLCONV\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${NATIVE_WINDOWS_TRUE}" && test -z "${NATIVE_WINDOWS_FALSE}"; then as_fn_error $? "conditional \"NATIVE_WINDOWS\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${NO_UNDEFINED_TRUE}" && test -z "${NO_UNDEFINED_FALSE}"; then as_fn_error $? "conditional \"NO_UNDEFINED\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${WINDOWSGUI_TRUE}" && test -z "${WINDOWSGUI_FALSE}"; then as_fn_error $? "conditional \"WINDOWSGUI\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${MACOSLDOPTS_TRUE}" && test -z "${MACOSLDOPTS_FALSE}"; then as_fn_error $? "conditional \"MACOSLDOPTS\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${INTINFISINT_TRUE}" && test -z "${INTINFISINT_FALSE}"; then as_fn_error $? "conditional \"INTINFISINT\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by Poly/ML $as_me 5.8, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac case $ac_config_headers in *" "*) set x $ac_config_headers; shift; ac_config_headers=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" config_headers="$ac_config_headers" config_commands="$ac_config_commands" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE --header=FILE[:TEMPLATE] instantiate the configuration header FILE Configuration files: $config_files Configuration headers: $config_headers Configuration commands: $config_commands Report bugs to ." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ Poly/ML config.status 5.8 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' INSTALL='$INSTALL' MKDIR_P='$MKDIR_P' AWK='$AWK' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --header | --heade | --head | --hea ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; esac as_fn_append CONFIG_HEADERS " '$ac_optarg'" ac_need_defaults=false;; --he | --h) # Conflict between --help and --header as_fn_error $? "ambiguous option: \`$1' Try \`$0 --help' for more information.";; --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX $as_echo "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # # INIT-COMMANDS # AMDEP_TRUE="$AMDEP_TRUE" ac_aux_dir="$ac_aux_dir" # The HP-UX ksh and POSIX shell print the target directory to stdout # if CDPATH is set. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH sed_quote_subst='$sed_quote_subst' double_quote_subst='$double_quote_subst' delay_variable_subst='$delay_variable_subst' macro_version='`$ECHO "$macro_version" | $SED "$delay_single_quote_subst"`' macro_revision='`$ECHO "$macro_revision" | $SED "$delay_single_quote_subst"`' AS='`$ECHO "$AS" | $SED "$delay_single_quote_subst"`' DLLTOOL='`$ECHO "$DLLTOOL" | $SED "$delay_single_quote_subst"`' OBJDUMP='`$ECHO "$OBJDUMP" | $SED "$delay_single_quote_subst"`' enable_shared='`$ECHO "$enable_shared" | $SED "$delay_single_quote_subst"`' enable_static='`$ECHO "$enable_static" | $SED "$delay_single_quote_subst"`' pic_mode='`$ECHO "$pic_mode" | $SED "$delay_single_quote_subst"`' enable_fast_install='`$ECHO "$enable_fast_install" | $SED "$delay_single_quote_subst"`' shared_archive_member_spec='`$ECHO "$shared_archive_member_spec" | $SED "$delay_single_quote_subst"`' SHELL='`$ECHO "$SHELL" | $SED "$delay_single_quote_subst"`' ECHO='`$ECHO "$ECHO" | $SED "$delay_single_quote_subst"`' PATH_SEPARATOR='`$ECHO "$PATH_SEPARATOR" | $SED "$delay_single_quote_subst"`' host_alias='`$ECHO "$host_alias" | $SED "$delay_single_quote_subst"`' host='`$ECHO "$host" | $SED "$delay_single_quote_subst"`' host_os='`$ECHO "$host_os" | $SED "$delay_single_quote_subst"`' build_alias='`$ECHO "$build_alias" | $SED "$delay_single_quote_subst"`' build='`$ECHO "$build" | $SED "$delay_single_quote_subst"`' build_os='`$ECHO "$build_os" | $SED "$delay_single_quote_subst"`' SED='`$ECHO "$SED" | $SED "$delay_single_quote_subst"`' Xsed='`$ECHO "$Xsed" | $SED "$delay_single_quote_subst"`' GREP='`$ECHO "$GREP" | $SED "$delay_single_quote_subst"`' EGREP='`$ECHO "$EGREP" | $SED "$delay_single_quote_subst"`' FGREP='`$ECHO "$FGREP" | $SED "$delay_single_quote_subst"`' LD='`$ECHO "$LD" | $SED "$delay_single_quote_subst"`' NM='`$ECHO "$NM" | $SED "$delay_single_quote_subst"`' LN_S='`$ECHO "$LN_S" | $SED "$delay_single_quote_subst"`' max_cmd_len='`$ECHO "$max_cmd_len" | $SED "$delay_single_quote_subst"`' ac_objext='`$ECHO "$ac_objext" | $SED "$delay_single_quote_subst"`' exeext='`$ECHO "$exeext" | $SED "$delay_single_quote_subst"`' lt_unset='`$ECHO "$lt_unset" | $SED "$delay_single_quote_subst"`' lt_SP2NL='`$ECHO "$lt_SP2NL" | $SED "$delay_single_quote_subst"`' lt_NL2SP='`$ECHO "$lt_NL2SP" | $SED "$delay_single_quote_subst"`' lt_cv_to_host_file_cmd='`$ECHO "$lt_cv_to_host_file_cmd" | $SED "$delay_single_quote_subst"`' lt_cv_to_tool_file_cmd='`$ECHO "$lt_cv_to_tool_file_cmd" | $SED "$delay_single_quote_subst"`' reload_flag='`$ECHO "$reload_flag" | $SED "$delay_single_quote_subst"`' reload_cmds='`$ECHO "$reload_cmds" | $SED "$delay_single_quote_subst"`' deplibs_check_method='`$ECHO "$deplibs_check_method" | $SED "$delay_single_quote_subst"`' file_magic_cmd='`$ECHO "$file_magic_cmd" | $SED "$delay_single_quote_subst"`' file_magic_glob='`$ECHO "$file_magic_glob" | $SED "$delay_single_quote_subst"`' want_nocaseglob='`$ECHO "$want_nocaseglob" | $SED "$delay_single_quote_subst"`' sharedlib_from_linklib_cmd='`$ECHO "$sharedlib_from_linklib_cmd" | $SED "$delay_single_quote_subst"`' AR='`$ECHO "$AR" | $SED "$delay_single_quote_subst"`' AR_FLAGS='`$ECHO "$AR_FLAGS" | $SED "$delay_single_quote_subst"`' archiver_list_spec='`$ECHO "$archiver_list_spec" | $SED "$delay_single_quote_subst"`' STRIP='`$ECHO "$STRIP" | $SED "$delay_single_quote_subst"`' RANLIB='`$ECHO "$RANLIB" | $SED "$delay_single_quote_subst"`' old_postinstall_cmds='`$ECHO "$old_postinstall_cmds" | $SED "$delay_single_quote_subst"`' old_postuninstall_cmds='`$ECHO "$old_postuninstall_cmds" | $SED "$delay_single_quote_subst"`' old_archive_cmds='`$ECHO "$old_archive_cmds" | $SED "$delay_single_quote_subst"`' lock_old_archive_extraction='`$ECHO "$lock_old_archive_extraction" | $SED "$delay_single_quote_subst"`' CC='`$ECHO "$CC" | $SED "$delay_single_quote_subst"`' CFLAGS='`$ECHO "$CFLAGS" | $SED "$delay_single_quote_subst"`' compiler='`$ECHO "$compiler" | $SED "$delay_single_quote_subst"`' GCC='`$ECHO "$GCC" | $SED "$delay_single_quote_subst"`' lt_cv_sys_global_symbol_pipe='`$ECHO "$lt_cv_sys_global_symbol_pipe" | $SED "$delay_single_quote_subst"`' lt_cv_sys_global_symbol_to_cdecl='`$ECHO "$lt_cv_sys_global_symbol_to_cdecl" | $SED "$delay_single_quote_subst"`' lt_cv_sys_global_symbol_to_import='`$ECHO "$lt_cv_sys_global_symbol_to_import" | $SED "$delay_single_quote_subst"`' lt_cv_sys_global_symbol_to_c_name_address='`$ECHO "$lt_cv_sys_global_symbol_to_c_name_address" | $SED "$delay_single_quote_subst"`' lt_cv_sys_global_symbol_to_c_name_address_lib_prefix='`$ECHO "$lt_cv_sys_global_symbol_to_c_name_address_lib_prefix" | $SED "$delay_single_quote_subst"`' lt_cv_nm_interface='`$ECHO "$lt_cv_nm_interface" | $SED "$delay_single_quote_subst"`' nm_file_list_spec='`$ECHO "$nm_file_list_spec" | $SED "$delay_single_quote_subst"`' lt_sysroot='`$ECHO "$lt_sysroot" | $SED "$delay_single_quote_subst"`' lt_cv_truncate_bin='`$ECHO "$lt_cv_truncate_bin" | $SED "$delay_single_quote_subst"`' objdir='`$ECHO "$objdir" | $SED "$delay_single_quote_subst"`' MAGIC_CMD='`$ECHO "$MAGIC_CMD" | $SED "$delay_single_quote_subst"`' lt_prog_compiler_no_builtin_flag='`$ECHO "$lt_prog_compiler_no_builtin_flag" | $SED "$delay_single_quote_subst"`' lt_prog_compiler_pic='`$ECHO "$lt_prog_compiler_pic" | $SED "$delay_single_quote_subst"`' lt_prog_compiler_wl='`$ECHO "$lt_prog_compiler_wl" | $SED "$delay_single_quote_subst"`' lt_prog_compiler_static='`$ECHO "$lt_prog_compiler_static" | $SED "$delay_single_quote_subst"`' lt_cv_prog_compiler_c_o='`$ECHO "$lt_cv_prog_compiler_c_o" | $SED "$delay_single_quote_subst"`' need_locks='`$ECHO "$need_locks" | $SED "$delay_single_quote_subst"`' MANIFEST_TOOL='`$ECHO "$MANIFEST_TOOL" | $SED "$delay_single_quote_subst"`' DSYMUTIL='`$ECHO "$DSYMUTIL" | $SED "$delay_single_quote_subst"`' NMEDIT='`$ECHO "$NMEDIT" | $SED "$delay_single_quote_subst"`' LIPO='`$ECHO "$LIPO" | $SED "$delay_single_quote_subst"`' OTOOL='`$ECHO "$OTOOL" | $SED "$delay_single_quote_subst"`' OTOOL64='`$ECHO "$OTOOL64" | $SED "$delay_single_quote_subst"`' libext='`$ECHO "$libext" | $SED "$delay_single_quote_subst"`' shrext_cmds='`$ECHO "$shrext_cmds" | $SED "$delay_single_quote_subst"`' extract_expsyms_cmds='`$ECHO "$extract_expsyms_cmds" | $SED "$delay_single_quote_subst"`' archive_cmds_need_lc='`$ECHO "$archive_cmds_need_lc" | $SED "$delay_single_quote_subst"`' enable_shared_with_static_runtimes='`$ECHO "$enable_shared_with_static_runtimes" | $SED "$delay_single_quote_subst"`' export_dynamic_flag_spec='`$ECHO "$export_dynamic_flag_spec" | $SED "$delay_single_quote_subst"`' whole_archive_flag_spec='`$ECHO "$whole_archive_flag_spec" | $SED "$delay_single_quote_subst"`' compiler_needs_object='`$ECHO "$compiler_needs_object" | $SED "$delay_single_quote_subst"`' old_archive_from_new_cmds='`$ECHO "$old_archive_from_new_cmds" | $SED "$delay_single_quote_subst"`' old_archive_from_expsyms_cmds='`$ECHO "$old_archive_from_expsyms_cmds" | $SED "$delay_single_quote_subst"`' archive_cmds='`$ECHO "$archive_cmds" | $SED "$delay_single_quote_subst"`' archive_expsym_cmds='`$ECHO "$archive_expsym_cmds" | $SED "$delay_single_quote_subst"`' module_cmds='`$ECHO "$module_cmds" | $SED "$delay_single_quote_subst"`' module_expsym_cmds='`$ECHO "$module_expsym_cmds" | $SED "$delay_single_quote_subst"`' with_gnu_ld='`$ECHO "$with_gnu_ld" | $SED "$delay_single_quote_subst"`' allow_undefined_flag='`$ECHO "$allow_undefined_flag" | $SED "$delay_single_quote_subst"`' no_undefined_flag='`$ECHO "$no_undefined_flag" | $SED "$delay_single_quote_subst"`' hardcode_libdir_flag_spec='`$ECHO "$hardcode_libdir_flag_spec" | $SED "$delay_single_quote_subst"`' hardcode_libdir_separator='`$ECHO "$hardcode_libdir_separator" | $SED "$delay_single_quote_subst"`' hardcode_direct='`$ECHO "$hardcode_direct" | $SED "$delay_single_quote_subst"`' hardcode_direct_absolute='`$ECHO "$hardcode_direct_absolute" | $SED "$delay_single_quote_subst"`' hardcode_minus_L='`$ECHO "$hardcode_minus_L" | $SED "$delay_single_quote_subst"`' hardcode_shlibpath_var='`$ECHO "$hardcode_shlibpath_var" | $SED "$delay_single_quote_subst"`' hardcode_automatic='`$ECHO "$hardcode_automatic" | $SED "$delay_single_quote_subst"`' inherit_rpath='`$ECHO "$inherit_rpath" | $SED "$delay_single_quote_subst"`' link_all_deplibs='`$ECHO "$link_all_deplibs" | $SED "$delay_single_quote_subst"`' always_export_symbols='`$ECHO "$always_export_symbols" | $SED "$delay_single_quote_subst"`' export_symbols_cmds='`$ECHO "$export_symbols_cmds" | $SED "$delay_single_quote_subst"`' exclude_expsyms='`$ECHO "$exclude_expsyms" | $SED "$delay_single_quote_subst"`' include_expsyms='`$ECHO "$include_expsyms" | $SED "$delay_single_quote_subst"`' prelink_cmds='`$ECHO "$prelink_cmds" | $SED "$delay_single_quote_subst"`' postlink_cmds='`$ECHO "$postlink_cmds" | $SED "$delay_single_quote_subst"`' file_list_spec='`$ECHO "$file_list_spec" | $SED "$delay_single_quote_subst"`' variables_saved_for_relink='`$ECHO "$variables_saved_for_relink" | $SED "$delay_single_quote_subst"`' need_lib_prefix='`$ECHO "$need_lib_prefix" | $SED "$delay_single_quote_subst"`' need_version='`$ECHO "$need_version" | $SED "$delay_single_quote_subst"`' version_type='`$ECHO "$version_type" | $SED "$delay_single_quote_subst"`' runpath_var='`$ECHO "$runpath_var" | $SED "$delay_single_quote_subst"`' shlibpath_var='`$ECHO "$shlibpath_var" | $SED "$delay_single_quote_subst"`' shlibpath_overrides_runpath='`$ECHO "$shlibpath_overrides_runpath" | $SED "$delay_single_quote_subst"`' libname_spec='`$ECHO "$libname_spec" | $SED "$delay_single_quote_subst"`' library_names_spec='`$ECHO "$library_names_spec" | $SED "$delay_single_quote_subst"`' soname_spec='`$ECHO "$soname_spec" | $SED "$delay_single_quote_subst"`' install_override_mode='`$ECHO "$install_override_mode" | $SED "$delay_single_quote_subst"`' postinstall_cmds='`$ECHO "$postinstall_cmds" | $SED "$delay_single_quote_subst"`' postuninstall_cmds='`$ECHO "$postuninstall_cmds" | $SED "$delay_single_quote_subst"`' finish_cmds='`$ECHO "$finish_cmds" | $SED "$delay_single_quote_subst"`' finish_eval='`$ECHO "$finish_eval" | $SED "$delay_single_quote_subst"`' hardcode_into_libs='`$ECHO "$hardcode_into_libs" | $SED "$delay_single_quote_subst"`' sys_lib_search_path_spec='`$ECHO "$sys_lib_search_path_spec" | $SED "$delay_single_quote_subst"`' configure_time_dlsearch_path='`$ECHO "$configure_time_dlsearch_path" | $SED "$delay_single_quote_subst"`' configure_time_lt_sys_library_path='`$ECHO "$configure_time_lt_sys_library_path" | $SED "$delay_single_quote_subst"`' hardcode_action='`$ECHO "$hardcode_action" | $SED "$delay_single_quote_subst"`' enable_dlopen='`$ECHO "$enable_dlopen" | $SED "$delay_single_quote_subst"`' enable_dlopen_self='`$ECHO "$enable_dlopen_self" | $SED "$delay_single_quote_subst"`' enable_dlopen_self_static='`$ECHO "$enable_dlopen_self_static" | $SED "$delay_single_quote_subst"`' old_striplib='`$ECHO "$old_striplib" | $SED "$delay_single_quote_subst"`' striplib='`$ECHO "$striplib" | $SED "$delay_single_quote_subst"`' compiler_lib_search_dirs='`$ECHO "$compiler_lib_search_dirs" | $SED "$delay_single_quote_subst"`' predep_objects='`$ECHO "$predep_objects" | $SED "$delay_single_quote_subst"`' postdep_objects='`$ECHO "$postdep_objects" | $SED "$delay_single_quote_subst"`' predeps='`$ECHO "$predeps" | $SED "$delay_single_quote_subst"`' postdeps='`$ECHO "$postdeps" | $SED "$delay_single_quote_subst"`' compiler_lib_search_path='`$ECHO "$compiler_lib_search_path" | $SED "$delay_single_quote_subst"`' LD_CXX='`$ECHO "$LD_CXX" | $SED "$delay_single_quote_subst"`' reload_flag_CXX='`$ECHO "$reload_flag_CXX" | $SED "$delay_single_quote_subst"`' reload_cmds_CXX='`$ECHO "$reload_cmds_CXX" | $SED "$delay_single_quote_subst"`' old_archive_cmds_CXX='`$ECHO "$old_archive_cmds_CXX" | $SED "$delay_single_quote_subst"`' compiler_CXX='`$ECHO "$compiler_CXX" | $SED "$delay_single_quote_subst"`' GCC_CXX='`$ECHO "$GCC_CXX" | $SED "$delay_single_quote_subst"`' lt_prog_compiler_no_builtin_flag_CXX='`$ECHO "$lt_prog_compiler_no_builtin_flag_CXX" | $SED "$delay_single_quote_subst"`' lt_prog_compiler_pic_CXX='`$ECHO "$lt_prog_compiler_pic_CXX" | $SED "$delay_single_quote_subst"`' lt_prog_compiler_wl_CXX='`$ECHO "$lt_prog_compiler_wl_CXX" | $SED "$delay_single_quote_subst"`' lt_prog_compiler_static_CXX='`$ECHO "$lt_prog_compiler_static_CXX" | $SED "$delay_single_quote_subst"`' lt_cv_prog_compiler_c_o_CXX='`$ECHO "$lt_cv_prog_compiler_c_o_CXX" | $SED "$delay_single_quote_subst"`' archive_cmds_need_lc_CXX='`$ECHO "$archive_cmds_need_lc_CXX" | $SED "$delay_single_quote_subst"`' enable_shared_with_static_runtimes_CXX='`$ECHO "$enable_shared_with_static_runtimes_CXX" | $SED "$delay_single_quote_subst"`' export_dynamic_flag_spec_CXX='`$ECHO "$export_dynamic_flag_spec_CXX" | $SED "$delay_single_quote_subst"`' whole_archive_flag_spec_CXX='`$ECHO "$whole_archive_flag_spec_CXX" | $SED "$delay_single_quote_subst"`' compiler_needs_object_CXX='`$ECHO "$compiler_needs_object_CXX" | $SED "$delay_single_quote_subst"`' old_archive_from_new_cmds_CXX='`$ECHO "$old_archive_from_new_cmds_CXX" | $SED "$delay_single_quote_subst"`' old_archive_from_expsyms_cmds_CXX='`$ECHO "$old_archive_from_expsyms_cmds_CXX" | $SED "$delay_single_quote_subst"`' archive_cmds_CXX='`$ECHO "$archive_cmds_CXX" | $SED "$delay_single_quote_subst"`' archive_expsym_cmds_CXX='`$ECHO "$archive_expsym_cmds_CXX" | $SED "$delay_single_quote_subst"`' module_cmds_CXX='`$ECHO "$module_cmds_CXX" | $SED "$delay_single_quote_subst"`' module_expsym_cmds_CXX='`$ECHO "$module_expsym_cmds_CXX" | $SED "$delay_single_quote_subst"`' with_gnu_ld_CXX='`$ECHO "$with_gnu_ld_CXX" | $SED "$delay_single_quote_subst"`' allow_undefined_flag_CXX='`$ECHO "$allow_undefined_flag_CXX" | $SED "$delay_single_quote_subst"`' no_undefined_flag_CXX='`$ECHO "$no_undefined_flag_CXX" | $SED "$delay_single_quote_subst"`' hardcode_libdir_flag_spec_CXX='`$ECHO "$hardcode_libdir_flag_spec_CXX" | $SED "$delay_single_quote_subst"`' hardcode_libdir_separator_CXX='`$ECHO "$hardcode_libdir_separator_CXX" | $SED "$delay_single_quote_subst"`' hardcode_direct_CXX='`$ECHO "$hardcode_direct_CXX" | $SED "$delay_single_quote_subst"`' hardcode_direct_absolute_CXX='`$ECHO "$hardcode_direct_absolute_CXX" | $SED "$delay_single_quote_subst"`' hardcode_minus_L_CXX='`$ECHO "$hardcode_minus_L_CXX" | $SED "$delay_single_quote_subst"`' hardcode_shlibpath_var_CXX='`$ECHO "$hardcode_shlibpath_var_CXX" | $SED "$delay_single_quote_subst"`' hardcode_automatic_CXX='`$ECHO "$hardcode_automatic_CXX" | $SED "$delay_single_quote_subst"`' inherit_rpath_CXX='`$ECHO "$inherit_rpath_CXX" | $SED "$delay_single_quote_subst"`' link_all_deplibs_CXX='`$ECHO "$link_all_deplibs_CXX" | $SED "$delay_single_quote_subst"`' always_export_symbols_CXX='`$ECHO "$always_export_symbols_CXX" | $SED "$delay_single_quote_subst"`' export_symbols_cmds_CXX='`$ECHO "$export_symbols_cmds_CXX" | $SED "$delay_single_quote_subst"`' exclude_expsyms_CXX='`$ECHO "$exclude_expsyms_CXX" | $SED "$delay_single_quote_subst"`' include_expsyms_CXX='`$ECHO "$include_expsyms_CXX" | $SED "$delay_single_quote_subst"`' prelink_cmds_CXX='`$ECHO "$prelink_cmds_CXX" | $SED "$delay_single_quote_subst"`' postlink_cmds_CXX='`$ECHO "$postlink_cmds_CXX" | $SED "$delay_single_quote_subst"`' file_list_spec_CXX='`$ECHO "$file_list_spec_CXX" | $SED "$delay_single_quote_subst"`' hardcode_action_CXX='`$ECHO "$hardcode_action_CXX" | $SED "$delay_single_quote_subst"`' compiler_lib_search_dirs_CXX='`$ECHO "$compiler_lib_search_dirs_CXX" | $SED "$delay_single_quote_subst"`' predep_objects_CXX='`$ECHO "$predep_objects_CXX" | $SED "$delay_single_quote_subst"`' postdep_objects_CXX='`$ECHO "$postdep_objects_CXX" | $SED "$delay_single_quote_subst"`' predeps_CXX='`$ECHO "$predeps_CXX" | $SED "$delay_single_quote_subst"`' postdeps_CXX='`$ECHO "$postdeps_CXX" | $SED "$delay_single_quote_subst"`' compiler_lib_search_path_CXX='`$ECHO "$compiler_lib_search_path_CXX" | $SED "$delay_single_quote_subst"`' LTCC='$LTCC' LTCFLAGS='$LTCFLAGS' compiler='$compiler_DEFAULT' # A function that is used when there is no print builtin or printf. func_fallback_echo () { eval 'cat <<_LTECHO_EOF \$1 _LTECHO_EOF' } # Quote evaled strings. for var in AS \ DLLTOOL \ OBJDUMP \ SHELL \ ECHO \ PATH_SEPARATOR \ SED \ GREP \ EGREP \ FGREP \ LD \ NM \ LN_S \ lt_SP2NL \ lt_NL2SP \ reload_flag \ deplibs_check_method \ file_magic_cmd \ file_magic_glob \ want_nocaseglob \ sharedlib_from_linklib_cmd \ AR \ AR_FLAGS \ archiver_list_spec \ STRIP \ RANLIB \ CC \ CFLAGS \ compiler \ lt_cv_sys_global_symbol_pipe \ lt_cv_sys_global_symbol_to_cdecl \ lt_cv_sys_global_symbol_to_import \ lt_cv_sys_global_symbol_to_c_name_address \ lt_cv_sys_global_symbol_to_c_name_address_lib_prefix \ lt_cv_nm_interface \ nm_file_list_spec \ lt_cv_truncate_bin \ lt_prog_compiler_no_builtin_flag \ lt_prog_compiler_pic \ lt_prog_compiler_wl \ lt_prog_compiler_static \ lt_cv_prog_compiler_c_o \ need_locks \ MANIFEST_TOOL \ DSYMUTIL \ NMEDIT \ LIPO \ OTOOL \ OTOOL64 \ shrext_cmds \ export_dynamic_flag_spec \ whole_archive_flag_spec \ compiler_needs_object \ with_gnu_ld \ allow_undefined_flag \ no_undefined_flag \ hardcode_libdir_flag_spec \ hardcode_libdir_separator \ exclude_expsyms \ include_expsyms \ file_list_spec \ variables_saved_for_relink \ libname_spec \ library_names_spec \ soname_spec \ install_override_mode \ finish_eval \ old_striplib \ striplib \ compiler_lib_search_dirs \ predep_objects \ postdep_objects \ predeps \ postdeps \ compiler_lib_search_path \ LD_CXX \ reload_flag_CXX \ compiler_CXX \ lt_prog_compiler_no_builtin_flag_CXX \ lt_prog_compiler_pic_CXX \ lt_prog_compiler_wl_CXX \ lt_prog_compiler_static_CXX \ lt_cv_prog_compiler_c_o_CXX \ export_dynamic_flag_spec_CXX \ whole_archive_flag_spec_CXX \ compiler_needs_object_CXX \ with_gnu_ld_CXX \ allow_undefined_flag_CXX \ no_undefined_flag_CXX \ hardcode_libdir_flag_spec_CXX \ hardcode_libdir_separator_CXX \ exclude_expsyms_CXX \ include_expsyms_CXX \ file_list_spec_CXX \ compiler_lib_search_dirs_CXX \ predep_objects_CXX \ postdep_objects_CXX \ predeps_CXX \ postdeps_CXX \ compiler_lib_search_path_CXX; do case \`eval \\\\\$ECHO \\\\""\\\\\$\$var"\\\\"\` in *[\\\\\\\`\\"\\\$]*) eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"\\\$\$var\\" | \\\$SED \\"\\\$sed_quote_subst\\"\\\`\\\\\\"" ## exclude from sc_prohibit_nested_quotes ;; *) eval "lt_\$var=\\\\\\"\\\$\$var\\\\\\"" ;; esac done # Double-quote double-evaled strings. for var in reload_cmds \ old_postinstall_cmds \ old_postuninstall_cmds \ old_archive_cmds \ extract_expsyms_cmds \ old_archive_from_new_cmds \ old_archive_from_expsyms_cmds \ archive_cmds \ archive_expsym_cmds \ module_cmds \ module_expsym_cmds \ export_symbols_cmds \ prelink_cmds \ postlink_cmds \ postinstall_cmds \ postuninstall_cmds \ finish_cmds \ sys_lib_search_path_spec \ configure_time_dlsearch_path \ configure_time_lt_sys_library_path \ reload_cmds_CXX \ old_archive_cmds_CXX \ old_archive_from_new_cmds_CXX \ old_archive_from_expsyms_cmds_CXX \ archive_cmds_CXX \ archive_expsym_cmds_CXX \ module_cmds_CXX \ module_expsym_cmds_CXX \ export_symbols_cmds_CXX \ prelink_cmds_CXX \ postlink_cmds_CXX; do case \`eval \\\\\$ECHO \\\\""\\\\\$\$var"\\\\"\` in *[\\\\\\\`\\"\\\$]*) eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"\\\$\$var\\" | \\\$SED -e \\"\\\$double_quote_subst\\" -e \\"\\\$sed_quote_subst\\" -e \\"\\\$delay_variable_subst\\"\\\`\\\\\\"" ## exclude from sc_prohibit_nested_quotes ;; *) eval "lt_\$var=\\\\\\"\\\$\$var\\\\\\"" ;; esac done ac_aux_dir='$ac_aux_dir' # See if we are running on zsh, and set the options that allow our # commands through without removal of \ escapes INIT. if test -n "\${ZSH_VERSION+set}"; then setopt NO_GLOB_SUBST fi PACKAGE='$PACKAGE' VERSION='$VERSION' RM='$RM' ofile='$ofile' _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "depfiles") CONFIG_COMMANDS="$CONFIG_COMMANDS depfiles" ;; "libtool") CONFIG_COMMANDS="$CONFIG_COMMANDS libtool" ;; "config.h") CONFIG_HEADERS="$CONFIG_HEADERS config.h" ;; "basis") CONFIG_COMMANDS="$CONFIG_COMMANDS basis" ;; "mlsource") CONFIG_COMMANDS="$CONFIG_COMMANDS mlsource" ;; "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; "libpolyml/Makefile") CONFIG_FILES="$CONFIG_FILES libpolyml/Makefile" ;; "libpolyml/polyml.pc") CONFIG_FILES="$CONFIG_FILES libpolyml/polyml.pc" ;; "libpolymain/Makefile") CONFIG_FILES="$CONFIG_FILES libpolymain/Makefile" ;; "modules/Makefile") CONFIG_FILES="$CONFIG_FILES modules/Makefile" ;; "modules/IntInfAsInt/Makefile") CONFIG_FILES="$CONFIG_FILES modules/IntInfAsInt/Makefile" ;; "polyc") CONFIG_FILES="$CONFIG_FILES polyc" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers test "${CONFIG_COMMANDS+set}" = set || CONFIG_COMMANDS=$config_commands fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to `$tmp'. $debug || { tmp= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" # Set up the scripts for CONFIG_HEADERS section. # No need to generate them if there are no CONFIG_HEADERS. # This happens for instance with `./config.status Makefile'. if test -n "$CONFIG_HEADERS"; then cat >"$ac_tmp/defines.awk" <<\_ACAWK || BEGIN { _ACEOF # Transform confdefs.h into an awk script `defines.awk', embedded as # here-document in config.status, that substitutes the proper values into # config.h.in to produce config.h. # Create a delimiter string that does not exist in confdefs.h, to ease # handling of long lines. ac_delim='%!_!# ' for ac_last_try in false false :; do ac_tt=`sed -n "/$ac_delim/p" confdefs.h` if test -z "$ac_tt"; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done # For the awk script, D is an array of macro values keyed by name, # likewise P contains macro parameters if any. Preserve backslash # newline sequences. ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* sed -n ' s/.\{148\}/&'"$ac_delim"'/g t rset :rset s/^[ ]*#[ ]*define[ ][ ]*/ / t def d :def s/\\$// t bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3"/p s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p d :bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3\\\\\\n"\\/p t cont s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p t cont d :cont n s/.\{148\}/&'"$ac_delim"'/g t clear :clear s/\\$// t bsnlc s/["\\]/\\&/g; s/^/"/; s/$/"/p d :bsnlc s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p b cont ' >$CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 for (key in D) D_is_set[key] = 1 FS = "" } /^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { line = \$ 0 split(line, arg, " ") if (arg[1] == "#") { defundef = arg[2] mac1 = arg[3] } else { defundef = substr(arg[1], 2) mac1 = arg[2] } split(mac1, mac2, "(") #) macro = mac2[1] prefix = substr(line, 1, index(line, defundef) - 1) if (D_is_set[macro]) { # Preserve the white space surrounding the "#". print prefix "define", macro P[macro] D[macro] next } else { # Replace #undef with comments. This is necessary, for example, # in the case of _POSIX_SOURCE, which is predefined and required # on some systems where configure will not decide to define it. if (defundef == "undef") { print "/*", prefix defundef, macro, "*/" next } } } { print } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 fi # test -n "$CONFIG_HEADERS" eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS :C $CONFIG_COMMANDS" shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # case $INSTALL in [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;; *) ac_INSTALL=$ac_top_build_prefix$INSTALL ;; esac ac_MKDIR_P=$MKDIR_P case $MKDIR_P in [\\/$]* | ?:[\\/]* ) ;; */*) ac_MKDIR_P=$ac_top_build_prefix$MKDIR_P ;; esac _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t s&@INSTALL@&$ac_INSTALL&;t t s&@MKDIR_P@&$ac_MKDIR_P&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; :H) # # CONFIG_HEADER # if test x"$ac_file" != x-; then { $as_echo "/* $configure_input */" \ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" } >"$ac_tmp/config.h" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then { $as_echo "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 $as_echo "$as_me: $ac_file is unchanged" >&6;} else rm -f "$ac_file" mv "$ac_tmp/config.h" "$ac_file" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 fi else $as_echo "/* $configure_input */" \ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ || as_fn_error $? "could not create -" "$LINENO" 5 fi # Compute "$ac_file"'s index in $config_headers. _am_arg="$ac_file" _am_stamp_count=1 for _am_header in $config_headers :; do case $_am_header in $_am_arg | $_am_arg:* ) break ;; * ) _am_stamp_count=`expr $_am_stamp_count + 1` ;; esac done echo "timestamp for $_am_arg" >`$as_dirname -- "$_am_arg" || $as_expr X"$_am_arg" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$_am_arg" : 'X\(//\)[^/]' \| \ X"$_am_arg" : 'X\(//\)$' \| \ X"$_am_arg" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$_am_arg" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'`/stamp-h$_am_stamp_count ;; :C) { $as_echo "$as_me:${as_lineno-$LINENO}: executing $ac_file commands" >&5 $as_echo "$as_me: executing $ac_file commands" >&6;} ;; esac case $ac_file$ac_mode in "depfiles":C) test x"$AMDEP_TRUE" != x"" || { # Older Autoconf quotes --file arguments for eval, but not when files # are listed without --file. Let's play safe and only enable the eval # if we detect the quoting. case $CONFIG_FILES in *\'*) eval set x "$CONFIG_FILES" ;; *) set x $CONFIG_FILES ;; esac shift for mf do # Strip MF so we end up with the name of the file. mf=`echo "$mf" | sed -e 's/:.*$//'` # Check whether this is an Automake generated Makefile or not. # We used to match only the files named 'Makefile.in', but # some people rename them; so instead we look at the file content. # Grep'ing the first line is not enough: some people post-process # each Makefile.in and add a new line on top of each file to say so. # Grep'ing the whole file is not good either: AIX grep has a line # limit of 2048, but all sed's we know have understand at least 4000. if sed -n 's,^#.*generated by automake.*,X,p' "$mf" | grep X >/dev/null 2>&1; then dirpart=`$as_dirname -- "$mf" || $as_expr X"$mf" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$mf" : 'X\(//\)[^/]' \| \ X"$mf" : 'X\(//\)$' \| \ X"$mf" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$mf" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` else continue fi # Extract the definition of DEPDIR, am__include, and am__quote # from the Makefile without running 'make'. DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"` test -z "$DEPDIR" && continue am__include=`sed -n 's/^am__include = //p' < "$mf"` test -z "$am__include" && continue am__quote=`sed -n 's/^am__quote = //p' < "$mf"` # Find all dependency output files, they are included files with # $(DEPDIR) in their names. We invoke sed twice because it is the # simplest approach to changing $(DEPDIR) to its actual value in the # expansion. for file in `sed -n " s/^$am__include $am__quote\(.*(DEPDIR).*\)$am__quote"'$/\1/p' <"$mf" | \ sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g'`; do # Make sure the directory exists. test -f "$dirpart/$file" && continue fdir=`$as_dirname -- "$file" || $as_expr X"$file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$file" : 'X\(//\)[^/]' \| \ X"$file" : 'X\(//\)$' \| \ X"$file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir=$dirpart/$fdir; as_fn_mkdir_p # echo "creating $dirpart/$file" echo '# dummy' > "$dirpart/$file" done done } ;; "libtool":C) # See if we are running on zsh, and set the options that allow our # commands through without removal of \ escapes. if test -n "${ZSH_VERSION+set}"; then setopt NO_GLOB_SUBST fi cfgfile=${ofile}T trap "$RM \"$cfgfile\"; exit 1" 1 2 15 $RM "$cfgfile" cat <<_LT_EOF >> "$cfgfile" #! $SHELL # Generated automatically by $as_me ($PACKAGE) $VERSION # NOTE: Changes made to this file will be lost: look at ltmain.sh. # Provide generalized library-building support services. # Written by Gordon Matzigkeit, 1996 # Copyright (C) 2014 Free Software Foundation, Inc. # This is free software; see the source for copying conditions. There is NO # warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. # GNU Libtool is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of of the License, or # (at your option) any later version. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program or library that is built # using GNU Libtool, you may include this file under the same # distribution terms that you use for the rest of that program. # # GNU Libtool 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # The names of the tagged configurations supported by this script. available_tags='CXX ' # Configured defaults for sys_lib_dlsearch_path munging. : \${LT_SYS_LIBRARY_PATH="$configure_time_lt_sys_library_path"} # ### BEGIN LIBTOOL CONFIG # Which release of libtool.m4 was used? macro_version=$macro_version macro_revision=$macro_revision # Assembler program. AS=$lt_AS # DLL creation program. DLLTOOL=$lt_DLLTOOL # Object dumper program. OBJDUMP=$lt_OBJDUMP # Whether or not to build shared libraries. build_libtool_libs=$enable_shared # Whether or not to build static libraries. build_old_libs=$enable_static # What type of objects to build. pic_mode=$pic_mode # Whether or not to optimize for fast installation. fast_install=$enable_fast_install # Shared archive member basename,for filename based shared library versioning on AIX. shared_archive_member_spec=$shared_archive_member_spec # Shell to use when invoking shell scripts. SHELL=$lt_SHELL # An echo program that protects backslashes. ECHO=$lt_ECHO # The PATH separator for the build system. PATH_SEPARATOR=$lt_PATH_SEPARATOR # The host system. host_alias=$host_alias host=$host host_os=$host_os # The build system. build_alias=$build_alias build=$build build_os=$build_os # A sed program that does not truncate output. SED=$lt_SED # Sed that helps us avoid accidentally triggering echo(1) options like -n. Xsed="\$SED -e 1s/^X//" # A grep program that handles long lines. GREP=$lt_GREP # An ERE matcher. EGREP=$lt_EGREP # A literal string matcher. FGREP=$lt_FGREP # A BSD- or MS-compatible name lister. NM=$lt_NM # Whether we need soft or hard links. LN_S=$lt_LN_S # What is the maximum length of a command? max_cmd_len=$max_cmd_len # Object file suffix (normally "o"). objext=$ac_objext # Executable file suffix (normally ""). exeext=$exeext # whether the shell understands "unset". lt_unset=$lt_unset # turn spaces into newlines. SP2NL=$lt_lt_SP2NL # turn newlines into spaces. NL2SP=$lt_lt_NL2SP # convert \$build file names to \$host format. to_host_file_cmd=$lt_cv_to_host_file_cmd # convert \$build files to toolchain format. to_tool_file_cmd=$lt_cv_to_tool_file_cmd # Method to check whether dependent libraries are shared objects. deplibs_check_method=$lt_deplibs_check_method # Command to use when deplibs_check_method = "file_magic". file_magic_cmd=$lt_file_magic_cmd # How to find potential files when deplibs_check_method = "file_magic". file_magic_glob=$lt_file_magic_glob # Find potential files using nocaseglob when deplibs_check_method = "file_magic". want_nocaseglob=$lt_want_nocaseglob # Command to associate shared and link libraries. sharedlib_from_linklib_cmd=$lt_sharedlib_from_linklib_cmd # The archiver. AR=$lt_AR # Flags to create an archive. AR_FLAGS=$lt_AR_FLAGS # How to feed a file listing to the archiver. archiver_list_spec=$lt_archiver_list_spec # A symbol stripping program. STRIP=$lt_STRIP # Commands used to install an old-style archive. RANLIB=$lt_RANLIB old_postinstall_cmds=$lt_old_postinstall_cmds old_postuninstall_cmds=$lt_old_postuninstall_cmds # Whether to use a lock for old archive extraction. lock_old_archive_extraction=$lock_old_archive_extraction # A C compiler. LTCC=$lt_CC # LTCC compiler flags. LTCFLAGS=$lt_CFLAGS # Take the output of nm and produce a listing of raw symbols and C names. global_symbol_pipe=$lt_lt_cv_sys_global_symbol_pipe # Transform the output of nm in a proper C declaration. global_symbol_to_cdecl=$lt_lt_cv_sys_global_symbol_to_cdecl # Transform the output of nm into a list of symbols to manually relocate. global_symbol_to_import=$lt_lt_cv_sys_global_symbol_to_import # Transform the output of nm in a C name address pair. global_symbol_to_c_name_address=$lt_lt_cv_sys_global_symbol_to_c_name_address # Transform the output of nm in a C name address pair when lib prefix is needed. global_symbol_to_c_name_address_lib_prefix=$lt_lt_cv_sys_global_symbol_to_c_name_address_lib_prefix # The name lister interface. nm_interface=$lt_lt_cv_nm_interface # Specify filename containing input files for \$NM. nm_file_list_spec=$lt_nm_file_list_spec # The root where to search for dependent libraries,and where our libraries should be installed. lt_sysroot=$lt_sysroot # Command to truncate a binary pipe. lt_truncate_bin=$lt_lt_cv_truncate_bin # The name of the directory that contains temporary libtool files. objdir=$objdir # Used to examine libraries when file_magic_cmd begins with "file". MAGIC_CMD=$MAGIC_CMD # Must we lock files when doing compilation? need_locks=$lt_need_locks # Manifest tool. MANIFEST_TOOL=$lt_MANIFEST_TOOL # Tool to manipulate archived DWARF debug symbol files on Mac OS X. DSYMUTIL=$lt_DSYMUTIL # Tool to change global to local symbols on Mac OS X. NMEDIT=$lt_NMEDIT # Tool to manipulate fat objects and archives on Mac OS X. LIPO=$lt_LIPO # ldd/readelf like tool for Mach-O binaries on Mac OS X. OTOOL=$lt_OTOOL # ldd/readelf like tool for 64 bit Mach-O binaries on Mac OS X 10.4. OTOOL64=$lt_OTOOL64 # Old archive suffix (normally "a"). libext=$libext # Shared library suffix (normally ".so"). shrext_cmds=$lt_shrext_cmds # The commands to extract the exported symbol list from a shared archive. extract_expsyms_cmds=$lt_extract_expsyms_cmds # Variables whose values should be saved in libtool wrapper scripts and # restored at link time. variables_saved_for_relink=$lt_variables_saved_for_relink # Do we need the "lib" prefix for modules? need_lib_prefix=$need_lib_prefix # Do we need a version for libraries? need_version=$need_version # Library versioning type. version_type=$version_type # Shared library runtime path variable. runpath_var=$runpath_var # Shared library path variable. shlibpath_var=$shlibpath_var # Is shlibpath searched before the hard-coded library search path? shlibpath_overrides_runpath=$shlibpath_overrides_runpath # Format of library name prefix. libname_spec=$lt_libname_spec # List of archive names. First name is the real one, the rest are links. # The last name is the one that the linker finds with -lNAME library_names_spec=$lt_library_names_spec # The coded name of the library, if different from the real name. soname_spec=$lt_soname_spec # Permission mode override for installation of shared libraries. install_override_mode=$lt_install_override_mode # Command to use after installation of a shared archive. postinstall_cmds=$lt_postinstall_cmds # Command to use after uninstallation of a shared archive. postuninstall_cmds=$lt_postuninstall_cmds # Commands used to finish a libtool library installation in a directory. finish_cmds=$lt_finish_cmds # As "finish_cmds", except a single script fragment to be evaled but # not shown. finish_eval=$lt_finish_eval # Whether we should hardcode library paths into libraries. hardcode_into_libs=$hardcode_into_libs # Compile-time system search path for libraries. sys_lib_search_path_spec=$lt_sys_lib_search_path_spec # Detected run-time system search path for libraries. sys_lib_dlsearch_path_spec=$lt_configure_time_dlsearch_path # Explicit LT_SYS_LIBRARY_PATH set during ./configure time. configure_time_lt_sys_library_path=$lt_configure_time_lt_sys_library_path # Whether dlopen is supported. dlopen_support=$enable_dlopen # Whether dlopen of programs is supported. dlopen_self=$enable_dlopen_self # Whether dlopen of statically linked programs is supported. dlopen_self_static=$enable_dlopen_self_static # Commands to strip libraries. old_striplib=$lt_old_striplib striplib=$lt_striplib # The linker used to build libraries. LD=$lt_LD # How to create reloadable object files. reload_flag=$lt_reload_flag reload_cmds=$lt_reload_cmds # Commands used to build an old-style archive. old_archive_cmds=$lt_old_archive_cmds # A language specific compiler. CC=$lt_compiler # Is the compiler the GNU compiler? with_gcc=$GCC # Compiler flag to turn off builtin functions. no_builtin_flag=$lt_lt_prog_compiler_no_builtin_flag # Additional compiler flags for building library objects. pic_flag=$lt_lt_prog_compiler_pic # How to pass a linker flag through the compiler. wl=$lt_lt_prog_compiler_wl # Compiler flag to prevent dynamic linking. link_static_flag=$lt_lt_prog_compiler_static # Does compiler simultaneously support -c and -o options? compiler_c_o=$lt_lt_cv_prog_compiler_c_o # Whether or not to add -lc for building shared libraries. build_libtool_need_lc=$archive_cmds_need_lc # Whether or not to disallow shared libs when runtime libs are static. allow_libtool_libs_with_static_runtimes=$enable_shared_with_static_runtimes # Compiler flag to allow reflexive dlopens. export_dynamic_flag_spec=$lt_export_dynamic_flag_spec # Compiler flag to generate shared objects directly from archives. whole_archive_flag_spec=$lt_whole_archive_flag_spec # Whether the compiler copes with passing no objects directly. compiler_needs_object=$lt_compiler_needs_object # Create an old-style archive from a shared archive. old_archive_from_new_cmds=$lt_old_archive_from_new_cmds # Create a temporary old-style archive to link instead of a shared archive. old_archive_from_expsyms_cmds=$lt_old_archive_from_expsyms_cmds # Commands used to build a shared archive. archive_cmds=$lt_archive_cmds archive_expsym_cmds=$lt_archive_expsym_cmds # Commands used to build a loadable module if different from building # a shared archive. module_cmds=$lt_module_cmds module_expsym_cmds=$lt_module_expsym_cmds # Whether we are building with GNU ld or not. with_gnu_ld=$lt_with_gnu_ld # Flag that allows shared libraries with undefined symbols to be built. allow_undefined_flag=$lt_allow_undefined_flag # Flag that enforces no undefined symbols. no_undefined_flag=$lt_no_undefined_flag # Flag to hardcode \$libdir into a binary during linking. # This must work even if \$libdir does not exist hardcode_libdir_flag_spec=$lt_hardcode_libdir_flag_spec # Whether we need a single "-rpath" flag with a separated argument. hardcode_libdir_separator=$lt_hardcode_libdir_separator # Set to "yes" if using DIR/libNAME\$shared_ext during linking hardcodes # DIR into the resulting binary. hardcode_direct=$hardcode_direct # Set to "yes" if using DIR/libNAME\$shared_ext during linking hardcodes # DIR into the resulting binary and the resulting library dependency is # "absolute",i.e impossible to change by setting \$shlibpath_var if the # library is relocated. hardcode_direct_absolute=$hardcode_direct_absolute # Set to "yes" if using the -LDIR flag during linking hardcodes DIR # into the resulting binary. hardcode_minus_L=$hardcode_minus_L # Set to "yes" if using SHLIBPATH_VAR=DIR during linking hardcodes DIR # into the resulting binary. hardcode_shlibpath_var=$hardcode_shlibpath_var # Set to "yes" if building a shared library automatically hardcodes DIR # into the library and all subsequent libraries and executables linked # against it. hardcode_automatic=$hardcode_automatic # Set to yes if linker adds runtime paths of dependent libraries # to runtime path list. inherit_rpath=$inherit_rpath # Whether libtool must link a program against all its dependency libraries. link_all_deplibs=$link_all_deplibs # Set to "yes" if exported symbols are required. always_export_symbols=$always_export_symbols # The commands to list exported symbols. export_symbols_cmds=$lt_export_symbols_cmds # Symbols that should not be listed in the preloaded symbols. exclude_expsyms=$lt_exclude_expsyms # Symbols that must always be exported. include_expsyms=$lt_include_expsyms # Commands necessary for linking programs (against libraries) with templates. prelink_cmds=$lt_prelink_cmds # Commands necessary for finishing linking programs. postlink_cmds=$lt_postlink_cmds # Specify filename containing input files. file_list_spec=$lt_file_list_spec # How to hardcode a shared library path into an executable. hardcode_action=$hardcode_action # The directories searched by this compiler when creating a shared library. compiler_lib_search_dirs=$lt_compiler_lib_search_dirs # Dependencies to place before and after the objects being linked to # create a shared library. predep_objects=$lt_predep_objects postdep_objects=$lt_postdep_objects predeps=$lt_predeps postdeps=$lt_postdeps # The library search path used internally by the compiler when linking # a shared library. compiler_lib_search_path=$lt_compiler_lib_search_path # ### END LIBTOOL CONFIG _LT_EOF cat <<'_LT_EOF' >> "$cfgfile" # ### BEGIN FUNCTIONS SHARED WITH CONFIGURE # func_munge_path_list VARIABLE PATH # ----------------------------------- # VARIABLE is name of variable containing _space_ separated list of # directories to be munged by the contents of PATH, which is string # having a format: # "DIR[:DIR]:" # string "DIR[ DIR]" will be prepended to VARIABLE # ":DIR[:DIR]" # string "DIR[ DIR]" will be appended to VARIABLE # "DIRP[:DIRP]::[DIRA:]DIRA" # string "DIRP[ DIRP]" will be prepended to VARIABLE and string # "DIRA[ DIRA]" will be appended to VARIABLE # "DIR[:DIR]" # VARIABLE will be replaced by "DIR[ DIR]" func_munge_path_list () { case x$2 in x) ;; *:) eval $1=\"`$ECHO $2 | $SED 's/:/ /g'` \$$1\" ;; x:*) eval $1=\"\$$1 `$ECHO $2 | $SED 's/:/ /g'`\" ;; *::*) eval $1=\"\$$1\ `$ECHO $2 | $SED -e 's/.*:://' -e 's/:/ /g'`\" eval $1=\"`$ECHO $2 | $SED -e 's/::.*//' -e 's/:/ /g'`\ \$$1\" ;; *) eval $1=\"`$ECHO $2 | $SED 's/:/ /g'`\" ;; esac } # Calculate cc_basename. Skip known compiler wrappers and cross-prefix. func_cc_basename () { for cc_temp in $*""; do case $cc_temp in compile | *[\\/]compile | ccache | *[\\/]ccache ) ;; distcc | *[\\/]distcc | purify | *[\\/]purify ) ;; \-*) ;; *) break;; esac done func_cc_basename_result=`$ECHO "$cc_temp" | $SED "s%.*/%%; s%^$host_alias-%%"` } # ### END FUNCTIONS SHARED WITH CONFIGURE _LT_EOF case $host_os in aix3*) cat <<\_LT_EOF >> "$cfgfile" # AIX sometimes has problems with the GCC collect2 program. For some # reason, if we set the COLLECT_NAMES environment variable, the problems # vanish in a puff of smoke. if test set != "${COLLECT_NAMES+set}"; then COLLECT_NAMES= export COLLECT_NAMES fi _LT_EOF ;; esac ltmain=$ac_aux_dir/ltmain.sh # We use sed instead of cat because bash on DJGPP gets confused if # if finds mixed CR/LF and LF-only lines. Since sed operates in # text mode, it properly converts lines to CR/LF. This bash problem # is reportedly fixed, but why not run on old versions too? sed '$q' "$ltmain" >> "$cfgfile" \ || (rm -f "$cfgfile"; exit 1) mv -f "$cfgfile" "$ofile" || (rm -f "$ofile" && cp "$cfgfile" "$ofile" && rm -f "$cfgfile") chmod +x "$ofile" cat <<_LT_EOF >> "$ofile" # ### BEGIN LIBTOOL TAG CONFIG: CXX # The linker used to build libraries. LD=$lt_LD_CXX # How to create reloadable object files. reload_flag=$lt_reload_flag_CXX reload_cmds=$lt_reload_cmds_CXX # Commands used to build an old-style archive. old_archive_cmds=$lt_old_archive_cmds_CXX # A language specific compiler. CC=$lt_compiler_CXX # Is the compiler the GNU compiler? with_gcc=$GCC_CXX # Compiler flag to turn off builtin functions. no_builtin_flag=$lt_lt_prog_compiler_no_builtin_flag_CXX # Additional compiler flags for building library objects. pic_flag=$lt_lt_prog_compiler_pic_CXX # How to pass a linker flag through the compiler. wl=$lt_lt_prog_compiler_wl_CXX # Compiler flag to prevent dynamic linking. link_static_flag=$lt_lt_prog_compiler_static_CXX # Does compiler simultaneously support -c and -o options? compiler_c_o=$lt_lt_cv_prog_compiler_c_o_CXX # Whether or not to add -lc for building shared libraries. build_libtool_need_lc=$archive_cmds_need_lc_CXX # Whether or not to disallow shared libs when runtime libs are static. allow_libtool_libs_with_static_runtimes=$enable_shared_with_static_runtimes_CXX # Compiler flag to allow reflexive dlopens. export_dynamic_flag_spec=$lt_export_dynamic_flag_spec_CXX # Compiler flag to generate shared objects directly from archives. whole_archive_flag_spec=$lt_whole_archive_flag_spec_CXX # Whether the compiler copes with passing no objects directly. compiler_needs_object=$lt_compiler_needs_object_CXX # Create an old-style archive from a shared archive. old_archive_from_new_cmds=$lt_old_archive_from_new_cmds_CXX # Create a temporary old-style archive to link instead of a shared archive. old_archive_from_expsyms_cmds=$lt_old_archive_from_expsyms_cmds_CXX # Commands used to build a shared archive. archive_cmds=$lt_archive_cmds_CXX archive_expsym_cmds=$lt_archive_expsym_cmds_CXX # Commands used to build a loadable module if different from building # a shared archive. module_cmds=$lt_module_cmds_CXX module_expsym_cmds=$lt_module_expsym_cmds_CXX # Whether we are building with GNU ld or not. with_gnu_ld=$lt_with_gnu_ld_CXX # Flag that allows shared libraries with undefined symbols to be built. allow_undefined_flag=$lt_allow_undefined_flag_CXX # Flag that enforces no undefined symbols. no_undefined_flag=$lt_no_undefined_flag_CXX # Flag to hardcode \$libdir into a binary during linking. # This must work even if \$libdir does not exist hardcode_libdir_flag_spec=$lt_hardcode_libdir_flag_spec_CXX # Whether we need a single "-rpath" flag with a separated argument. hardcode_libdir_separator=$lt_hardcode_libdir_separator_CXX # Set to "yes" if using DIR/libNAME\$shared_ext during linking hardcodes # DIR into the resulting binary. hardcode_direct=$hardcode_direct_CXX # Set to "yes" if using DIR/libNAME\$shared_ext during linking hardcodes # DIR into the resulting binary and the resulting library dependency is # "absolute",i.e impossible to change by setting \$shlibpath_var if the # library is relocated. hardcode_direct_absolute=$hardcode_direct_absolute_CXX # Set to "yes" if using the -LDIR flag during linking hardcodes DIR # into the resulting binary. hardcode_minus_L=$hardcode_minus_L_CXX # Set to "yes" if using SHLIBPATH_VAR=DIR during linking hardcodes DIR # into the resulting binary. hardcode_shlibpath_var=$hardcode_shlibpath_var_CXX # Set to "yes" if building a shared library automatically hardcodes DIR # into the library and all subsequent libraries and executables linked # against it. hardcode_automatic=$hardcode_automatic_CXX # Set to yes if linker adds runtime paths of dependent libraries # to runtime path list. inherit_rpath=$inherit_rpath_CXX # Whether libtool must link a program against all its dependency libraries. link_all_deplibs=$link_all_deplibs_CXX # Set to "yes" if exported symbols are required. always_export_symbols=$always_export_symbols_CXX # The commands to list exported symbols. export_symbols_cmds=$lt_export_symbols_cmds_CXX # Symbols that should not be listed in the preloaded symbols. exclude_expsyms=$lt_exclude_expsyms_CXX # Symbols that must always be exported. include_expsyms=$lt_include_expsyms_CXX # Commands necessary for linking programs (against libraries) with templates. prelink_cmds=$lt_prelink_cmds_CXX # Commands necessary for finishing linking programs. postlink_cmds=$lt_postlink_cmds_CXX # Specify filename containing input files. file_list_spec=$lt_file_list_spec_CXX # How to hardcode a shared library path into an executable. hardcode_action=$hardcode_action_CXX # The directories searched by this compiler when creating a shared library. compiler_lib_search_dirs=$lt_compiler_lib_search_dirs_CXX # Dependencies to place before and after the objects being linked to # create a shared library. predep_objects=$lt_predep_objects_CXX postdep_objects=$lt_postdep_objects_CXX predeps=$lt_predeps_CXX postdeps=$lt_postdeps_CXX # The library search path used internally by the compiler when linking # a shared library. compiler_lib_search_path=$lt_compiler_lib_search_path_CXX # ### END LIBTOOL TAG CONFIG: CXX _LT_EOF ;; "basis":C) test -e basis || ln -sf ${ac_top_srcdir}/basis . ;; "mlsource":C) test -e mlsource || ln -sf ${ac_top_srcdir}/mlsource . ;; "polyc":F) chmod +x polyc ;; esac done # for ac_tag as_fn_exit 0 _ACEOF ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit 1 fi # # CONFIG_SUBDIRS section. # if test "$no_recursion" != yes; then # Remove --cache-file, --srcdir, and --disable-option-checking arguments # so they do not pile up. ac_sub_configure_args= ac_prev= eval "set x $ac_configure_args" shift for ac_arg do if test -n "$ac_prev"; then ac_prev= continue fi case $ac_arg in -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* \ | --c=*) ;; --config-cache | -C) ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) ;; --disable-option-checking) ;; *) case $ac_arg in *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac as_fn_append ac_sub_configure_args " '$ac_arg'" ;; esac done # Always prepend --prefix to ensure using the same prefix # in subdir configurations. ac_arg="--prefix=$prefix" case $ac_arg in *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac ac_sub_configure_args="'$ac_arg' $ac_sub_configure_args" # Pass --silent if test "$silent" = yes; then ac_sub_configure_args="--silent $ac_sub_configure_args" fi # Always prepend --disable-option-checking to silence warnings, since # different subdirs can have different --enable and --with options. ac_sub_configure_args="--disable-option-checking $ac_sub_configure_args" ac_popdir=`pwd` for ac_dir in : $subdirs; do test "x$ac_dir" = x: && continue # Do not complain, so a configure script can configure whichever # parts of a large source tree are present. test -d "$srcdir/$ac_dir" || continue ac_msg="=== configuring in $ac_dir (`pwd`/$ac_dir)" $as_echo "$as_me:${as_lineno-$LINENO}: $ac_msg" >&5 $as_echo "$ac_msg" >&6 as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" # Check for guested configure; otherwise get Cygnus style configure. if test -f "$ac_srcdir/configure.gnu"; then ac_sub_configure=$ac_srcdir/configure.gnu elif test -f "$ac_srcdir/configure"; then ac_sub_configure=$ac_srcdir/configure elif test -f "$ac_srcdir/configure.in"; then # This should be Cygnus configure. ac_sub_configure=$ac_aux_dir/configure else { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: no configuration information is in $ac_dir" >&5 $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2;} ac_sub_configure= fi # The recursion is here. if test -n "$ac_sub_configure"; then # Make the cache file name correct relative to the subdirectory. case $cache_file in [\\/]* | ?:[\\/]* ) ac_sub_cache_file=$cache_file ;; *) # Relative name. ac_sub_cache_file=$ac_top_build_prefix$cache_file ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: running $SHELL $ac_sub_configure $ac_sub_configure_args --cache-file=$ac_sub_cache_file --srcdir=$ac_srcdir" >&5 $as_echo "$as_me: running $SHELL $ac_sub_configure $ac_sub_configure_args --cache-file=$ac_sub_cache_file --srcdir=$ac_srcdir" >&6;} # The eval makes quoting arguments work. eval "\$SHELL \"\$ac_sub_configure\" $ac_sub_configure_args \ --cache-file=\"\$ac_sub_cache_file\" --srcdir=\"\$ac_srcdir\"" || as_fn_error $? "$ac_sub_configure failed for $ac_dir" "$LINENO" 5 fi cd "$ac_popdir" done fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi diff --git a/configure.ac b/configure.ac index bc7ac7d7..24a2e617 100644 --- a/configure.ac +++ b/configure.ac @@ -1,620 +1,620 @@ # -*- Autoconf -*- # Process this file with autoconf to produce a configure script. AC_INIT([Poly/ML],[5.8],[polyml AT polyml DOT org],[polyml]) AM_INIT_AUTOMAKE AC_PREREQ(2.69) # libtoolize recommends this line. AC_CONFIG_MACRO_DIR([m4]) ac_debug_mode="no" AC_ARG_ENABLE([debug], [ --enable-debug Compiles without optimisation for debugging ], [ac_debug_mode="yes"]) if test "$ac_debug_mode" != "yes"; then # Default to maximum optimisation. -O2 is not good enough. # Set CCASFLAGS to empty so that it doesn't get set to CFLAGS. # The -g option on assembler causes problems on Sparc/Solaris 10. # test X || Y is equivalent to if !X then Y test "${CFLAGS+set}" = set || CFLAGS="-O3" test "${CXXFLAGS+set}" = set || CXXFLAGS="-O3" test "${CCASFLAGS+set}" = set || CCASFLAGS="" else test "${CFLAGS+set}" = set || CFLAGS="-g" test "${CXXFLAGS+set}" = set || CXXFLAGS="-g" test "${CCASFLAGS+set}" = set || CCASFLAGS="" fi AC_CANONICAL_HOST # If the compiler defines _WIN32 we're building for native Windows otherwise we're # building for something else. AC_CHECK_DECL([_WIN32], [poly_native_windows=yes], [poly_native_windows=no]) # If we are building on cygwin or mingw we need to give the -no-defined flag to # build a DLL. We also have to use Windows calling conventions rather than # SysV on 64-bit. poly_use_windowscc=no poly_need_macosopt=no case "${host_os}" in darwin*) AC_SUBST([OSFLAG], [-DMACOSX]) poly_need_macosopt=yes ;; sunos* | solaris*) AC_SUBST([OSFLAG], [-DSOLARIS]) ;; *mingw* | *cygwin*) poly_no_undefined=yes poly_use_windowscc=yes ;; esac # libpolyml can be a DLL but libpolymain can't. # Enable shared libraries by default. It complicates installation a bit if the # the library is installed to a non-standard location but simplifies polyc. LT_INIT([win32-dll]) AM_MAINTAINER_MODE # Check we're in the right directory AC_CONFIG_SRCDIR([polyexports.h]) AC_CONFIG_HEADER([config.h]) # Checks for programs. AC_PROG_CXX # The following check was supposed to check that there was actually a # C++ compiler but doesn't work properly if CXX is set by the user. #AC_CHECK_PROG(check_cpp, $CXX, "yes", "no") #if test "$check_cpp" != "yes"; then # AC_MSG_ERROR([No C++ compiler found. Unable to build Poly/ML.]) #fi AC_PROG_CC AC_PROG_MAKE_SET AC_PROG_CPP AM_PROG_AS # Activate large file mode if needed AC_SYS_LARGEFILE # Checks for libraries. AC_CHECK_LIB(gcc, main) AC_CHECK_LIB(gcc_s, main) AC_CHECK_LIB(stdc++, main) # These can sometimes be in the standard libraries AC_SEARCH_LIBS([dlopen], [dl dld]) AC_SEARCH_LIBS([floor], [m]) ## External names on Win64. They have no leading underscores as per ## the X64 ABI published by MS. Earlier versions of GCC (anything ## prior to 4.5.0) were faulty. LT_SYS_SYMBOL_USCORE if test x$sys_symbol_underscore = xyes; then AC_DEFINE(SYMBOLS_REQUIRE_UNDERSCORE, [1], [Defined if external symbols are prefixed by underscores]) fi # Check for headers AC_FUNC_ALLOCA AC_HEADER_DIRENT AC_HEADER_STDC AC_HEADER_SYS_WAIT AC_CHECK_HEADERS([stdio.h time.h fcntl.h float.h limits.h locale.h malloc.h netdb.h netinet/in.h stddef.h]) AC_CHECK_HEADERS([stdlib.h string.h sys/file.h sys/ioctl.h sys/param.h sys/socket.h sys/systeminfo.h]) AC_CHECK_HEADERS([sys/time.h unistd.h values.h dlfcn.h signal.h ucontext.h]) AC_CHECK_HEADERS([assert.h ctype.h direct.h errno.h excpt.h fenv.h fpu_control.h grp.h]) -AC_CHECK_HEADERS([ieeefp.h io.h math.h memory.h netinet/tcp.h poll.h pwd.h siginfo.h]) +AC_CHECK_HEADERS([ieeefp.h io.h math.h memory.h netinet/tcp.h arpa/inet.h poll.h pwd.h siginfo.h]) AC_CHECK_HEADERS([stdarg.h sys/errno.h sys/filio.h sys/mman.h sys/resource.h]) AC_CHECK_HEADERS([sys/signal.h sys/sockio.h sys/stat.h termios.h sys/termios.h sys/times.h]) AC_CHECK_HEADERS([sys/types.h sys/uio.h sys/un.h sys/utsname.h sys/select.h sys/sysctl.h]) AC_CHECK_HEADERS([sys/elf_SPARC.h sys/elf_386.h sys/elf_amd64.h asm/elf.h]) AC_CHECK_HEADERS([windows.h tchar.h semaphore.h]) AC_CHECK_HEADERS([stdint.h inttypes.h]) # Only check for the X headers if the user said --with-x. if test "${with_x+set}" = set; then AC_CHECK_HEADERS([X11/Xlib.h Xm/Xm.h]) fi PKG_PROG_PKG_CONFIG # Check for GMP AC_ARG_WITH([gmp], [AS_HELP_STRING([--with-gmp], [use the GMP library for arbitrary precision arithmetic @<:@default=check@:>@])], [], [with_gmp=check]) # If we want GMP check that the library and headers are installed. if test "x$with_gmp" != "xno"; then AC_CHECK_LIB([gmp], [__gmpn_tdiv_qr], [AC_DEFINE([HAVE_LIBGMP], [1], [Define to 1 if you have libgmp]) [LIBS="-lgmp $LIBS"] AC_CHECK_HEADER([gmp.h], [AC_DEFINE([HAVE_GMP_H], [1], [Define to 1 if you have the gmp.h header file])], [if test "x$with_gmp" != "xcheck"; then AC_MSG_FAILURE( [--with-gmp was given, but gmp.h header file is not installed]) fi ]) ], [if test "x$with_gmp" != "xcheck"; then AC_MSG_FAILURE( [--with-gmp was given, but gmp library (version 4 or later) is not installed]) fi ]) fi # libffi # libffi must be configured even if we are not building with it so that things like "make dist" work. AC_CONFIG_SUBDIRS([libpolyml/libffi]) # Use the internal version unless --with-system-libffi is given. AC_ARG_WITH([system-libffi], [AS_HELP_STRING([--with-system-libffi], [use the version of libffi installed on your system rather than the version supplied with poly @<:@default=no@:>@])], [], [with_system_libffi=no]) # Libffi uses pkg-config. if test "x$with_system_libffi" = "xyes"; then PKG_CHECK_MODULES([FFI], [libffi], [LIBS="$FFI_LIBS $LIBS" CFLAGS="$FFI_CFLAGS $CFLAGS"], [AC_CHECK_LIB([ffi], [ffi_prep_closure_loc], [ [LIBS="-lffi $LIBS"] AC_CHECK_HEADER([ffi.h], [], [ AC_MSG_FAILURE([--with-system-libffi was given, but ffi.h header file cannot be found]) ]) ], [AC_MSG_FAILURE([--with-system-libffi was given, but the ffi library is not installed])] ) ] ) else # Use internal libffi CFLAGS="$CFLAGS -Ilibffi/include" CXXFLAGS="$CXXFLAGS -Ilibffi/include" fi AM_CONDITIONAL([INTERNAL_LIBFFI], [test "x$with_system_libffi" != "xyes"]) # Special configuration for Windows or Unix. poly_windows_enablegui=false if test "x$poly_native_windows" = xyes; then # The next two are only used with mingw. We mustn't include ws2_32 in Cygwin64 because # the "select" function gets used instead of Cygwin's own. AC_CHECK_LIB(ws2_32, main) AC_CHECK_LIB(gdi32, main) CFLAGS="$CFLAGS -mthreads" CXXFLAGS="$CXXFLAGS -mthreads" AC_SUBST([OSFLAG], ["-DUNICODE -D_UNICODE -D_WIN32_WINNT=0x600"]) AC_CHECK_TOOL(WINDRES, windres) # Enable/Disable the GUI in Windows. AC_ARG_ENABLE([windows-gui], [AS_HELP_STRING([--enable-windows-gui], [create a GUI in Windows. If this is disabled use a Windows console. @<:@default=yes@:>@])], [case "${enableval}" in yes) poly_windows_enablegui=true ;; no) poly_windows_enablegui=false ;; *) AC_MSG_ERROR([bad value ${enableval} for --enable-windows-gui]) ;; esac], [poly_windows_enablegui=true]) else # Unix or similar e.g. Cygwin. We need pthreads. # On Android pthread_create is in the standard library AC_SEARCH_LIBS([pthread_create], [pthread], [AC_DEFINE([HAVE_LIBPTHREAD], [1], [Define to 1 if you have the `pthread' library (-lpthread).]) AC_CHECK_HEADER([pthread.h], [AC_DEFINE([HAVE_PTHREAD_H], [1], [Define to 1 if you have the header file.])], [ AC_MSG_FAILURE([pthread.h header file is not installed]) ]) ], [ AC_MSG_FAILURE([pthread library is not installed]) ]) # Solaris needs -lsocket, -lnsl and -lrt AC_SEARCH_LIBS([gethostbyname], [nsl]) AC_SEARCH_LIBS([getsockopt], [socket]) AC_SEARCH_LIBS([sem_wait], [rt]) # Check for X and Motif headers and libraries AC_PATH_X if test "x${with_x}" = "xyes"; then AC_DEFINE([WITH_XWINDOWS], [1], [Define if the X-Windows interface should be built]) if test "$x_includes" != "" ; then if test "$x_includes" != "NONE" ; then CFLAGS="$CFLAGS -I$x_includes" CXXFLAGS="$CXXFLAGS -I$x_includes" CPPFLAGS="$CPPFLAGS -I$x_includes" fi fi if test "$x_libraries" != "" ; then if test "$x_libraries" != "NONE" ; then LIBS="-L$x_libraries $LIBS" fi fi AC_CHECK_LIB(X11, XCreateGC) AC_CHECK_LIB(Xt, XtMalloc) AC_CHECK_LIB(Xext, XextAddDisplay) if test "$xm_includes" != "" ; then if test "$xm_includes" != "NONE" ; then CFLAGS="$CFLAGS -I$xm_includes" CXXFLAGS="$CXXFLAGS -I$xm_includes" CPPFLAGS="$CPPFLAGS -I$xm_includes" fi fi if test "$xm_libraries" != "" ; then if test "$xm_libraries" != "NONE" ; then LIBS="-L$xm_libraries $LIBS" fi fi AC_CHECK_LIB(Xm, XmGetDestination) fi # TODO: May need AC_PATH_XTRA for Solaris fi # End of Windows/Unix configuration. # Find out which type of object code exporter to use. # If we have winnt use PECOFF. This really only applies to cygwin here. # If we have elf.h use ELF. # If we have mach-o/reloc.h use Mach-O # Otherwise use the C source code exporter. AC_CHECK_TYPES([IMAGE_FILE_HEADER], [AC_DEFINE([HAVE_PECOFF], [], [Define to 1 if you have the PE/COFF types.])] [polyexport=pecoff], [AC_CHECK_HEADER([elf.h], [AC_DEFINE([HAVE_ELF_H], [], [Define to 1 if you have the header file.])] [polyexport=elf], [AC_CHECK_HEADER([mach-o/reloc.h], [AC_DEFINE([HAVE_MACH_O_RELOC_H], [], [Define to 1 if you have the header file.])] [polyexport=macho], [AC_CHECK_HEADERS([elf_abi.h machine/reloc.h], [AC_DEFINE([HAVE_ELF_ABI_H], [], [Define to 1 if you have and header files.])] [polyexport=elf] )] )] )], [#include ] ) AM_CONDITIONAL([EXPPECOFF], [test "$polyexport" = pecoff]) AM_CONDITIONAL([EXPELF], [test "$polyexport" = elf]) AM_CONDITIONAL([EXPMACHO], [test "$polyexport" = macho]) # Checks for typedefs, structures, and compiler characteristics. AC_HEADER_STDBOOL AC_C_CONST AC_TYPE_INT16_T AC_TYPE_UINT16_T AC_TYPE_INT32_T AC_TYPE_UINT32_T AC_TYPE_INT64_T AC_TYPE_UINT64_T AC_TYPE_INTPTR_T AC_TYPE_UINTPTR_T AC_TYPE_UID_T AC_TYPE_MODE_T AC_TYPE_OFF_T AC_TYPE_PID_T AC_TYPE_SIZE_T AC_TYPE_SSIZE_T AC_HEADER_TIME AC_STRUCT_TM # Check for the various sub-second fields of the stat structure. AC_CHECK_MEMBERS([struct stat.st_atim, struct stat.st_atimespec, struct stat.st_atimensec, struct stat.st_atime_n, struct stat.st_uatime]) # Mac OS X, at any rate, needs signal.h to be included first. AC_CHECK_TYPES([ucontext_t], , , [#include "signal.h" #include "ucontext.h"]) AC_CHECK_TYPES([struct sigcontext, stack_t, sighandler_t, sig_t], , ,[#include "signal.h"]) AC_CHECK_TYPES([socklen_t],,,[#include "sys/types.h" #include "sys/socket.h"]) AC_CHECK_TYPES([SYSTEM_LOGICAL_PROCESSOR_INFORMATION],,,[#include "windows.h"]) AC_CHECK_TYPES(long long) AC_CHECK_TYPES(ssize_t) AC_CHECK_SIZEOF(void*) AC_CHECK_SIZEOF(long) AC_CHECK_SIZEOF(int) AC_CHECK_SIZEOF(long long) AC_CHECK_SIZEOF(double) AC_CHECK_SIZEOF(float) AC_C_BIGENDIAN # Checks for library functions. AC_FUNC_ERROR_AT_LINE AC_FUNC_GETGROUPS AC_FUNC_GETPGRP AC_PROG_GCC_TRADITIONAL AC_FUNC_SELECT_ARGTYPES AC_FUNC_STAT AC_FUNC_STRTOD AC_CHECK_FUNCS([dlopen strtod dtoa getpagesize sigaltstack mmap mkstemp]) ## There does not seem to be a declaration for fpsetmask in mingw64. AC_CHECK_DECLS([fpsetmask], [], [], [[#include ]]) AC_CHECK_FUNCS([sysctl sysctlbyname]) AC_CHECK_FUNCS([localtime_r gmtime_r]) AC_CHECK_FUNCS([ctermid tcdrain]) # Where are the registers when we get a signal? Used in time profiling. #Linux: AC_CHECK_MEMBERS([mcontext_t.gregs, mcontext_t.regs, mcontext_t.mc_esp],,,[#include "ucontext.h"]) #Mac OS X: AC_CHECK_MEMBERS([struct mcontext.ss, struct __darwin_mcontext.ss, struct __darwin_mcontext.__ss, struct __darwin_mcontext32.ss, struct __darwin_mcontext32.__ss, struct __darwin_mcontext64.ss, struct __darwin_mcontext64.__ss],,, [#include "signal.h" #include "ucontext.h"]) # FreeBSD includes a sun_len member in struct sockaddr_un AC_CHECK_MEMBERS([struct sockaddr_un.sun_len],,, [#include ]) # This option enables the native code generator. More precisely it allows # the byte code interpreter to be built on X86. AC_ARG_ENABLE([native-codegeneration], [AS_HELP_STRING([--disable-native-codegeneration], [disable the native code generator and use the slow byte code interpreter instead.])], [case "${enableval}" in no) with_portable=yes ;; yes) with_portable=no ;; *) AC_MSG_ERROR([bad value ${enableval} for --enable-native-codegeneration]) ;; esac], [with_portable=check]) # Check which CPU we're building for. Can we use a native pre-built compiler # or do we need to fall back to the interpreter? Most of these settings are to tweak # the ELF exporter. case "${host_cpu}" in i[[3456]]86*) AC_DEFINE([HOSTARCHITECTURE_X86], [1], [Define if the host is an X86 (32-bit)]) polyarch=i386 ;; x86_64* | amd64*) if test X"$ac_cv_sizeof_voidp" = X8; then AC_DEFINE([HOSTARCHITECTURE_X86_64], [1], [Define if the host is an X86 (64-bit)]) polyarch=x86_64 else AC_DEFINE([HOSTARCHITECTURE_X32], [1], [Define if the host is an X86 (32-bit ABI, 64-bit processor)]) polyarch=interpret fi ;; sparc64*) AC_DEFINE([HOSTARCHITECTURE_SPARC64], [1], [Define if the host is a Sparc (64-bit)]) polyarch=interpret ;; sparc*) AC_DEFINE([HOSTARCHITECTURE_SPARC], [1], [Define if the host is a Sparc (32-bit)]) polyarch=interpret ;; powerpc64* | ppc64*) AC_DEFINE([HOSTARCHITECTURE_PPC64], [1], [Define if the host is a PowerPC (64-bit)]) polyarch=interpret ;; power* | ppc*) AC_DEFINE([HOSTARCHITECTURE_PPC], [1], [Define if the host is a PowerPC (32-bit)]) polyarch=interpret ;; arm*) AC_DEFINE([HOSTARCHITECTURE_ARM], [1], [Define if the host is an ARM (32-bit)]) polyarch=interpret ;; aarch64*) AC_DEFINE([HOSTARCHITECTURE_AARCH64], [1], [Define if the host is an ARM (64-bit)]) polyarch=interpret ;; hppa*) AC_DEFINE([HOSTARCHITECTURE_HPPA], [1], [Define if the host is an HP PA-RISC (32-bit)]) polyarch=interpret ;; ia64*) AC_DEFINE([HOSTARCHITECTURE_IA64], [1], [Define if the host is an Itanium]) polyarch=interpret ;; m68k*) AC_DEFINE([HOSTARCHITECTURE_M68K], [1], [Define if the host is a Motorola 68000]) polyarch=interpret ;; mips64*) AC_DEFINE([HOSTARCHITECTURE_MIPS64], [1], [Define if the host is a MIPS (64-bit)]) polyarch=interpret ;; mips*) AC_DEFINE([HOSTARCHITECTURE_MIPS], [1], [Define if the host is a MIPS (32-bit)]) polyarch=interpret ;; s390x*) AC_DEFINE([HOSTARCHITECTURE_S390X], [1], [Define if the host is an S/390 (64-bit)]) polyarch=interpret ;; s390*) AC_DEFINE([HOSTARCHITECTURE_S390], [1], [Define if the host is an S/390 (32-bit)]) polyarch=interpret ;; sh*) AC_DEFINE([HOSTARCHITECTURE_SH], [1], [Define if the host is a SuperH (32-bit)]) polyarch=interpret ;; alpha*) AC_DEFINE([HOSTARCHITECTURE_ALPHA], [1], [Define if the host is an Alpha (64-bit)]) polyarch=interpret # GCC defaults to non-conforming floating-point, and does not respect the rounding mode # in the floating-point control register, so we force it to conform to IEEE and use the # dynamic suffix on the floating-point instructions it produces. CFLAGS="$CFLAGS -mieee -mfp-rounding-mode=d" CXXFLAGS="$CXXFLAGS -mieee -mfp-rounding-mode=d" ;; riscv32) AC_DEFINE([HOSTARCHITECTURE_RISCV32], [1], [Define if the host is a RISC-V (32-bit)]) polyarch=interpret ;; riscv64) AC_DEFINE([HOSTARCHITECTURE_RISCV64], [1], [Define if the host is a RISC-V (64-bit)]) polyarch=interpret ;; *) AC_MSG_ERROR([Poly/ML is not supported for this architecture]) ;; esac # If we explicitly asked to use the interpreter set the architecture to interpreted. if test "x$with_portable" = "xyes" ; then if test "x$polyarch" != "xinterpret" ; then AC_MSG_WARN( [*******You have disabled native code generation. Are you really sure you want to do that?*******]) fi polyarch=interpret fi # If we asked not to use the interpreter check we have native code support. if test "x$with_portable" = "xno" ; then if test "x$polyarch" = "xinterpret" ; then AC_MSG_ERROR( [--enable-native-codegeneration was given but native code is not supported on this platform]) fi fi if test "x$polyarch" != "xinterpret" ; then # Check for .note.GNU-stack support, used for marking the stack as non-executable. # Only do this check if we're using the native X86 versions. We don't need this if # we're using the interpreter and the assembler on other architectures may choke. AC_MSG_CHECKING([whether as supports .note.GNU-stack]) AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[__asm__(".section .note.GNU-stack,\"\",@progbits");]])], [AC_MSG_RESULT([yes])] [AC_DEFINE([HAVE_GNU_STACK], [1], [Define to 1 if you have .note.GNU-stack support in the assembler.])], [AC_MSG_RESULT([no])]) fi # Build 32-bit in 64-bits. This is only allowed when building on native 64-bit X86. AC_ARG_ENABLE([compact32bit], [AS_HELP_STRING([--enable-compact32bit], [use 32-bit values rather than native 64-bits.])]) if test "x$enable_compact32bit" = "xyes"; then if test X"$polyarch" = "Xx86_64" ; then AC_DEFINE([POLYML32IN64], [1], [Define if this should use 32-bit values in 64-bit architectures]) polyarch=x86_32in64 else AC_MSG_ERROR([--enable-compact32bit is only available on X86/64]) fi fi # Put this test at the end where it's less likely to be missed. # If we're compiling on Cygwin (and mingw?) and /usr/bin/file is not present # the link step will produce some strange warning messages of the form: # "Warning: linker path does not have real file for library -lXXX". I think # that's really a bug in autoconf but to explain what's happening to the user # add a test here. if test "$lt_cv_file_magic_cmd" = "func_win32_libid"; then if test \! -x /usr/bin/file; then echo "" echo "*** Warning: You are building Poly/ML on Cygwin/Mingw but '/usr/bin/file' cannot be found." echo "*** You can still go ahead and build Poly/ML but libpolyml will not be built as a" echo "*** shared library and you may get strange warning messages from the linker step." echo "*** Install the 'file' package to correct this problem." echo "" fi fi AM_CONDITIONAL([ARCHI386], [test "$polyarch" = i386]) AM_CONDITIONAL([ARCHX86_64], [test "$polyarch" = x86_64]) AM_CONDITIONAL([ARCHINTERPRET], [test "$polyarch" = interpret -a X"$ac_cv_sizeof_voidp" = X4]) AM_CONDITIONAL([ARCHINTERPRET64], [test "$polyarch" = interpret -a X"$ac_cv_sizeof_voidp" = X8]) AM_CONDITIONAL([ARCHX8632IN64], [test "$polyarch" = x86_32in64]) # If we are targeting Windows rather than *nix we need the pre=built compiler with Windows conventions. AM_CONDITIONAL([WINDOWSCALLCONV], [test "$poly_use_windowscc" = yes]) # This is true if we are building for native Windows rather than Cygwin AM_CONDITIONAL([NATIVE_WINDOWS], [test "$poly_native_windows" = yes]) AM_CONDITIONAL([NO_UNDEFINED], [test "$poly_no_undefined" = yes]) AM_CONDITIONAL([WINDOWSGUI], [test x$poly_windows_enablegui = xtrue]) AM_CONDITIONAL([MACOSLDOPTS], [test "$poly_need_macosopt" = yes ]) # If we're building only the static version of libpolyml # then polyc and polyml.pc have to include the dependent libraries. dependentlibs="" if test "${enable_shared}" != yes; then dependentlibs=${LIBS} fi AC_SUBST([dependentlibs], ["$dependentlibs"]) # Test whether this is a git directory and set the version if possible AC_CHECK_PROG([gitinstalled], [git], [yes], [no]) if test X"$gitinstalled" = "Xyes" -a -d ".git"; then GIT_VERSION='-DGIT_VERSION=\"$(shell git describe --tags --always)\"' AC_SUBST(GIT_VERSION) fi # Strip -fdebug-prefix-map= from CFLAGS; it's meaningless for users of polyc, # and hurts reproducibility. polyc_CFLAGS= for cflag in $CFLAGS; do cflag="${cflag##-fdebug-prefix-map=*}" if test -n "$cflag"; then if test -n "$polyc_CFLAGS"; then polyc_CFLAGS="$polyc_CFLAGS $cflag" else polyc_CFLAGS="$cflag" fi fi done AC_SUBST([polyc_CFLAGS], ["$polyc_CFLAGS"]) # Modules directory AC_ARG_WITH([moduledir], [AS_HELP_STRING([--with-moduledir=DIR], [directory for Poly/ML modules])], [moduledir=$withval], [moduledir="\${libdir}/polyml/modules"]) AC_SUBST([moduledir], [$moduledir]) # Control whether to build the basis library with arbitrary precision as the default int AC_ARG_ENABLE([intinf-as-int], [AS_HELP_STRING([--enable-intinf-as-int], [set arbitrary precision as the default int type])], [case "${enableval}" in no) intisintinf=no ;; yes) intisintinf=yes ;; *) AC_MSG_ERROR([bad value ${enableval} for --enable-intinf-as-int]) ;; esac], [intisintinf=no]) AM_CONDITIONAL([INTINFISINT], [test "$intisintinf" = "yes"]) # These are needed for building in a separate build directory, as they are # referenced from exportPoly.sml. AC_CONFIG_COMMANDS([basis], [test -e basis || ln -sf ${ac_top_srcdir}/basis .]) AC_CONFIG_COMMANDS([mlsource], [test -e mlsource || ln -sf ${ac_top_srcdir}/mlsource .]) AC_CONFIG_FILES([Makefile libpolyml/Makefile libpolyml/polyml.pc libpolymain/Makefile modules/Makefile modules/IntInfAsInt/Makefile]) AC_CONFIG_FILES([polyc], [chmod +x polyc]) AC_OUTPUT diff --git a/libpolyml/arb.cpp b/libpolyml/arb.cpp index c065b80d..1e85fd73 100644 --- a/libpolyml/arb.cpp +++ b/libpolyml/arb.cpp @@ -1,2034 +1,2034 @@ /* Title: Arbitrary Precision Package. Author: Dave Matthews, Cambridge University Computer Laboratory Further modification Copyright 2010, 2012, 2015, 2017 David C. J. Matthews Copyright (c) 2000 Cambridge University Technical Services Limited 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 */ /* Arbitrary precision package in C. Integers are held in two formats in this system, long-form and short-form. The two are distinquished by the integer tag bit, short-form having the tag bit set and pointers to long-form being untagged. The long-form integers use the standard Poly format for multi-word objects, with the length count and flags in the word just before the object pointed to. The sign of long-form integers is coded in one of the flag bits. Short integers are signed quantities, and can be directly manipulated by the relevant instructions, but if overflow occurs then the full long versions of the operations will need to be called. There are two versions of long-form integers depending on whether the GMP library is available. If it is then the byte cells contain "limbs", typically native 32 or 64-bit words. If it is not, the fall-back Poly code is used in which long-form integers are vectors of bytes (i.e. unsigned char). Integers are always stored in the least possible number of words, and will be shortened to the short-form when possible. Thanks are due to D. Knuth for the long division algorithm. */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ALLOCA_H #include #endif #ifdef HAVE_MALLOC_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #ifdef HAVE_GMP_H #include #define USE_GMP 1 #endif #include "globals.h" #include "sys.h" #include "run_time.h" #include "arb.h" #include "save_vec.h" #include "processes.h" #include "memmgr.h" #include "rtsentry.h" #include "profiling.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyAddArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolySubtractArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyMultiplyArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyDivideArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyRemainderArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyQuotRemArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyQuotRemArbitraryPair(PolyObject *threadId, PolyWord arg1, PolyWord arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyAddArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolySubtractArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyMultiplyArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyDivideArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyRemainderArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyQuotRemArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyQuotRemArbitraryPair(FirstArgument threadId, PolyWord arg1, PolyWord arg2); POLYEXTERNALSYMBOL POLYSIGNED PolyCompareArbitrary(PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyGCDArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyLCMArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetLowOrderAsLargeWord(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyOrArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyAndArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyXorArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGCDArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyLCMArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetLowOrderAsLargeWord(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyOrArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyAndArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyXorArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); } static Handle add_longc(TaskData *taskData, Handle,Handle); static Handle sub_longc(TaskData *taskData, Handle,Handle); static Handle mult_longc(TaskData* taskData, Handle, Handle); static Handle or_longc(TaskData *taskData, Handle,Handle); static Handle and_longc(TaskData *taskData, Handle,Handle); static Handle xor_longc(TaskData *taskData, Handle,Handle); static Handle neg_longc(TaskData *taskData, Handle); static Handle gcd_arbitrary(TaskData *taskData, Handle,Handle); static Handle lcm_arbitrary(TaskData *taskData, Handle,Handle); // Number of bits in a Poly word. N.B. This is not necessarily the same as SIZEOF_VOIDP. #define BITS_PER_POLYWORD (SIZEOF_POLYWORD*8) #ifdef USE_GMP #if (BITS_PER_POLYWORD > GMP_LIMB_BITS) // We're assuming that every GMP limb occupies at least one word #error "Size of GMP limb is less than a Poly word" #endif #endif #ifdef USE_GMP #define DEREFLIMBHANDLE(_x) ((mp_limb_t *)DEREFHANDLE(_x)) // Returns the length of the argument with trailing zeros removed. static mp_size_t numLimbs(PolyWord x) { POLYUNSIGNED numWords = OBJECT_LENGTH(x); #if BITS_PER_POLYWORD != GMP_LIMB_BITS ASSERT((numWords & (sizeof(mp_limb_t)/sizeof(PolyWord)-1)) == 0); #endif mp_size_t lu = numWords*sizeof(PolyWord)/sizeof(mp_limb_t); mp_limb_t *u = (mp_limb_t *)x.AsObjPtr(); while (lu > 0 && u[lu-1] == 0) lu--; return lu; } #else // Returns the length of the argument with trailing zeros removed. static POLYUNSIGNED get_length(PolyWord x) { byte *u = (byte *)x.AsObjPtr(); POLYUNSIGNED lu = OBJECT_LENGTH(x)*sizeof(PolyWord); for( ; (lu > 0) && (u[lu-1] == 0); lu--) { /* do nothing */ } return lu; } #endif // Return a uintptr_t value i.e. unsigned 32-bits on 32-bit architecture and 64-bits on 64-bit architecture. POLYUNSIGNED getPolyUnsigned(TaskData *taskData, PolyWord number) { if ( IS_INT(number) ) { POLYSIGNED i = UNTAGGED(number); if ( i < 0 ) raise_exception0(taskData, EXC_size ); return i; } else { if (OBJ_IS_NEGATIVE(GetLengthWord(number))) raise_exception0(taskData, EXC_size ); #ifdef USE_GMP unsigned length = numLimbs(number); if (length > 1) raise_exception0(taskData, EXC_size); mp_limb_t first = *(mp_limb_t*)number.AsCodePtr(); #if (BITS_PER_POLYWORD < GMP_NUMB_BITS) if (first > (mp_limb_t)1 << BITS_PER_POLYWORD) raise_exception0(taskData, EXC_size); #endif return first; #else byte *ptr = number.AsCodePtr(); POLYUNSIGNED length = get_length(number); if (length > sizeof(PolyWord) ) raise_exception0(taskData, EXC_size); POLYSIGNED c = 0; while ( length-- ) c = (c << 8) | ((byte *) ptr)[length]; return c; #endif } } #define MAX_INT_PLUS1 ((POLYUNSIGNED)0x80 << ( (sizeof(PolyWord)-1) *8)) // Return an intptr_t value i.e. signed 32-bits on 32-bit architecture and 64-bits on 64-bit architecture. POLYSIGNED getPolySigned(TaskData *taskData, PolyWord number) { if ( IS_INT(number) ) { return UNTAGGED(number); } else { int sign = OBJ_IS_NEGATIVE(GetLengthWord(number)) ? -1 : 0; #ifdef USE_GMP unsigned length = numLimbs(number); if (length > 1) raise_exception0(taskData, EXC_size); mp_limb_t c = *(mp_limb_t*)number.AsCodePtr(); #else POLYUNSIGNED length = get_length(number); POLYUNSIGNED c = 0; byte *ptr = number.AsCodePtr(); if ( length > sizeof(PolyWord) ) raise_exception0(taskData, EXC_size ); while ( length-- ) { c = (c << 8) | ptr[length]; } #endif if ( sign == 0 && c < MAX_INT_PLUS1) return (POLYSIGNED)c; if ( sign != 0 && c <= MAX_INT_PLUS1) return -((POLYSIGNED)c); raise_exception0(taskData, EXC_size ); /*NOTREACHED*/ return 0; } } short get_C_short(TaskData *taskData, PolyWord number) { int i = (int)get_C_long(taskData, number); if ( i <= 32767 && i >= -32768 ) return i; raise_exception0(taskData, EXC_size ); /*NOTREACHED*/ return 0; } unsigned short get_C_ushort(TaskData *taskData, PolyWord number) { POLYUNSIGNED u = get_C_ulong(taskData, number ); if ( u <= 65535 ) return (short)u; raise_exception0(taskData, EXC_size ); /*NOTREACHED*/ return 0; } #if (SIZEOF_LONG == SIZEOF_POLYWORD) unsigned get_C_unsigned(TaskData *taskData, PolyWord number) { return get_C_ulong(taskData, number); } int get_C_int(TaskData *taskData, PolyWord number) { return get_C_long(taskData, number); } #else // Poly words are the same size as a pointer but that may // not be the same as int or long. unsigned get_C_unsigned(TaskData *taskData, PolyWord number) { POLYUNSIGNED res = get_C_ulong(taskData, number); unsigned result = (unsigned)res; if ((POLYUNSIGNED)result != res) raise_exception0(taskData, EXC_size); return result; } int get_C_int(TaskData *taskData, PolyWord number) { POLYSIGNED res = get_C_long(taskData, number); int result = (int)res; if ((POLYSIGNED)result != res) raise_exception0(taskData, EXC_size); return result; } #endif // Convert short values to long. Returns a pointer to the memory. // This is generally called before allocating memory for the result. // It is unsafe to use the result after the allocation if the value is // an address because it may have been moved by a GC. #ifdef USE_GMP static mp_limb_t *convertToLong(Handle x, mp_limb_t *extend, mp_size_t *length, int *sign) { if (IS_INT(x->Word())) { // Short form - put it in the temporary. POLYSIGNED x_v = UNTAGGED(DEREFWORD(x)); if (x_v < 0) x_v = -x_v; *extend = x_v; if (x_v == 0) *length = 0; else *length = 1; if (sign) *sign = UNTAGGED(x->Word()) >= 0 ? 0 : -1; return extend; } else { *length = numLimbs(x->Word()); if (sign) *sign = OBJ_IS_NEGATIVE(GetLengthWord(x->Word())) ? -1 : 0; return DEREFLIMBHANDLE(x); } } #else static byte *convertToLong(Handle x, byte *extend, POLYUNSIGNED *length, int *sign) { if (IS_INT(x->Word())) { // Short form - put it in the temporary. POLYSIGNED x_v = UNTAGGED(DEREFWORD(x)); if (x_v < 0) x_v = -x_v; /* Put into extend buffer, low order byte first. */ *length = 0; for (unsigned i = 0; i < sizeof(PolyWord); i++) { if (x_v != 0) *length = i + 1; extend[i] = x_v & 0xff; x_v = x_v >> 8; } if (sign) *sign = UNTAGGED(x->Word()) >= 0 ? 0 : -1; return extend; } else { *length = get_length(DEREFWORD(x)); if (sign) *sign = OBJ_IS_NEGATIVE(GetLengthWord(x->Word())) ? -1 : 0; return DEREFBYTEHANDLE(x); } } #endif /* make_canonical is used to force a result into its shortest form, in the style of get_length, but also may convert its argument from long to short integer */ static Handle make_canonical(TaskData *taskData, Handle x, int sign) { #ifdef USE_GMP unsigned size = numLimbs(DEREFWORD(x)); if (size <= 1) // May be zero if the result is zero. { mp_limb_t r = *DEREFLIMBHANDLE(x); if (r <= MAXTAGGED || (r == MAXTAGGED+1 && sign < 0)) { if (sign < 0) return taskData->saveVec.push(TAGGED(-(POLYSIGNED)r)); else return taskData->saveVec.push(TAGGED(r)); } } // Throw away any unused words. DEREFWORDHANDLE(x)->SetLengthWord(WORDS(size*sizeof(mp_limb_t)), F_BYTE_OBJ | (sign < 0 ? F_NEGATIVE_BIT: 0)); return x; #else /* get length in BYTES */ POLYUNSIGNED size = get_length(DEREFWORD(x)); // We can use the short representation if it will fit in a word. if (size <= sizeof(PolyWord)) { /* Convert the digits. */ byte *u = DEREFBYTEHANDLE(x); POLYUNSIGNED r = 0; for (unsigned i=0; i < sizeof(PolyWord); i++) { r |= ((POLYUNSIGNED)u[i]) << (8*i); } /* Check for MAXTAGGED+1 before subtraction in case MAXTAGGED is 0x7fffffff */ if (r <= MAXTAGGED || (r == MAXTAGGED+1 && sign < 0)) { if (sign < 0) return taskData->saveVec.push(TAGGED(-(POLYSIGNED)r)); else return taskData->saveVec.push(TAGGED(r)); } } /* The length word of the object is changed to reflect the new length. This is safe because any words thrown away must be zero. */ DEREFWORDHANDLE(x)->SetLengthWord(WORDS(size), F_BYTE_OBJ | (sign < 0 ? F_NEGATIVE_BIT: 0)); return x; #endif } Handle ArbitraryPrecionFromSigned(TaskData *taskData, POLYSIGNED val) /* Called from routines in the run-time system to generate an arbitrary precision integer from a word value. */ { if (val <= MAXTAGGED && val >= -MAXTAGGED-1) /* No overflow */ return taskData->saveVec.push(TAGGED(val)); POLYUNSIGNED uval = val < 0 ? -val : val; #ifdef USE_GMP Handle y = alloc_and_save(taskData, WORDS(sizeof(mp_limb_t)), ((val < 0) ? F_NEGATIVE_BIT : 0)| F_BYTE_OBJ); mp_limb_t *v = DEREFLIMBHANDLE(y); *v = uval; #else Handle y = alloc_and_save(taskData, 1, ((val < 0) ? F_NEGATIVE_BIT : 0)| F_BYTE_OBJ); byte *v = DEREFBYTEHANDLE(y); for (POLYUNSIGNED i = 0; uval != 0; i++) { v[i] = (byte)(uval & 0xff); uval >>= 8; } #endif return y; } Handle ArbitraryPrecionFromUnsigned(TaskData *taskData, POLYUNSIGNED uval) /* Called from routines in the run-time system to generate an arbitrary precision integer from an unsigned value. */ { if (uval <= MAXTAGGED) return taskData->saveVec.push(TAGGED(uval)); #ifdef USE_GMP Handle y = alloc_and_save(taskData, WORDS(sizeof(mp_limb_t)), F_BYTE_OBJ); mp_limb_t *v = DEREFLIMBHANDLE(y); *v = uval; #else Handle y = alloc_and_save(taskData, 1, F_BYTE_OBJ); byte *v = DEREFBYTEHANDLE(y); for (POLYUNSIGNED i = 0; uval != 0; i++) { v[i] = (byte)(uval & 0xff); uval >>= 8; } #endif return y; } Handle Make_arbitrary_precision(TaskData *taskData, int val) { return ArbitraryPrecionFromSigned(taskData, val); } Handle Make_arbitrary_precision(TaskData *taskData, unsigned uval) { return ArbitraryPrecionFromUnsigned(taskData, uval); } #if (SIZEOF_LONG <= SIZEOF_POLYWORD) Handle Make_arbitrary_precision(TaskData *taskData, long val) { return ArbitraryPrecionFromSigned(taskData, val); } Handle Make_arbitrary_precision(TaskData *taskData, unsigned long uval) { return ArbitraryPrecionFromUnsigned(taskData, uval); } #else // This is needed in Unix in 32-in-64. Handle Make_arbitrary_precision(TaskData *taskData, long val) { if (val <= (long)(MAXTAGGED) && val >= -((long)(MAXTAGGED))-1) /* No overflow */ return taskData->saveVec.push(TAGGED((POLYSIGNED)val)); // Recursive call to handle the high-order part Handle hi = Make_arbitrary_precision(taskData, val >> (sizeof(int32_t) * 8)); // The low-order part is treated as UNsigned. Handle lo = Make_arbitrary_precision(taskData, (uint32_t)val); Handle twoTo16 = taskData->saveVec.push(TAGGED(65536)); Handle twoTo32 = mult_longc(taskData, twoTo16, twoTo16); return add_longc(taskData, mult_longc(taskData, hi, twoTo32), lo); } Handle Make_arbitrary_precision(TaskData *taskData, unsigned long uval) { if (uval <= (unsigned long)(MAXTAGGED)) return taskData->saveVec.push(TAGGED((POLYUNSIGNED)uval)); // Recursive call to handle the high-order part Handle hi = Make_arbitrary_precision(taskData, uval >> (sizeof(uint32_t) * 8)); Handle lo = Make_arbitrary_precision(taskData, (uint32_t)uval); Handle twoTo16 = taskData->saveVec.push(TAGGED(65536)); Handle twoTo32 = mult_longc(taskData, twoTo16, twoTo16); return add_longc(taskData, mult_longc(taskData, hi, twoTo32), lo); } #endif #ifdef HAVE_LONG_LONG #if (SIZEOF_LONG_LONG <= SIZEOF_POLYWORD) Handle Make_arbitrary_precision(TaskData *taskData, long long val) { return ArbitraryPrecionFromSigned(taskData, val); } Handle Make_arbitrary_precision(TaskData *taskData, unsigned long long uval) { return ArbitraryPrecionFromUnsigned(taskData, uval); } #else // 32-bit implementation. Handle Make_arbitrary_precision(TaskData *taskData, long long val) { if (val <= (long long)(MAXTAGGED) && val >= -((long long)(MAXTAGGED))-1) /* No overflow */ return taskData->saveVec.push(TAGGED((POLYSIGNED)val)); // Recursive call to handle the high-order part Handle hi = Make_arbitrary_precision(taskData, val >> (sizeof(int32_t) * 8)); // The low-order part is treated as UNsigned. Handle lo = Make_arbitrary_precision(taskData, (uint32_t)val); Handle twoTo16 = taskData->saveVec.push(TAGGED(65536)); Handle twoTo32 = mult_longc(taskData, twoTo16, twoTo16); return add_longc(taskData, mult_longc(taskData, hi, twoTo32), lo); } Handle Make_arbitrary_precision(TaskData *taskData, unsigned long long uval) { if (uval <= (unsigned long long)(MAXTAGGED)) return taskData->saveVec.push(TAGGED((POLYUNSIGNED)uval)); // Recursive call to handle the high-order part Handle hi = Make_arbitrary_precision(taskData, uval >> (sizeof(uint32_t) * 8)); Handle lo = Make_arbitrary_precision(taskData, (uint32_t)uval); Handle twoTo16 = taskData->saveVec.push(TAGGED(65536)); Handle twoTo32 = mult_longc(taskData, twoTo16, twoTo16); return add_longc(taskData, mult_longc(taskData, hi, twoTo32), lo); } #endif #endif #if defined(_WIN32) // Creates an arbitrary precision number from two words. // Used only in Windows for FILETIME and file-size. Handle Make_arb_from_32bit_pair(TaskData *taskData, uint32_t hi, uint32_t lo) { Handle hHi = Make_arbitrary_precision(taskData, hi); Handle hLo = Make_arbitrary_precision(taskData, lo); Handle twoTo16 = taskData->saveVec.push(TAGGED(65536)); Handle twoTo32 = mult_longc(taskData, twoTo16, twoTo16); return add_longc(taskData, mult_longc(taskData, hHi, twoTo32), hLo); } // Convert a Windows FILETIME into an arbitrary precision integer Handle Make_arb_from_Filetime(TaskData *taskData, const FILETIME &ft) { return Make_arb_from_32bit_pair(taskData, ft.dwHighDateTime, ft.dwLowDateTime); } #endif /* Returns hi*scale+lo as an arbitrary precision number. Currently used for Unix time values where the time is returned as two words, a number of seconds and a number of microseconds and we wish to return the result as a number of microseconds. */ Handle Make_arb_from_pair_scaled(TaskData *taskData, unsigned hi, unsigned lo, unsigned scale) { /* We might be able to compute the number as a 64 bit quantity and then convert it but this is probably more portable. It does risk overflowing the save vector. */ Handle hHi = Make_arbitrary_precision(taskData, hi); Handle hLo = Make_arbitrary_precision(taskData, lo); Handle hScale = Make_arbitrary_precision(taskData, scale); return add_longc(taskData, mult_longc(taskData, hHi, hScale), hLo); } Handle neg_longc(TaskData *taskData, Handle x) { if (IS_INT(DEREFWORD(x))) { POLYSIGNED s = UNTAGGED(DEREFWORD(x)); if (s != -MAXTAGGED-1) // If it won't overflow return taskData->saveVec.push(TAGGED(-s)); } // Either overflow or long argument - convert to long form. int sign_x; #if USE_GMP mp_limb_t x_extend; mp_size_t lx; (void)convertToLong(x, &x_extend, &lx, &sign_x); #else byte x_extend[sizeof(PolyWord)]; POLYUNSIGNED lx; (void)convertToLong(x, x_extend, &lx, &sign_x); #endif #ifdef USE_GMP POLYUNSIGNED bytes = lx*sizeof(mp_limb_t); #else POLYUNSIGNED bytes = lx; #endif Handle long_y = alloc_and_save(taskData, WORDS(bytes), F_MUTABLE_BIT|F_BYTE_OBJ); byte *v = DEREFBYTEHANDLE(long_y); if (IS_INT(DEREFWORD(x))) memcpy(v, &x_extend, bytes); else memcpy(v, DEREFBYTEHANDLE(x), bytes); #ifndef USE_GMP // Make sure the last word is zero. We may have unused bytes there. memset(v+bytes, 0, WORDS(bytes)*sizeof(PolyWord)-lx); #endif /* Return the value with the sign changed. */ return make_canonical(taskData, long_y, sign_x ^ -1); } /* neg_longc */ #ifdef USE_GMP static Handle add_unsigned_long(TaskData *taskData, Handle x, Handle y, int sign) { /* find the longer number */ mp_size_t lx, ly; mp_limb_t x_extend, y_extend; mp_limb_t *xb = convertToLong(x, &x_extend, &lx, NULL); mp_limb_t *yb = convertToLong(y, &y_extend, &ly, NULL); mp_limb_t *u; /* limb-pointer for longer number */ mp_limb_t *v; /* limb-pointer for shorter number */ Handle z; mp_size_t lu; /* length of u in limbs */ mp_size_t lv; /* length of v in limbs */ if (lx < ly) { // Get result vector. It must be 1 limb longer than u // to have space for any carry. z = alloc_and_save(taskData, WORDS((ly+1)*sizeof(mp_limb_t)), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(y)) ? yb : DEREFLIMBHANDLE(y); v = IS_INT(DEREFWORD(x)) ? xb : DEREFLIMBHANDLE(x); lu = ly; lv = lx; } else { // Get result vector. It must be 1 limb longer than u // to have space for any carry. z = alloc_and_save(taskData, WORDS((lx+1)*sizeof(mp_limb_t)), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(x)) ? xb : DEREFLIMBHANDLE(x); v = IS_INT(DEREFWORD(y)) ? yb : DEREFLIMBHANDLE(y); lu = lx; lv = ly; } mp_limb_t *w = DEREFLIMBHANDLE(z); // Do the addition. mp_limb_t carry = 0; if (lv != 0) carry = mpn_add_n(w, u, v, lv); // Add the carry to the rest of the longer number. if (lu != lv) carry = mpn_add_1(w+lv, u+lv, lu-lv, carry); // Put the remaining carry in the final limb. w[lu] = carry; return make_canonical(taskData, z, sign); } #else static Handle add_unsigned_long(TaskData *taskData, Handle x, Handle y, int sign) { byte x_extend[sizeof(PolyWord)], y_extend[sizeof(PolyWord)]; POLYUNSIGNED lx; /* length of u in bytes */ POLYUNSIGNED ly; /* length of v in bytes */ byte *xb = convertToLong(x, x_extend, &lx, NULL); byte *yb = convertToLong(y, y_extend, &ly, NULL); Handle z; byte *u; /* byte-pointer for longer number */ byte *v; /* byte-pointer for shorter number */ POLYUNSIGNED lu, lv; /* Make ``u'' the longer. */ if (lx < ly) { // Get result vector. It must be 1 byte longer than u // to have space for any carry. z = alloc_and_save(taskData, WORDS(ly+1), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(y)) ? yb : DEREFBYTEHANDLE(y); v = IS_INT(DEREFWORD(x)) ? xb : DEREFBYTEHANDLE(x); lu = ly; lv = lx; } else { // Get result vector. It must be 1 byte longer than u // to have space for any carry, plus one byte for the sign. z = alloc_and_save(taskData, WORDS(lx+2), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(x)) ? xb : DEREFBYTEHANDLE(x); v = IS_INT(DEREFWORD(y)) ? yb : DEREFBYTEHANDLE(y); lu = lx; lv = ly; } /* do the actual addition */ byte *w = DEREFBYTEHANDLE(z); unsigned carry = 0; POLYUNSIGNED i = 0; /* Do the additions */ for( ; i < lv; i++) { carry += u[i] + v[i]; w[i] = carry & 0xff; carry >>= 8; } /* Add the carry to the rest of ``u''. */ for( ; i < lu; i++) { carry += u[i]; w[i] = carry & 0xff; carry >>= 8; } /* Finally put the carry into the last byte */ w[i] = (byte)carry; return make_canonical(taskData, z, sign); } /* add_unsigned_long */ #endif #ifdef USE_GMP static Handle sub_unsigned_long(TaskData *taskData, Handle x, Handle y, int sign) { mp_limb_t *u; /* limb-pointer alias for larger number */ mp_limb_t *v; /* limb-pointer alias for smaller number */ mp_size_t lu; /* length of u in limbs */ mp_size_t lv; /* length of v in limbs */ Handle z; /* get the larger argument into ``u'' */ /* This is necessary so that we can discard */ /* the borrow at the end of the subtraction */ mp_size_t lx, ly; mp_limb_t x_extend, y_extend; mp_limb_t *xb = convertToLong(x, &x_extend, &lx, NULL); mp_limb_t *yb = convertToLong(y, &y_extend, &ly, NULL); // Find the larger number. Check the lengths first and if they're equal check the values. int res; if (lx < ly) res = -1; else if (lx > ly) res = 1; else res = mpn_cmp(xb, yb, lx); // If they're equal the result is zero. if (res == 0) return taskData->saveVec.push(TAGGED(0)); /* They are equal */ if (res < 0) { sign ^= -1; /* swap sign of result */ z = alloc_and_save(taskData, WORDS(ly*sizeof(mp_limb_t)), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(y)) ? yb : DEREFLIMBHANDLE(y); v = IS_INT(DEREFWORD(x)) ? xb : DEREFLIMBHANDLE(x); lu = ly; lv = lx; } else { z = alloc_and_save(taskData, WORDS(lx*sizeof(mp_limb_t)), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(x)) ? xb : DEREFLIMBHANDLE(x); v = IS_INT(DEREFWORD(y)) ? yb : DEREFLIMBHANDLE(y); lu = lx; lv = ly; } mp_limb_t *w = DEREFLIMBHANDLE(z); // Do the subtraction. mp_limb_t borrow = 0; if (lv != 0) borrow = mpn_sub_n(w, u, v, lv); // Subtract the borrow from the rest of the longer number. if (lu != lv) borrow = mpn_sub_1(w+lv, u+lv, lu-lv, borrow); return make_canonical(taskData, z, sign); } #else static Handle sub_unsigned_long(TaskData *taskData, Handle x, Handle y, int sign) { byte x_extend[sizeof(PolyWord)], y_extend[sizeof(PolyWord)]; /* This is necessary so that we can discard */ /* the borrow at the end of the subtraction */ POLYUNSIGNED lx, ly; byte *xb = convertToLong(x, x_extend, &lx, NULL); byte *yb = convertToLong(y, y_extend, &ly, NULL); byte *u; /* byte-pointer alias for larger number */ byte *v; /* byte-pointer alias for smaller number */ POLYUNSIGNED lu; /* length of u in bytes */ POLYUNSIGNED lv; /* length of v in bytes */ Handle z; /* get the larger argument into ``u'' */ if (lx < ly) { sign ^= -1; // swap sign of result z = alloc_and_save(taskData, WORDS(ly+1), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(y)) ? yb : DEREFBYTEHANDLE(y); v = IS_INT(DEREFWORD(x)) ? xb : DEREFBYTEHANDLE(x); lu = ly; lv = lx; } else if (ly < lx) { z = alloc_and_save(taskData, WORDS(lx+1), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(x)) ? xb : DEREFBYTEHANDLE(x); v = IS_INT(DEREFWORD(y)) ? yb : DEREFBYTEHANDLE(y); lu = lx; lv = ly; } else /* lx == ly */ { /* Must look at the numbers to decide which is bigger. */ POLYUNSIGNED i = lx; while (i > 0 && xb[i-1] == yb[i-1]) i--; if (i == 0) return taskData->saveVec.push(TAGGED(0)); /* They are equal */ if (xb[i-1] < yb[i-1]) { sign ^= -1; /* swap sign of result SPF 21/1/94 */ z = alloc_and_save(taskData, WORDS(ly+1), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(y)) ? yb : DEREFBYTEHANDLE(y); v = IS_INT(DEREFWORD(x)) ? xb : DEREFBYTEHANDLE(x); lu = ly; lv = lx; } else { z = alloc_and_save(taskData, WORDS(lx+1), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(x)) ? xb : DEREFBYTEHANDLE(x); v = IS_INT(DEREFWORD(y)) ? yb : DEREFBYTEHANDLE(y); lu = lx; lv = ly; } } byte *w = DEREFBYTEHANDLE(z); unsigned borrow = 1; /* Becomes 0 if there is a borrow */ POLYUNSIGNED i = 0; /* Do the subtractions */ for( ; i < lv; i++) { borrow += 255 + u[i] - v[i]; w[i] = borrow & 0xff; borrow >>= 8; } /* Add the borrow into the rest of ``u''. */ for( ; i < lu; i++) { borrow += 255 + u[i]; w[i] = borrow & 0xff; borrow >>= 8; } return make_canonical(taskData, z, sign); } /* sub_unsigned_long */ #endif Handle add_longc(TaskData *taskData, Handle y, Handle x) { if (IS_INT(DEREFWORD(x)) && IS_INT(DEREFWORD(y))) { /* Both short */ /* The easiest way to do the addition is simply *x-1+*y, but that makes it more difficult to check for overflow. */ POLYSIGNED t = UNTAGGED(DEREFWORD(x)) + UNTAGGED(DEREFWORD(y)); if (t <= MAXTAGGED && t >= -MAXTAGGED-1) /* No overflow */ { return taskData->saveVec.push(TAGGED(t)); } } int sign_x, sign_y; if (IS_INT(DEREFWORD(x))) sign_x = UNTAGGED(DEREFWORD(x)) >= 0 ? 0 : -1; else sign_x = OBJ_IS_NEGATIVE(GetLengthWord(DEREFWORD(x))) ? -1 : 0; if (IS_INT(DEREFWORD(y))) sign_y = UNTAGGED(DEREFWORD(y)) >= 0 ? 0 : -1; else sign_y = OBJ_IS_NEGATIVE(GetLengthWord(DEREFWORD(y))) ? -1 : 0; /* Work out whether to add or subtract */ if ((sign_y ^ sign_x) >= 0) /* signs the same? */ /* sign(x) * (abs(x) + abs(y)) */ return add_unsigned_long(taskData, x, y, sign_x); else /* sign(x) * (abs(x) - abs(y)) */ return sub_unsigned_long(taskData, x, y, sign_x); } /* add_longc */ Handle sub_longc(TaskData *taskData, Handle y, Handle x) { if (IS_INT(DEREFWORD(x)) && IS_INT(DEREFWORD(y))) /* Both short */ { /* The easiest way to do the subtraction is simply *x-*y+1, but that makes it more difficult to check for overflow. */ POLYSIGNED t = UNTAGGED(DEREFWORD(x)) - UNTAGGED(DEREFWORD(y)); if (t <= MAXTAGGED && t >= -MAXTAGGED-1) /* No overflow */ return taskData->saveVec.push(TAGGED(t)); } int sign_x, sign_y; if (IS_INT(DEREFWORD(x))) sign_x = UNTAGGED(DEREFWORD(x)) >= 0 ? 0 : -1; else sign_x = OBJ_IS_NEGATIVE(GetLengthWord(DEREFWORD(x))) ? -1 : 0; if (IS_INT(DEREFWORD(y))) sign_y = UNTAGGED(DEREFWORD(y)) >= 0 ? 0 : -1; else sign_y = OBJ_IS_NEGATIVE(GetLengthWord(DEREFWORD(y))) ? -1 : 0; /* If the signs are different add the two values. */ if ((sign_y ^ sign_x) < 0) /* signs differ */ { /* sign(x) * (abs(x) + abs(y)) */ return add_unsigned_long(taskData, x, y, sign_x); } else { /* sign(x) * (abs(x) - abs(y)) */ return sub_unsigned_long(taskData, x, y, sign_x); } } /* sub_longc */ Handle mult_longc(TaskData *taskData, Handle y, Handle x) { int sign_x, sign_y; #if USE_GMP mp_limb_t x_extend, y_extend; mp_size_t lx, ly; (void)convertToLong(x, &x_extend, &lx, &sign_x); (void)convertToLong(y, &y_extend, &ly, &sign_y); #else byte x_extend[sizeof(PolyWord)], y_extend[sizeof(PolyWord)]; POLYUNSIGNED lx, ly; (void)convertToLong(x, x_extend, &lx, &sign_x); (void)convertToLong(y, y_extend, &ly, &sign_y); #endif // Check for zero args. if (lx == 0 || ly == 0) return taskData->saveVec.push(TAGGED(0)); #if USE_GMP Handle z = alloc_and_save(taskData, WORDS((lx+ly)*sizeof(mp_limb_t)), F_MUTABLE_BIT|F_BYTE_OBJ); mp_limb_t *w = DEREFLIMBHANDLE(z); mp_limb_t *u = IS_INT(DEREFWORD(x)) ? &x_extend : DEREFLIMBHANDLE(x); mp_limb_t *v = IS_INT(DEREFWORD(y)) ? &y_extend : DEREFLIMBHANDLE(y); // The first argument must be the longer. if (lx < ly) mpn_mul(w, v, ly, u, lx); else mpn_mul(w, u, lx, v, ly); return make_canonical(taskData, z, sign_x ^ sign_y); #else /* Get space for result */ Handle long_z = alloc_and_save(taskData, WORDS(lx+ly+1), F_MUTABLE_BIT|F_BYTE_OBJ); /* Can now load the actual addresses because they will not change now. */ byte *u = IS_INT(DEREFWORD(x)) ? x_extend : DEREFBYTEHANDLE(x); byte *v = IS_INT(DEREFWORD(y)) ? y_extend : DEREFBYTEHANDLE(y); byte *w = DEREFBYTEHANDLE(long_z); for(POLYUNSIGNED i = 0; i < lx; i++) { POLYUNSIGNED j; long r = 0; /* Set the carry to zero */ for(j = 0; j < ly; j++) { /* Compute the product. */ r += u[i] * v[j]; /* Now add in to the result. */ r += w[i+j]; w[i+j] = r & 0xff; r >>= 8; } /* Put in any carry. */ w[i+j] = (byte)r; } return make_canonical(taskData, long_z, sign_x ^ sign_y); #endif } /* mult_long */ #ifndef USE_GMP static void div_unsigned_long(byte *u, byte *v, byte *remres, byte *divres, POLYUNSIGNED lu, POLYUNSIGNED lv) // Unsigned division. This is the main divide and remainder routine. // remres must be at least lu+1 bytes long // divres must be at least lu-lv+1 bytes long but can be zero if not required { POLYUNSIGNED i,j; long r; /* Find out how far to shift v to get a 1 in the top bit. */ int bits = 0; for(r = v[lv-1]; r < 128; r <<= 1) bits++; /* 128 ??? */ /* Shift u that amount into res. We have allowed enough room for overflow. */ r = 0; for (i = 0; i < lu; i++) { r |= u[i] << bits; /*``Or in'' the new bits after shifting*/ remres[i] = r & 0xff; /* Put into the destination. */ r >>= 8; /* and shift down the carry. */ } remres[i] = (byte)r; /* Put in the carry */ /* And v that amount. It has already been copied. */ if ( bits ) { r = 0; for (i = 0; i < lv; i++) { r |= v[i] << bits; v[i] = r & 0xff; r >>= 8; } /* No carry */ } for(j = lu; j >= lv; j--) { /* j iterates over the higher digits of the dividend until we are left with a number which is less than the divisor. This is the remainder. */ long quotient, dividend, r; dividend = remres[j]*256 + remres[j-1]; quotient = (remres[j] == v[lv-1]) ? 255 : dividend/(long)v[lv-1]; if (lv != 1) { while ((long)v[lv-2]*quotient > (dividend - quotient*(long)v[lv-1])*256 + (long)remres[j-2]) { quotient--; } } /* The quotient is at most 1 too large */ /* Subtract the product of this with ``v'' from ``res''. */ r = 1; /* Initial borrow */ for(i = 0; i < lv; i++) { r += 255 + remres[j-lv+i] - quotient * v[i]; remres[j-lv+i] = r & 0xff; r >>= 8; } r += remres[j]; /* Borrow from leading digit. */ /* If we are left with a borrow when the subtraction is complete the quotient must have been too big. We add ``v'' to the dividend and subtract 1 from the quotient. */ if (r == 0 /* would be 1 if there were no borrow */) { quotient --; r = 0; for (i = 0; i < lv; i++) { r += v[i] + remres[j-lv+i]; remres[j-lv+i] = r & 0xff; r >>= 8; } } /* Place the next digit of quotient in result */ if (divres) divres[j-lv] = (byte)quotient; } /* Likewise the remainder. */ if (bits) { r = 0; j = lv; while (j > 0) { j--; r |= remres[j]; remres[j] = (r >> bits) & 0xff; r = (r & 0xff) << 8; } } } /* div_unsigned_long */ #endif // Common code for div and mod. Returns handles to the results. static void quotRem(TaskData *taskData, Handle y, Handle x, Handle &remHandle, Handle &divHandle) { if (IS_INT(DEREFWORD(x)) && IS_INT(DEREFWORD(y))) /* Both short */ { POLYSIGNED xs = UNTAGGED(DEREFWORD(x)); POLYSIGNED ys = UNTAGGED(DEREFWORD(y)); /* Raise exceptions if dividing by zero. */ if (ys == 0) raise_exception0(taskData, EXC_divide); /* Only possible overflow is minint div -1 */ if (xs != -MAXTAGGED-1 || ys != -1) { divHandle = taskData->saveVec.push(TAGGED(xs / ys)); remHandle = taskData->saveVec.push(TAGGED(xs % ys)); return; } } int sign_x, sign_y; #if USE_GMP mp_limb_t x_extend, y_extend; mp_size_t lx, ly; (void)convertToLong(x, &x_extend, &lx, &sign_x); (void)convertToLong(y, &y_extend, &ly, &sign_y); // If length of v is zero raise divideerror. if (ly == 0) raise_exception0(taskData, EXC_divide); if (lx < ly) { divHandle = taskData->saveVec.push(TAGGED(0)); remHandle = x; /* When x < y remainder is x. */ return; } Handle remRes = alloc_and_save(taskData, WORDS(ly * sizeof(mp_limb_t)), F_MUTABLE_BIT | F_BYTE_OBJ); Handle divRes = alloc_and_save(taskData, WORDS((lx - ly + 1) * sizeof(mp_limb_t)), F_MUTABLE_BIT | F_BYTE_OBJ); mp_limb_t *u = IS_INT(DEREFWORD(x)) ? &x_extend : DEREFLIMBHANDLE(x); mp_limb_t *v = IS_INT(DEREFWORD(y)) ? &y_extend : DEREFLIMBHANDLE(y); mp_limb_t *quotient = DEREFLIMBHANDLE(divRes); mp_limb_t *remainder = DEREFLIMBHANDLE(remRes); // Do the division. mpn_tdiv_qr(quotient, remainder, 0, u, lx, v, ly); // Return the results. remHandle = make_canonical(taskData, remRes, sign_x /* Same sign as dividend */); divHandle = make_canonical(taskData, divRes, sign_x ^ sign_y); #else byte x_extend[sizeof(PolyWord)], y_extend[sizeof(PolyWord)]; POLYUNSIGNED lx, ly; (void)convertToLong(x, x_extend, &lx, &sign_x); (void)convertToLong(y, y_extend, &ly, &sign_y); /* If length of y is zero raise divideerror */ if (ly == 0) raise_exception0(taskData, EXC_divide); // If the length of divisor is less than the dividend the quotient is zero. if (lx < ly) { divHandle = taskData->saveVec.push(TAGGED(0)); remHandle = x; /* When x < y remainder is x. */ return; } /* copy in case it needs shifting */ Handle longCopyHndl = alloc_and_save(taskData, WORDS(ly), F_BYTE_OBJ | F_MUTABLE_BIT); byte *u = IS_INT(DEREFWORD(y)) ? y_extend : DEREFBYTEHANDLE(y); memcpy(DEREFBYTEHANDLE(longCopyHndl), u, ly); Handle divRes = alloc_and_save(taskData, WORDS(lx-ly+1), F_MUTABLE_BIT|F_BYTE_OBJ); Handle remRes = alloc_and_save(taskData, WORDS(lx+1), F_MUTABLE_BIT|F_BYTE_OBJ); byte *long_x = IS_INT(DEREFWORD(x)) ? x_extend : DEREFBYTEHANDLE(x); div_unsigned_long (long_x, DEREFBYTEHANDLE(longCopyHndl), DEREFBYTEHANDLE(remRes), DEREFBYTEHANDLE(divRes), lx, ly); /* Clear the rest */ for(POLYUNSIGNED i=ly; i < lx+1; i++) { DEREFBYTEHANDLE(remRes)[i] = 0; } remHandle = make_canonical(taskData, remRes, sign_x /* Same sign as dividend */ ); divHandle = make_canonical(taskData, divRes, sign_x ^ sign_y); #endif } // This returns x divided by y. This always rounds towards zero so // corresponds to Int.quot in ML not Int.div. Handle div_longc(TaskData *taskData, Handle y, Handle x) { Handle remHandle, divHandle; quotRem(taskData, y, x, remHandle, divHandle); return divHandle; } Handle rem_longc(TaskData *taskData, Handle y, Handle x) { Handle remHandle, divHandle; quotRem(taskData, y, x, remHandle, divHandle); return remHandle; } #if defined(_WIN32) // Return a FILETIME from an arbitrary precision number. On both 32-bit and 64-bit Windows // this is a pair of 32-bit values. void getFileTimeFromArb(TaskData *taskData, Handle numHandle, PFILETIME ft) { Handle twoTo16 = taskData->saveVec.push(TAGGED(65536)); Handle twoTo32 = mult_longc(taskData, twoTo16, twoTo16); Handle highPart, lowPart; quotRem(taskData, twoTo32, numHandle, lowPart, highPart); ft->dwLowDateTime = get_C_unsigned(taskData, lowPart->Word()); ft->dwHighDateTime = get_C_unsigned(taskData, highPart->Word()); } #endif /* compare_unsigned is passed LONG integers only */ static int compare_unsigned(PolyWord x, PolyWord y) { #ifdef USE_GMP mp_size_t lx = numLimbs(x); mp_size_t ly = numLimbs(y); if (lx != ly) /* u > v if u longer than v */ { return (lx > ly ? 1 : -1); } return mpn_cmp((mp_limb_t *)x.AsCodePtr(), (mp_limb_t *)y.AsCodePtr(), lx); #else /* First look at the lengths */ POLYUNSIGNED lx = get_length(x); POLYUNSIGNED ly = get_length(y); if (lx != ly) /* u > v if u longer than v */ { return (lx > ly ? 1 : -1); } // Same length - look at the values. */ byte *u = x.AsCodePtr(); byte *v = y.AsCodePtr(); POLYUNSIGNED i = lx; while (i > 0) { i--; if (u[i] != v[i]) { return u[i] > v[i] ? 1 : -1; } } /* Must be equal */ return 0; #endif } int compareLong(PolyWord y, PolyWord x) { // Test if the values are bitwise equal. If either is short // this is the only case where the values could be equal. if (x == y) // Equal return 0; if (x.IsTagged()) { // x is short. if (y.IsTagged()) { // Both short. We've already tested for equality. if (x.UnTagged() < y.UnTagged()) return -1; // Less else return 1; // Greater } // y is not short. Just test the sign. If it's negative // it must be less than any short value and if it's positive // it must be greater. if (OBJ_IS_NEGATIVE(GetLengthWord(y))) return 1; // x is greater else return -1; // x is less } // x is not short if (y.IsTagged()) { // y is short. Just test the sign of x if (OBJ_IS_NEGATIVE(GetLengthWord(x))) return -1; // x is less else return 1; // x is greater } // Must both be long. We may be able to determine the result based purely on the sign bits. if (! OBJ_IS_NEGATIVE(GetLengthWord(x))) /* x is positive */ { if (! OBJ_IS_NEGATIVE(GetLengthWord(y))) /* y also positive */ { return compare_unsigned(x, y); } else /* y negative so x > y */ { return 1; } } else { /* x is negative */ if (OBJ_IS_NEGATIVE(GetLengthWord(y))) /* y also negative */ { return compare_unsigned(y, x); } else /* y positive so x < y */ { return -1; } } } /* compareLong */ /* logical_long. General purpose function for binary logical operations. */ static Handle logical_long(TaskData *taskData, Handle x, Handle y, unsigned(*op)(unsigned, unsigned)) { int signX, signY; #if USE_GMP mp_limb_t x_extend, y_extend; mp_size_t lx, ly; (void)convertToLong(x, &x_extend, &lx, &signX); (void)convertToLong(y, &y_extend, &ly, &signY); lx = lx*sizeof(mp_limb_t); // We want these in bytes ly = ly*sizeof(mp_limb_t); #else byte x_extend[sizeof(PolyWord)], y_extend[sizeof(PolyWord)]; POLYUNSIGNED lx, ly; (void)convertToLong(x, x_extend, &lx, &signX); (void)convertToLong(y, y_extend, &ly, &signY); #endif byte *u; /* byte-pointer for longer number */ byte *v; /* byte-pointer for shorter number */ Handle z; int sign, signU, signV; POLYUNSIGNED lu; /* length of u in bytes */ POLYUNSIGNED lv; /* length of v in bytes */ /* find the longer number */ /* Make ``u'' the longer. */ if (lx < ly) { // Get result vector. There can't be any carry at the end so // we just need to make this as large as the larger number. z = alloc_and_save(taskData, WORDS(ly), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(y)) ? (byte*)&y_extend : DEREFBYTEHANDLE(y); lu = ly; v = IS_INT(DEREFWORD(x)) ? (byte*)&x_extend : DEREFBYTEHANDLE(x); lv = lx; signU = signY; signV = signX; } else { /* Get result vector. */ #if USE_GMP // Add one limb z = alloc_and_save(taskData, WORDS(lx+sizeof(mp_limb_t)), F_MUTABLE_BIT|F_BYTE_OBJ); #else // Add one word. Actually we just want one more byte. z = alloc_and_save(taskData, WORDS(lx+sizeof(PolyWord)), F_MUTABLE_BIT|F_BYTE_OBJ); #endif /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(x)) ? (byte*)&x_extend : DEREFBYTEHANDLE(x); lu = lx; v = IS_INT(DEREFWORD(y)) ? (byte*)&y_extend : DEREFBYTEHANDLE(y); lv = ly; signU = signX; signV = signY; } sign = (*op)(signU, signV); /* -1 if negative, 0 if positive. */ { /* do the actual operations */ byte *w = DEREFBYTEHANDLE(z); int borrowU = 1, borrowV = 1, borrowW = 1; POLYUNSIGNED i = 0; /* Do the operations. */ for( ; i < lv; i++) { int wI; /* Have to convert negative values to twos complement. */ if (signU) borrowU += 255 - u[i]; else borrowU = u[i]; if (signV) borrowV += 255 - v[i]; else borrowV = v[i]; wI = (*op)(borrowU, borrowV) & 255; if (sign) { /* Have to convert the result back to twos complement. */ borrowW += 255 - wI; w[i] = borrowW & 255; borrowW >>= 8; } else w[i] = wI; borrowU >>= 8; borrowV >>= 8; } /* At this point the borrow of V should be zero. */ ASSERT(signV == 0 || borrowV == 0); /* Continue with ``u''. */ for( ; i < lu; i++) { int wI; if (signU) borrowU += 255 - u[i]; else borrowU = u[i]; if (signV) borrowV = 255; else borrowV = 0; wI = (*op)(borrowU, borrowV) & 255; if (sign) { /* Have to convert the result back to twos complement. */ borrowW += 255 - wI; w[i] = borrowW & 255; borrowW >>= 8; } else w[i] = wI; borrowU >>= 8; borrowV >>= 8; } /* We should now no longer have any borrows. */ ASSERT(signU == 0 || borrowU == 0); ASSERT(sign == 0 || borrowW == 0); } return make_canonical(taskData, z, sign); } /* logical_long */ static unsigned doAnd(unsigned i, unsigned j) { return i & j; } static unsigned doOr(unsigned i, unsigned j) { return i | j; } static unsigned doXor(unsigned i, unsigned j) { return i ^ j; } Handle and_longc(TaskData *taskData, Handle y, Handle x) { if (IS_INT(DEREFWORD(x)) && IS_INT(DEREFWORD(y))) /* Both short */ { /* There's no problem with overflow so we can just AND together the values. */ POLYSIGNED t = UNTAGGED(DEREFWORD(x)) & UNTAGGED(DEREFWORD(y)); return taskData->saveVec.push(TAGGED(t)); } return logical_long(taskData, x, y, doAnd); } Handle or_longc(TaskData *taskData, Handle y, Handle x) { if (IS_INT(DEREFWORD(x)) && IS_INT(DEREFWORD(y))) /* Both short */ { /* There's no problem with overflow so we can just OR together the values. */ POLYSIGNED t = UNTAGGED(DEREFWORD(x)) | UNTAGGED(DEREFWORD(y)); return taskData->saveVec.push(TAGGED(t)); } return logical_long(taskData, x, y, doOr); } Handle xor_longc(TaskData *taskData, Handle y, Handle x) { if (IS_INT(DEREFWORD(x)) && IS_INT(DEREFWORD(y))) /* Both short */ { /* There's no problem with overflow so we can just XOR together the values. */ POLYSIGNED t = UNTAGGED(DEREFWORD(x)) ^ UNTAGGED(DEREFWORD(y)); return taskData->saveVec.push(TAGGED(t)); } return logical_long(taskData, x, y, doXor); } // Convert a long precision value to floating point double get_arbitrary_precision_as_real(PolyWord x) { if (IS_INT(x)) { POLYSIGNED t = UNTAGGED(x); return (double)t; } double acc = 0; #if USE_GMP mp_limb_t *u = (mp_limb_t *)(x.AsObjPtr()); mp_size_t lx = numLimbs(x); for ( ; lx > 0; lx--) { int ll = sizeof(mp_limb_t); for ( ; ll > 0 ; ll-- ) { acc = acc * 256; } acc = acc + (double)u[lx-1]; } #else byte *u = (byte *)(x.AsObjPtr()); POLYUNSIGNED lx = OBJECT_LENGTH(x)*sizeof(PolyWord); for( ; lx > 0; lx--) { acc = acc * 256 + (double)u[lx-1]; } #endif if (OBJ_IS_NEGATIVE(GetLengthWord(x))) return -acc; else return acc; } /* Arbitrary precision GCD function. This is really included to make use of GMP's GCD function that selects an algorithm based on the length of the arguments. */ #ifdef USE_GMP Handle gcd_arbitrary(TaskData *taskData, Handle x, Handle y) { /* mpn_gcd requires that each argument is odd and its first argument must be no longer than its second. This requires shifting before the call and after the result has been returned. This code is modelled roughly on the high level mpz_gcd call in GMP. */ mp_limb_t x_extend, y_extend; int sign_x, sign_y; // Signs are ignored - the result is always positive. mp_size_t lx, ly; mp_limb_t *longX = convertToLong(x, &x_extend, &lx, &sign_x); mp_limb_t *longY = convertToLong(y, &y_extend, &ly, &sign_y); // Test for zero length and therefore zero argument if (lx == 0) { // GCD(0,y) = abs(y) if (sign_y) return neg_longc(taskData, y); else return y; } if (ly == 0) { // GCD(x,0 = abs(x) if (sign_x) return neg_longc(taskData, x); else return x; } // If one of the arguments is a single limb we can use the special case. // This doesn't require shifting. It also doesn't say that it could // overwrite the arguments. if (lx == 1 || ly == 1) { mp_limb_t g = (lx == 1) ? mpn_gcd_1(longY, ly, *longX) : mpn_gcd_1(longX, lx, *longY); if (g <= MAXTAGGED) return taskData->saveVec.push(TAGGED(g)); // Need to allocate space. Handle r = alloc_and_save(taskData, WORDS(sizeof(mp_limb_t)), F_BYTE_OBJ); *(DEREFLIMBHANDLE(r)) = g; return r; } // Memory for result. This can be up to the shorter of the two. // We rely on this zero the memory because we may not set every word here. Handle r = alloc_and_save(taskData, WORDS((lx < ly ? lx : ly)*sizeof(mp_limb_t)), F_BYTE_OBJ|F_MUTABLE_BIT); // Can now dereference the handles. mp_limb_t *xl = IS_INT(DEREFWORD(x)) ? &x_extend : DEREFLIMBHANDLE(x); mp_limb_t *yl = IS_INT(DEREFWORD(y)) ? &y_extend : DEREFLIMBHANDLE(y); mp_limb_t *rl = DEREFLIMBHANDLE(r); unsigned xZeroLimbs = 0, xZeroBits = 0; // Remove whole limbs of zeros. There must be a word which is non-zero. while (*xl == 0) { xl++; xZeroLimbs++; lx--; } // Count the low-order bits and shift by that amount. mp_limb_t t = *xl; while ((t & 1) == 0) { t = t >> 1; xZeroBits++; } // Copy the non-zero limbs into a temporary, shifting if necessary. mp_limb_t *xC = (mp_limb_t*)alloca(lx * sizeof(mp_limb_t)); if (xZeroBits != 0) { mpn_rshift(xC, xl, lx, xZeroBits); if (xC[lx-1] == 0) lx--; } else memcpy(xC, xl, lx * sizeof(mp_limb_t)); unsigned yZeroLimbs = 0, yZeroBits = 0; while (*yl == 0) { yl++; yZeroLimbs++; ly--; } t = *yl; while ((t & 1) == 0) { t = t >> 1; yZeroBits++; } mp_limb_t *yC = (mp_limb_t*)alloca(ly * sizeof(mp_limb_t)); if (yZeroBits != 0) { mpn_rshift(yC, yl, ly, yZeroBits); if (yC[ly-1] == 0) ly--; } else memcpy(yC, yl, ly * sizeof(mp_limb_t)); // The result length and shift is the smaller of these unsigned rZeroLimbs, rZeroBits; if (xZeroLimbs < yZeroLimbs || (xZeroLimbs == yZeroLimbs && xZeroBits < yZeroBits)) { rZeroLimbs = xZeroLimbs; rZeroBits = xZeroBits; } else { rZeroLimbs = yZeroLimbs; rZeroBits = yZeroBits; } // Now actually compute the GCD if (lx < ly || (lx == ly && xC[lx-1] < yC[ly-1])) lx = mpn_gcd(xC, yC, ly, xC, lx); else lx = mpn_gcd(xC, xC, lx, yC, ly); // Shift the temporary result into the final area. if (rZeroBits != 0) { t = mpn_lshift(rl+rZeroLimbs, xC, lx, rZeroBits); if (t != 0) rl[rZeroLimbs+lx] = t; } else memcpy(rl+rZeroLimbs, xC, lx * sizeof(mp_limb_t)); return make_canonical(taskData, r, false); } #else // Fallback version for when GMP is not defined. static Handle gxd(TaskData *taskData, Handle x, Handle y) { Handle marker = taskData->saveVec.mark(); while (1) { if (DEREFWORD(y) == TAGGED(0)) return x; Handle res = rem_longc(taskData, y, x); PolyWord newY = res->Word(); PolyWord newX = y->Word(); taskData->saveVec.reset(marker); y = taskData->saveVec.push(newY); x = taskData->saveVec.push(newX); } } static Handle absValue(TaskData *taskData, Handle x) { if (IS_INT(DEREFWORD(x))) { if (UNTAGGED(DEREFWORD(x)) < 0) return neg_longc(taskData, x); } else if (OBJ_IS_NEGATIVE(GetLengthWord(DEREFWORD(x)))) return neg_longc(taskData, x); return x; } Handle gcd_arbitrary(TaskData *taskData, Handle x, Handle y) { x = absValue(taskData, x); y = absValue(taskData, y); if (compareLong(y->Word(), x->Word()) < 0) return gxd(taskData, y, x); else return gxd(taskData, x, y); } #endif // This is provided as an adjunct to GCD. Using this saves the RTS // calls necessary for the division and multiplication. Handle lcm_arbitrary(TaskData *taskData, Handle x, Handle y) { Handle g = gcd_arbitrary(taskData, x, y); return mult_longc(taskData, x, div_longc(taskData, g, y)); } -POLYUNSIGNED PolyAddArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyAddArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { // Could raise an exception if out of memory. result = add_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolySubtractArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolySubtractArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { result = sub_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyMultiplyArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyMultiplyArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { result = mult_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyDivideArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyDivideArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { // May raise divide exception result = div_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyRemainderArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyRemainderArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { result = rem_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // This is the older version that took a container as an argument. -POLYUNSIGNED PolyQuotRemArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3) +POLYUNSIGNED PolyQuotRemArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); // arg3 is an address on the stack. It is not a PolyWord. if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { // The result handle will almost certainly point into the stack. // This should now be safe within the GC. Handle remHandle, divHandle; quotRem(taskData, pushedArg2, pushedArg1, remHandle, divHandle); arg3.AsObjPtr()->Set(0, divHandle->Word()); arg3.AsObjPtr()->Set(1, remHandle->Word()); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); return 0; // Result is unit } // This is the newer version that returns a pair. It's simpler and works with 32-in-64. -POLYUNSIGNED PolyQuotRemArbitraryPair(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyQuotRemArbitraryPair(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; // arg3 is an address on the stack. It is not a PolyWord. if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { // The result handle will almost certainly point into the stack. // This should now be safe within the GC. Handle remHandle, divHandle; quotRem(taskData, pushedArg2, pushedArg1, remHandle, divHandle); result = alloc_and_save(taskData, 2); result->WordP()->Set(0, divHandle->Word()); result->WordP()->Set(1, remHandle->Word()); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // This can be a fast call. It does not need to allocate or use handles. POLYSIGNED PolyCompareArbitrary(PolyWord arg1, PolyWord arg2) { return TAGGED(compareLong(arg2, arg1)).AsSigned(); } -POLYUNSIGNED PolyGCDArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyGCDArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; try { result = gcd_arbitrary(taskData, pushedArg2, pushedArg1); // Generally shouldn't raise an exception but might run out of store. } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyLCMArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyLCMArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; try { result = lcm_arbitrary(taskData, pushedArg2, pushedArg1); // Generally shouldn't raise an exception but might run out of store. } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Extract the low order part of an arbitrary precision value as a boxed LargeWord.word // value. If the value is negative it is treated as a twos complement value. // This is used Word.fromLargeInt and LargeWord.fromLargeInt with long-form // arbitrary precision values. -POLYUNSIGNED PolyGetLowOrderAsLargeWord(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyGetLowOrderAsLargeWord(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); uintptr_t p = 0; if (arg.IsTagged()) p = arg.UnTagged(); else { bool negative = OBJ_IS_NEGATIVE(GetLengthWord(arg)) ? true : false; #ifdef USE_GMP mp_limb_t c = *(mp_limb_t*)arg.AsCodePtr(); p = c; #else POLYUNSIGNED length = get_length(arg); if (length > sizeof(uintptr_t)) length = sizeof(uintptr_t); byte *ptr = arg.AsCodePtr(); while (length--) { p = (p << 8) | ptr[length]; } #endif if (negative) p = 0-p; } Handle result = 0; try { result = Make_sysword(taskData, p); } catch (...) {} // We could run out of memory. taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyOrArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyOrArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; try { // Could raise an exception if out of memory. result = or_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyAndArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyAndArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; try { // Could raise an exception if out of memory. result = and_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyXorArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyXorArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; try { // Could raise an exception if out of memory. result = xor_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } struct _entrypts arbitraryPrecisionEPT[] = { { "PolyAddArbitrary", (polyRTSFunction)&PolyAddArbitrary}, { "PolySubtractArbitrary", (polyRTSFunction)&PolySubtractArbitrary}, { "PolyMultiplyArbitrary", (polyRTSFunction)&PolyMultiplyArbitrary}, { "PolyDivideArbitrary", (polyRTSFunction)&PolyDivideArbitrary}, { "PolyRemainderArbitrary", (polyRTSFunction)&PolyRemainderArbitrary}, { "PolyQuotRemArbitrary", (polyRTSFunction)&PolyQuotRemArbitrary}, { "PolyQuotRemArbitraryPair", (polyRTSFunction)&PolyQuotRemArbitraryPair }, { "PolyCompareArbitrary", (polyRTSFunction)&PolyCompareArbitrary}, { "PolyGCDArbitrary", (polyRTSFunction)&PolyGCDArbitrary}, { "PolyLCMArbitrary", (polyRTSFunction)&PolyLCMArbitrary}, { "PolyGetLowOrderAsLargeWord", (polyRTSFunction)&PolyGetLowOrderAsLargeWord}, { "PolyOrArbitrary", (polyRTSFunction)&PolyOrArbitrary}, { "PolyAndArbitrary", (polyRTSFunction)&PolyAndArbitrary}, { "PolyXorArbitrary", (polyRTSFunction)&PolyXorArbitrary}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/basicio.cpp b/libpolyml/basicio.cpp index 09db46b6..93be528a 100644 --- a/libpolyml/basicio.cpp +++ b/libpolyml/basicio.cpp @@ -1,1151 +1,1124 @@ /* Title: Basic IO. Copyright (c) 2000, 2015-2019 David C. J. Matthews Portions of this code are derived from the original stream io package copyright CUTS 1983-2000. 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 */ /* This module replaces the old stream IO based on stdio. It works at a lower level with the buffering being done in ML. Sockets are generally dealt with in network.c but it is convenient to use the same table for them particularly since it simplifies the implementation of "poll". Directory operations are also included in here. DCJM May 2000. */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_STAT_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_SIGNAL_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_ALLOCA_H #include #endif #ifdef HAVE_IO_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_SYS_IOCTL_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_POLL_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_SYS_SELECT_H #include #endif #ifdef HAVE_MALLOC_H #include #endif #ifdef HAVE_DIRECT_H #include #endif #ifdef HAVE_STDIO_H #include #endif #include #ifndef INFTIM #define INFTIM (-1) #endif #ifdef HAVE_DIRENT_H # include # define NAMLEN(dirent) strlen((dirent)->d_name) #else # define dirent direct # define NAMLEN(dirent) (dirent)->d_namlen # if HAVE_SYS_NDIR_H # include # endif # if HAVE_SYS_DIR_H # include # endif # if HAVE_NDIR_H # include # endif #endif #include "globals.h" #include "basicio.h" #include "sys.h" #include "gc.h" #include "run_time.h" #include "machine_dep.h" #include "arb.h" #include "processes.h" #include "diagnostics.h" #include "io_internal.h" #include "scanaddrs.h" #include "polystring.h" #include "mpoly.h" #include "save_vec.h" #include "rts_module.h" #include "locking.h" #include "rtsentry.h" #include "timing.h" #define TOOMANYFILES EMFILE #define NOMEMORY ENOMEM #define STREAMCLOSED EBADF #define FILEDOESNOTEXIST ENOENT #define ERRORNUMBER errno #ifndef O_ACCMODE #define O_ACCMODE (O_RDONLY|O_RDWR|O_WRONLY) #endif #define SAVE(x) taskData->saveVec.push(x) #ifdef _MSC_VER // Don't tell me about ISO C++ changes. #pragma warning(disable:4996) #endif extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyChDir(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyBasicIOGeneral(PolyObject *threadId, PolyWord code, PolyWord strm, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyPosixCreatePersistentFD(PolyObject *threadId, PolyWord fd); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyChDir(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyBasicIOGeneral(FirstArgument threadId, PolyWord code, PolyWord strm, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(FirstArgument threadId, PolyWord streamVec, PolyWord bitVec, PolyWord maxMillisecs); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyPosixCreatePersistentFD(FirstArgument threadId, PolyWord fd); } static bool isAvailable(TaskData *taskData, int ioDesc) { #ifdef __CYGWIN__ static struct timeval poll = {0,1}; #else static struct timeval poll = {0,0}; #endif fd_set read_fds; int selRes; FD_ZERO(&read_fds); FD_SET(ioDesc, &read_fds); /* If there is something there we can return. */ selRes = select(FD_SETSIZE, &read_fds, NULL, NULL, &poll); if (selRes > 0) return true; /* Something waiting. */ else if (selRes < 0 && errno != EINTR) // Maybe another thread closed descr raise_syscall(taskData, "select error", ERRORNUMBER); else return false; } // The strm argument is a volatile word containing the descriptor. // Volatiles are set to zero on entry to indicate a closed descriptor. // Zero is a valid descriptor but -1 is not so we add 1 when storing and // subtract 1 when loading. // N.B. There are also persistent descriptors created with PolyPosixCreatePersistentFD Handle wrapFileDescriptor(TaskData *taskData, int fd) { return MakeVolatileWord(taskData, fd+1); } // Return a file descriptor or -1 if it is invalid. int getStreamFileDescriptorWithoutCheck(PolyWord strm) { return *(intptr_t*)(strm.AsObjPtr()) -1; } // Most of the time we want to raise an exception if the file descriptor // has been closed although this could be left to the system call. int getStreamFileDescriptor(TaskData *taskData, PolyWord strm) { int descr = getStreamFileDescriptorWithoutCheck(strm); if (descr == -1) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); return descr; } /* Open a file in the required mode. */ static Handle open_file(TaskData *taskData, Handle filename, int mode, int access, int isPosix) { while (true) // Repeat only with certain kinds of errors { TempString cFileName(filename->Word()); // Get file name if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); int stream = open(cFileName, mode, access); if (stream >= 0) { if (! isPosix) { /* Set the close-on-exec flag. We don't set this if we are being called from one of the low level functions in the Posix structure. I assume that if someone is using those functions they know what they're doing and would expect the behaviour to be close to that of the underlying function. */ fcntl(stream, F_SETFD, 1); } return wrapFileDescriptor(taskData, stream); } switch (errno) { case EINTR: // Just try the call. Is it possible to block here indefinitely? continue; default: raise_syscall(taskData, "Cannot open", ERRORNUMBER); /*NOTREACHED*/ return 0; } } } /* Close the stream unless it is stdin or stdout or already closed. */ static Handle close_file(TaskData *taskData, Handle stream) { int descr = getStreamFileDescriptorWithoutCheck(stream->Word()); // Don't close it if it's already closed or any of the standard streams if (descr > 2) { close(descr); *(intptr_t*)(stream->WordP()) = 0; // Mark as closed } return Make_fixed_precision(taskData, 0); } static void waitForAvailableInput(TaskData *taskData, Handle stream) { int fd = getStreamFileDescriptor(taskData, stream->Word()); while (!isAvailable(taskData, fd)) { WaitInputFD waiter(fd); processes->ThreadPauseForIO(taskData, &waiter); } } /* Read into an array. */ // We can't combine readArray and readString because we mustn't compute the // destination of the data in readArray until after any GC. static Handle readArray(TaskData *taskData, Handle stream, Handle args, bool/*isText*/) { /* The isText argument is ignored in both Unix and Windows but is provided for future use. Windows remembers the mode used when the file was opened to determine whether to translate CRLF into LF. */ // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); while (1) // Loop if interrupted. { // First test to see if we have input available. // These tests may result in a GC if another thread is running. // First test to see if we have input available. // These tests may result in a GC if another thread is running. waitForAvailableInput(taskData, stream); // We can now try to read without blocking. // Actually there's a race here in the unlikely situation that there // are multiple threads sharing the same low-level reader. They could // both detect that input is available but only one may succeed in // reading without blocking. This doesn't apply where the threads use // the higher-level IO interfaces in ML which have their own mutexes. int fd = getStreamFileDescriptor(taskData, stream->Word()); byte *base = DEREFHANDLE(args)->Get(0).AsObjPtr()->AsBytePtr(); POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(1)); size_t length = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(2)); ssize_t haveRead = read(fd, base + offset, length); if (haveRead >= 0) return Make_fixed_precision(taskData, haveRead); // Success. // If it failed because it was interrupted keep trying otherwise it's an error. if (errno != EINTR) raise_syscall(taskData, "Error while reading", ERRORNUMBER); } } /* Return input as a string. We don't actually need both readArray and readString but it's useful to have both to reduce unnecessary garbage. The IO library will construct one from the other but the higher levels choose the appropriate function depending on need. */ static Handle readString(TaskData *taskData, Handle stream, Handle args, bool/*isText*/) { size_t length = getPolyUnsigned(taskData, DEREFWORD(args)); // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); while (1) // Loop if interrupted. { // First test to see if we have input available. // These tests may result in a GC if another thread is running. waitForAvailableInput(taskData, stream); // We can now try to read without blocking. int fd = getStreamFileDescriptor(taskData, stream->Word()); // We previously allocated the buffer on the stack but that caused // problems with multi-threading at least on Mac OS X because of // stack exhaustion. We limit the space to 100k. */ if (length > 102400) length = 102400; byte *buff = (byte*)malloc(length); if (buff == 0) raise_syscall(taskData, "Unable to allocate buffer", NOMEMORY); ssize_t haveRead = read(fd, buff, length); if (haveRead >= 0) { Handle result = SAVE(C_string_to_Poly(taskData, (char*)buff, haveRead)); free(buff); return result; } free(buff); // If it failed because it was interrupted keep trying otherwise it's an error. if (errno != EINTR) raise_syscall(taskData, "Error while reading", ERRORNUMBER); } } static Handle writeArray(TaskData *taskData, Handle stream, Handle args, bool/*isText*/) { /* The isText argument is ignored in both Unix and Windows but is provided for future use. Windows remembers the mode used when the file was opened to determine whether to translate LF into CRLF. */ PolyWord base = DEREFWORDHANDLE(args)->Get(0); POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(1)); size_t length = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(2)); int fd = getStreamFileDescriptor(taskData, stream->Word()); /* We don't actually handle cases of blocking on output. */ byte *toWrite = base.AsObjPtr()->AsBytePtr(); ssize_t haveWritten = write(fd, toWrite+offset, length); if (haveWritten < 0) raise_syscall(taskData, "Error while writing", ERRORNUMBER); return Make_fixed_precision(taskData, haveWritten); } // Test whether we can write without blocking. Returns false if it will block, // true if it will not. static bool canOutput(TaskData *taskData, Handle stream) { int fd = getStreamFileDescriptor(taskData, stream->Word()); /* Unix - use "select" to find out if output is possible. */ #ifdef __CYGWIN__ static struct timeval poll = {0,1}; #else static struct timeval poll = {0,0}; #endif fd_set read_fds, write_fds, except_fds; int sel; FD_ZERO(&read_fds); FD_ZERO(&write_fds); FD_ZERO(&except_fds); FD_SET(fd, &write_fds); sel = select(FD_SETSIZE,&read_fds,&write_fds,&except_fds,&poll); if (sel < 0 && errno != EINTR) raise_syscall(taskData, "select failed", ERRORNUMBER); return sel > 0; } static long seekStream(TaskData *taskData, int fd, long pos, int origin) { long lpos = lseek(fd, pos, origin); if (lpos < 0) raise_syscall(taskData, "Position error", ERRORNUMBER); return lpos; } /* Return the number of bytes available on the device. Works only for files since it is meaningless for other devices. */ static Handle bytesAvailable(TaskData *taskData, Handle stream) { int fd = getStreamFileDescriptor(taskData, stream->Word()); /* Remember our original position, seek to the end, then seek back. */ long original = seekStream(taskData, fd, 0L, SEEK_CUR); long endOfStream = seekStream(taskData, fd, 0L, SEEK_END); if (seekStream(taskData, fd, original, SEEK_SET) != original) raise_syscall(taskData, "Position error", ERRORNUMBER); return Make_fixed_precision(taskData, endOfStream-original); } static Handle fileKind(TaskData *taskData, Handle stream) { int fd = getStreamFileDescriptor(taskData, stream->Word()); struct stat statBuff; if (fstat(fd, &statBuff) < 0) raise_syscall(taskData, "Stat failed", ERRORNUMBER); switch (statBuff.st_mode & S_IFMT) { case S_IFIFO: return Make_fixed_precision(taskData, FILEKIND_PIPE); case S_IFCHR: case S_IFBLK: if (isatty(fd)) return Make_fixed_precision(taskData, FILEKIND_TTY); else return Make_fixed_precision(taskData, FILEKIND_DEV); case S_IFDIR: return Make_fixed_precision(taskData, FILEKIND_DIR); case S_IFREG: return Make_fixed_precision(taskData, FILEKIND_FILE); case S_IFLNK: return Make_fixed_precision(taskData, FILEKIND_LINK); case S_IFSOCK: return Make_fixed_precision(taskData, FILEKIND_SKT); default: return Make_fixed_precision(taskData, -1); } } /* Find out what polling options, if any, are allowed on this file descriptor. We assume that polling is allowed on all descriptors, either for reading or writing depending on how the stream was opened. */ Handle pollTest(TaskData *taskData, Handle stream) { // How do we test this? Assume all of them. return Make_fixed_precision(taskData, POLL_BIT_IN|POLL_BIT_OUT|POLL_BIT_PRI); } // Do the polling. Takes a vector of io descriptors, a vector of bits to test // and a time to wait and returns a vector of results. class WaitPoll: public Waiter{ public: WaitPoll(POLYUNSIGNED nDesc, struct pollfd *fds, unsigned maxMillisecs); virtual void Wait(unsigned maxMillisecs); int PollResult(void) { return pollResult; } int PollError(void) { return errorResult; } private: int pollResult; int errorResult; unsigned maxTime; struct pollfd *fdVec; POLYUNSIGNED nDescr; }; WaitPoll::WaitPoll(POLYUNSIGNED nDesc, struct pollfd *fds, unsigned maxMillisecs) { maxTime = maxMillisecs; pollResult = 0; errorResult = 0; nDescr = nDesc; fdVec = fds; } void WaitPoll::Wait(unsigned maxMillisecs) { if (nDescr == 0) pollResult = 0; else { if (maxTime < maxMillisecs) maxMillisecs = maxTime; pollResult = poll(fdVec, nDescr, maxMillisecs); if (pollResult < 0) errorResult = ERRORNUMBER; } } -static Handle pollDescriptors(TaskData *taskData, Handle args, int blockType) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(FirstArgument threadId, PolyWord streamVector, PolyWord bitVector, PolyWord maxMillisecs) { - Handle hSave = taskData->saveVec.mark(); - PolyObject *strmVec = DEREFHANDLE(args)->Get(0).AsObjPtr(); - PolyObject *bitVec = DEREFHANDLE(args)->Get(1).AsObjPtr(); - POLYUNSIGNED nDesc = strmVec->Length(); - ASSERT(nDesc == bitVec->Length()); + TaskData *taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + POLYUNSIGNED maxMilliseconds = maxMillisecs.UnTaggedUnsigned(); + Handle result = 0; + + try { + PolyObject *strmVec = streamVector.AsObjPtr(); + PolyObject *bitVec = bitVector.AsObjPtr(); + POLYUNSIGNED nDesc = strmVec->Length(); + ASSERT(nDesc == bitVec->Length()); - while (1) // Until timeout or we get a result. - { struct pollfd * fds = 0; - unsigned maxMillisecs = 1000; - // Set the wait time. This code is almost the same as selectCall in network.cpp. - switch (blockType) - { - case 0: - { - struct timeval tvTime, tvNow; - /* We have a value in microseconds. We need to split - it into seconds and microseconds. */ - Handle hTime = SAVE(DEREFWORDHANDLE(args)->Get(2)); - Handle hMillion = Make_arbitrary_precision(taskData, 1000000); - tvTime.tv_sec = - get_C_ulong(taskData, DEREFWORD(div_longc(taskData, hMillion, hTime))); - tvTime.tv_usec = - get_C_ulong(taskData, DEREFWORD(rem_longc(taskData, hMillion, hTime))); - // If the timeout time is earlier than the current time we just poll - // otherwise we block for up to a second. - if (gettimeofday(&tvNow, NULL) != 0) - raise_syscall(taskData, "gettimeofday failed", errno); - if (tvNow.tv_sec > tvTime.tv_sec || (tvNow.tv_sec == tvTime.tv_sec && tvNow.tv_usec >= tvTime.tv_usec)) - maxMillisecs = 0; - else - { - subTimevals(&tvTime, &tvNow); - if (tvTime.tv_sec >= 1) maxMillisecs = 1000; // Don't overflow if it's very long - else maxMillisecs = tvTime.tv_usec / 1000; - } - break; - } - case 1: /* Block until one of the descriptors is ready. */ - maxMillisecs = 1000; // Max 1 second - break; - case 2: // Just a simple poll - maxMillisecs = 0; - break; - } if (nDesc > 0) fds = (struct pollfd *)alloca(nDesc * sizeof(struct pollfd)); - + /* Set up the request vector. */ for (unsigned i = 0; i < nDesc; i++) { fds[i].fd = getStreamFileDescriptor(taskData, strmVec->Get(i)); POLYUNSIGNED bits = UNTAGGED(bitVec->Get(i)); fds[i].events = 0; if (bits & POLL_BIT_IN) fds[i].events |= POLLIN; /* | POLLRDNORM??*/ if (bits & POLL_BIT_OUT) fds[i].events |= POLLOUT; if (bits & POLL_BIT_PRI) fds[i].events |= POLLPRI; fds[i].revents = 0; } // Poll the descriptors. - WaitPoll pollWait(nDesc, fds, maxMillisecs); + WaitPoll pollWait(nDesc, fds, maxMilliseconds); processes->ThreadPauseForIO(taskData, &pollWait); if (pollWait.PollResult() < 0) raise_syscall(taskData, "poll failed", pollWait.PollError()); - else if (pollWait.PollResult() > 0 || maxMillisecs == 0) + // Construct the result vectors. + result = alloc_and_save(taskData, nDesc); + for (unsigned i = 0; i < nDesc; i++) { - // There was a result or the time expired or it was just a poll. - // Construct the result vectors. - Handle resVec = alloc_and_save(taskData, nDesc); - for (unsigned i = 0; i < nDesc; i++) - { - int res = 0; - if (fds[i].revents & POLLIN) res = POLL_BIT_IN; - if (fds[i].revents & POLLOUT) res = POLL_BIT_OUT; - if (fds[i].revents & POLLPRI) res = POLL_BIT_PRI; - DEREFWORDHANDLE(resVec)->Set(i, TAGGED(res)); - } - return resVec; + int res = 0; + if (fds[i].revents & POLLIN) res = POLL_BIT_IN; + if (fds[i].revents & POLLOUT) res = POLL_BIT_OUT; + if (fds[i].revents & POLLPRI) res = POLL_BIT_PRI; + DEREFWORDHANDLE(result)->Set(i, TAGGED(res)); } - // else try again. - taskData->saveVec.reset(hSave); } + catch (KillException &) { + processes->ThreadExit(taskData); // TestAnyEvents may test for kill + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); } // Directory functions. static Handle openDirectory(TaskData *taskData, Handle dirname) { TempString dirName(dirname->Word()); if (dirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); while (1) { DIR *dirp = opendir(dirName); if (dirp != NULL) return MakeVolatileWord(taskData, dirp); switch (errno) { case EINTR: continue; // Just retry the call. default: raise_syscall(taskData, "opendir failed", ERRORNUMBER); } } } /* Return the next entry from the directory, ignoring current and parent arcs ("." and ".." in Windows and Unix) */ Handle readDirectory(TaskData *taskData, Handle stream) { DIR *pDir = *(DIR**)(stream->WordP()); // In a Volatile if (pDir == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); while (1) { struct dirent *dp = readdir(pDir); int len; if (dp == NULL) return taskData->saveVec.push(EmptyString(taskData)); len = NAMLEN(dp); if (!((len == 1 && strncmp(dp->d_name, ".", 1) == 0) || (len == 2 && strncmp(dp->d_name, "..", 2) == 0))) return SAVE(C_string_to_Poly(taskData, dp->d_name, len)); } } Handle rewindDirectory(TaskData *taskData, Handle stream, Handle dirname) { DIR *pDir = *(DIR**)(stream->WordP()); // In a Volatile if (pDir == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); rewinddir(pDir); return Make_fixed_precision(taskData, 0); } static Handle closeDirectory(TaskData *taskData, Handle stream) { DIR *pDir = *(DIR**)(stream->WordP()); // In a SysWord if (pDir != 0) { closedir(pDir); *((DIR**)stream->WordP()) = 0; // Clear this - no longer valid } return Make_fixed_precision(taskData, 0); } /* change_dirc - this is called directly and not via the dispatch function. */ static Handle change_dirc(TaskData *taskData, Handle name) /* Change working directory. */ { TempString cDirName(name->Word()); if (cDirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (chdir(cDirName) != 0) raise_syscall(taskData, "chdir failed", ERRORNUMBER); return SAVE(TAGGED(0)); } // External call -POLYUNSIGNED PolyChDir(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyChDir(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); try { (void)change_dirc(taskData, pushedArg); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); // Result is unit } /* Test for a directory. */ Handle isDir(TaskData *taskData, Handle name) { TempString cDirName(name->Word()); if (cDirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); struct stat fbuff; if (stat(cDirName, &fbuff) != 0) raise_syscall(taskData, "stat failed", ERRORNUMBER); if ((fbuff.st_mode & S_IFMT) == S_IFDIR) return Make_fixed_precision(taskData, 1); else return Make_fixed_precision(taskData, 0); } /* Get absolute canonical path name. */ Handle fullPath(TaskData *taskData, Handle filename) { TempString cFileName; /* Special case of an empty string. */ if (PolyStringLength(filename->Word()) == 0) cFileName = strdup("."); else cFileName = Poly_string_to_C_alloc(filename->Word()); if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); TempCString resBuf(realpath(cFileName, NULL)); if (resBuf == NULL) raise_syscall(taskData, "realpath failed", ERRORNUMBER); /* Some versions of Unix don't check the final component of a file. To be consistent try doing a "stat" of the resulting string to check it exists. */ struct stat fbuff; if (stat(resBuf, &fbuff) != 0) raise_syscall(taskData, "stat failed", ERRORNUMBER); return(SAVE(C_string_to_Poly(taskData, resBuf))); } /* Get file modification time. This returns the value in the time units and from the base date used by timing.c. c.f. filedatec */ Handle modTime(TaskData *taskData, Handle filename) { TempString cFileName(filename->Word()); if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); struct stat fbuff; if (stat(cFileName, &fbuff) != 0) raise_syscall(taskData, "stat failed", ERRORNUMBER); /* Convert to microseconds. */ return Make_arb_from_pair_scaled(taskData, STAT_SECS(&fbuff,m), STAT_USECS(&fbuff,m), 1000000); } /* Get file size. */ Handle fileSize(TaskData *taskData, Handle filename) { TempString cFileName(filename->Word()); if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); struct stat fbuff; if (stat(cFileName, &fbuff) != 0) raise_syscall(taskData, "stat failed", ERRORNUMBER); return Make_arbitrary_precision(taskData, fbuff.st_size); } /* Set file modification and access times. */ Handle setTime(TaskData *taskData, Handle fileName, Handle fileTime) { TempString cFileName(fileName->Word()); if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); struct timeval times[2]; /* We have a value in microseconds. We need to split it into seconds and microseconds. */ Handle hTime = fileTime; Handle hMillion = Make_arbitrary_precision(taskData, 1000000); /* N.B. Arguments to div_longc and rem_longc are in reverse order. */ unsigned secs = get_C_ulong(taskData, DEREFWORD(div_longc(taskData, hMillion, hTime))); unsigned usecs = get_C_ulong(taskData, DEREFWORD(rem_longc(taskData, hMillion, hTime))); times[0].tv_sec = times[1].tv_sec = secs; times[0].tv_usec = times[1].tv_usec = usecs; if (utimes(cFileName, times) != 0) raise_syscall(taskData, "utimes failed", ERRORNUMBER); return Make_fixed_precision(taskData, 0); } /* Rename a file. */ Handle renameFile(TaskData *taskData, Handle oldFileName, Handle newFileName) { TempString oldName(oldFileName->Word()), newName(newFileName->Word()); if (oldName == 0 || newName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (rename(oldName, newName) != 0) raise_syscall(taskData, "rename failed", ERRORNUMBER); return Make_fixed_precision(taskData, 0); } /* Access right requests passed in from ML. */ #define FILE_ACCESS_READ 1 #define FILE_ACCESS_WRITE 2 #define FILE_ACCESS_EXECUTE 4 /* Get access rights to a file. */ Handle fileAccess(TaskData *taskData, Handle name, Handle rights) { TempString fileName(name->Word()); if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); int rts = get_C_int(taskData, DEREFWORD(rights)); int mode = 0; if (rts & FILE_ACCESS_READ) mode |= R_OK; if (rts & FILE_ACCESS_WRITE) mode |= W_OK; if (rts & FILE_ACCESS_EXECUTE) mode |= X_OK; if (mode == 0) mode = F_OK; /* Return true if access is allowed, otherwise false for any other error. */ if (access(fileName, mode) == 0) return Make_fixed_precision(taskData, 1); else return Make_fixed_precision(taskData, 0); } /* IO_dispatchc. Called from assembly code module. */ static Handle IO_dispatch_c(TaskData *taskData, Handle args, Handle strm, Handle code) { unsigned c = get_C_unsigned(taskData, DEREFWORD(code)); switch (c) { case 0: /* Return standard input */ return wrapFileDescriptor(taskData, 0); case 1: /* Return standard output */ return wrapFileDescriptor(taskData, 1); case 2: /* Return standard error */ return wrapFileDescriptor(taskData, 2); case 3: /* Open file for text input. */ case 4: /* Open file for binary input. */ return open_file(taskData, args, O_RDONLY, 0666, 0); case 5: /* Open file for text output. */ case 6: /* Open file for binary output. */ return open_file(taskData, args, O_WRONLY | O_CREAT | O_TRUNC, 0666, 0); case 7: /* Close file */ return close_file(taskData, strm); case 8: /* Read text into an array. */ return readArray(taskData, strm, args, true); case 9: /* Read binary into an array. */ return readArray(taskData, strm, args, false); case 10: /* Get text as a string. */ return readString(taskData, strm, args, true); case 11: /* Write from memory into a text file. */ return writeArray(taskData, strm, args, true); case 12: /* Write from memory into a binary file. */ return writeArray(taskData, strm, args, false); case 13: /* Open text file for appending. */ /* The IO library definition leaves it open whether this should use "append mode" or not. */ case 14: /* Open binary file for appending. */ return open_file(taskData, args, O_WRONLY | O_CREAT | O_APPEND, 0666, 0); case 15: /* Return recommended buffer size. */ // This is a guess but 4k seems reasonable. return Make_fixed_precision(taskData, 4096); case 16: /* See if we can get some input. */ { int fd = getStreamFileDescriptor(taskData, strm->Word()); return Make_fixed_precision(taskData, isAvailable(taskData, fd) ? 1 : 0); } case 17: /* Return the number of bytes available. */ return bytesAvailable(taskData, strm); case 18: /* Get position on stream. */ { /* Get the current position in the stream. This is used to test for the availability of random access so it should raise an exception if setFilePos or endFilePos would fail. */ int fd = getStreamFileDescriptor(taskData, strm->Word()); long pos = seekStream(taskData, fd, 0L, SEEK_CUR); return Make_arbitrary_precision(taskData, pos); } case 19: /* Seek to position on stream. */ { long position = (long)get_C_long(taskData, DEREFWORD(args)); int fd = getStreamFileDescriptor(taskData, strm->Word()); (void)seekStream(taskData, fd, position, SEEK_SET); return Make_arbitrary_precision(taskData, 0); } case 20: /* Return position at end of stream. */ { int fd = getStreamFileDescriptor(taskData, strm->Word()); /* Remember our original position, seek to the end, then seek back. */ long original = seekStream(taskData, fd, 0L, SEEK_CUR); long endOfStream = seekStream(taskData, fd, 0L, SEEK_END); if (seekStream(taskData, fd, original, SEEK_SET) != original) raise_syscall(taskData, "Position error", ERRORNUMBER); return Make_arbitrary_precision(taskData, endOfStream); } case 21: /* Get the kind of device underlying the stream. */ return fileKind(taskData, strm); case 22: /* Return the polling options allowed on this descriptor. */ return pollTest(taskData, strm); - case 23: /* Poll the descriptor, waiting forever. */ - return pollDescriptors(taskData, args, 1); - case 24: /* Poll the descriptor, waiting for the time requested. */ - return pollDescriptors(taskData, args, 0); - case 25: /* Poll the descriptor, returning immediately.*/ - return pollDescriptors(taskData, args, 2); +// case 23: /* Poll the descriptor, waiting forever. */ +// return pollDescriptors(taskData, args, 1); +// case 24: /* Poll the descriptor, waiting for the time requested. */ +// return pollDescriptors(taskData, args, 0); +// case 25: /* Poll the descriptor, returning immediately.*/ +// return pollDescriptors(taskData, args, 2); case 26: /* Get binary as a vector. */ return readString(taskData, strm, args, false); case 27: /* Block until input is available. */ // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); waitForAvailableInput(taskData, strm); return Make_fixed_precision(taskData, 0); case 28: /* Test whether output is possible. */ return Make_fixed_precision(taskData, canOutput(taskData, strm) ? 1:0); case 29: /* Block until output is possible. */ // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); while (true) { if (canOutput(taskData, strm)) return Make_fixed_precision(taskData, 0); // Use the default waiter for the moment since we don't have // one to test for output. processes->ThreadPauseForIO(taskData, Waiter::defaultWaiter); } /* Functions added for Posix structure. */ case 30: /* Return underlying file descriptor. */ /* This is now also used internally to test for stdIn, stdOut and stdErr. */ { int fd = getStreamFileDescriptor(taskData, strm->Word()); return Make_fixed_precision(taskData, fd); } case 31: /* Make an entry for a given descriptor. */ { int ioDesc = get_C_int(taskData, DEREFWORD(args)); return wrapFileDescriptor(taskData, ioDesc); } /* Directory functions. */ case 50: /* Open a directory. */ return openDirectory(taskData, args); case 51: /* Read a directory entry. */ return readDirectory(taskData, strm); case 52: /* Close the directory */ return closeDirectory(taskData, strm); case 53: /* Rewind the directory. */ return rewindDirectory(taskData, strm, args); case 54: /* Get current working directory. */ { size_t size = 4096; TempString string_buffer((char *)malloc(size * sizeof(char))); if (string_buffer == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); char *cwd; while ((cwd = getcwd(string_buffer, size)) == NULL && errno == ERANGE) { if (size > std::numeric_limits::max() / 2) raise_fail(taskData, "getcwd needs too large a buffer"); size *= 2; char *new_buf = (char *)realloc(string_buffer, size * sizeof(char)); if (new_buf == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); string_buffer = new_buf; } if (cwd == NULL) raise_syscall(taskData, "getcwd failed", ERRORNUMBER); return SAVE(C_string_to_Poly(taskData, cwd)); } case 55: /* Create a new directory. */ { TempString dirName(args->Word()); if (dirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (mkdir(dirName, 0777) != 0) raise_syscall(taskData, "mkdir failed", ERRORNUMBER); return Make_fixed_precision(taskData, 0); } case 56: /* Delete a directory. */ { TempString dirName(args->Word()); if (dirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (rmdir(dirName) != 0) raise_syscall(taskData, "rmdir failed", ERRORNUMBER); return Make_fixed_precision(taskData, 0); } case 57: /* Test for directory. */ return isDir(taskData, args); case 58: /* Test for symbolic link. */ { TempString fileName(args->Word()); if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); struct stat fbuff; if (lstat(fileName, &fbuff) != 0) raise_syscall(taskData, "stat failed", ERRORNUMBER); return Make_fixed_precision(taskData, ((fbuff.st_mode & S_IFMT) == S_IFLNK) ? 1 : 0); } case 59: /* Read a symbolic link. */ { int nLen; TempString linkName(args->Word()); if (linkName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); size_t size = 4096; TempString resBuf((char *)malloc(size * sizeof(char))); if (resBuf == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); // nLen is signed, so cast size to ssize_t to perform signed // comparison, avoiding an infinite loop when nLen is -1. while ((nLen = readlink(linkName, resBuf, size)) >= (ssize_t) size) { size *= 2; if (size > std::numeric_limits::max()) raise_fail(taskData, "readlink needs too large a buffer"); char *newBuf = (char *)realloc(resBuf, size * sizeof(char)); if (newBuf == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); resBuf = newBuf; } if (nLen < 0) raise_syscall(taskData, "readlink failed", ERRORNUMBER); return(SAVE(C_string_to_Poly(taskData, resBuf, nLen))); } case 60: /* Return the full absolute path name. */ return fullPath(taskData, args); case 61: /* Modification time. */ return modTime(taskData, args); case 62: /* File size. */ return fileSize(taskData, args); case 63: /* Set file time. */ return setTime(taskData, strm, args); case 64: /* Delete a file. */ { TempString fileName(args->Word()); if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (unlink(fileName) != 0) raise_syscall(taskData, "unlink failed", ERRORNUMBER); return Make_fixed_precision(taskData, 0); } case 65: /* rename a file. */ return renameFile(taskData, strm, args); case 66: /* Get access rights. */ return fileAccess(taskData, strm, args); case 67: /* Return a temporary file name. */ { const char *template_subdir = "/MLTEMPXXXXXX"; #ifdef P_tmpdir TempString buff((char *)malloc(strlen(P_tmpdir) + strlen(template_subdir) + 1)); if (buff == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); strcpy(buff, P_tmpdir); #else const char *tmpdir = "/tmp"; TempString buff((char *)malloc(strlen(tmpdir) + strlen(template_subdir) + 1)); if (buff == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); strcpy(buff, tmpdir); #endif strcat(buff, template_subdir); #if (defined(HAVE_MKSTEMP) && ! defined(UNICODE)) // mkstemp is present in the Mingw64 headers but only as ANSI not Unicode. // Set the umask to mask out access by anyone else. // mkstemp generally does this anyway. mode_t oldMask = umask(0077); int fd = mkstemp(buff); int wasError = ERRORNUMBER; (void)umask(oldMask); if (fd != -1) close(fd); else raise_syscall(taskData, "mkstemp failed", wasError); #else if (mktemp(buff) == 0) raise_syscall(taskData, "mktemp failed", ERRORNUMBER); int fd = open(buff, O_RDWR | O_CREAT | O_EXCL, 00600); if (fd != -1) close(fd); else raise_syscall(taskData, "Temporary file creation failed", ERRORNUMBER); #endif Handle res = SAVE(C_string_to_Poly(taskData, buff)); return res; } case 68: /* Get the file id. */ { struct stat fbuff; TempString fileName(args->Word()); if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (stat(fileName, &fbuff) != 0) raise_syscall(taskData, "stat failed", ERRORNUMBER); /* Assume that inodes are always non-negative. */ return Make_arbitrary_precision(taskData, fbuff.st_ino); } case 69: // Return an index for a token. It is used in OS.IO.hash. // This is supposed to be well distributed for any 2^n but simply return // the stream number. return Make_fixed_precision(taskData, getStreamFileDescriptor(taskData, strm->Word())); case 70: /* Posix.FileSys.openf - open a file with given mode. */ { Handle name = taskData->saveVec.push(DEREFWORDHANDLE(args)->Get(0)); int mode = get_C_int(taskData, DEREFWORDHANDLE(args)->Get(1)); return open_file(taskData, name, mode, 0666, 1); } case 71: /* Posix.FileSys.createf - create a file with given mode and access. */ { Handle name = taskData->saveVec.push(DEREFWORDHANDLE(args)->Get(0)); int mode = get_C_int(taskData, DEREFWORDHANDLE(args)->Get(1)); int access = get_C_int(taskData, DEREFWORDHANDLE(args)->Get(2)); return open_file(taskData, name, mode|O_CREAT, access, 1); } default: { char msg[100]; sprintf(msg, "Unknown io function: %d", c); raise_exception_string(taskData, EXC_Fail, msg); return 0; } } } // General interface to IO. Ideally the various cases will be made into // separate functions. -POLYUNSIGNED PolyBasicIOGeneral(PolyObject *threadId, PolyWord code, PolyWord strm, PolyWord arg) +POLYUNSIGNED PolyBasicIOGeneral(FirstArgument threadId, PolyWord code, PolyWord strm, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCode = taskData->saveVec.push(code); Handle pushedStrm = taskData->saveVec.push(strm); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = IO_dispatch_c(taskData, pushedArg, pushedStrm, pushedCode); } catch (KillException &) { processes->ThreadExit(taskData); // TestAnyEvents may test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Create a persistent file descriptor value for Posix.FileSys.stdin etc. -POLYEXTERNALSYMBOL POLYUNSIGNED PolyPosixCreatePersistentFD(PolyObject *threadId, PolyWord fd) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyPosixCreatePersistentFD(FirstArgument threadId, PolyWord fd) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = alloc_and_save(taskData, WORDS(SIZEOF_VOIDP), F_BYTE_OBJ | F_MUTABLE_BIT | F_NO_OVERWRITE); *(POLYSIGNED*)(result->Word().AsCodePtr()) = fd.UnTagged() + 1; } catch (...) { } // If an ML exception is raised - could have run out of memory taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } struct _entrypts basicIOEPT[] = { { "PolyChDir", (polyRTSFunction)&PolyChDir}, { "PolyBasicIOGeneral", (polyRTSFunction)&PolyBasicIOGeneral}, + { "PolyPollIODescriptors", (polyRTSFunction)&PolyPollIODescriptors }, { "PolyPosixCreatePersistentFD", (polyRTSFunction)&PolyPosixCreatePersistentFD}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/check_objects.cpp b/libpolyml/check_objects.cpp index 391f8dbe..dedcbd96 100644 --- a/libpolyml/check_objects.cpp +++ b/libpolyml/check_objects.cpp @@ -1,169 +1,166 @@ /* Title: Validate addresses in objects. Copyright (c) 2006, 2012, 2017 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License 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 */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #include "globals.h" #include "diagnostics.h" #include "machine_dep.h" #include "scanaddrs.h" #include "memmgr.h" #define INRANGE(val,start,end)\ (start <= val && val < end) static void CheckAddress(PolyWord *pt) { MemSpace *space = gMem.SpaceForAddress(pt-1); if (space == 0) { Log("Check: Bad pointer %p (no space found)\n", pt); ASSERT(space != 0); } if (space->spaceType == ST_STACK) // This may not have valid length words. return; PolyObject *obj = (PolyObject*)pt; ASSERT(obj->ContainsNormalLengthWord()); POLYUNSIGNED length = obj->Length(); if (pt+length > space->top) { Log("Check: Bad pointer %p (space %p) length %" POLYUFMT "\n", pt, space, length); ASSERT(pt+length <= space->top); } if (space->spaceType == ST_LOCAL) { LocalMemSpace *lSpace = (LocalMemSpace*)space; if (!((pt > lSpace->bottom && pt+length <= lSpace->lowerAllocPtr) || (pt > lSpace->upperAllocPtr && pt+length <= space->top))) { Log("Check: Bad pointer %p (space %p) length %" POLYUFMT " outside allocated area\n", pt, space, length); ASSERT((pt > lSpace->bottom && pt+length <= lSpace->lowerAllocPtr) || (pt > lSpace->upperAllocPtr && pt+length <= space->top)); } } } void DoCheck (const PolyWord pt) { if (pt == PolyWord::FromUnsigned(0)) return; if (pt.IsTagged()) return; CheckAddress(pt.AsStackAddr()); } class ScanCheckAddress: public ScanAddress { public: virtual PolyObject *ScanObjectAddress(PolyObject *pt) { CheckAddress((PolyWord*)pt); return pt; } }; void DoCheckObject (const PolyObject *base, POLYUNSIGNED L) { PolyWord *pt = (PolyWord*)base; CheckAddress(pt); MemSpace *space = gMem.SpaceForAddress(pt-1); if (space == 0) Crash ("Bad pointer 0x%08" PRIxPTR " found", (uintptr_t)pt); ASSERT (OBJ_IS_LENGTH(L)); POLYUNSIGNED n = OBJ_OBJECT_LENGTH(L); if (n == 0) return; ASSERT (n > 0); ASSERT(pt-1 >= space->bottom && pt+n <= space->top); byte flags = GetTypeBits(L); /* discards GC flag and mutable bit */ if (flags == F_BYTE_OBJ) /* possibly signed byte object */ return; /* Nothing more to do */ if (flags == F_CODE_OBJ) /* code object */ { ScanCheckAddress checkAddr; - /* We flush the instruction cache here in case we change any of the - instructions when we update addresses. */ - machineDependent->FlushInstructionCache(pt, (n + 1) * sizeof(PolyWord)); machineDependent->ScanConstantsWithinCode((PolyObject *)base, (PolyObject *)base, n, &checkAddr); /* Skip to the constants. */ base->GetConstSegmentForCode(n, pt, n); } else if (flags == F_CLOSURE_OBJ) { n -= sizeof(PolyObject*) / sizeof(PolyWord); pt += sizeof(PolyObject*) / sizeof(PolyWord); } else ASSERT (flags == 0); /* ordinary word object */ while (n--) DoCheck (*pt++); } void DoCheckPointer (const PolyWord pt) { if (pt == PolyWord::FromUnsigned(0)) return; if (OBJ_IS_AN_INTEGER(pt)) return; DoCheck (pt); if (pt.IsDataPtr()) { PolyObject *obj = pt.AsObjPtr(); DoCheckObject (obj, obj->LengthWord()); } } // Check all the objects in the memory. Used to check the garbage collector // void DoCheckMemory() { ScanCheckAddress memCheck; // Scan the local areas. for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *space = *i; memCheck.ScanAddressesInRegion(space->bottom, space->lowerAllocPtr); memCheck.ScanAddressesInRegion(space->upperAllocPtr, space->top); } // Scan the permanent mutable areas. for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { PermanentMemSpace *space = *i; if (space->isMutable && ! space->byteOnly) memCheck.ScanAddressesInRegion(space->bottom, space->top); } } diff --git a/libpolyml/exporter.cpp b/libpolyml/exporter.cpp index 591903c4..6d7ea139 100644 --- a/libpolyml/exporter.cpp +++ b/libpolyml/exporter.cpp @@ -1,914 +1,914 @@ /* Title: exporter.cpp - Export a function as an object or C file Copyright (c) 2006-7, 2015, 2016-19 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #if (defined(_WIN32)) #include #else #define _T(x) x #define _tcslen strlen #define _tcscmp strcmp #define _tcscat strcat #endif #include "exporter.h" #include "save_vec.h" #include "polystring.h" #include "run_time.h" #include "osmem.h" #include "scanaddrs.h" #include "gc.h" #include "machine_dep.h" #include "diagnostics.h" #include "memmgr.h" #include "processes.h" // For IO_SPACING #include "sys.h" // For EXC_Fail #include "rtsentry.h" #include "pexport.h" #ifdef HAVE_PECOFF #include "pecoffexport.h" #elif defined(HAVE_ELF_H) || defined(HAVE_ELF_ABI_H) #include "elfexport.h" #elif defined(HAVE_MACH_O_RELOC_H) #include "machoexport.h" #endif #if (defined(_WIN32)) #define NOMEMORY ERROR_NOT_ENOUGH_MEMORY #define ERRORNUMBER _doserrno #else #define NOMEMORY ENOMEM #define ERRORNUMBER errno #endif extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyExport(PolyObject *threadId, PolyWord fileName, PolyWord root); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyExportPortable(PolyObject *threadId, PolyWord fileName, PolyWord root); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyExport(FirstArgument threadId, PolyWord fileName, PolyWord root); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyExportPortable(FirstArgument threadId, PolyWord fileName, PolyWord root); } /* To export the function and everything reachable from it we need to copy all the objects into a new area. We leave tombstones in the original objects by overwriting the length word. That prevents us from copying an object twice and breaks loops. Once we've copied the objects we then have to go back over the memory and turn the tombstones back into length words. */ GraveYard::~GraveYard() { free(graves); } // Used to calculate the space required for the ordinary mutables // and the no-overwrite mutables. They are interspersed in local space. class MutSizes : public ScanAddress { public: MutSizes() : mutSize(0), noOverSize(0) {} virtual PolyObject *ScanObjectAddress(PolyObject *base) { return base; }// No Actually used virtual void ScanAddressesInObject(PolyObject *base, POLYUNSIGNED lengthWord) { const POLYUNSIGNED words = OBJ_OBJECT_LENGTH(lengthWord) + 1; // Include length word if (OBJ_IS_NO_OVERWRITE(lengthWord)) noOverSize += words; else mutSize += words; } POLYUNSIGNED mutSize, noOverSize; }; CopyScan::CopyScan(unsigned h/*=0*/): hierarchy(h) { defaultImmSize = defaultMutSize = defaultCodeSize = defaultNoOverSize = 0; tombs = 0; graveYard = 0; } void CopyScan::initialise(bool isExport/*=true*/) { ASSERT(gMem.eSpaces.size() == 0); // Set the space sizes to a proportion of the space currently in use. // Computing these sizes is not obvious because CopyScan is used both // for export and for saved states. For saved states in particular we // want to use a smaller size because they are retained after we save // the state and if we have many child saved states it's important not // to waste memory. if (hierarchy == 0) { graveYard = new GraveYard[gMem.pSpaces.size()]; if (graveYard == 0) { if (debugOptions & DEBUG_SAVING) Log("SAVE: Unable to allocate graveyard, size: %lu.\n", gMem.pSpaces.size()); throw MemoryException(); } } for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { PermanentMemSpace *space = *i; if (space->hierarchy >= hierarchy) { // Include this if we're exporting (hierarchy=0) or if we're saving a state // and will include this in the new state. size_t size = (space->top-space->bottom)/4; if (space->noOverwrite) defaultNoOverSize += size; else if (space->isMutable) defaultMutSize += size; else if (space->isCode) defaultCodeSize += size; else defaultImmSize += size; if (space->hierarchy == 0 && ! space->isMutable) { // We need a separate area for the tombstones because this is read-only graveYard[tombs].graves = (PolyWord*)calloc(space->spaceSize(), sizeof(PolyWord)); if (graveYard[tombs].graves == 0) { if (debugOptions & DEBUG_SAVING) Log("SAVE: Unable to allocate graveyard for permanent space, size: %lu.\n", space->spaceSize() * sizeof(PolyWord)); throw MemoryException(); } if (debugOptions & DEBUG_SAVING) Log("SAVE: Allocated graveyard for permanent space, %p size: %lu.\n", graveYard[tombs].graves, space->spaceSize() * sizeof(PolyWord)); graveYard[tombs].startAddr = space->bottom; graveYard[tombs].endAddr = space->top; tombs++; } } } for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *space = *i; uintptr_t size = space->allocatedSpace(); // It looks as though the mutable size generally gets // overestimated while the immutable size is correct. if (space->isMutable) { MutSizes sizeMut; sizeMut.ScanAddressesInRegion(space->bottom, space->lowerAllocPtr); sizeMut.ScanAddressesInRegion(space->upperAllocPtr, space->top); defaultNoOverSize += sizeMut.noOverSize / 4; defaultMutSize += sizeMut.mutSize / 4; } else defaultImmSize += size/2; } for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { CodeSpace *space = *i; uintptr_t size = space->spaceSize(); defaultCodeSize += size/2; } if (isExport) { // Minimum 1M words. if (defaultMutSize < 1024*1024) defaultMutSize = 1024*1024; if (defaultImmSize < 1024*1024) defaultImmSize = 1024*1024; if (defaultCodeSize < 1024*1024) defaultCodeSize = 1024*1024; #ifdef MACOSX // Limit the segment size for Mac OS X. The linker has a limit of 2^24 relocations // in a segment so this is a crude way of ensuring the limit isn't exceeded. // It's unlikely to be exceeded by the code itself. // Actually, from trial-and-error, the limit seems to be around 6M. if (defaultMutSize > 6 * 1024 * 1024) defaultMutSize = 6 * 1024 * 1024; if (defaultImmSize > 6 * 1024 * 1024) defaultImmSize = 6 * 1024 * 1024; #endif if (defaultNoOverSize < 4096) defaultNoOverSize = 4096; // Except for the no-overwrite area } else { // Much smaller minimum sizes for saved states. if (defaultMutSize < 1024) defaultMutSize = 1024; if (defaultImmSize < 4096) defaultImmSize = 4096; if (defaultCodeSize < 4096) defaultCodeSize = 4096; if (defaultNoOverSize < 4096) defaultNoOverSize = 4096; // Set maximum sizes as well. We may have insufficient contiguous space for // very large areas. if (defaultMutSize > 1024 * 1024) defaultMutSize = 1024 * 1024; if (defaultImmSize > 1024 * 1024) defaultImmSize = 1024 * 1024; if (defaultCodeSize > 1024 * 1024) defaultCodeSize = 1024 * 1024; if (defaultNoOverSize > 1024 * 1024) defaultNoOverSize = 1024 * 1024; } if (debugOptions & DEBUG_SAVING) Log("SAVE: Copyscan default sizes: Immutable: %" POLYUFMT ", Mutable: %" POLYUFMT ", Code: %" POLYUFMT ", No-overwrite %" POLYUFMT ".\n", defaultImmSize, defaultMutSize, defaultCodeSize, defaultNoOverSize); } CopyScan::~CopyScan() { gMem.DeleteExportSpaces(); if (graveYard) delete[](graveYard); } // This function is called for each address in an object // once it has been copied to its new location. We copy first // then scan to update the addresses. POLYUNSIGNED CopyScan::ScanAddressAt(PolyWord *pt) { PolyWord val = *pt; // Ignore integers. if (IS_INT(val) || val == PolyWord::FromUnsigned(0)) return 0; PolyObject *obj = val.AsObjPtr(); POLYUNSIGNED l = ScanAddress(&obj); *pt = obj; return l; } // This function is called for each address in an object // once it has been copied to its new location. We copy first // then scan to update the addresses. POLYUNSIGNED CopyScan::ScanAddress(PolyObject **pt) { PolyObject *obj = *pt; MemSpace *space = gMem.SpaceForAddress((PolyWord*)obj - 1); ASSERT(space != 0); // We may sometimes get addresses that have already been updated // to point to the new area. e.g. (only?) in the case of constants // that have been updated in ScanConstantsWithinCode. if (space->spaceType == ST_EXPORT) return 0; // If this is at a lower level than the hierarchy we are saving // then leave it untouched. if (space->spaceType == ST_PERMANENT) { PermanentMemSpace *pmSpace = (PermanentMemSpace*)space; if (pmSpace->hierarchy < hierarchy) return 0; } // Have we already scanned this? if (obj->ContainsForwardingPtr()) { // Update the address to the new value. #ifdef POLYML32IN64 PolyObject *newAddr; if (space->isCode) newAddr = (PolyObject*)(globalCodeBase + ((obj->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); else newAddr = obj->GetForwardingPtr(); #else PolyObject *newAddr = obj->GetForwardingPtr(); #endif *pt = newAddr; return 0; // No need to scan it again. } else if (space->spaceType == ST_PERMANENT) { // See if we have this in the grave-yard. for (unsigned i = 0; i < tombs; i++) { GraveYard *g = &graveYard[i]; if ((PolyWord*)obj >= g->startAddr && (PolyWord*)obj < g->endAddr) { PolyWord *tombAddr = g->graves + ((PolyWord*)obj - g->startAddr); PolyObject *tombObject = (PolyObject*)tombAddr; if (tombObject->ContainsForwardingPtr()) { #ifdef POLYML32IN64 PolyObject *newAddr; if (space->isCode) newAddr = (PolyObject*)(globalCodeBase + ((tombObject->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); else newAddr = tombObject->GetForwardingPtr(); #else PolyObject *newAddr = tombObject->GetForwardingPtr(); #endif *pt = newAddr; return 0; } break; // No need to look further } } } // No, we need to copy it. ASSERT(space->spaceType == ST_LOCAL || space->spaceType == ST_PERMANENT || space->spaceType == ST_CODE); POLYUNSIGNED lengthWord = obj->LengthWord(); POLYUNSIGNED words = OBJ_OBJECT_LENGTH(lengthWord); PolyObject *newObj = 0; bool isMutableObj = obj->IsMutable(); bool isNoOverwrite = false; bool isByteObj = false; bool isCodeObj = false; if (isMutableObj) { isNoOverwrite = obj->IsNoOverwriteObject(); isByteObj = obj->IsByteObject(); } else isCodeObj = obj->IsCodeObject(); // Allocate a new address for the object. for (std::vector::iterator i = gMem.eSpaces.begin(); i < gMem.eSpaces.end(); i++) { PermanentMemSpace *space = *i; if (isMutableObj == space->isMutable && isNoOverwrite == space->noOverwrite && isByteObj == space->byteOnly && isCodeObj == space->isCode) { ASSERT(space->topPointer <= space->top && space->topPointer >= space->bottom); size_t spaceLeft = space->top - space->topPointer; if (spaceLeft > words) { newObj = (PolyObject*)(space->topPointer + 1); space->topPointer += words + 1; #ifdef POLYML32IN64 // Maintain the odd-word alignment of topPointer if ((words & 1) == 0 && space->topPointer < space->top) { *space->topPointer = PolyWord::FromUnsigned(0); space->topPointer++; } #endif break; } } } if (newObj == 0) { // Didn't find room in the existing spaces. Create a new space. uintptr_t spaceWords; if (isMutableObj) { if (isNoOverwrite) spaceWords = defaultNoOverSize; else spaceWords = defaultMutSize; } else { if (isCodeObj) spaceWords = defaultCodeSize; else spaceWords = defaultImmSize; } if (spaceWords <= words) spaceWords = words + 1; // Make sure there's space for this object. PermanentMemSpace *space = gMem.NewExportSpace(spaceWords, isMutableObj, isNoOverwrite, isCodeObj); if (isByteObj) space->byteOnly = true; if (space == 0) { if (debugOptions & DEBUG_SAVING) Log("SAVE: Unable to allocate export space, size: %lu.\n", spaceWords); // Unable to allocate this. throw MemoryException(); } newObj = (PolyObject*)(space->topPointer + 1); space->topPointer += words + 1; #ifdef POLYML32IN64 // Maintain the odd-word alignment of topPointer if ((words & 1) == 0 && space->topPointer < space->top) { *space->topPointer = PolyWord::FromUnsigned(0); space->topPointer++; } #endif ASSERT(space->topPointer <= space->top && space->topPointer >= space->bottom); } newObj->SetLengthWord(lengthWord); // copy length word memcpy(newObj, obj, words * sizeof(PolyWord)); if (space->spaceType == ST_PERMANENT && !space->isMutable && ((PermanentMemSpace*)space)->hierarchy == 0) { // The immutable permanent areas are read-only. unsigned m; for (m = 0; m < tombs; m++) { GraveYard *g = &graveYard[m]; if ((PolyWord*)obj >= g->startAddr && (PolyWord*)obj < g->endAddr) { PolyWord *tombAddr = g->graves + ((PolyWord*)obj - g->startAddr); PolyObject *tombObject = (PolyObject*)tombAddr; #ifdef POLYML32IN64 if (isCodeObj) { POLYUNSIGNED ll = (POLYUNSIGNED)(((PolyWord*)newObj - globalCodeBase) >> 1 | _OBJ_TOMBSTONE_BIT); tombObject->SetLengthWord(ll); } else tombObject->SetForwardingPtr(newObj); #else tombObject->SetForwardingPtr(newObj); #endif break; // No need to look further } } ASSERT(m < tombs); // Should be there. } #ifdef POLYML32IN64 // If this is a code address we can't use the usual forwarding pointer format. // Instead we have to compute the offset relative to the base of the code. else if (isCodeObj) { POLYUNSIGNED ll = (POLYUNSIGNED)(((PolyWord*)newObj-globalCodeBase) >> 1 | _OBJ_TOMBSTONE_BIT); obj->SetLengthWord(ll); } #endif else obj->SetForwardingPtr(newObj); // Put forwarding pointer in old object. if (OBJ_IS_CODE_OBJECT(lengthWord)) { // We don't need to worry about flushing the instruction cache // since we're not going to execute this code here. // We do have to update any relative addresses within the code // to take account of its new position. We have to do that now // even though ScanAddressesInObject will do it again because this // is the only point where we have both the old and the new addresses. machineDependent->ScanConstantsWithinCode(newObj, obj, words, this); } *pt = newObj; // Update it to the newly copied object. return lengthWord; // This new object needs to be scanned. } // The address of code in the code area. We treat this as a normal heap cell. // We will probably need to copy this and to process addresses within it. POLYUNSIGNED CopyScan::ScanCodeAddressAt(PolyObject **pt) { POLYUNSIGNED lengthWord = ScanAddress(pt); if (lengthWord) ScanAddressesInObject(*pt, lengthWord); return 0; } PolyObject *CopyScan::ScanObjectAddress(PolyObject *base) { PolyWord val = base; // Scan this as an address. POLYUNSIGNED lengthWord = CopyScan::ScanAddressAt(&val); if (lengthWord) ScanAddressesInObject(val.AsObjPtr(), lengthWord); return val.AsObjPtr(); } #define MAX_EXTENSION 4 // The longest extension we may need to add is ".obj" // Convert the forwarding pointers in a region back into length words. // Generally if this object has a forwarding pointer that's // because we've moved it into the export region. We can, // though, get multiple levels of forwarding if there is an object // that has been shifted up by a garbage collection, leaving a forwarding // pointer and then that object has been moved to the export region. // We mustn't turn locally forwarded values back into ordinary objects // because they could contain addresses that are no longer valid. static POLYUNSIGNED GetObjLength(PolyObject *obj) { if (obj->ContainsForwardingPtr()) { PolyObject *forwardedTo; #ifdef POLYML32IN64 { MemSpace *space = gMem.SpaceForAddress((PolyWord*)obj - 1); if (space->isCode) forwardedTo = (PolyObject*)(globalCodeBase + ((obj->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); else forwardedTo = obj->GetForwardingPtr(); } #else forwardedTo = obj->GetForwardingPtr(); #endif POLYUNSIGNED length = GetObjLength(forwardedTo); MemSpace *space = gMem.SpaceForAddress((PolyWord*)forwardedTo-1); if (space->spaceType == ST_EXPORT) obj->SetLengthWord(length); return length; } else { ASSERT(obj->ContainsNormalLengthWord()); return obj->LengthWord(); } } static void FixForwarding(PolyWord *pt, size_t space) { while (space) { pt++; PolyObject *obj = (PolyObject*)pt; #ifdef POLYML32IN64 if ((uintptr_t)obj & 4) { // Skip filler words needed to align to an even word space--; continue; // We've added 1 to pt so just loop. } #endif size_t length = OBJ_OBJECT_LENGTH(GetObjLength(obj)); pt += length; ASSERT(space > length); space -= length+1; } } class ExportRequest: public MainThreadRequest { public: ExportRequest(Handle root, Exporter *exp): MainThreadRequest(MTP_EXPORTING), exportRoot(root), exporter(exp) {} virtual void Perform() { exporter->RunExport(exportRoot->WordP()); } Handle exportRoot; Exporter *exporter; }; static void exporter(TaskData *taskData, Handle fileName, Handle root, const TCHAR *extension, Exporter *exports) { size_t extLen = _tcslen(extension); TempString fileNameBuff(Poly_string_to_T_alloc(fileName->Word(), extLen)); if (fileNameBuff == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); size_t length = _tcslen(fileNameBuff); // Does it already have the extension? If not add it on. if (length < extLen || _tcscmp(fileNameBuff + length - extLen, extension) != 0) _tcscat(fileNameBuff, extension); #if (defined(_WIN32) && defined(UNICODE)) exports->exportFile = _wfopen(fileNameBuff, L"wb"); #else exports->exportFile = fopen(fileNameBuff, "wb"); #endif if (exports->exportFile == NULL) raise_syscall(taskData, "Cannot open export file", ERRORNUMBER); // Request a full GC to reduce the size of fix-ups. FullGC(taskData); // Request the main thread to do the export. ExportRequest request(root, exports); processes->MakeRootRequest(taskData, &request); if (exports->errorMessage) raise_fail(taskData, exports->errorMessage); } // This is called by the initial thread to actually do the export. void Exporter::RunExport(PolyObject *rootFunction) { Exporter *exports = this; PolyObject *copiedRoot = 0; CopyScan copyScan(hierarchy); try { copyScan.initialise(); // Copy the root and everything reachable from it into the temporary area. copiedRoot = copyScan.ScanObjectAddress(rootFunction); } catch (MemoryException &) { // If we ran out of memory. copiedRoot = 0; } // Fix the forwarding pointers. for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *space = *i; // Local areas only have objects from the allocation pointer to the top. FixForwarding(space->bottom, space->lowerAllocPtr - space->bottom); FixForwarding(space->upperAllocPtr, space->top - space->upperAllocPtr); } for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { MemSpace *space = *i; // Permanent areas are filled with objects from the bottom. FixForwarding(space->bottom, space->top - space->bottom); } for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { MemSpace *space = *i; // Code areas are filled with objects from the bottom. FixForwarding(space->bottom, space->top - space->bottom); } // Reraise the exception after cleaning up the forwarding pointers. if (copiedRoot == 0) { exports->errorMessage = "Insufficient Memory"; return; } // Copy the areas into the export object. size_t tableEntries = gMem.eSpaces.size(); unsigned memEntry = 0; if (hierarchy != 0) tableEntries += gMem.pSpaces.size(); exports->memTable = new memoryTableEntry[tableEntries]; // If we're constructing a module we need to include the global spaces. if (hierarchy != 0) { // Permanent spaces from the executable. for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { PermanentMemSpace *space = *i; if (space->hierarchy < hierarchy) { memoryTableEntry *entry = &exports->memTable[memEntry++]; entry->mtOriginalAddr = entry->mtCurrentAddr = space->bottom; entry->mtLength = (space->topPointer-space->bottom)*sizeof(PolyWord); entry->mtIndex = space->index; entry->mtFlags = 0; if (space->isMutable) entry->mtFlags |= MTF_WRITEABLE; if (space->isCode) entry->mtFlags |= MTF_EXECUTABLE; } } newAreas = memEntry; } for (std::vector::iterator i = gMem.eSpaces.begin(); i < gMem.eSpaces.end(); i++) { memoryTableEntry *entry = &exports->memTable[memEntry++]; PermanentMemSpace *space = *i; entry->mtOriginalAddr = entry->mtCurrentAddr = space->bottom; entry->mtLength = (space->topPointer-space->bottom)*sizeof(PolyWord); entry->mtIndex = hierarchy == 0 ? memEntry-1 : space->index; entry->mtFlags = 0; if (space->isMutable) { entry->mtFlags = MTF_WRITEABLE; if (space->noOverwrite) entry->mtFlags |= MTF_NO_OVERWRITE; } if (space->isCode) entry->mtFlags |= MTF_EXECUTABLE; if (space->byteOnly) entry->mtFlags |= MTF_BYTES; } ASSERT(memEntry == tableEntries); exports->memTableEntries = memEntry; exports->rootFunction = copiedRoot; try { // This can raise MemoryException at least in PExport::exportStore. exports->exportStore(); } catch (MemoryException &) { exports->errorMessage = "Insufficient Memory"; } } // Functions called via the RTS call. Handle exportNative(TaskData *taskData, Handle args) { #ifdef HAVE_PECOFF // Windows including Cygwin #if (defined(_WIN32)) const TCHAR *extension = _T(".obj"); // Windows #else const char *extension = ".o"; // Cygwin #endif PECOFFExport exports; exporter(taskData, taskData->saveVec.push(args->WordP()->Get(0)), taskData->saveVec.push(args->WordP()->Get(1)), extension, &exports); #elif defined(HAVE_ELF_H) || defined(HAVE_ELF_ABI_H) // Most Unix including Linux, FreeBSD and Solaris. const char *extension = ".o"; ELFExport exports; exporter(taskData, taskData->saveVec.push(args->WordP()->Get(0)), taskData->saveVec.push(args->WordP()->Get(1)), extension, &exports); #elif defined(HAVE_MACH_O_RELOC_H) // Mac OS-X const char *extension = ".o"; MachoExport exports; exporter(taskData, taskData->saveVec.push(args->WordP()->Get(0)), taskData->saveVec.push(args->WordP()->Get(1)), extension, &exports); #else raise_exception_string (taskData, EXC_Fail, "Native export not available for this platform"); #endif return taskData->saveVec.push(TAGGED(0)); } Handle exportPortable(TaskData *taskData, Handle args) { PExport exports; exporter(taskData, taskData->saveVec.push(args->WordP()->Get(0)), taskData->saveVec.push(args->WordP()->Get(1)), _T(".txt"), &exports); return taskData->saveVec.push(TAGGED(0)); } -POLYUNSIGNED PolyExport(PolyObject *threadId, PolyWord fileName, PolyWord root) +POLYUNSIGNED PolyExport(FirstArgument threadId, PolyWord fileName, PolyWord root) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedName = taskData->saveVec.push(fileName); Handle pushedRoot = taskData->saveVec.push(root); try { #ifdef HAVE_PECOFF // Windows including Cygwin #if (defined(_WIN32)) const TCHAR *extension = _T(".obj"); // Windows #else const char *extension = ".o"; // Cygwin #endif PECOFFExport exports; exporter(taskData, pushedName, pushedRoot, extension, &exports); #elif defined(HAVE_ELF_H) || defined(HAVE_ELF_ABI_H) // Most Unix including Linux, FreeBSD and Solaris. const char *extension = ".o"; ELFExport exports; exporter(taskData, pushedName, pushedRoot, extension, &exports); #elif defined(HAVE_MACH_O_RELOC_H) // Mac OS-X const char *extension = ".o"; MachoExport exports; exporter(taskData, pushedName, pushedRoot, extension, &exports); #else raise_exception_string (taskData, EXC_Fail, "Native export not available for this platform"); #endif } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); // Returns unit } -POLYUNSIGNED PolyExportPortable(PolyObject *threadId, PolyWord fileName, PolyWord root) +POLYUNSIGNED PolyExportPortable(FirstArgument threadId, PolyWord fileName, PolyWord root) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedName = taskData->saveVec.push(fileName); Handle pushedRoot = taskData->saveVec.push(root); try { PExport exports; exporter(taskData, pushedName, pushedRoot, _T(".txt"), &exports); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); // Returns unit } // Helper functions for exporting. We need to produce relocation information // and this code is common to every method. Exporter::Exporter(unsigned int h): exportFile(NULL), errorMessage(0), hierarchy(h), memTable(0), newAreas(0) { } Exporter::~Exporter() { delete[](memTable); if (exportFile) fclose(exportFile); } void Exporter::relocateValue(PolyWord *pt) { #ifndef POLYML32IN64 PolyWord q = *pt; if (IS_INT(q) || q == PolyWord::FromUnsigned(0)) {} else createRelocation(pt); #endif } // Check through the areas to see where the address is. It must be // in one of them. unsigned Exporter::findArea(void *p) { for (unsigned i = 0; i < memTableEntries; i++) { if (p > memTable[i].mtOriginalAddr && p <= (char*)memTable[i].mtOriginalAddr + memTable[i].mtLength) return i; } { ASSERT(0); } return 0; } void Exporter::relocateObject(PolyObject *p) { if (p->IsByteObject()) { if (p->IsMutable() && p->IsWeakRefObject()) { // Weak mutable byte refs are used for external references and // also in the FFI for non-persistent values. bool isFuncPtr = true; const char *entryName = getEntryPointName(p, &isFuncPtr); if (entryName != 0) addExternalReference(p, entryName, isFuncPtr); // Clear the first word of the data. ASSERT(p->Length() >= sizeof(uintptr_t)/sizeof(PolyWord)); *(uintptr_t*)p = 0; } } else if (p->IsCodeObject()) { POLYUNSIGNED constCount; PolyWord *cp; ASSERT(! p->IsMutable() ); p->GetConstSegmentForCode(cp, constCount); /* Now the constants. */ for (POLYUNSIGNED i = 0; i < constCount; i++) relocateValue(&(cp[i])); } else if (p->IsClosureObject()) { #ifndef POLYML32IN64 ASSERT(0); #endif // This should only be used in 32-in-64 where we don't use relocations. } else /* Ordinary objects, essentially tuples. */ { POLYUNSIGNED length = p->Length(); for (POLYUNSIGNED i = 0; i < length; i++) relocateValue(p->Offset(i)); } } ExportStringTable::ExportStringTable(): strings(0), stringSize(0), stringAvailable(0) { } ExportStringTable::~ExportStringTable() { free(strings); } // Add a string to the string table, growing it if necessary. unsigned long ExportStringTable::makeEntry(const char *str) { unsigned len = (unsigned)strlen(str); unsigned long entry = stringSize; if (stringSize + len + 1 > stringAvailable) { stringAvailable = stringAvailable+stringAvailable/2; if (stringAvailable < stringSize + len + 1) stringAvailable = stringSize + len + 1 + 500; char* newStrings = (char*)realloc(strings, stringAvailable); if (newStrings == 0) { if (debugOptions & DEBUG_SAVING) Log("SAVE: Unable to realloc string table, size: %lu.\n", stringAvailable); throw MemoryException(); } else strings = newStrings; } strcpy(strings + stringSize, str); stringSize += len + 1; return entry; } struct _entrypts exporterEPT[] = { { "PolyExport", (polyRTSFunction)&PolyExport}, { "PolyExportPortable", (polyRTSFunction)&PolyExportPortable}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/gc_share_phase.cpp b/libpolyml/gc_share_phase.cpp index f4c2bf80..d1ddabad 100644 --- a/libpolyml/gc_share_phase.cpp +++ b/libpolyml/gc_share_phase.cpp @@ -1,753 +1,987 @@ /* Title: Multi-Threaded Garbage Collector - Data sharing phase Copyright (c) 2012, 2017, 2019 David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License 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 */ /* GC Sharing pass. This pass is invoked only if the heap sizing code detects that heap space is running very short because it adds a very considerable overhead to GC. It aims to reduce the size of the live data in a similar way to the data sharing function PolyML.shareCommonData by merging immutable cells that contain data that cannot be distinguished. This version of the code now does a deep structure merge in a similar way to the full sharing function. This code first does a full pass over the heap creating lists of cells that could possibly be merged. There are separate lists for byte and word objects up to a fixed size. Larger objects and other objects are not considered. Because all the items in a list have the same length and type (flag bits) we can use the length word to link the items in the list. A consequence of this is that positive long precision values can be shared but negative values cannot. There is a sharing function that first distributes items into a hash table. Then each hash table is sorted and as part of the sorting process cells with the same contents are merged. One cell is chosen and the length words on the others are set to be forwarding pointers to the chosen cell. Hashing allows for easy parallel processing. The structure sharing code works by first sharing the byte data which cannot contain pointers. Then the word data is processed to separate out "tail" cells that contain only tagged integers or pointers to cells that either cannot be merged, such as mutables, or those that have already been processed, such as the byte data. Any pointers to shared data are updated to point to the merged cell. The tail cells are then sorted and shared using the sharing function and become part of the "processed" set. This process is repeated to find cells that are now tails and so on. Compared with the full sharing code this is expensive since it requires repeated scans of the list of unprocessed cells. In particular there may be cells that form loops (basically closures for mutually recusive functions) and if they are present they and anything that points directly or indirectly at them will never be removed from the list. We stop when it appears that we are not making progress and simply do a final bit-wise share of the remainder. This now uses the forwarding pointer both to indicate that a cell shares with another and also to link together cells that have yet to be tested for sharing. To detect the difference the bitmap is used. The initial scan to create the sharing chains sets the bit for each visited cell so at the start of the sharing phase all reachable cells will be marked. We remove the mark if the cell is to be removed. This requires the bitmap to be locked. */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #include "globals.h" #include "processes.h" #include "gc.h" #include "scanaddrs.h" #include "bitmap.h" #include "memmgr.h" #include "diagnostics.h" #include "gctaskfarm.h" #include "heapsizing.h" #ifdef POLYML32IN64 #define ENDOFLIST ((PolyObject*)globalHeapBase) #else #define ENDOFLIST 0 #endif // Set the forwarding so that references to objToSet will be forwarded to // objToShare. objToSet will be garbage. void shareWith(PolyObject *objToSet, PolyObject *objToShare) { // We need to remove the bit from this so that we know it's not // a share chain. PolyWord *lengthWord = ((PolyWord*)objToSet) - 1; LocalMemSpace *space = gMem.LocalSpaceForAddress(lengthWord); ASSERT(space); PLocker locker(&space->bitmapLock); ASSERT(space->bitmap.TestBit(space->wordNo(lengthWord))); space->bitmap.ClearBit(space->wordNo(lengthWord)); // Actually do the forwarding objToSet->SetForwardingPtr(objToShare); } // When we find an address it could be a cell that: // 1. is never processed or one that is the copy to be retained, // 2. has been merged with another and contains a forwarding pointer or // 3. has not yet been processed. typedef enum { REALOBJECT, FORWARDED, CHAINED } objectState; objectState getObjectState(PolyObject *p) { PolyWord *lengthWord = ((PolyWord*)p) - 1; LocalMemSpace *space = gMem.LocalSpaceForAddress(lengthWord); if (space == 0) return REALOBJECT; // May be the address of a permanent or something else. PLocker locker(&space->bitmapLock); if (!p->ContainsForwardingPtr()) return REALOBJECT; if (space->bitmap.TestBit(space->wordNo(lengthWord))) return CHAINED; else return FORWARDED; } class ObjEntry { public: ObjEntry(): objList(ENDOFLIST), objCount(0), shareCount(0) {} PolyObject *objList; POLYUNSIGNED objCount; POLYUNSIGNED shareCount; }; // There is an instance of this class for each combination of size and // word/byte. class SortVector { public: SortVector(): totalCount(0), carryOver(0) {} void AddToVector(PolyObject *obj, POLYUNSIGNED length); void SortData(void); POLYUNSIGNED TotalCount() const { return totalCount; } POLYUNSIGNED CurrentCount() const { return baseObject.objCount; } POLYUNSIGNED Shared() const; void SetLengthWord(POLYUNSIGNED l) { lengthWord = l; } POLYUNSIGNED CarryOver() const { return carryOver; } static void hashAndSortAllTask(GCTaskId*, void *a, void *b); static void sharingTask(GCTaskId*, void *a, void *b); static void wordDataTask(GCTaskId*, void *a, void *b); private: void sortList(PolyObject *head, POLYUNSIGNED nItems, POLYUNSIGNED &count); ObjEntry baseObject, processObjects[256]; POLYUNSIGNED totalCount; POLYUNSIGNED lengthWord; POLYUNSIGNED carryOver; }; POLYUNSIGNED SortVector::Shared() const { // Add all the sharing counts POLYUNSIGNED shareCount = baseObject.shareCount; for (unsigned i = 0; i < 256; i++) shareCount += processObjects[i].shareCount; return shareCount; } void SortVector::AddToVector(PolyObject *obj, POLYUNSIGNED length) { obj->SetForwardingPtr(baseObject.objList); baseObject.objList = obj; baseObject.objCount++; totalCount++; } // The number of byte and word entries. // Objects of up to and including this size are shared. // Byte objects include strings so it is more likely that // larger objects will share. Word objects that share // are much more likely to be 2 or 3 words. #define NUM_BYTE_VECTORS 23 #define NUM_WORD_VECTORS 11 +// The stack is allocated as a series of blocks chained together. +#define RSTACK_SEGMENT_SIZE 1000 + +class RScanStack { +public: + RScanStack() : nextStack(0), lastStack(0), sp(0) {} + ~RScanStack() { delete(nextStack); } + + RScanStack *nextStack; + RScanStack *lastStack; + unsigned sp; + struct { PolyObject *obj; PolyWord *base; } stack[RSTACK_SEGMENT_SIZE]; +}; + +class RecursiveScanWithStack : public ScanAddress +{ +public: + RecursiveScanWithStack() : stack(0) {} + ~RecursiveScanWithStack() { delete(stack); } + +public: + virtual PolyObject *ScanObjectAddress(PolyObject *base); + virtual void ScanAddressesInObject(PolyObject *base, POLYUNSIGNED lengthWord); + // Have to redefine this for some reason. + void ScanAddressesInObject(PolyObject *base) + { + ScanAddressesInObject(base, base->LengthWord()); + } + +protected: + // Test the word at the location to see if it points to + // something that may have to be scanned. We pass in the + // pointer here because the called may side-effect it. + virtual bool TestForScan(PolyWord *) = 0; + // If we are definitely scanning the address we mark it. + virtual void MarkAsScanning(PolyObject *) = 0; + // Called when the object has been completed. + virtual void Completed(PolyObject *) {} + +protected: + void PushToStack(PolyObject *obj, PolyWord *base); + void PopFromStack(PolyObject *&obj, PolyWord *&base); + + bool StackIsEmpty(void) + { + return stack == 0 || (stack->sp == 0 && stack->lastStack == 0); + } + + RScanStack *stack; +}; + +// This gets called in two circumstances. It may be called for the roots +// in which case the stack will be empty and we want to process it completely +// or it is called for a constant address in which case it will have been +// called from RecursiveScan::ScanAddressesInObject and that can process +// any addresses. +PolyObject *RecursiveScanWithStack::ScanObjectAddress(PolyObject *obj) +{ + PolyWord pWord = obj; + // Test to see if this needs to be scanned. + // It may update the word. + bool test = TestForScan(&pWord); + obj = pWord.AsObjPtr(); + + if (test) + { + MarkAsScanning(obj); + if (obj->IsByteObject()) + Completed(obj); // Don't need to put it on the stack + // If we already have something on the stack we must being called + // recursively to process a constant in a code segment. Just push + // it on the stack and let the caller deal with it. + else if (StackIsEmpty()) + RecursiveScanWithStack::ScanAddressesInObject(obj, obj->LengthWord()); + else + PushToStack(obj, (PolyWord*)obj); + } + + return obj; +} + +// This is called via ScanAddressesInRegion to process the permanent mutables. It is +// also called from ScanObjectAddress to process root addresses. +// It processes all the addresses reachable from the object. +// This is almost the same as MTGCProcessMarkPointers::ScanAddressesInObject. +void RecursiveScanWithStack::ScanAddressesInObject(PolyObject *obj, POLYUNSIGNED lengthWord) +{ + if (OBJ_IS_BYTE_OBJECT(lengthWord)) + return; // Ignore byte cells and don't call Completed on them + + PolyWord *baseAddr = (PolyWord*)obj; + + while (true) + { + ASSERT(OBJ_IS_LENGTH(lengthWord)); + + // Get the length and base address. N.B. If this is a code segment + // these will be side-effected by GetConstSegmentForCode. + POLYUNSIGNED length = OBJ_OBJECT_LENGTH(lengthWord); + + if (OBJ_IS_CODE_OBJECT(lengthWord) || OBJ_IS_CLOSURE_OBJECT(lengthWord)) + { + // It's better to process the whole code object in one go. + // For the moment do that for closure objects as well. + ScanAddress::ScanAddressesInObject(obj, lengthWord); + length = 0; // Finished + } + + // else it's a normal object, + + // If there are only two addresses in this cell that need to be + // followed we follow them immediately and treat this cell as done. + // If there are more than two we push the address of this cell on + // the stack, follow the first address and then rescan it. That way + // list cells are processed once only but we don't overflow the + // stack by pushing all the addresses in a very large vector. + PolyWord *endWord = (PolyWord*)obj + length; + PolyObject *firstWord = 0; + PolyObject *secondWord = 0; + PolyWord *restartFrom = baseAddr; + + while (baseAddr != endWord) + { + PolyWord wordAt = *baseAddr; + + if (wordAt.IsDataPtr() && wordAt != PolyWord::FromUnsigned(0)) + { + // Normal address. We can have words of all zeros at least in the + // situation where we have a partially constructed code segment where + // the constants at the end of the code have not yet been filled in. + if (TestForScan(baseAddr)) // Test value at baseAddr (may side-effect it) + { + PolyObject *wObj = (*baseAddr).AsObjPtr(); + if (wObj->IsByteObject()) + { + // Can do this now - don't need to push it + MarkAsScanning(wObj); + Completed(wObj); + } + else if (firstWord == 0) + { + firstWord = wObj; + // We mark the word immediately. We can have + // two words in an object that are the same + // and we don't want to process it again. + MarkAsScanning(firstWord); + } + else if (secondWord == 0) + { + secondWord = wObj; + restartFrom = baseAddr; + } + else break; // More than two words. + } + } + baseAddr++; + } + + if (baseAddr == endWord) + { + // We have done everything except possibly firstWord and secondWord. + // Note: Unfortunately the way that ScanAddressesInRegion works means that + // we call Completed on the addresses of cells in the permanent areas without + // having called TestForScan. + Completed(obj); + if (secondWord != 0) + { + MarkAsScanning(secondWord); + // Put this on the stack. If this is a list node we will be + // pushing the tail. + PushToStack(secondWord, (PolyWord*)secondWord); + } + } + else // Put this back on the stack while we process the first word + PushToStack(obj, restartFrom); + + if (firstWord != 0) + { + // Process it immediately. + obj = firstWord; + baseAddr = (PolyWord*)obj; + } + else if (StackIsEmpty()) + return; + else + PopFromStack(obj, baseAddr); + + lengthWord = obj->LengthWord(); + } +} + +void RecursiveScanWithStack::PushToStack(PolyObject *obj, PolyWord *base) +{ + if (stack == 0 || stack->sp == RSTACK_SEGMENT_SIZE) + { + if (stack != 0 && stack->nextStack != 0) + stack = stack->nextStack; + else + { + // Need a new segment + try { + RScanStack *s = new RScanStack; + s->lastStack = stack; + if (stack != 0) + stack->nextStack = s; + stack = s; + } + catch (std::bad_alloc &) { + // Ignore stack overflow + return; + } + } + } + stack->stack[stack->sp].obj = obj; + stack->stack[stack->sp].base = base; + stack->sp++; +} + +void RecursiveScanWithStack::PopFromStack(PolyObject *&obj, PolyWord *&base) +{ + if (stack->sp == 0) + { + // Chain to the previous stack if any + ASSERT(stack->lastStack != 0); + // Before we do, delete any further one to free some memory + delete(stack->nextStack); + stack->nextStack = 0; + stack = stack->lastStack; + ASSERT(stack->sp == RSTACK_SEGMENT_SIZE); + } + --stack->sp; + obj = stack->stack[stack->sp].obj; + base = stack->stack[stack->sp].base; +} + class GetSharing: public RecursiveScanWithStack { public: GetSharing(); void SortData(void); static void shareByteData(GCTaskId *, void *, void *); static void shareWordData(GCTaskId *, void *, void *); static void shareRemainingWordData(GCTaskId *, void *, void *); virtual PolyObject *ScanObjectAddress(PolyObject *obj); protected: virtual bool TestForScan(PolyWord *); virtual void MarkAsScanning(PolyObject *); - virtual void StackOverflow(void) { } // Ignore stack overflow virtual void Completed(PolyObject *); private: // The head of chains of cells of the same size SortVector byteVectors[NUM_BYTE_VECTORS]; SortVector wordVectors[NUM_WORD_VECTORS]; POLYUNSIGNED largeWordCount, largeByteCount, excludedCount; public: POLYUNSIGNED totalVisited, byteAdded, wordAdded, totalSize; }; GetSharing::GetSharing() { for (unsigned i = 0; i < NUM_BYTE_VECTORS; i++) byteVectors[i].SetLengthWord((POLYUNSIGNED)i | _OBJ_BYTE_OBJ); for (unsigned j = 0; j < NUM_WORD_VECTORS; j++) wordVectors[j].SetLengthWord(j); largeWordCount = largeByteCount = excludedCount = 0; totalVisited = byteAdded = wordAdded = totalSize = 0; } // This is called for roots and also for constants in the constant area. // If we have a code address we MUSTN't call RecursiveScan::ScanObjectAddress // because that turns the address into a PolyWord and doesn't work in 32-in-64. // We process the code area explicitly so we can simply skip code addresses. PolyObject *GetSharing::ScanObjectAddress(PolyObject *obj) { LocalMemSpace *sp = gMem.LocalSpaceForAddress((PolyWord*)obj - 1); if (sp == 0) return obj; return RecursiveScanWithStack::ScanObjectAddress(obj); } bool GetSharing::TestForScan(PolyWord *pt) { PolyObject *obj; // This may be a forwarding pointer left over from a minor GC that did // not complete or it may be a sharing chain pointer that we've set up. while (1) { PolyWord p = *pt; ASSERT(p.IsDataPtr()); obj = p.AsObjPtr(); PolyWord *lengthWord = ((PolyWord*)obj) - 1; LocalMemSpace *space = gMem.LocalSpaceForAddress(lengthWord); if (space == 0) return false; // Ignore it if it points to a permanent area if (space->bitmap.TestBit(space->wordNo(lengthWord))) return false; // Wasn't marked - must be a forwarding pointer. if (obj->ContainsForwardingPtr()) { obj = obj->GetForwardingPtr(); *pt = obj; } else break; } ASSERT(obj->ContainsNormalLengthWord()); totalVisited += 1; totalSize += obj->Length() + 1; return true; } void GetSharing::MarkAsScanning(PolyObject *obj) { ASSERT(obj->ContainsNormalLengthWord()); PolyWord *lengthWord = ((PolyWord*)obj) - 1; LocalMemSpace *space = gMem.LocalSpaceForAddress(lengthWord); ASSERT(! space->bitmap.TestBit(space->wordNo(lengthWord))); space->bitmap.SetBit(space->wordNo(lengthWord)); } void GetSharing::Completed(PolyObject *obj) { // We mustn't include cells in the permanent area. // We scan the permanent mutable areas for local addresses // but we mustn't add the cells themselves. Normally they // will be mutable so would be ignored but cells that have been // locked will now be immutable. The test in TestForScan is bypassed // by ScanAddressesInRegion. PolyWord *lengthWord = ((PolyWord*)obj) - 1; if (gMem.LocalSpaceForAddress(lengthWord) == 0) return; POLYUNSIGNED L = obj->LengthWord(); // We have tables for word objects and byte objects // We chain entries together using the length word so it // is important that we only do this for objects that // have no other bits in the header, such as the sign bit. if ((L & _OBJ_PRIVATE_FLAGS_MASK) == 0) { POLYUNSIGNED length = obj->Length(); if (length < NUM_WORD_VECTORS) wordVectors[length].AddToVector(obj, length); else largeWordCount++; wordAdded++; } else if ((L & _OBJ_PRIVATE_FLAGS_MASK) == _OBJ_BYTE_OBJ) { POLYUNSIGNED length = obj->Length(); if (length < NUM_BYTE_VECTORS) byteVectors[length].AddToVector(obj, length); else largeByteCount++; byteAdded++; } else if (! OBJ_IS_CODE_OBJECT(L) && ! OBJ_IS_MUTABLE_OBJECT(L)) excludedCount++; // Code and mutables can't be shared - see what could be // TODO: We don't attempt to share closure cells in 32-in-64. } // Quicksort the list to detect cells with the same content. These are made // to share and removed from further sorting. void SortVector::sortList(PolyObject *head, POLYUNSIGNED nItems, POLYUNSIGNED &shareCount) { while (nItems > 2) { size_t bytesToCompare = OBJ_OBJECT_LENGTH(lengthWord)*sizeof(PolyWord); PolyObject *median = head; head = head->GetForwardingPtr(); median->SetLengthWord(lengthWord); PolyObject *left = ENDOFLIST, *right = ENDOFLIST; POLYUNSIGNED leftCount = 0, rightCount = 0; while (head != ENDOFLIST) { PolyObject *next = head->GetForwardingPtr(); int res = memcmp(median, head, bytesToCompare); if (res == 0) { // Equal - they can share shareWith(head, median); shareCount++; } else if (res < 0) { head->SetForwardingPtr(left); left = head; leftCount++; } else { head->SetForwardingPtr(right); right = head; rightCount++; } head = next; } // We can now drop the median and anything that shares with it. // Process the smaller partition recursively and the larger by // tail recursion. if (leftCount < rightCount) { sortList(left, leftCount, shareCount); head = right; nItems = rightCount; } else { sortList(right, rightCount, shareCount); head = left; nItems = leftCount; } } if (nItems == 1) head->SetLengthWord(lengthWord); else if (nItems == 2) { PolyObject *next = head->GetForwardingPtr(); head->SetLengthWord(lengthWord); if (memcmp(head, next, OBJ_OBJECT_LENGTH(lengthWord)*sizeof(PolyWord)) == 0) { shareWith(next, head); shareCount++; } else next->SetLengthWord(lengthWord); } } void SortVector::sharingTask(GCTaskId*, void *a, void *b) { SortVector *s = (SortVector *)a; ObjEntry *o = (ObjEntry*)b; s->sortList(o->objList, o->objCount, o->shareCount); } // Process one level of the word data. // N.B. The length words are updated without any locking. This is safe // because all length words are initially chain entries and a chain entry // can be replaced by another chain entry, a forwarding pointer or a normal // length word. Forwarding pointers and normal length words are only ever // set once. There is a small chance that we could lose some sharing as a // result of a race condition if a thread defers an object because it // contains a pointer with a chain entry and later sees an otherwise // equal object where another thread has replaced the chain with a // normal address, adds it to the list for immediate processing and // so never compares the two. void SortVector::wordDataTask(GCTaskId*, void *a, void *) { SortVector *s = (SortVector*)a; // Partition the objects between those that have pointers to objects that are // still to be processed and those that have been processed. if (s->baseObject.objList == ENDOFLIST) return; PolyObject *h = s->baseObject.objList; s->baseObject.objList = ENDOFLIST; s->baseObject.objCount = 0; POLYUNSIGNED words = OBJ_OBJECT_LENGTH(s->lengthWord); s->carryOver = 0; for (unsigned i = 0; i < 256; i++) { // Clear the entries in the hash table but not the sharing count. s->processObjects[i].objList = ENDOFLIST; s->processObjects[i].objCount = 0; } while (h != ENDOFLIST) { PolyObject *next = h->GetForwardingPtr(); bool deferred = false; for (POLYUNSIGNED i = 0; i < words; i++) { PolyWord w = h->Get(i); if (w.IsDataPtr()) { PolyObject *p = w.AsObjPtr(); objectState state = getObjectState(p); if (state == FORWARDED) { // Update the addresses of objects that have been merged h->Set(i, p->GetForwardingPtr()); s->carryOver++; break; } else if (state == CHAINED) { // If it is still to be shared leave it deferred = true; break; // from the loop } } } if (deferred) { // We can't do it yet: add it back to the list h->SetForwardingPtr(s->baseObject.objList); s->baseObject.objList = h; s->baseObject.objCount++; } else { // Add it to the hash table. unsigned char hash = 0; for (POLYUNSIGNED i = 0; i < words*sizeof(PolyWord); i++) hash += h->AsBytePtr()[i]; h->SetForwardingPtr(s->processObjects[hash].objList); s->processObjects[hash].objList = h; s->processObjects[hash].objCount++; } h = next; } s->SortData(); } // Sort the entries in the hash table. void SortVector::SortData() { for (unsigned j = 0; j < 256; j++) { ObjEntry *oentry = &processObjects[j]; // Sort this entry. If it's very small just process it now. switch (oentry->objCount) { case 0: break; // Nothing there case 1: // Singleton - just restore the length word oentry->objList->SetLengthWord(lengthWord); break; case 2: { // Two items - process now PolyObject *obj1 = oentry->objList; PolyObject *obj2 = obj1->GetForwardingPtr(); obj1->SetLengthWord(lengthWord); if (memcmp(obj1, obj2, OBJ_OBJECT_LENGTH(lengthWord)*sizeof(PolyWord)) == 0) { shareWith(obj2, obj1); oentry->shareCount++; } else obj2->SetLengthWord(lengthWord); break; } default: gpTaskFarm->AddWorkOrRunNow(sharingTask, this, oentry); } } } void SortVector::hashAndSortAllTask(GCTaskId*, void *a, void *b) { SortVector *s = (SortVector *)a; // Hash the contents of the base object then sort them. for (unsigned i = 0; i < 256; i++) { // Clear the entries in the hash table but not the sharing count. s->processObjects[i].objList = ENDOFLIST; s->processObjects[i].objCount = 0; } PolyObject *h = s->baseObject.objList; POLYUNSIGNED bytes = OBJ_OBJECT_LENGTH(s->lengthWord)*sizeof(PolyWord); while (h != ENDOFLIST) { PolyObject *next = h->GetForwardingPtr(); unsigned char hash = 0; for (POLYUNSIGNED j = 0; j < bytes; j++) hash += h->AsBytePtr()[j]; h->SetForwardingPtr(s->processObjects[hash].objList); s->processObjects[hash].objList = h; s->processObjects[hash].objCount++; h = next; } s->SortData(); } // Look for sharing between byte data. These cannot contain pointers // so they can all be processed together. void GetSharing::shareByteData(GCTaskId *, void *a, void *) { GetSharing *s = (GetSharing*)a; for (unsigned i = 0; i < NUM_BYTE_VECTORS; i++) { if (s->byteVectors[i].CurrentCount() != 0) gpTaskFarm->AddWorkOrRunNow(SortVector::hashAndSortAllTask, &(s->byteVectors[i]), 0); } } // Process word data at this particular level void GetSharing::shareWordData(GCTaskId *, void *a, void *) { GetSharing *s = (GetSharing*)a; for (unsigned i = 0; i < NUM_WORD_VECTORS; i++) { if (s->wordVectors[i].CurrentCount() != 0) gpTaskFarm->AddWorkOrRunNow(SortVector::wordDataTask, &(s->wordVectors[i]), 0); } } // Share any entries left. void GetSharing::shareRemainingWordData(GCTaskId *, void *a, void *) { GetSharing *s = (GetSharing*)a; for (unsigned i = 0; i < NUM_WORD_VECTORS; i++) { if (s->wordVectors[i].CurrentCount() != 0) gpTaskFarm->AddWorkOrRunNow(SortVector::hashAndSortAllTask, &(s->wordVectors[i]), 0); } } void GetSharing::SortData() { // First process the byte objects. They cannot contain pointers. // We create a task to do this so that we never have more threads // running than given with --gcthreads. gpTaskFarm->AddWorkOrRunNow(shareByteData, this, 0); gpTaskFarm->WaitForCompletion(); // Word data may contain pointers to other objects. If an object // has been processed its header will contain either a normal length // word or a forwarding pointer if it shares. We can process an // object if every word in it is either a tagged integer or an // address we have already processed. This works provided there // are no loops so when we reach a stage where we are unable to // process anything we simply run a final scan on the remainder. // Loops can arise from the closures of mutually recursive functions. // Now process the word entries until we have nothing left apart from loops. POLYUNSIGNED lastCount = 0, lastShared = 0; for (unsigned n = 0; n < NUM_WORD_VECTORS; n++) lastCount += wordVectors[n].CurrentCount(); for(unsigned pass = 1; lastCount != 0; pass++) { gpTaskFarm->AddWorkOrRunNow(shareWordData, this, 0); gpTaskFarm->WaitForCompletion(); // At each stage check that we have removed some items // from the lists. POLYUNSIGNED postCount = 0, postShared = 0, carryOver = 0; for (unsigned i = 0; i < NUM_WORD_VECTORS; i++) { postCount += wordVectors[i].CurrentCount(); postShared += wordVectors[i].Shared(); carryOver += wordVectors[i].CarryOver(); } if (debugOptions & DEBUG_GC) Log("GC: Share: Pass %u: %" POLYUFMT " removed (%1.1f%%) %" POLYUFMT " shared (%1.1f%%) %" POLYUFMT " remain. %" POLYUFMT " entries updated (%1.1f%%).\n", pass, lastCount-postCount, (double)(lastCount-postCount) / (double) lastCount * 100.0, postShared - lastShared, (double)(postShared - lastShared) / (double) (lastCount-postCount) * 100.0, postCount, carryOver, (double)carryOver / (double)(lastCount-postCount) * 100.0); // Condition for exiting the loop. There are some heuristics here. // If we remove less than 10% in a pass it's probably not worth continuing // unless the carry over is large. The "carry over" is the number of words updated as // a result of the last pass. It represents the extra sharing we gained in this pass // as a result of the last pass. If there are deep data structures that can be shared // we get better sharing with more passes. If the data structures are shallow we will // get as much sharing by just running the final pass. The first pass only carries // over any sharing from the byte objects so we need to run at least one more before // checking the carry over. if (pass > 1 && (lastCount - postCount) * 10 < lastCount && (carryOver*2 < (lastCount-postCount) || (lastCount - postCount) * 1000 < lastCount )) break; lastCount = postCount; lastShared = postShared; } // Process any remaining entries. There may be loops. gpTaskFarm->AddWorkOrRunNow(shareRemainingWordData, this, 0); gpTaskFarm->WaitForCompletion(); if (debugOptions & DEBUG_GC) { POLYUNSIGNED postShared = 0; for (unsigned i = 0; i < NUM_WORD_VECTORS; i++) postShared += wordVectors[i].Shared(); if (debugOptions & DEBUG_GC) Log("GC: Share: Final pass %" POLYUFMT " removed %" POLYUFMT " shared (%1.1f%%).\n", lastCount, postShared - lastShared, (double)(postShared - lastShared) / (double) lastCount * 100.0); } // Calculate the totals. POLYUNSIGNED totalSize = 0, totalShared = 0, totalRecovered = 0; for (unsigned k = 0; k < NUM_BYTE_VECTORS; k++) { totalSize += byteVectors[k].TotalCount(); POLYUNSIGNED shared = byteVectors[k].Shared(); totalShared += shared; totalRecovered += shared * (k+1); // Add 1 for the length word. if (debugOptions & DEBUG_GC) Log("GC: Share: Byte objects of size %u: %" POLYUFMT " objects %" POLYUFMT " shared\n", k, byteVectors[k].TotalCount(), byteVectors[k].Shared()); } for (unsigned l = 0; l < NUM_WORD_VECTORS; l++) { totalSize += wordVectors[l].TotalCount(); POLYUNSIGNED shared = wordVectors[l].Shared(); totalShared += shared; totalRecovered += shared * (l+1); if (debugOptions & DEBUG_GC) Log("GC: Share: Word objects of size %u: %" POLYUFMT " objects %" POLYUFMT " shared\n", l, wordVectors[l].TotalCount(), wordVectors[l].Shared()); } if (debugOptions & DEBUG_GC) { Log("GC: Share: Total %" POLYUFMT " objects, %" POLYUFMT " shared (%1.0f%%). %" POLYUFMT " words recovered.\n", totalSize, totalShared, (double)totalShared / (double)totalSize * 100.0, totalRecovered); Log("GC: Share: Excluding %" POLYUFMT " large word objects %" POLYUFMT " large byte objects and %" POLYUFMT " others\n", largeWordCount, largeByteCount, excludedCount); } gHeapSizeParameters.RecordSharingData(totalRecovered); } void GCSharingPhase(void) { mainThreadPhase = MTP_GCPHASESHARING; GetSharing sharer; for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *lSpace = *i; lSpace->bitmap.ClearBits(0, lSpace->spaceSize()); } // Scan the code areas to share any constants. We don't share the code // cells themselves. for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { CodeSpace *space = *i; sharer.ScanAddressesInRegion(space->bottom, space->top); } if (debugOptions & DEBUG_GC) Log("GC: Share: After scanning code: Total %" POLYUFMT " (%" POLYUFMT " words) byte %" POLYUFMT " word %" POLYUFMT ".\n", sharer.totalVisited, sharer.totalSize, sharer.byteAdded, sharer.wordAdded); // Process the permanent mutable areas and the code areas for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { PermanentMemSpace *space = *i; if (space->isMutable && ! space->byteOnly) sharer.ScanAddressesInRegion(space->bottom, space->top); } if (debugOptions & DEBUG_GC) Log("GC: Share: After scanning permanent: Total %" POLYUFMT " (%" POLYUFMT " words) byte %" POLYUFMT " word %" POLYUFMT ".\n", sharer.totalVisited, sharer.totalSize, sharer.byteAdded, sharer.wordAdded); // Process the RTS roots. GCModules(&sharer); if (debugOptions & DEBUG_GC) Log("GC: Share: After scanning other roots: Total %" POLYUFMT " (%" POLYUFMT " words) byte %" POLYUFMT " word %" POLYUFMT ".\n", sharer.totalVisited, sharer.totalSize, sharer.byteAdded, sharer.wordAdded); gHeapSizeParameters.RecordGCTime(HeapSizeParameters::GCTimeIntermediate, "Table"); // Sort and merge the data. sharer.SortData(); gHeapSizeParameters.RecordGCTime(HeapSizeParameters::GCTimeIntermediate, "Sort"); } diff --git a/libpolyml/io_internal.h b/libpolyml/io_internal.h index dae40e71..50b4151c 100644 --- a/libpolyml/io_internal.h +++ b/libpolyml/io_internal.h @@ -1,211 +1,213 @@ /* Title: Data structures shared between basioio.c and network.c. Copyright (c) 2000, 2016, 2018-19 David C. J. Matthews Portions of this code are derived from the original stream io package copyright CUTS 1983-2000. 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 */ #ifndef IO_INTERNAL_H #define IO_INTERNAL_H // Bits to define tests and results in poll. // These are the values passed to and from ML. #define POLL_BIT_IN 1 #define POLL_BIT_OUT 2 #define POLL_BIT_PRI 4 // Return values from fileKind #define FILEKIND_FILE 0 #define FILEKIND_DIR 1 #define FILEKIND_LINK 2 #define FILEKIND_TTY 3 #define FILEKIND_PIPE 4 #define FILEKIND_SKT 5 #define FILEKIND_DEV 6 #define FILEKIND_UNKNOWN 7 #define FILEKIND_ERROR (-1) #if (defined(_WIN32)) #include #include "locking.h" // For PLock // Unlike Unix where select and poll can be used on both sockets and other // streams, in Windows there is no single way of testing different sorts of // streams. class WinStreamBase { public: virtual ~WinStreamBase() {} // Quieten some warnings virtual int pollTest() { // Return the valid options for this descriptor return 0; } virtual int poll(TaskData *taskData, int test) { // Return the values set return 0; } // These are not currently used but could be used to poll // multiple sockets or streams. virtual SOCKET getSocket() { return INVALID_SOCKET; } virtual HANDLE getHandle() { return INVALID_HANDLE_VALUE; } }; typedef enum { OPENREAD, OPENWRITE, OPENAPPEND } openMode; // Abstract Windows stream class WinStream : public WinStreamBase { public: virtual void closeEntry(TaskData *taskData) = 0; + + // Block for a short time until either input is possible, returning true, + // or the time-out, which may be zero, has expired. + virtual bool testForInput(TaskData *taskData, unsigned waitMilliSecs) = 0; + + // The same for output. + virtual bool testForOutput(TaskData *taskData, unsigned waitMilliSecs) = 0; + + // These are really for backwards compatibility. virtual void waitUntilAvailable(TaskData *taskData); virtual void waitUntilOutputPossible(TaskData *taskData); + virtual size_t readStream(TaskData *taskData, byte *base, size_t length) { unimplemented(taskData); return 0; } virtual uint64_t getPos(TaskData *taskData) { unimplemented(taskData); return 0; } virtual void setPos(TaskData *taskData, uint64_t pos) { unimplemented(taskData); } virtual uint64_t fileSize(TaskData *taskData) { unimplemented(taskData); return 0; } virtual size_t writeStream(TaskData *taskData, byte *base, size_t length) { unimplemented(taskData); return 0; } virtual int fileKind() = 0; static int fileTypeOfHandle(HANDLE hStream); - // In general this class does not support polling. - // We return true for both of these so we will block. - virtual bool isAvailable(TaskData *taskData) { - return true; // No general way to test this - } - - virtual bool canOutput(TaskData *taskData) { - // There doesn't seem to be a way to do this in Windows. - return true; - } - protected: void unimplemented(TaskData *taskData); }; // Windows stream input using overlapped IO and the Windows calls. class WinInOutStream : public WinStream { public: WinInOutStream(); ~WinInOutStream(); virtual void closeEntry(TaskData *taskData); virtual void openFile(TaskData * taskData, TCHAR *name, openMode mode, bool text); virtual size_t readStream(TaskData *taskData, byte *base, size_t length); - virtual bool isAvailable(TaskData *taskData); - virtual void waitUntilAvailable(TaskData *taskData); + + virtual bool testForInput(TaskData *taskData, unsigned waitMilliSecs); + virtual bool testForOutput(TaskData *taskData, unsigned waitMilliSecs); + virtual uint64_t getPos(TaskData *taskData); virtual void setPos(TaskData *taskData, uint64_t pos); virtual uint64_t fileSize(TaskData *taskData); - virtual bool canOutput(TaskData *taskData); - virtual void waitUntilOutputPossible(TaskData *taskData); virtual size_t writeStream(TaskData *taskData, byte *base, size_t length); // Open on a handle. This returns an error result rather than raising an exception virtual bool openHandle(HANDLE hndl, openMode mode, bool isText); virtual int fileKind() { return WinStream::fileTypeOfHandle(hStream); } virtual int pollTest() { // We can poll this to test for input. return isRead ? POLL_BIT_IN : POLL_BIT_OUT; } virtual int poll(TaskData *taskData, int test); virtual HANDLE getHandle() { return hEvent; } protected: bool beginReading(); void flushOut(TaskData *taskData); uint64_t getOverlappedPos() { return ((uint64_t)(overlap.OffsetHigh) << 32) + overlap.Offset; } void setOverlappedPos(uint64_t newPos) { overlap.Offset = (DWORD)newPos; overlap.OffsetHigh = (DWORD)(newPos >> 32); } + bool isAvailable(TaskData *taskData); + bool canOutput(TaskData *taskData); + protected: bool isRead; bool isText; // Remove CRs? byte *buffer; unsigned buffSize, currentInBuffer, currentPtr; bool endOfStream; HANDLE hStream; HANDLE hEvent; OVERLAPPED overlap; PLock lock; }; // Create a new pipe. extern void newPipeName(TCHAR *name); #else extern Handle wrapFileDescriptor(TaskData *taskData, int fd); // Get a file descriptor and raise an exception if it is closed. extern int getStreamFileDescriptor(TaskData *taskData, PolyWord strm); extern int getStreamFileDescriptorWithoutCheck(PolyWord strm); #endif // This is used in both basicio and unix-specific #if defined(HAVE_STRUCT_STAT_ST_ATIM) # define STAT_SECS(stat,kind) (stat)->st_##kind##tim.tv_sec # define STAT_USECS(stat,kind) (((stat)->st_##kind##tim.tv_nsec + 500) / 1000) #elif defined(HAVE_STRUCT_STAT_ST_ATIMENSEC) # define STAT_SECS(stat,kind) (stat)->st_##kind##time # define STAT_USECS(stat,kind) (((stat)->st_##kind##timensec + 500) / 1000) #elif defined(HAVE_STRUCT_STAT_ST_ATIMESPEC) # define STAT_SECS(stat,kind) (stat)->st_##kind##timespec.tv_sec # define STAT_USECS(stat,kind) (((stat)->st_##kind##timespec.tv_nsec + 500) / 1000) #elif defined(HAVE_STRUCT_STAT_ST_ATIME_N) # define STAT_SECS(stat,kind) (stat)->st_##kind##time # define STAT_USECS(stat,kind) (((stat)->st_##kind##time_n + 500) / 1000) #elif defined(HAVE_STRUCT_STAT_ST_UATIME) # define STAT_SECS(stat,kind) (stat)->st_##kind##time # define STAT_USECS(stat,kind) (stat)->st_u##kind##time #else # define STAT_SECS(stat,kind) (stat)->st_##kind##time # define STAT_USECS(stat,kind) 0 #endif #endif diff --git a/libpolyml/machine_dep.h b/libpolyml/machine_dep.h index 7198b96b..1d8bc7ae 100644 --- a/libpolyml/machine_dep.h +++ b/libpolyml/machine_dep.h @@ -1,62 +1,61 @@ /* Title: machine_dep.h - exports signature for machine_dep.c Copyright (c) 2000 Cambridge University Technical Services Limited 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 */ #ifndef _MACHINE_DEP_H #define _MACHINE_DEP_H class ScanAddress; class TaskData; class SaveVecEntry; typedef SaveVecEntry *Handle; class StackSpace; // Machine architecture values. typedef enum { MA_Interpreted = 0, MA_I386, MA_X86_64, MA_X86_64_32 } Architectures; // Machine-dependent module. class MachineDependent { public: virtual ~MachineDependent() {} // Keep the compiler happy // Create the machine-specific task data object. virtual TaskData *CreateTaskData(void) = 0; virtual unsigned InitialStackSize(void) { return 128; } // Initial size of a stack // Must be > 40 (i.e. 2*min_stack_check) + base area in each stack frame /* ScanConstantsWithinCode - update addresses within a code segment.*/ virtual void ScanConstantsWithinCode(PolyObject *addr, PolyObject *oldAddr, POLYUNSIGNED length, ScanAddress *process) {} void ScanConstantsWithinCode(PolyObject *addr, ScanAddress *process) { ScanConstantsWithinCode(addr, addr, addr->Length(), process); } // Common case - virtual void FlushInstructionCache(void *p, POLYUNSIGNED bytes) {} virtual Architectures MachineArchitecture(void) = 0; }; extern MachineDependent *machineDependent; #endif /* _MACHINE_DEP_H */ diff --git a/libpolyml/network.cpp b/libpolyml/network.cpp index a6ff02f1..e17b61eb 100644 --- a/libpolyml/network.cpp +++ b/libpolyml/network.cpp @@ -1,1797 +1,2222 @@ /* Title: Network functions. Copyright (c) 2000-7, 2016, 2018, 2019 David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_NETDB_H #include #endif #ifdef HAVE_SYS_SOCKET_H #include #endif #ifdef HAVE_NETINET_IN_H #include #endif #ifdef HAVE_NETINET_TCP_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_SYS_IOCTL_H #include #endif #ifdef HAVE_SYS_UN_H #include #endif #ifdef HAVE_SYS_FILIO_H #include #endif #ifdef HAVE_SYS_SOCKIO_H #include #endif #ifdef HAVE_SYS_SELECT_H #include #endif +#ifdef HAVE_ARPA_INET_H +#include +#endif + +#ifdef HAVE_LIMITS_H +#include +#endif + #ifndef HAVE_SOCKLEN_T typedef int socklen_t; #endif + #if (defined(_WIN32)) -// Temporarily define this to suppress warnings for gethostname and gethostbyaddr -#define _WINSOCK_DEPRECATED_NO_WARNINGS 1 #include +#include // For getaddrinfo #else typedef int SOCKET; #endif #ifdef HAVE_WINDOWS_H #include #endif -#include -#ifdef max -#undef max -#endif - #include #include "globals.h" #include "gc.h" #include "arb.h" #include "run_time.h" #include "mpoly.h" #include "processes.h" #include "network.h" #include "io_internal.h" #include "sys.h" #include "polystring.h" #include "save_vec.h" #include "rts_module.h" #include "machine_dep.h" #include "errors.h" #include "rtsentry.h" #include "timing.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByName(PolyObject *threadId, PolyWord servName); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByNameAndProtocol(PolyObject *threadId, PolyWord servName, PolyWord protName); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByPort(PolyObject *threadId, PolyWord portNo); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByPortAndProtocol(PolyObject *threadId, PolyWord portNo, PolyWord protName); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetProtByName(PolyObject *threadId, PolyWord protocolName); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetProtByNo(PolyObject *threadId, PolyWord protoNo); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetHostName(PolyObject *threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetHostByName(PolyObject *threadId, PolyWord hostName); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetHostByAddr(PolyObject *threadId, PolyWord hostAddr); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCloseSocket(PolyObject *threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddrList(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetSockTypeList(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateSocket(FirstArgument threadId, PolyWord af, PolyWord st, PolyWord prot); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSetOption(FirstArgument threadId, PolyWord code, PolyWord sock, PolyWord opt); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetOption(FirstArgument threadId, PolyWord code, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSetLinger(FirstArgument threadId, PolyWord sock, PolyWord linger); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetLinger(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetPeerName(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetSockName(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkBytesAvailable(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAtMark(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkBind(FirstArgument threadId, PolyWord sock, PolyWord addr); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkListen(FirstArgument threadId, PolyWord sock, PolyWord back); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkShutdown(FirstArgument threadId, PolyWord skt, PolyWord smode); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateSocketPair(FirstArgument threadId, PolyWord af, PolyWord st, PolyWord prot); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkUnixPathToSockAddr(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkUnixSockAddrToPath(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByName(FirstArgument threadId, PolyWord servName); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByNameAndProtocol(FirstArgument threadId, PolyWord servName, PolyWord protName); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByPort(FirstArgument threadId, PolyWord portNo); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByPortAndProtocol(FirstArgument threadId, PolyWord portNo, PolyWord protName); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetProtByName(FirstArgument threadId, PolyWord protocolName); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetProtByNo(FirstArgument threadId, PolyWord protoNo); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetHostName(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddrInfo(FirstArgument threadId, PolyWord hostName, PolyWord addrFamily); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetNameInfo(FirstArgument threadId, PolyWord sockAddr); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCloseSocket(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSelect(FirstArgument threadId, PolyWord fdVecTriple, PolyWord maxMillisecs); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetSocketError(FirstArgument threadId, PolyWord skt); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkConnect(FirstArgument threadId, PolyWord skt, PolyWord addr); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkAccept(FirstArgument threadId, PolyWord skt); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSend(FirstArgument threadId, PolyWord args); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSendTo(FirstArgument threadId, PolyWord args); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceive(FirstArgument threadId, PolyWord args); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceiveFrom(FirstArgument threadId, PolyWord args); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetFamilyFromAddress(PolyWord sockAddress); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddressAndPortFromIP4(FirstArgument threadId, PolyWord sockAddress); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateIP4Address(FirstArgument threadId, PolyWord ip4Address, PolyWord portNumber); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReturnIP4AddressAny(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddressAndPortFromIP6(FirstArgument threadId, PolyWord sockAddress); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateIP6Address(FirstArgument threadId, PolyWord ip6Address, PolyWord portNumber); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReturnIP6AddressAny(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkIP6AddressToString(FirstArgument threadId, PolyWord ip6Address); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkStringToIP6Address(FirstArgument threadId, PolyWord stringRep); } #define SAVE(x) taskData->saveVec.push(x) #define ALLOC(n) alloc_and_save(taskData, n) #define SIZEOF(x) (sizeof(x)/sizeof(PolyWord)) #if (defined(_WIN32)) static int winsock_init = 0; /* Check that it has been initialised. */ #else #define INVALID_SOCKET (-1) #define SOCKET_ERROR (-1) #endif #ifndef HAVE_SOCKLEN_T typedef int socklen_t; // This must be int for Windows at least #endif #ifndef SHUT_RD #define SHUT_RD 0 #endif #ifndef SHUT_WR #define SHUT_WR 1 #endif #ifndef SHUT_RDWR #define SHUT_RDWR 2 #endif /* Address families. Although this table is in ascending numerical order of address family nothing depends on that. The only requirement is that "INET" => AF_INET must always be present and "UNIX" => AF_UNIX must be present on Unix. Other entries are entirely optional and are for amusement only. */ struct af_tab_struct { const char *af_name; int af_num; } af_table[] = { #ifdef AF_UNIX { "UNIX", AF_UNIX }, /* This is nearly always there. */ #endif #ifdef AF_LOCAL { "LOCAL", AF_LOCAL }, #endif { "INET", AF_INET }, /* This one should always be there. */ #ifdef AF_IMPLINK - { "IMPLINK", AF_IMPLINK }, + { "IMPLINK", AF_IMPLINK }, #endif #ifdef AF_PUP { "PUP", AF_PUP }, #endif #ifdef AF_CHAOS { "CHAOS", AF_CHAOS }, #endif #ifdef AF_IPX { "IPX", AF_IPX }, #endif #ifdef AF_NS { "NS", AF_NS }, #endif #ifdef AF_ISO { "ISO", AF_ISO }, #endif #ifdef AF_OSI { "OSI", AF_OSI }, #endif #ifdef AF_ECMA { "ECMA", AF_ECMA }, #endif #ifdef AF_DATAKIT - { "DATAKIT", AF_DATAKIT }, + { "DATAKIT", AF_DATAKIT }, #endif #ifdef AF_CCITT { "CCITT", AF_CCITT }, #endif #ifdef AF_SNA { "SNA", AF_SNA }, #endif #ifdef AF_DECnet { "DECnet", AF_DECnet }, #endif #ifdef AF_DLI { "DLI", AF_DLI }, #endif #ifdef AF_LAT { "LAT", AF_LAT }, #endif #ifdef AF_HYLINK { "HYLINK", AF_HYLINK }, #endif #ifdef AF_APPLETALK - { "APPLETALK", AF_APPLETALK }, + { "APPLETALK", AF_APPLETALK }, #endif #ifdef AF_NETBIOS - { "NETBIOS", AF_NETBIOS }, + { "NETBIOS", AF_NETBIOS }, #endif #ifdef AF_ROUTE { "ROUTE", AF_ROUTE }, #endif #ifdef AF_VOICEVIEW - { "VOICEVIEW", AF_VOICEVIEW }, + { "VOICEVIEW", AF_VOICEVIEW }, #endif #ifdef AF_FIREFOX - { "FIREFOX", AF_FIREFOX }, + { "FIREFOX", AF_FIREFOX }, #endif #ifdef AF_BAN { "BAN", AF_BAN }, #endif #ifdef AF_LINK { "LINK", AF_LINK }, #endif #ifdef AF_COIP { "COIP", AF_COIP }, #endif #ifdef AF_CNT { "CNT", AF_CNT }, #endif #ifdef AF_SIP { "SIP", AF_SIP }, #endif #ifdef AF_ISDN { "ISDN", AF_ISDN }, #endif #ifdef AF_E164 { "E164", AF_E164 }, #endif #ifdef AF_INET6 - { "INET6", AF_INET6 }, + { "INET6", AF_INET6 }, // This one should always be there. #endif #ifdef AF_NATM { "NATM", AF_NATM }, #endif #ifdef AF_ATM { "ATM", AF_ATM }, #endif #ifdef AF_NETGRAPH - { "NETGRAPH", AF_NETGRAPH }, + { "NETGRAPH", AF_NETGRAPH }, +#endif +#ifdef AF_CLUSTER + { "CLUSTER", AF_CLUSTER }, +#endif +#ifdef AF_12844 + { "12844", AF_12844 }, +#endif +#ifdef AF_IRDA + { "IRDA", AF_IRDA }, +#endif +#ifdef AF_NETDES + { "NETDES", AF_NETDES }, +#endif +#ifdef AF_TCNPROCESS + { "TCNPROCESS", AF_TCNPROCESS }, +#endif +#ifdef AF_TCNMESSAGE + { "TCNMESSAGE", AF_TCNMESSAGE }, +#endif +#ifdef AF_ICLFXBM + { "ICLFXBM", AF_ICLFXBM }, +#endif +#ifdef AF_BTH + { "BTH", AF_BTH }, +#endif +#ifdef AF_HYPERV + { "HYPERV", AF_HYPERV }, +#endif +#ifdef AF_FILE + { "FILE", AF_FILE }, +#endif +#ifdef AF_AX25 + { "AX25", AF_AX25 }, +#endif +#ifdef AF_NETROM + { "NETROM", AF_NETROM }, +#endif +#ifdef AF_BRIDGE + { "BRIDGE", AF_BRIDGE }, +#endif +#ifdef AF_ATMPVC + { "ATMPVC", AF_ATMPVC }, +#endif +#ifdef AF_X25 + { "X25", AF_X25 }, +#endif +#ifdef AF_ROSE + { "ROSE", AF_ROSE }, +#endif +#ifdef AF_NETBEUI + { "NETBEUI", AF_NETBEUI }, +#endif +#ifdef AF_SECURITY + { "SECURITY", AF_SECURITY }, +#endif +#ifdef AF_KEY + { "KEY", AF_KEY }, +#endif +#ifdef AF_NETLINK + { "NETLINK", AF_NETLINK }, +#endif +#ifdef AF_PACKET + { "PACKET", AF_PACKET }, +#endif +#ifdef AF_ASH + { "ASH", AF_ASH }, +#endif +#ifdef AF_ECONET + { "ECONET", AF_ECONET }, +#endif +#ifdef AF_ATMSVC + { "ATMSVC", AF_ATMSVC }, +#endif +#ifdef AF_RDS + { "RDS", AF_RDS }, +#endif +#ifdef AF_PPPOX + { "PPPOX", AF_PPPOX }, +#endif +#ifdef AF_WANPIPE + { "WANPIPE", AF_WANPIPE }, +#endif +#ifdef AF_LLC + { "LLC", AF_LLC }, +#endif +#ifdef AF_IB + { "IB", AF_IB }, +#endif +#ifdef AF_MPLS + { "MPLS", AF_MPLS }, +#endif +#ifdef AF_CAN + { "CAN", AF_CAN }, +#endif +#ifdef AF_TIPC + { "TIPC", AF_TIPC }, +#endif +#ifdef AF_BLUETOOTH + { "BLUETOOTH", AF_BLUETOOTH }, +#endif +#ifdef AF_IUCV + { "IUCV", AF_IUCV }, +#endif +#ifdef AF_RXRPC + { "RXRPC", AF_RXRPC }, +#endif +#ifdef AF_PHONET + { "PHONET", AF_PHONET }, +#endif +#ifdef AF_IEEE802154 + { "IEEE802154", AF_IEEE802154 }, +#endif +#ifdef AF_CAIF + { "CAIF", AF_CAIF }, +#endif +#ifdef AF_ALG + { "ALG", AF_ALG }, +#endif +#ifdef AF_NFC + { "NFC", AF_NFC }, +#endif +#ifdef AF_VSOCK + { "VSOCK", AF_VSOCK }, +#endif +#ifdef AF_KCM + { "KCM", AF_KCM }, #endif }; /* Socket types. Only STREAM and DGRAM are required. */ struct sk_tab_struct { const char *sk_name; int sk_num; } sk_table[] = { { "STREAM", SOCK_STREAM }, { "DGRAM", SOCK_DGRAM }, { "RAW", SOCK_RAW }, { "RDM", SOCK_RDM }, - { "SEQPACKET", SOCK_SEQPACKET } + { "SEQPACKET", SOCK_SEQPACKET }, +#ifdef SOCK_DCCP + { "DCCP", SOCK_DCCP }, +#endif }; -static Handle makeHostEntry(TaskData *taskData, struct hostent *host); static Handle makeProtoEntry(TaskData *taskData, struct protoent *proto); static Handle mkAftab(TaskData *taskData, void*, char *p); static Handle mkSktab(TaskData *taskData, void*, char *p); -static Handle setSocketOption(TaskData *taskData, Handle args, int level, int opt); +static Handle setSocketOption(TaskData *taskData, Handle sockHandle, Handle optHandle, int level, int opt); static Handle getSocketOption(TaskData *taskData, Handle args, int level, int opt); -static Handle getSocketInt(TaskData *taskData, Handle args, int level, int opt); -static Handle selectCall(TaskData *taskData, Handle args, int blockType); #if (defined(_WIN32)) #define GETERROR (WSAGetLastError()) #define TOOMANYFILES WSAEMFILE #define NOMEMORY WSA_NOT_ENOUGH_MEMORY #define STREAMCLOSED WSA_INVALID_HANDLE #define WOULDBLOCK WSAEWOULDBLOCK #define INPROGRESS WSAEINPROGRESS #define CALLINTERRUPTED WSAEINTR #undef EBADF #undef EMFILE #undef EAGAIN #undef EINTR #undef EWOULDBLOCK #undef ENOMEM #else #define GETERROR (errno) #define TOOMANYFILES EMFILE #define NOMEMORY ENOMEM #define STREAMCLOSED EBADF #define ERRORNUMBER errno #define FILEDOESNOTEXIST ENOENT #define WOULDBLOCK EWOULDBLOCK #define INPROGRESS EINPROGRESS #define CALLINTERRUPTED EINTR #endif // Wait until "select" returns. In Windows this is used only for networking. class WaitSelect: public Waiter { public: WaitSelect(unsigned maxMillisecs=(unsigned)-1); virtual void Wait(unsigned maxMillisecs); void SetRead(SOCKET fd) { FD_SET(fd, &readSet); } void SetWrite(SOCKET fd) { FD_SET(fd, &writeSet); } void SetExcept(SOCKET fd) { FD_SET(fd, &exceptSet); } bool IsSetRead(SOCKET fd) { return FD_ISSET(fd, &readSet) != 0; } bool IsSetWrite(SOCKET fd) { return FD_ISSET(fd, &writeSet) != 0; } bool IsSetExcept(SOCKET fd) { return FD_ISSET(fd, &exceptSet) != 0; } // Save the result of the select call and any associated error int SelectResult(void) { return selectResult; } int SelectError(void) { return errorResult; } private: fd_set readSet, writeSet, exceptSet; int selectResult; int errorResult; unsigned maxTime; }; WaitSelect::WaitSelect(unsigned maxMillisecs) { FD_ZERO(&readSet); FD_ZERO(&writeSet); FD_ZERO(&exceptSet); selectResult = 0; errorResult = 0; maxTime = maxMillisecs; } void WaitSelect::Wait(unsigned maxMillisecs) { if (maxTime < maxMillisecs) maxMillisecs = maxTime; struct timeval toWait = { 0, 0 }; toWait.tv_sec = maxMillisecs / 1000; toWait.tv_usec = (maxMillisecs % 1000) * 1000; selectResult = select(FD_SETSIZE, &readSet, &writeSet, &exceptSet, &toWait); if (selectResult < 0) errorResult = GETERROR; } -class WaitNet: public WaitSelect { -public: - WaitNet(SOCKET sock, bool isOOB = false); -}; - -// Use "select" in both Windows and Unix. In Windows that means we -// don't watch hWakeupEvent but that's only a hint. -WaitNet::WaitNet(SOCKET sock, bool isOOB) -{ - if (isOOB) SetExcept(sock); else SetRead(sock); -} - -// Wait for a socket to be free to write. -class WaitNetSend: public WaitSelect { -public: - WaitNetSend(SOCKET sock) { SetWrite(sock); } -}; - #if (defined(_WIN32)) class WinSocket : public WinStreamBase { public: WinSocket(SOCKET skt) : socket(skt) {} virtual SOCKET getSocket() { return socket; } virtual int pollTest() { // We can poll for any of these. return POLL_BIT_IN | POLL_BIT_OUT | POLL_BIT_PRI; } virtual int poll(TaskData *taskData, int test); public: SOCKET socket; }; // Poll without blocking. int WinSocket::poll(TaskData *taskData, int bits) { int result = 0; if (bits & POLL_BIT_PRI) { u_long atMark = 0; if (ioctlsocket(socket, SIOCATMARK, &atMark) != 0) raise_syscall(taskData, "ioctlsocket failed", GETERROR); if (atMark) { result |= POLL_BIT_PRI; } } if (bits & (POLL_BIT_IN | POLL_BIT_OUT)) { FD_SET readFds, writeFds; TIMEVAL poll = { 0, 0 }; FD_ZERO(&readFds); FD_ZERO(&writeFds); if (bits & POLL_BIT_IN) FD_SET(socket, &readFds); if (bits & POLL_BIT_OUT) FD_SET(socket, &writeFds); int selRes = select(FD_SETSIZE, &readFds, &writeFds, NULL, &poll); if (selRes < 0) raise_syscall(taskData, "select failed", GETERROR); else if (selRes > 0) { // N.B. select only tells us about out-of-band data if SO_OOBINLINE is FALSE. */ if (FD_ISSET(socket, &readFds)) result |= POLL_BIT_IN; if (FD_ISSET(socket, &writeFds)) result |= POLL_BIT_OUT; } } return result; } static SOCKET getStreamSocket(TaskData *taskData, PolyWord strm) { WinSocket *winskt = *(WinSocket**)(strm.AsObjPtr()); if (winskt == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); return winskt->getSocket(); } static Handle wrapStreamSocket(TaskData *taskData, SOCKET skt) { try { WinSocket *winskt = new WinSocket(skt); return MakeVolatileWord(taskData, winskt); } catch (std::bad_alloc&) { raise_syscall(taskData, "Insufficient memory", NOMEMORY); } } #else static SOCKET getStreamSocket(TaskData *taskData, PolyWord strm) { return getStreamFileDescriptor(taskData, strm); } static Handle wrapStreamSocket(TaskData *taskData, SOCKET skt) { return wrapFileDescriptor(taskData, skt); } #endif -static Handle Net_dispatch_c(TaskData *taskData, Handle args, Handle code) -{ - unsigned c = get_C_unsigned(taskData, code->Word()); - Handle hSave = taskData->saveVec.mark(); -TryAgain: // Used for various retries. - // N.B. If we call ThreadPause etc we may GC. We MUST reload any handles so for - // safety we always come back here. - switch (c) - { - - case 11: - { - /* Return a list of known address families. */ - return makeList(taskData, sizeof(af_table)/sizeof(af_table[0]), - (char*)af_table, sizeof(af_table[0]), - 0, mkAftab); - } - - case 12: - { - /* Return a list of known socket types. */ - return makeList(taskData, sizeof(sk_table)/sizeof(sk_table[0]), - (char*)sk_table, sizeof(sk_table[0]), - 0, mkSktab); - } - - case 13: /* Return the "any" internet address. */ - return Make_arbitrary_precision(taskData, INADDR_ANY); - - case 14: /* Create a socket */ - { - int af = get_C_int(taskData, DEREFHANDLE(args)->Get(0)); - int type = get_C_int(taskData, DEREFHANDLE(args)->Get(1)); - int proto = get_C_int(taskData, DEREFHANDLE(args)->Get(2)); - SOCKET skt = socket(af, type, proto); - if (skt == INVALID_SOCKET) - { - switch (GETERROR) - { - case CALLINTERRUPTED: - taskData->saveVec.reset(hSave); - goto TryAgain; - default: raise_syscall(taskData, "socket failed", GETERROR); - } - } - /* Set the socket to non-blocking mode. */ -#if (defined(_WIN32)) - unsigned long onOff = 1; - if (ioctlsocket(skt, FIONBIO, &onOff) != 0) -#else - int onOff = 1; - if (ioctl(skt, FIONBIO, &onOff) < 0) -#endif - { -#if (defined(_WIN32)) - closesocket(skt); -#else - close(skt); -#endif - raise_syscall(taskData, "ioctl failed", GETERROR); - } - return wrapStreamSocket(taskData, skt); - } - - case 15: /* Set TCP No-delay option. */ - return setSocketOption(taskData, args, IPPROTO_TCP, TCP_NODELAY); - - case 16: /* Get TCP No-delay option. */ - return getSocketOption(taskData, args, IPPROTO_TCP, TCP_NODELAY); - - case 17: /* Set Debug option. */ - return setSocketOption(taskData, args, SOL_SOCKET, SO_DEBUG); - - case 18: /* Get Debug option. */ - return getSocketOption(taskData, args, SOL_SOCKET, SO_DEBUG); - - case 19: /* Set REUSEADDR option. */ - return setSocketOption(taskData, args, SOL_SOCKET, SO_REUSEADDR); - - case 20: /* Get REUSEADDR option. */ - return getSocketOption(taskData, args, SOL_SOCKET, SO_REUSEADDR); - - case 21: /* Set KEEPALIVE option. */ - return setSocketOption(taskData, args, SOL_SOCKET, SO_KEEPALIVE); - - case 22: /* Get KEEPALIVE option. */ - return getSocketOption(taskData, args, SOL_SOCKET, SO_KEEPALIVE); - - case 23: /* Set DONTROUTE option. */ - return setSocketOption(taskData, args, SOL_SOCKET, SO_DONTROUTE); - - case 24: /* Get DONTROUTE option. */ - return getSocketOption(taskData, args, SOL_SOCKET, SO_DONTROUTE); - - case 25: /* Set BROADCAST option. */ - return setSocketOption(taskData, args, SOL_SOCKET, SO_BROADCAST); - - case 26: /* Get BROADCAST option. */ - return getSocketOption(taskData, args, SOL_SOCKET, SO_BROADCAST); - - case 27: /* Set OOBINLINE option. */ - return setSocketOption(taskData, args, SOL_SOCKET, SO_OOBINLINE); - - case 28: /* Get OOBINLINE option. */ - return getSocketOption(taskData, args, SOL_SOCKET, SO_OOBINLINE); - - case 29: /* Set SNDBUF size. */ - return setSocketOption(taskData, args, SOL_SOCKET, SO_SNDBUF); - - case 30: /* Get SNDBUF size. */ - return getSocketInt(taskData, args, SOL_SOCKET, SO_SNDBUF); - - case 31: /* Set RCVBUF size. */ - return setSocketOption(taskData, args, SOL_SOCKET, SO_RCVBUF); - - case 32: /* Get RCVBUF size. */ - return getSocketInt(taskData, args, SOL_SOCKET, SO_RCVBUF); - - case 33: /* Get socket type e.g. SOCK_STREAM. */ - return getSocketInt(taskData, args, SOL_SOCKET, SO_TYPE); - - case 34: /* Get error status and clear it. */ - return getSocketOption(taskData, args, SOL_SOCKET, SO_ERROR); - - case 35: /* Set Linger time. */ - { - struct linger linger; - SOCKET skt = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); - int lTime = get_C_int(taskData, DEREFHANDLE(args)->Get(1)); - /* We pass in a negative value to turn the option off, - zero or positive to turn it on. */ - if (lTime < 0) - { - linger.l_onoff = 0; - linger.l_linger = 0; - } - else - { - linger.l_onoff = 1; - linger.l_linger = lTime; - } - if (setsockopt(skt, SOL_SOCKET, SO_LINGER, - (char*)&linger, sizeof(linger)) != 0) - raise_syscall(taskData, "setsockopt failed", GETERROR); - return Make_arbitrary_precision(taskData, 0); - } - - case 36: /* Get Linger time. */ - { - struct linger linger; - SOCKET skt = getStreamSocket(taskData, args->Word()); - socklen_t size = sizeof(linger); - int lTime = 0; - if (getsockopt(skt, SOL_SOCKET, SO_LINGER, - (char*)&linger, &size) != 0) - raise_syscall(taskData, "getsockopt failed", GETERROR); - /* If the option is off return a negative. */ - if (linger.l_onoff == 0) lTime = -1; - else lTime = linger.l_linger; - return Make_arbitrary_precision(taskData, lTime); - } - - case 37: /* Get peer name. */ - { - SOCKET skt = getStreamSocket(taskData, args->Word()); - struct sockaddr sockA; - socklen_t size = sizeof(sockA); - if (getpeername(skt, &sockA, &size) != 0) - raise_syscall(taskData, "getpeername failed", GETERROR); - /* Addresses are treated as strings. */ - return(SAVE(C_string_to_Poly(taskData, (char*)&sockA, size))); - } - - case 38: /* Get socket name. */ - { - SOCKET skt = getStreamSocket(taskData, args->Word()); - struct sockaddr sockA; - socklen_t size = sizeof(sockA); - if (getsockname(skt, &sockA, &size) != 0) - raise_syscall(taskData, "getsockname failed", GETERROR); - return(SAVE(C_string_to_Poly(taskData, (char*)&sockA, size))); - } - - case 39: /* Return the address family from an address. */ - { - PolyStringObject *psAddr = (PolyStringObject *)args->WordP(); - struct sockaddr *psock = (struct sockaddr *)&psAddr->chars; - return Make_arbitrary_precision(taskData, psock->sa_family); - } - - case 40: /* Create a socket address from a port number and - internet address. */ - { - struct sockaddr_in sockaddr; - memset(&sockaddr, 0, sizeof(sockaddr)); - sockaddr.sin_family = AF_INET; - sockaddr.sin_port = htons(get_C_ushort(taskData, DEREFHANDLE(args)->Get(0))); - sockaddr.sin_addr.s_addr = - htonl(get_C_unsigned(taskData, DEREFHANDLE(args)->Get(1))); - return(SAVE(C_string_to_Poly(taskData, (char*)&sockaddr, sizeof(sockaddr)))); - } - - case 41: /* Return port number from an internet socket address. - Assumes that we've already checked the address family. */ - { - PolyStringObject *psAddr = (PolyStringObject *)args->WordP(); - struct sockaddr_in *psock = - (struct sockaddr_in *)&psAddr->chars; - return Make_arbitrary_precision(taskData, ntohs(psock->sin_port)); - } - - case 42: /* Return internet address from an internet socket address. - Assumes that we've already checked the address family. */ - { - PolyStringObject * psAddr = (PolyStringObject *)args->WordP(); - struct sockaddr_in *psock = - (struct sockaddr_in *)&psAddr->chars; - return Make_arbitrary_precision(taskData, ntohl(psock->sin_addr.s_addr)); - } - - /* 43 - Set non-blocking mode. Now removed. */ - - case 44: /* Find number of bytes available. */ - { - SOCKET skt = getStreamSocket(taskData, args->Word()); -#if (defined(_WIN32)) - unsigned long readable; - if (ioctlsocket(skt, FIONREAD, &readable) != 0) - raise_syscall(taskData, "ioctlsocket failed", GETERROR); -#else - int readable; - if (ioctl(skt, FIONREAD, &readable) < 0) - raise_syscall(taskData, "ioctl failed", GETERROR); -#endif - return Make_arbitrary_precision(taskData, readable); - } - - case 45: /* Find out if we are at the mark. */ - { - SOCKET skt = getStreamSocket(taskData, args->Word()); -#if (defined(_WIN32)) - unsigned long atMark; - if (ioctlsocket(skt, SIOCATMARK, &atMark) != 0) - raise_syscall(taskData, "ioctlsocket failed", GETERROR); -#else - int atMark; - if (ioctl(skt, SIOCATMARK, &atMark) < 0) - raise_syscall(taskData, "ioctl failed", GETERROR); -#endif - return Make_arbitrary_precision(taskData, atMark == 0 ? 0 : 1); - } - - case 46: /* Accept a connection. */ - // We should check for interrupts even if we're not going to block. - processes->TestAnyEvents(taskData); - - case 58: /* Non-blocking accept. */ - { - SOCKET sock = getStreamSocket(taskData, args->Word()); - struct sockaddr resultAddr; - Handle addrHandle, pair; - socklen_t addrLen = sizeof(resultAddr); - SOCKET result = accept(sock, &resultAddr, &addrLen); - - if (result == INVALID_SOCKET) - { - switch (GETERROR) - { - case CALLINTERRUPTED: - taskData->saveVec.reset(hSave); - goto TryAgain; /* Have to retry if we got EINTR. */ - case WOULDBLOCK: -#if (WOULDBLOCK != INPROGRESS) - case INPROGRESS: -#endif - /* If the socket is in non-blocking mode we pass - this back to the caller. If it is blocking we - suspend this process and try again later. */ - if (c == 46 /* blocking version. */) { - WaitNet waiter(sock); - processes->ThreadPauseForIO(taskData, &waiter); - taskData->saveVec.reset(hSave); - goto TryAgain; - } - /* else drop through. */ - default: - raise_syscall(taskData, "accept failed", GETERROR); - } - } - - addrHandle = SAVE(C_string_to_Poly(taskData, (char*)&resultAddr, addrLen)); - // Return a pair of the new socket and the address. - Handle resSkt = wrapStreamSocket(taskData, result); - pair = ALLOC(2); - DEREFHANDLE(pair)->Set(0, resSkt->Word()); - DEREFHANDLE(pair)->Set(1, addrHandle->Word()); - return pair; - } - - case 47: /* Bind an address to a socket. */ - { - SOCKET skt = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); - PolyStringObject * psAddr = (PolyStringObject *)args->WordP()->Get(1).AsObjPtr(); - struct sockaddr *psock = (struct sockaddr *)&psAddr->chars; - if (bind(skt, psock, (int)psAddr->length) != 0) - raise_syscall(taskData, "bind failed", GETERROR); - return Make_arbitrary_precision(taskData, 0); - } - - case 48: /* Connect to an address. */ - // We should check for interrupts even if we're not going to block. - processes->TestAnyEvents(taskData); - case 59: /* Non-blocking connect. */ - { - SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); - PolyStringObject * psAddr = (PolyStringObject *)args->WordP()->Get(1).AsObjPtr(); - struct sockaddr *psock = (struct sockaddr *)&psAddr->chars; - /* In Windows, and possibly also in Unix, if we have - received a previous EWOULDBLOCK we have to use "select" - to tell us whether the connection actually succeeded. */ - while (1) - { - int res = connect(sock, psock, (int)psAddr->length); - if (res == 0) return Make_arbitrary_precision(taskData, 0); /* OK */ - /* It isn't clear that EINTR can ever occur with - connect, but just to be safe, we retry. */ - int err = GETERROR; - if ((err == WOULDBLOCK || err == INPROGRESS) && c == 48 /*blocking version*/) - break; // It's in progress and we need to wait for completion - else if (err != CALLINTERRUPTED) - raise_syscall(taskData, "connect failed", err); - /* else try again. */ - } - - while (1) - { - /* In Windows failure is indicated by the bit being set in - the exception set rather than the write set. */ - WaitSelect waiter; - waiter.SetWrite(sock); - waiter.SetExcept(sock); - processes->ThreadPauseForIO(taskData, &waiter); - - if (waiter.SelectResult() < 0) - { - int err = waiter.SelectError(); - if (err != CALLINTERRUPTED) - raise_syscall(taskData, "select failed", err); - /* else continue */ - } - else if (waiter.SelectResult() != 0) /* Definite result. */ - { - int result = 0; - socklen_t len = sizeof(result); - if (getsockopt(sock, SOL_SOCKET, SO_ERROR, (char*)&result, &len) != 0) - raise_syscall(taskData, "connect failed", GETERROR); - else if (result != 0) - raise_syscall(taskData, "connect failed", result); - return Make_arbitrary_precision(taskData, 0); /* Success. */ - } - } - } - - case 49: /* Put socket into listening mode. */ - { - SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); - int backlog = get_C_int(taskData, DEREFHANDLE(args)->Get(1)); - if (listen(sock, backlog) != 0) - raise_syscall(taskData, "listen failed", GETERROR); - return Make_arbitrary_precision(taskData, 0); - } - - case 50: /* Shutdown the socket. */ - { - SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); - int mode = 0; - switch (get_C_ulong(taskData, DEREFHANDLE(args)->Get(1))) - { - case 1: mode = SHUT_RD; break; - case 2: mode = SHUT_WR; break; - case 3: mode = SHUT_RDWR; - } - if (shutdown(sock, mode) != 0) - raise_syscall(taskData, "shutdown failed", GETERROR); - return Make_arbitrary_precision(taskData, 0); - } - - case 51: /* Send data on a socket. */ - // We should check for interrupts even if we're not going to block. - processes->TestAnyEvents(taskData); - case 60: /* Non-blocking send. */ - { - SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); - PolyWord pBase = DEREFHANDLE(args)->Get(1); - char ch, *base; - POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(2)); -#if(defined(_WIN32)) - int length = get_C_int(taskData, DEREFHANDLE(args)->Get(3)); -#else - ssize_t length = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(3)); -#endif - unsigned int dontRoute = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(4)); - unsigned int outOfBand = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(5)); - int flags = 0; - if (dontRoute != 0) flags |= MSG_DONTROUTE; - if (outOfBand != 0) flags |= MSG_OOB; - if (IS_INT(pBase)) { - /* Handle the special case where we are sending a single - byte vector and the "address" is the tagged byte itself. */ - ch = (char)UNTAGGED(pBase); - base = &ch; - offset = 0; - length = 1; - } - else base = (char*)pBase.AsObjPtr()->AsBytePtr(); - - while (1) - { - int err; -#if(defined(_WIN32)) - int sent; -#else - ssize_t sent; -#endif - sent = send(sock, base+offset, length, flags); - /* It isn't clear that EINTR can ever occur with - send but just to be safe we deal with that case and - retry the send. */ - if (sent != SOCKET_ERROR) /* OK. */ - return Make_arbitrary_precision(taskData, sent); - err = GETERROR; - if ((err == WOULDBLOCK || err == INPROGRESS) && c == 51 /* blocking */) - { - WaitNetSend waiter(sock); - processes->ThreadPauseForIO(taskData, &waiter); - // It is NOT safe to just loop here. We may have GCed. - taskData->saveVec.reset(hSave); - goto TryAgain; - } - else if (err != CALLINTERRUPTED) - raise_syscall(taskData, "send failed", err); - /* else try again */ - } - } - - case 52: /* Send data on a socket to a given address. */ - // We should check for interrupts even if we're not going to block. - processes->TestAnyEvents(taskData); - case 61: /* Non-blocking send. */ - { - SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); - PolyStringObject * psAddr = (PolyStringObject *)args->WordP()->Get(1).AsObjPtr(); - PolyWord pBase = DEREFHANDLE(args)->Get(2); - char ch, *base; - POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(3)); -#if(defined(_WIN32)) - int length = get_C_int(taskData, DEREFHANDLE(args)->Get(4)); -#else - size_t length = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(4)); -#endif - unsigned int dontRoute = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(5)); - unsigned int outOfBand = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(6)); - int flags = 0; - if (dontRoute != 0) flags |= MSG_DONTROUTE; - if (outOfBand != 0) flags |= MSG_OOB; - if (IS_INT(pBase)) { - /* Handle the special case where we are sending a single - byte vector and the "address" is the tagged byte itself. */ - ch = (char)UNTAGGED(pBase); - base = &ch; - offset = 0; - length = 1; - } - else base = (char*)pBase.AsObjPtr()->AsBytePtr(); - - while (1) - { - int err; -#if(defined(_WIN32)) - int sent; -#else - ssize_t sent; -#endif - sent = sendto(sock, base+offset, length, flags, - (struct sockaddr *)psAddr->chars, (int)psAddr->length); - /* It isn't clear that EINTR can ever occur with - send but just to be safe we deal with that case and - retry the send. */ - if (sent != SOCKET_ERROR) /* OK. */ - return Make_arbitrary_precision(taskData, sent); - err = GETERROR; - if ((err == WOULDBLOCK || err == INPROGRESS) && c == 52 /* blocking */) - { - WaitNetSend waiter(sock); - processes->ThreadPauseForIO(taskData, &waiter); - // It is NOT safe to just loop here. We may have GCed. - taskData->saveVec.reset(hSave); - goto TryAgain; - } - else if (err != CALLINTERRUPTED) - raise_syscall(taskData, "sendto failed", err); - /* else try again */ - } - } - - case 53: /* Receive data into an array. */ - // We should check for interrupts even if we're not going to block. - processes->TestAnyEvents(taskData); - case 62: /* Non-blocking receive. */ - { - SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); - char *base = (char*)DEREFHANDLE(args)->Get(1).AsObjPtr()->AsBytePtr(); - POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(2)); -#if(defined(_WIN32)) - int length = get_C_int(taskData, DEREFHANDLE(args)->Get(3)); -#else - size_t length = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(3)); -#endif - unsigned int peek = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(4)); - unsigned int outOfBand = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(5)); - int flags = 0; - if (peek != 0) flags |= MSG_PEEK; - if (outOfBand != 0) flags |= MSG_OOB; - - while (1) { - int err; -#if(defined(_WIN32)) - int recvd; -#else - ssize_t recvd; -#endif - recvd = recv(sock, base+offset, length, flags); - err = GETERROR; - if (recvd != SOCKET_ERROR) { /* OK. */ - /* It appears that recv may return the length of the - message if that is longer than the buffer. */ - if (recvd > (int)length) recvd = length; - return Make_arbitrary_precision(taskData, recvd); - } - if ((err == WOULDBLOCK || err == INPROGRESS) && c == 53 /* blocking */) - { - /* Block until something arrives. */ - WaitNet waiter(sock, outOfBand != 0); - processes->ThreadPauseForIO(taskData, &waiter); - // It is NOT safe to just loop here. We may have GCed. - taskData->saveVec.reset(hSave); - goto TryAgain; - } - else if (err != CALLINTERRUPTED) - raise_syscall(taskData, "recv failed", err); - /* else try again */ - } - } - - case 54: /* Receive data into an array and return the sender's - address along with the length. In Windows this can - only be used with datagrams. */ - // We should check for interrupts even if we're not going to block. - processes->TestAnyEvents(taskData); - case 63: /* Non-blocking receive. */ - { - SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); - char *base = (char*)DEREFHANDLE(args)->Get(1).AsObjPtr()->AsBytePtr(); - POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(2)); -#if(defined(_WIN32)) - int length = get_C_int(taskData, DEREFHANDLE(args)->Get(3)); -#else - size_t length = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(3)); -#endif - unsigned int peek = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(4)); - unsigned int outOfBand = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(5)); - int flags = 0; - socklen_t addrLen; - struct sockaddr resultAddr; - - if (peek != 0) flags |= MSG_PEEK; - if (outOfBand != 0) flags |= MSG_OOB; - - while (1) { - int err; -#if(defined(_WIN32)) - int recvd; -#else - ssize_t recvd; -#endif - recvd = recvfrom(sock, base+offset, length, flags, &resultAddr, &addrLen); - err = GETERROR; - - if (recvd != SOCKET_ERROR) { /* OK. */ - Handle addrHandle, lengthHandle, pair; - if (recvd > (int)length) recvd = length; - lengthHandle = Make_arbitrary_precision(taskData, recvd); - addrHandle = SAVE(C_string_to_Poly(taskData, (char*)&resultAddr, addrLen)); - pair = ALLOC(2); - DEREFHANDLE(pair)->Set(0, lengthHandle->Word()); - DEREFHANDLE(pair)->Set(1, addrHandle->Word()); - return pair; - } - if ((err == WOULDBLOCK || err == INPROGRESS) && c == 54 /* blocking */) - { - WaitNet waiter(sock, outOfBand != 0); - processes->ThreadPauseForIO(taskData, &waiter); - // It is NOT safe to just loop here. We may have GCed. - taskData->saveVec.reset(hSave); - goto TryAgain; - } - else if (err != CALLINTERRUPTED) - raise_syscall(taskData, "recvfrom failed", err); - /* else try again */ - } - } - - case 55: /* Create a socket pair. */ -#if (defined(_WIN32)) - /* Not implemented. */ - raise_syscall(taskData, "socketpair not implemented", WSAEAFNOSUPPORT); -#else - { - Handle pair; - - int af = get_C_long(taskData, DEREFHANDLE(args)->Get(0)); - int type = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); - int proto = get_C_long(taskData, DEREFHANDLE(args)->Get(2)); - int onOff = 1; - SOCKET skt[2]; - if (socketpair(af, type, proto, skt) != 0) - { - switch (GETERROR) - { - case CALLINTERRUPTED: - taskData->saveVec.reset(hSave); - goto TryAgain; - default: raise_syscall(taskData, "socketpair failed", GETERROR); - } - } - /* Set the sockets to non-blocking mode. */ - if (ioctl(skt[0], FIONBIO, &onOff) < 0 || - ioctl(skt[1], FIONBIO, &onOff) < 0) - { - close(skt[0]); - close(skt[1]); - raise_syscall(taskData, "ioctl failed", GETERROR); - } - Handle str_token1 = wrapStreamSocket(taskData, skt[0]); - Handle str_token2 = wrapStreamSocket(taskData, skt[1]); - /* Return the two streams as a pair. */ - pair = ALLOC(2); - DEREFHANDLE(pair)->Set(0, DEREFWORD(str_token1)); - DEREFHANDLE(pair)->Set(1, DEREFWORD(str_token2)); - return pair; - } -#endif - - case 56: /* Create a Unix socket address from a string. */ -#if (defined(_WIN32)) - /* Not implemented. */ - raise_syscall(taskData, "Unix addresses not implemented", WSAEAFNOSUPPORT); -#else - { - struct sockaddr_un addr; - memset(&addr, 0, sizeof(addr)); - addr.sun_family = AF_UNIX; -#ifdef HAVE_STRUCT_SOCKADDR_UN_SUN_LEN - addr.sun_len = sizeof(addr); // Used in FreeBSD only. -#endif - POLYUNSIGNED length = Poly_string_to_C(DEREFWORD(args), addr.sun_path, sizeof(addr.sun_path)); - if (length > (int)sizeof(addr.sun_path)) - raise_syscall(taskData, "Address too long", ENAMETOOLONG); - return SAVE(C_string_to_Poly(taskData, (char*)&addr, sizeof(addr))); - } -#endif - - case 57: /* Get the file name from a Unix socket address. */ -#if (defined(_WIN32)) - /* Not implemented. */ - raise_syscall(taskData, "Unix addresses not implemented", WSAEAFNOSUPPORT); -#else - { - PolyStringObject * psAddr = (PolyStringObject *)args->WordP(); - struct sockaddr_un *psock = (struct sockaddr_un *)&psAddr->chars; - return SAVE(C_string_to_Poly(taskData, psock->sun_path)); - } -#endif - - case 64: /* Blocking select call. Infinite timeout. */ - return selectCall(taskData, args, 1); - - case 65: /* Polling select call. Zero timeout. */ - return selectCall(taskData, args, 2); - - case 66: /* Select call with non-zero timeout. */ - return selectCall(taskData, args, 0); - - - default: - { - char msg[100]; - sprintf(msg, "Unknown net function: %d", c); - raise_exception_string(taskData, EXC_Fail, msg); - return 0; - } - } -} - -static Handle mkAddr(TaskData *taskData, void *arg, char *p) -{ - int j; - struct hostent *host = (struct hostent *)arg; - unsigned long addr = 0; - /* Addresses are in network order so this is fairly easy. - In practice they will be 4 byte entries so we could - just use ntohl. */ - for (j = 0; j < host->h_length; j++) - addr = (addr << 8) | ((*(char**)p)[j] & 255); - return Make_arbitrary_precision(taskData, addr); -} - -/* Convert a host entry into a tuple for ML. */ -static Handle makeHostEntry(TaskData *taskData, struct hostent *host) -{ - /* We need to do all this in the right order. We cannot - construct the result tuple until all the values are - ready. We have to save each entry on the save stack - just in case of a garbage collection. */ - int i; - char **p; - Handle aliases, name, addrType, result; - Handle addrList = SAVE(ListNull); - - /* Canonical name. */ - name = SAVE(C_string_to_Poly(taskData, host->h_name)); - - /* Aliases. */ - for (i=0, p = host->h_aliases; *p != NULL; p++, i++); - aliases = convert_string_list(taskData, i, host->h_aliases); - - /* Address type. */ - addrType = Make_arbitrary_precision(taskData, host->h_addrtype); - - /* Addresses. */ - /* Count them first and then work from the end back. */ - for (i=0, p = host->h_addr_list; *p != NULL; p++, i++); - addrList = makeList(taskData, i, (char*)host->h_addr_list, sizeof(char*), host, mkAddr); - - /* Make the result structure. */ - result = ALLOC(4); - DEREFHANDLE(result)->Set(0, name->Word()); - DEREFHANDLE(result)->Set(1, aliases->Word()); - DEREFHANDLE(result)->Set(2, addrType->Word()); - DEREFHANDLE(result)->Set(3, addrList->Word()); - return result; -} - static Handle makeProtoEntry(TaskData *taskData, struct protoent *proto) { int i; char **p; Handle aliases, name, protocol, result; /* Canonical name. */ name = SAVE(C_string_to_Poly(taskData, proto->p_name)); /* Aliases. */ for (i=0, p = proto->p_aliases; *p != NULL; p++, i++); aliases = convert_string_list(taskData, i, proto->p_aliases); /* Protocol number. */ - protocol = Make_arbitrary_precision(taskData, proto->p_proto); + protocol = Make_fixed_precision(taskData, proto->p_proto); /* Make the result structure. */ result = ALLOC(3); DEREFHANDLE(result)->Set(0, name->Word()); DEREFHANDLE(result)->Set(1, aliases->Word()); DEREFHANDLE(result)->Set(2, protocol->Word()); return result; } static Handle makeServEntry(TaskData *taskData, struct servent *serv) { int i; char **p; Handle aliases, name, protocol, result, port; /* Canonical name. */ name = SAVE(C_string_to_Poly(taskData, serv->s_name)); /* Aliases. */ for (i=0, p = serv->s_aliases; *p != NULL; p++, i++); aliases = convert_string_list(taskData, i, serv->s_aliases); /* Port number. */ - port = Make_arbitrary_precision(taskData, ntohs(serv->s_port)); + port = Make_fixed_precision(taskData, ntohs(serv->s_port)); /* Protocol name. */ protocol = SAVE(C_string_to_Poly(taskData, serv->s_proto)); /* Make the result structure. */ result = ALLOC(4); DEREFHANDLE(result)->Set(0, name->Word()); DEREFHANDLE(result)->Set(1, aliases->Word()); DEREFHANDLE(result)->Set(2, port->Word()); DEREFHANDLE(result)->Set(3, protocol->Word()); return result; } static Handle mkAftab(TaskData *taskData, void *arg, char *p) { struct af_tab_struct *af = (struct af_tab_struct *)p; Handle result, name, num; /* Construct a pair of the string and the number. */ name = SAVE(C_string_to_Poly(taskData, af->af_name)); - num = Make_arbitrary_precision(taskData, af->af_num); + num = Make_fixed_precision(taskData, af->af_num); result = ALLOC(2); DEREFHANDLE(result)->Set(0, name->Word()); DEREFHANDLE(result)->Set(1, num->Word()); return result; } static Handle mkSktab(TaskData *taskData, void *arg, char *p) { struct sk_tab_struct *sk = (struct sk_tab_struct *)p; Handle result, name, num; /* Construct a pair of the string and the number. */ name = SAVE(C_string_to_Poly(taskData, sk->sk_name)); - num = Make_arbitrary_precision(taskData, sk->sk_num); + num = Make_fixed_precision(taskData, sk->sk_num); result = ALLOC(2); DEREFHANDLE(result)->Set(0, name->Word()); DEREFHANDLE(result)->Set(1, num->Word()); return result; } /* This sets an option and can also be used to set an integer. */ -static Handle setSocketOption(TaskData *taskData, Handle args, int level, int opt) +static Handle setSocketOption(TaskData *taskData, Handle sockHandle, Handle optHandle, int level, int opt) { - SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); - int onOff = get_C_int(taskData, DEREFHANDLE(args)->Get(1)); + SOCKET sock = getStreamSocket(taskData, sockHandle->Word()); + int onOff = get_C_int(taskData, optHandle->Word()); if (setsockopt(sock, level, opt, (char*)&onOff, sizeof(int)) != 0) raise_syscall(taskData, "setsockopt failed", GETERROR); - return Make_arbitrary_precision(taskData, 0); + return Make_fixed_precision(taskData, 0); } -/* Get a socket option as a boolean */ +// Get a socket option as an integer. static Handle getSocketOption(TaskData *taskData, Handle args, int level, int opt) { SOCKET sock = getStreamSocket(taskData, args->Word()); - int onOff = 0; + int optVal = 0; socklen_t size = sizeof(int); - if (getsockopt(sock, level, opt, (char*)&onOff, &size) != 0) + if (getsockopt(sock, level, opt, (char*)&optVal, &size) != 0) raise_syscall(taskData, "getsockopt failed", GETERROR); - return Make_arbitrary_precision(taskData, onOff == 0 ? 0 : 1); + return Make_fixed_precision(taskData, optVal); } -/* Get a socket option as an integer */ -static Handle getSocketInt(TaskData *taskData, Handle args, int level, int opt) +// Get and clear the error state for the socket. Returns a SysWord.word value. +POLYUNSIGNED PolyNetworkGetSocketError(FirstArgument threadId, PolyWord skt) { - SOCKET sock = getStreamSocket(taskData, args->Word()); - int optVal = 0; - socklen_t size = sizeof(int); - if (getsockopt(sock, level, opt, (char*)&optVal, &size) != 0) - raise_syscall(taskData, "getsockopt failed", GETERROR); - return Make_arbitrary_precision(taskData, optVal); + TaskData *taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + SOCKET sock = getStreamSocket(taskData, skt); + int intVal = 0; + socklen_t size = sizeof(int); + if (getsockopt(sock, SOL_SOCKET, SO_ERROR, (char*)&intVal, &size) != 0) + raise_syscall(taskData, "getsockopt failed", GETERROR); + result = Make_sysword(taskData, intVal); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); } // Helper function for selectCall. Creates the result vector of active sockets. static bool testBit(int offset, SOCKET fd, WaitSelect *pSelect) { switch (offset) { case 0: return pSelect->IsSetRead(fd); case 1: return pSelect->IsSetWrite(fd); case 2: return pSelect->IsSetExcept(fd); default: return false; } } static Handle getSelectResult(TaskData *taskData, Handle args, int offset, WaitSelect *pSelect) { /* Construct the result vectors. */ PolyObject *inVec = DEREFHANDLE(args)->Get(offset).AsObjPtr(); POLYUNSIGNED nVec = inVec->Length(); int nRes = 0; POLYUNSIGNED i; for (i = 0; i < nVec; i++) { SOCKET sock = getStreamSocket(taskData, inVec->Get(i)); if (testBit(offset, sock, pSelect)) nRes++; } if (nRes == 0) return ALLOC(0); /* None - return empty vector. */ else { Handle result = ALLOC(nRes); inVec = DEREFHANDLE(args)->Get(offset).AsObjPtr(); /* It could have moved as a result of a gc. */ nRes = 0; for (i = 0; i < nVec; i++) { SOCKET sock = getStreamSocket(taskData, inVec->Get(i)); if (testBit(offset, sock, pSelect)) DEREFWORDHANDLE(result)->Set(nRes++, inVec->Get(i)); } return result; } } /* Wrapper for "select" call. The arguments are arrays of socket ids. These arrays are updated so that "active" sockets are left unchanged and inactive sockets are set to minus one. */ -static Handle selectCall(TaskData *taskData, Handle args, int blockType) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSelect(FirstArgument threadId, PolyWord fdVecTriple, PolyWord maxMillisecs) { - Handle hSave = taskData->saveVec.mark(); - - while (1) // Until we time-out or get a result. - { - POLYUNSIGNED i, nVec; - Handle rdResult, wrResult, exResult, result; - unsigned maxMillisecs = 1000; // Set the time to the maximum i.e. block - switch (blockType) - { - case 0: /* Check the timeout. */ - { - /* The time argument is an absolute time. */ -#if (defined(_WIN32)) - FILETIME ftTime, ftNow; - /* Get the file time. */ - getFileTimeFromArb(taskData, taskData->saveVec.push(DEREFHANDLE(args)->Get(3)), &ftTime); - GetSystemTimeAsFileTime(&ftNow); - /* If the timeout time is earlier than the current time - we must return, otherwise we block. */ - if (CompareFileTime(&ftTime, &ftNow) <= 0) - maxMillisecs = 0; - else - { - subFiletimes(&ftTime, &ftNow); - if (ftTime.dwHighDateTime > 0 || ftTime.dwLowDateTime > 10000000) - maxMillisecs = 1000; // No more than 1 second - else maxMillisecs = ftTime.dwLowDateTime / 10000; - } -#else /* Unix */ - struct timeval tvTime, tvNow; - /* We have a value in microseconds. We need to split - it into seconds and microseconds. */ - Handle hTime = SAVE(DEREFWORDHANDLE(args)->Get(3)); - Handle hMillion = Make_arbitrary_precision(taskData, 1000000); - tvTime.tv_sec = - get_C_ulong(taskData, DEREFWORD(div_longc(taskData, hMillion, hTime))); - tvTime.tv_usec = - get_C_ulong(taskData, DEREFWORD(rem_longc(taskData, hMillion, hTime))); - /* If the timeout time is earlier than the current time - we must return, otherwise we block. */ - if (gettimeofday(&tvNow, NULL) != 0) - raise_syscall(taskData, "gettimeofday failed", errno); - if (tvNow.tv_sec > tvTime.tv_sec || (tvNow.tv_sec == tvTime.tv_sec && tvNow.tv_usec >= tvTime.tv_usec)) - maxMillisecs = 0; - else - { - subTimevals(&tvTime, &tvNow); - if (tvTime.tv_sec >= 1) maxMillisecs = 1000; // Don't overflow if it's very long - else maxMillisecs = tvTime.tv_usec / 1000; - } -#endif - break; - } - case 1: // Block until one of the descriptors is ready. - maxMillisecs = 1000; // Max 1 second - break; - case 2: // Just a simple poll - maxMillisecs = 0; - break; - } - WaitSelect waitSelect(maxMillisecs); - /* Set up the bitmaps for the select call from the arrays. */ - PolyObject *readVec = DEREFHANDLE(args)->Get(0).AsObjPtr(); - PolyObject *writeVec = DEREFHANDLE(args)->Get(1).AsObjPtr(); - PolyObject *excVec = DEREFHANDLE(args)->Get(2).AsObjPtr(); - nVec = readVec->Length(); - for (i = 0; i < nVec; i++) + TaskData *taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + POLYUNSIGNED maxMilliseconds = maxMillisecs.UnTaggedUnsigned(); + Handle fdVecTripleHandle = taskData->saveVec.push(fdVecTriple); + /* Set up the bitmaps for the select call from the arrays. */ + + try { + WaitSelect waitSelect((unsigned int)maxMilliseconds); + PolyObject *readVec = fdVecTripleHandle->WordP()->Get(0).AsObjPtr(); + PolyObject *writeVec = fdVecTripleHandle->WordP()->Get(1).AsObjPtr(); + PolyObject *excVec = fdVecTripleHandle->WordP()->Get(2).AsObjPtr(); + for (POLYUNSIGNED i = 0; i < readVec->Length(); i++) waitSelect.SetRead(getStreamSocket(taskData, readVec->Get(i))); - nVec = writeVec->Length(); - for (i = 0; i < nVec; i++) + for (POLYUNSIGNED i = 0; i < writeVec->Length(); i++) waitSelect.SetWrite(getStreamSocket(taskData, writeVec->Get(i))); - nVec = excVec->Length(); - for (i = 0; i < nVec; i++) + for (POLYUNSIGNED i = 0; i < excVec->Length(); i++) waitSelect.SetExcept(getStreamSocket(taskData, excVec->Get(i))); - // Do the select. This may return immediately if the maximum time-out is short. - processes->ThreadPauseForIO(taskData, &waitSelect); - if (waitSelect.SelectResult() < 0) - raise_syscall(taskData, "select failed", waitSelect.SelectError()); - else if (waitSelect.SelectResult() > 0 || maxMillisecs == 0) + // Do the select. This may return immediately if the maximum time-out is short. + processes->ThreadPauseForIO(taskData, &waitSelect); + if (waitSelect.SelectResult() < 0) + raise_syscall(taskData, "select failed", waitSelect.SelectError()); + + // Construct the result vectors. + Handle rdResult = getSelectResult(taskData, fdVecTripleHandle, 0, &waitSelect); + Handle wrResult = getSelectResult(taskData, fdVecTripleHandle, 1, &waitSelect); + Handle exResult = getSelectResult(taskData, fdVecTripleHandle, 2, &waitSelect); + result = ALLOC(3); + DEREFHANDLE(result)->Set(0, rdResult->Word()); + DEREFHANDLE(result)->Set(1, wrResult->Word()); + DEREFHANDLE(result)->Set(2, exResult->Word()); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); + +} + +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkConnect(FirstArgument threadId, PolyWord skt, PolyWord addr) +{ + TaskData *taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + try { + SOCKET sock = getStreamSocket(taskData, skt); + PolyStringObject * psAddr = (PolyStringObject *)(addr.AsObjPtr()); + struct sockaddr *psock = (struct sockaddr *)&psAddr->chars; + // Begin the connection. The socket is always non-blocking so this will return immediately. + if (connect(sock, psock, (int)psAddr->length) != 0) + raise_syscall(taskData, "connect failed", GETERROR); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + return TAGGED(0).AsUnsigned(); // Always returns unit +} + +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkAccept(FirstArgument threadId, PolyWord skt) +{ + TaskData *taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + SOCKET sock = getStreamSocket(taskData, skt); + struct sockaddr_storage resultAddr; + socklen_t addrLen = sizeof(resultAddr); + SOCKET resultSkt = accept(sock, (struct sockaddr*)&resultAddr, &addrLen); + if (resultSkt == INVALID_SOCKET) + raise_syscall(taskData, "accept failed", GETERROR); + if (addrLen > sizeof(resultAddr)) addrLen = sizeof(resultAddr); + Handle addrHandle = taskData->saveVec.push(C_string_to_Poly(taskData, (char*)&resultAddr, addrLen)); + // Return a pair of the new socket and the address. + Handle resSkt = wrapStreamSocket(taskData, resultSkt); + result = alloc_and_save(taskData, 2); + result->WordP()->Set(0, resSkt->Word()); + result->WordP()->Set(1, addrHandle->Word()); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSend(FirstArgument threadId, PolyWord argsAsWord) +{ + TaskData *taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle args = taskData->saveVec.push(argsAsWord); +#if(defined(_WIN32) && ! defined(_CYGWIN)) + int sent = 0; +#else + ssize_t sent = 0; +#endif + + try { + SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); + PolyWord pBase = DEREFHANDLE(args)->Get(1); + POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(2)); +#if(defined(_WIN32) && ! defined(_CYGWIN)) + int length = get_C_int(taskData, DEREFHANDLE(args)->Get(3)); +#else + ssize_t length = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(3)); +#endif + unsigned int dontRoute = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(4)); + unsigned int outOfBand = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(5)); + int flags = 0; + if (dontRoute != 0) flags |= MSG_DONTROUTE; + if (outOfBand != 0) flags |= MSG_OOB; + char *base = (char*)pBase.AsObjPtr()->AsBytePtr(); + sent = send(sock, base + offset, length, flags); + if (sent == SOCKET_ERROR) + raise_syscall(taskData, "send failed", GETERROR); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + return TAGGED(sent).AsUnsigned(); +} + +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSendTo(FirstArgument threadId, PolyWord argsAsWord) +{ + TaskData *taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle args = taskData->saveVec.push(argsAsWord); +#if(defined(_WIN32) && ! defined(_CYGWIN)) + int sent = 0; +#else + ssize_t sent = 0; +#endif + + try { + SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); + PolyStringObject * psAddr = (PolyStringObject *)args->WordP()->Get(1).AsObjPtr(); + PolyWord pBase = DEREFHANDLE(args)->Get(2); + + POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(3)); +#if(defined(_WIN32) && ! defined(_CYGWIN)) + int length = get_C_int(taskData, DEREFHANDLE(args)->Get(4)); +#else + size_t length = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(4)); +#endif + unsigned int dontRoute = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(5)); + unsigned int outOfBand = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(6)); + int flags = 0; + if (dontRoute != 0) flags |= MSG_DONTROUTE; + if (outOfBand != 0) flags |= MSG_OOB; + char *base = (char*)pBase.AsObjPtr()->AsBytePtr(); + sent = sendto(sock, base + offset, length, flags, + (struct sockaddr *)psAddr->chars, (int)psAddr->length); + if (sent == SOCKET_ERROR) + raise_syscall(taskData, "sendto failed", GETERROR); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + return TAGGED(sent).AsUnsigned(); +} + +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceive(FirstArgument threadId, PolyWord argsAsWord) +{ + TaskData *taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle args = taskData->saveVec.push(argsAsWord); +#if(defined(_WIN32) && ! defined(_CYGWIN)) + int recvd = 0; +#else + ssize_t recvd = 0; +#endif + + try { + SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); + char *base = (char*)DEREFHANDLE(args)->Get(1).AsObjPtr()->AsBytePtr(); + POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(2)); +#if(defined(_WIN32) && ! defined(_CYGWIN)) + int length = get_C_int(taskData, DEREFHANDLE(args)->Get(3)); +#else + size_t length = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(3)); +#endif + unsigned int peek = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(4)); + unsigned int outOfBand = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(5)); + int flags = 0; + if (peek != 0) flags |= MSG_PEEK; + if (outOfBand != 0) flags |= MSG_OOB; + + recvd = recv(sock, base + offset, length, flags); + if (recvd == SOCKET_ERROR) + raise_syscall(taskData, "recv failed", GETERROR); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + return TAGGED(recvd).AsUnsigned(); +} + +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceiveFrom(FirstArgument threadId, PolyWord argsAsWord) +{ + TaskData *taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle args = taskData->saveVec.push(argsAsWord); + Handle result = 0; + + try { + SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); + char *base = (char*)DEREFHANDLE(args)->Get(1).AsObjPtr()->AsBytePtr(); + POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(2)); +#if(defined(_WIN32) && ! defined(_CYGWIN)) + int length = get_C_int(taskData, DEREFHANDLE(args)->Get(3)); +#else + size_t length = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(3)); +#endif + unsigned int peek = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(4)); + unsigned int outOfBand = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(5)); + int flags = 0; + struct sockaddr_storage resultAddr; + socklen_t addrLen = sizeof(resultAddr); + + if (peek != 0) flags |= MSG_PEEK; + if (outOfBand != 0) flags |= MSG_OOB; + +#if(defined(_WIN32) && ! defined(_CYGWIN)) + int recvd; +#else + ssize_t recvd; +#endif + recvd = recvfrom(sock, base + offset, length, flags, (struct sockaddr*)&resultAddr, &addrLen); + if (recvd == SOCKET_ERROR) + raise_syscall(taskData, "recvfrom failed", GETERROR); + + if (recvd > (int)length) recvd = length; + Handle lengthHandle = Make_fixed_precision(taskData, recvd); + if (addrLen > sizeof(resultAddr)) addrLen = sizeof(resultAddr); + Handle addrHandle = SAVE(C_string_to_Poly(taskData, (char*)&resultAddr, addrLen)); + result = ALLOC(2); + DEREFHANDLE(result)->Set(0, lengthHandle->Word()); + DEREFHANDLE(result)->Set(1, addrHandle->Word()); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Return a list of known address families. */ +POLYUNSIGNED PolyNetworkGetAddrList(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + result = makeList(taskData, sizeof(af_table) / sizeof(af_table[0]), + (char*)af_table, sizeof(af_table[0]), 0, mkAftab); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Return a list of known socket types. */ +POLYUNSIGNED PolyNetworkGetSockTypeList(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + result = makeList(taskData, sizeof(sk_table) / sizeof(sk_table[0]), + (char*)sk_table, sizeof(sk_table[0]), + 0, mkSktab); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +// Create a socket */ +POLYUNSIGNED PolyNetworkCreateSocket(FirstArgument threadId, PolyWord family, PolyWord st, PolyWord prot) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + int af = (int)family.UnTagged(); + int type = (int)st.UnTagged(); + int proto = (int)prot.UnTagged(); + + try { + SOCKET skt = 0; + do { + skt = socket(af, type, proto); + } while (skt == INVALID_SOCKET && GETERROR == CALLINTERRUPTED); + + if (skt == INVALID_SOCKET) + raise_syscall(taskData, "socket failed", GETERROR); + + /* Set the socket to non-blocking mode. */ +#if (defined(_WIN32) && ! defined(__CYGWIN__)) + unsigned long onOff = 1; + if (ioctlsocket(skt, FIONBIO, &onOff) != 0) +#else + int onOff = 1; + if (ioctl(skt, FIONBIO, &onOff) < 0) +#endif + { +#if (defined(_WIN32) && ! defined(__CYGWIN__)) + closesocket(skt); +#else + close(skt); +#endif + raise_syscall(taskData, "ioctl failed", GETERROR); + } + result = wrapStreamSocket(taskData, skt); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +POLYUNSIGNED PolyNetworkSetOption(FirstArgument threadId, PolyWord code, PolyWord sock, PolyWord opt) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle pushedSock = taskData->saveVec.push(sock); + Handle pushedOpt = taskData->saveVec.push(opt); + + try { + switch (UNTAGGED(code)) + { + case 15: /* Set TCP No-delay option. */ + setSocketOption(taskData, pushedSock, pushedOpt, IPPROTO_TCP, TCP_NODELAY); + break; + + case 17: /* Set Debug option. */ + setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_DEBUG); + break; + + case 19: /* Set REUSEADDR option. */ + setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_REUSEADDR); + break; + + case 21: /* Set KEEPALIVE option. */ + setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_KEEPALIVE); + break; + + case 23: /* Set DONTROUTE option. */ + setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_DONTROUTE); + break; + + case 25: /* Set BROADCAST option. */ + setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_BROADCAST); + break; + + case 27: /* Set OOBINLINE option. */ + setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_OOBINLINE); + break; + + case 29: /* Set SNDBUF size. */ + setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_SNDBUF); + break; + + case 31: /* Set RCVBUF size. */ + setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_RCVBUF); + break; + } + } + catch (KillException&) { + processes->ThreadExit(taskData); // May test for kill + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + return TAGGED(0).AsUnsigned(); +} + +POLYUNSIGNED PolyNetworkGetOption(FirstArgument threadId, PolyWord code, PolyWord arg) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle pushedArg = taskData->saveVec.push(arg); + Handle result = 0; + + try { + switch (UNTAGGED(code)) + { + case 16: /* Get TCP No-delay option. */ + result = getSocketOption(taskData, pushedArg, IPPROTO_TCP, TCP_NODELAY); + break; + + case 18: /* Get Debug option. */ + result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_DEBUG); + break; + + case 20: /* Get REUSEADDR option. */ + result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_REUSEADDR); + break; + + case 22: /* Get KEEPALIVE option. */ + result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_KEEPALIVE); + break; + + case 24: /* Get DONTROUTE option. */ + result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_DONTROUTE); + break; + + case 26: /* Get BROADCAST option. */ + result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_BROADCAST); + break; + + case 28: /* Get OOBINLINE option. */ + result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_OOBINLINE); + break; + + case 30: /* Get SNDBUF size. */ + result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_SNDBUF); + break; + + case 32: /* Get RCVBUF size. */ + result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_RCVBUF); + break; + + case 33: /* Get socket type e.g. SOCK_STREAM. */ + result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_TYPE); + break; + } + } + catch (KillException&) { + processes->ThreadExit(taskData); // May test for kill + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Set Linger time. */ +POLYUNSIGNED PolyNetworkSetLinger(FirstArgument threadId, PolyWord sock, PolyWord lingerTime) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + + try { + SOCKET skt = getStreamSocket(taskData, sock); + int lTime = get_C_int(taskData, lingerTime); + struct linger linger; + /* We pass in a negative value to turn the option off, + zero or positive to turn it on. */ + if (lTime < 0) + { + linger.l_onoff = 0; + linger.l_linger = 0; + } + else + { + linger.l_onoff = 1; + linger.l_linger = lTime; + } + if (setsockopt(skt, SOL_SOCKET, SO_LINGER, + (char*)& linger, sizeof(linger)) != 0) + raise_syscall(taskData, "setsockopt failed", GETERROR); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + return TAGGED(0).AsUnsigned(); +} + +/* Get Linger time. */ +POLYUNSIGNED PolyNetworkGetLinger(FirstArgument threadId, PolyWord sock) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + SOCKET skt = getStreamSocket(taskData, sock); + socklen_t size = sizeof(linger); + int lTime = 0; + struct linger linger; + if (getsockopt(skt, SOL_SOCKET, SO_LINGER, (char*)& linger, &size) != 0) + raise_syscall(taskData, "getsockopt failed", GETERROR); + /* If the option is off return a negative. */ + if (linger.l_onoff == 0) lTime = -1; + else lTime = linger.l_linger; + result = Make_arbitrary_precision(taskData, lTime); // Returns LargeInt.int + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Get peer name. */ +POLYUNSIGNED PolyNetworkGetPeerName(FirstArgument threadId, PolyWord sock) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + SOCKET skt = getStreamSocket(taskData, sock); + struct sockaddr_storage sockA; + socklen_t size = sizeof(sockA); + if (getpeername(skt, (struct sockaddr*) & sockA, &size) != 0) + raise_syscall(taskData, "getpeername failed", GETERROR); + if (size > sizeof(sockA)) size = sizeof(sockA); + /* Addresses are treated as strings. */ + result = (SAVE(C_string_to_Poly(taskData, (char*)& sockA, size))); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Get socket name. */ +POLYUNSIGNED PolyNetworkGetSockName(FirstArgument threadId, PolyWord sock) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + SOCKET skt = getStreamSocket(taskData, sock); + struct sockaddr_storage sockA; + socklen_t size = sizeof(sockA); + if (getsockname(skt, (struct sockaddr*) & sockA, &size) != 0) + raise_syscall(taskData, "getsockname failed", GETERROR); + if (size > sizeof(sockA)) size = sizeof(sockA); + result = (SAVE(C_string_to_Poly(taskData, (char*)& sockA, size))); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Find number of bytes available. */ +POLYUNSIGNED PolyNetworkBytesAvailable(FirstArgument threadId, PolyWord sock) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + SOCKET skt = getStreamSocket(taskData, sock); +#if (defined(_WIN32) && ! defined(__CYGWIN__)) + unsigned long readable; + if (ioctlsocket(skt, FIONREAD, &readable) != 0) + raise_syscall(taskData, "ioctlsocket failed", GETERROR); +#else + int readable; + if (ioctl(skt, FIONREAD, &readable) < 0) + raise_syscall(taskData, "ioctl failed", GETERROR); +#endif + result = Make_fixed_precision(taskData, readable); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Find out if we are at the mark. */ +POLYUNSIGNED PolyNetworkGetAtMark(FirstArgument threadId, PolyWord sock) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + SOCKET skt = getStreamSocket(taskData, sock); +#if (defined(_WIN32) && ! defined(__CYGWIN__)) + unsigned long atMark; + if (ioctlsocket(skt, SIOCATMARK, &atMark) != 0) + raise_syscall(taskData, "ioctlsocket failed", GETERROR); +#else + int atMark; + if (ioctl(skt, SIOCATMARK, &atMark) < 0) + raise_syscall(taskData, "ioctl failed", GETERROR); +#endif + result = Make_fixed_precision(taskData, atMark == 0 ? 0 : 1); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Bind an address to a socket. */ +POLYUNSIGNED PolyNetworkBind(FirstArgument threadId, PolyWord sock, PolyWord addr) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + + try { + SOCKET skt = getStreamSocket(taskData, sock); + PolyStringObject* psAddr = (PolyStringObject*)addr.AsObjPtr(); + struct sockaddr* psock = (struct sockaddr*) & psAddr->chars; + if (bind(skt, psock, (int)psAddr->length) != 0) + raise_syscall(taskData, "bind failed", GETERROR); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + return TAGGED(0).AsUnsigned(); +} + +/* Put socket into listening mode. */ +POLYUNSIGNED PolyNetworkListen(FirstArgument threadId, PolyWord skt, PolyWord back) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + + try { + SOCKET sock = getStreamSocket(taskData, skt); + int backlog = get_C_int(taskData, back); + if (listen(sock, backlog) != 0) + raise_syscall(taskData, "listen failed", GETERROR); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + return TAGGED(0).AsUnsigned(); +} + +/* Shutdown the socket. */ +POLYUNSIGNED PolyNetworkShutdown(FirstArgument threadId, PolyWord skt, PolyWord smode) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + + try { + SOCKET sock = getStreamSocket(taskData, skt); + int mode = 0; + switch (get_C_ulong(taskData, smode)) { - // There was a result or the time expired or it was just a poll. - // Construct the result vectors. - rdResult = getSelectResult(taskData, args, 0, &waitSelect); - wrResult = getSelectResult(taskData, args, 1, &waitSelect); - exResult = getSelectResult(taskData, args, 2, &waitSelect); - result = ALLOC(3); - DEREFHANDLE(result)->Set(0, rdResult->Word()); - DEREFHANDLE(result)->Set(1, wrResult->Word()); - DEREFHANDLE(result)->Set(2, exResult->Word()); - return result; + case 1: mode = SHUT_RD; break; + case 2: mode = SHUT_WR; break; + case 3: mode = SHUT_RDWR; } - // else try again. - taskData->saveVec.reset(hSave); + if (shutdown(sock, mode) != 0) + raise_syscall(taskData, "shutdown failed", GETERROR); } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + return TAGGED(0).AsUnsigned(); } -// General interface to networking. Ideally the various cases will be made into -// separate functions. -POLYUNSIGNED PolyNetworkGeneral(PolyObject *threadId, PolyWord code, PolyWord arg) +/* Create a socket pair. */ +POLYUNSIGNED PolyNetworkCreateSocketPair(FirstArgument threadId, PolyWord family, PolyWord st, PolyWord prot) { - TaskData *taskData = TaskData::FindTaskForId(threadId); + TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); - Handle pushedCode = taskData->saveVec.push(code); - Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { - result = Net_dispatch_c(taskData, pushedArg, pushedCode); +#if (defined(_WIN32) && ! defined(__CYGWIN__)) + /* Not implemented. */ + raise_syscall(taskData, "socketpair not implemented", WSAEAFNOSUPPORT); +#else + int af = family.UnTagged(); + int type = st.UnTagged(); + int proto = prot.UnTagged(); + SOCKET skt[2]; + int skPRes = 0; + + do { + skPRes = socketpair(af, type, proto, skt); + } while (skPRes != 0 && GETERROR == CALLINTERRUPTED); + + int onOff = 1; + /* Set the sockets to non-blocking mode. */ + if (ioctl(skt[0], FIONBIO, &onOff) < 0 || + ioctl(skt[1], FIONBIO, &onOff) < 0) + { + close(skt[0]); + close(skt[1]); + raise_syscall(taskData, "ioctl failed", GETERROR); + } + Handle str_token1 = wrapStreamSocket(taskData, skt[0]); + Handle str_token2 = wrapStreamSocket(taskData, skt[1]); + /* Return the two streams as a pair. */ + result = ALLOC(2); + DEREFHANDLE(result)->Set(0, DEREFWORD(str_token1)); + DEREFHANDLE(result)->Set(1, DEREFWORD(str_token2)); +#endif } - catch (KillException &) { + catch (KillException&) { processes->ThreadExit(taskData); // May test for kill } - catch (...) { } // If an ML exception is raised + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Create a Unix socket address from a string. */ +POLYUNSIGNED PolyNetworkUnixPathToSockAddr(FirstArgument threadId, PolyWord arg) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { +#if (defined(_WIN32) && ! defined(__CYGWIN__)) + /* Not implemented. */ + raise_syscall(taskData, "Unix addresses not implemented", WSAEAFNOSUPPORT); +#else + struct sockaddr_un addr; + memset(&addr, 0, sizeof(addr)); + addr.sun_family = AF_UNIX; +#ifdef HAVE_STRUCT_SOCKADDR_UN_SUN_LEN + addr.sun_len = sizeof(addr); // Used in FreeBSD only. +#endif + POLYUNSIGNED length = Poly_string_to_C(arg, addr.sun_path, sizeof(addr.sun_path)); + if (length > (int)sizeof(addr.sun_path)) + raise_syscall(taskData, "Address too long", ENAMETOOLONG); + result = SAVE(C_string_to_Poly(taskData, (char*)& addr, sizeof(addr))); +#endif + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Get the file name from a Unix socket address. */ +POLYUNSIGNED PolyNetworkUnixSockAddrToPath(FirstArgument threadId, PolyWord arg) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { +#if (defined(_WIN32) && ! defined(__CYGWIN__)) + /* Not implemented. */ + raise_syscall(taskData, "Unix addresses not implemented", WSAEAFNOSUPPORT); +#else + PolyStringObject* psAddr = (PolyStringObject*)arg.AsObjPtr(); + struct sockaddr_un* psock = (struct sockaddr_un*) & psAddr->chars; + result = SAVE(C_string_to_Poly(taskData, psock->sun_path)); +#endif + } + catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetServByName(PolyObject *threadId, PolyWord serviceName) +POLYUNSIGNED PolyNetworkGetServByName(FirstArgument threadId, PolyWord serviceName) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); /* Get service given service name only. */ TempCString servName(Poly_string_to_C_alloc(serviceName)); struct servent *serv = getservbyname (servName, NULL); // If this fails the ML function returns NONE Handle result = serv == NULL ? 0 : makeServEntry(taskData, serv); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetServByNameAndProtocol(PolyObject *threadId, PolyWord serviceName, PolyWord protName) +POLYUNSIGNED PolyNetworkGetServByNameAndProtocol(FirstArgument threadId, PolyWord serviceName, PolyWord protName) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); /* Get service given service name and protocol name. */ TempCString servName(Poly_string_to_C_alloc(serviceName)); TempCString protoName(Poly_string_to_C_alloc(protName)); struct servent *serv = getservbyname (servName, protoName); Handle result = serv == NULL ? 0 : makeServEntry(taskData, serv); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetServByPort(PolyObject *threadId, PolyWord portNo) +POLYUNSIGNED PolyNetworkGetServByPort(FirstArgument threadId, PolyWord portNo) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); /* Get service given port number only. */ long port = htons(get_C_ushort(taskData, portNo)); struct servent *serv = getservbyport(port, NULL); Handle result = serv == NULL ? 0 : makeServEntry(taskData, serv); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetServByPortAndProtocol(PolyObject *threadId, PolyWord portNo, PolyWord protName) +POLYUNSIGNED PolyNetworkGetServByPortAndProtocol(FirstArgument threadId, PolyWord portNo, PolyWord protName) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); /* Get service given port number and protocol name. */ long port = htons(get_C_ushort(taskData, portNo)); TempCString protoName(Poly_string_to_C_alloc(protName)); struct servent *serv = getservbyport (port, protoName); Handle result = serv == NULL ? 0 : makeServEntry(taskData, serv); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetProtByName(PolyObject *threadId, PolyWord protocolName) +POLYUNSIGNED PolyNetworkGetProtByName(FirstArgument threadId, PolyWord protocolName) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); /* Look up protocol entry. */ TempCString protoName(Poly_string_to_C_alloc(protocolName)); struct protoent *proto = getprotobyname(protoName); // If this fails the ML function returns NONE Handle result = proto == NULL ? 0 : makeProtoEntry(taskData, proto); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetProtByNo(PolyObject *threadId, PolyWord protoNo) +POLYUNSIGNED PolyNetworkGetProtByNo(FirstArgument threadId, PolyWord protoNo) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); /* Look up protocol entry. */ int pNum = get_C_int(taskData, protoNo); struct protoent *proto = getprotobynumber(pNum); Handle result = proto == NULL ? 0 : makeProtoEntry(taskData, proto); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetHostName(PolyObject *threadId) +POLYUNSIGNED PolyNetworkGetHostName(FirstArgument threadId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { /* Get the current host name. */ - size_t size = 4096; - TempCString hostName((char *)malloc(size)); - if (hostName == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); - int err; - while ((err = gethostname(hostName, size)) != 0 && GETERROR == ENAMETOOLONG) - { - if (size > std::numeric_limits::max() / 2) raise_fail(taskData, "gethostname needs too large a buffer"); - size *= 2; - char *new_buf = (char *)realloc(hostName, size); - if (new_buf == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); - hostName = new_buf; - } - + // Since the maximum length of a FQDN is 256 bytes it should fit in the buffer. +#ifdef HOST_NAME_MAX + char hostName[HOST_NAME_MAX+1]; +#else + char hostName[1024]; +#endif + int err = gethostname(hostName, sizeof(hostName)); if (err != 0) raise_syscall(taskData, "gethostname failed", GETERROR); + // Add a null at the end just in case. See gethostname man page. + hostName[sizeof(hostName) - 1] = 0; result = SAVE(C_string_to_Poly(taskData, hostName)); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetHostByName(PolyObject *threadId, PolyWord hName) +POLYUNSIGNED PolyNetworkGetNameInfo(FirstArgument threadId, PolyWord sockAddr) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); + Handle result = 0; - /* Look up a host name. */ - TempCString hostName(Poly_string_to_C_alloc(hName)); - struct hostent *host = gethostbyname(hostName); - // If this fails the ML function returns NONE - Handle result = host == NULL ? 0 : makeHostEntry(taskData, host); + try { + PolyStringObject* psAddr = (PolyStringObject*)sockAddr.AsObjPtr(); + struct sockaddr* psock = (struct sockaddr*) & psAddr->chars; + // Since the maximum length of a FQDN is 256 bytes it should fit in the buffer. + char hostName[1024]; + int gniRes = getnameinfo(psock, (socklen_t)psAddr->length, hostName, sizeof(hostName), NULL, 0, 0); + if (gniRes != 0) + { +#if (defined(_WIN32) && ! defined(__CYGWIN__)) + raise_syscall(taskData, "getnameinfo failed", GETERROR); +#else + if (gniRes == EAI_SYSTEM) + raise_syscall(taskData, "getnameinfo failed", GETERROR); + else raise_syscall(taskData, gai_strerror(gniRes), 0); +#endif + } + result = SAVE(C_string_to_Poly(taskData, hostName)); + } + catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetHostByAddr(PolyObject *threadId, PolyWord hostAddr) +// Copy addrInfo data into ML memory. We copy this although most of it +// is currently unused. +static Handle extractAddrInfo(TaskData *taskData, struct addrinfo *ainfo) +{ + if (ainfo == 0) + return taskData->saveVec.push(ListNull); + + Handle reset = taskData->saveVec.mark(); + Handle tail = extractAddrInfo(taskData, ainfo->ai_next); + Handle name = 0; + // Only the first entry may have a canonical name. + if (ainfo->ai_canonname == 0) + name = taskData->saveVec.push(C_string_to_Poly(taskData, "")); + else name = taskData->saveVec.push(C_string_to_Poly(taskData, ainfo->ai_canonname)); + + Handle address = taskData->saveVec.push(C_string_to_Poly(taskData, (char*)ainfo->ai_addr, ainfo->ai_addrlen)); + + Handle value = alloc_and_save(taskData, 6); + value->WordP()->Set(0, TAGGED(ainfo->ai_flags)); + value->WordP()->Set(1, TAGGED(ainfo->ai_family)); + value->WordP()->Set(2, TAGGED(ainfo->ai_socktype)); + value->WordP()->Set(3, TAGGED(ainfo->ai_protocol)); + value->WordP()->Set(4, address->Word()); + value->WordP()->Set(5, name->Word()); + + ML_Cons_Cell *next = (ML_Cons_Cell*)alloc(taskData, SIZEOF(ML_Cons_Cell)); + next->h = value->Word(); + next->t = tail->Word(); + + taskData->saveVec.reset(reset); + return taskData->saveVec.push(next); +} + +POLYUNSIGNED PolyNetworkGetAddrInfo(FirstArgument threadId, PolyWord hName, PolyWord addrFamily) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); + Handle result = 0; + struct addrinfo *resAddr = 0; + + try { + TempCString hostName(Poly_string_to_C_alloc(hName)); + struct addrinfo hints; + memset(&hints, 0, sizeof(hints)); + hints.ai_family = (int)UNTAGGED(addrFamily); // AF_INET or AF_INET6 or, possibly, AF_UNSPEC. + hints.ai_flags = AI_CANONNAME; + + int gaiRes = getaddrinfo(hostName, 0, &hints, &resAddr); + if (gaiRes != 0) + { +#if (defined(_WIN32) && ! defined(__CYGWIN__)) + raise_syscall(taskData, "getaddrinfo failed", GETERROR); +#else + if (gaiRes == EAI_SYSTEM) + raise_syscall(taskData, "getnameinfo failed", GETERROR); + else raise_syscall(taskData, gai_strerror(gaiRes), 0); +#endif + } + + result = extractAddrInfo(taskData, resAddr); + } + catch (...) { } // Could raise an exception if we run out of heap space - /* Look up entry by address. */ - unsigned long addr = htonl(get_C_unsigned(taskData, hostAddr)); - /* Look up a host name given an address. */ - struct hostent *host = gethostbyaddr((char*)&addr, sizeof(addr), AF_INET); - Handle result = host == NULL ? 0 : makeHostEntry(taskData, host); + if (resAddr) freeaddrinfo(resAddr); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkCloseSocket(PolyObject *threadId, PolyWord strm) +POLYUNSIGNED PolyNetworkCloseSocket(FirstArgument threadId, PolyWord strm) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; Handle pushedStream = taskData->saveVec.push(strm); try { // This is defined to raise an exception if the socket has already been closed #if (defined(_WIN32)) WinSocket *winskt = *(WinSocket**)(pushedStream->WordP()); if (winskt != 0) { if (closesocket(winskt->getSocket()) != 0) raise_syscall(taskData, "Error during close", GETERROR); } else raise_syscall(taskData, "Socket is closed", WSAEBADF); *(WinSocket **)(pushedStream->WordP()) = 0; // Mark as closed #else int descr = getStreamFileDescriptorWithoutCheck(pushedStream->Word()); if (descr >= 0) { if (close(descr) != 0) raise_syscall(taskData, "Error during close", GETERROR); } else raise_syscall(taskData, "Socket is closed", EBADF); *(int*)(pushedStream->WordP()) = 0; // Mark as closed #endif result = Make_fixed_precision(taskData, 0); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } +// Return the family +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetFamilyFromAddress(PolyWord sockAddress) +{ + PolyStringObject* psAddr = (PolyStringObject*)sockAddress.AsObjPtr(); + struct sockaddr* psock = (struct sockaddr*) & psAddr->chars; + return TAGGED(psock->sa_family).AsUnsigned(); +} + +// Return internet address and port from an internet socket address. +// Assumes that we've already checked the address family. +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddressAndPortFromIP4(FirstArgument threadId, PolyWord sockAddress) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + PolyStringObject* psAddr = (PolyStringObject*)sockAddress.AsObjPtr(); + struct sockaddr_in* psock = (struct sockaddr_in*) & psAddr->chars; + Handle ipAddr = Make_arbitrary_precision(taskData, ntohl(psock->sin_addr.s_addr)); // IPv4 addr is LargeInt.int + result = alloc_and_save(taskData, 2); + result->WordP()->Set(0, ipAddr->Word()); + result->WordP()->Set(1, TAGGED(ntohs(psock->sin_port))); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +// Create a socket address from a port number and internet address. +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateIP4Address(FirstArgument threadId, PolyWord ip4Address, PolyWord portNumber) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + struct sockaddr_in sockaddr; + memset(&sockaddr, 0, sizeof(sockaddr)); + sockaddr.sin_family = AF_INET; + sockaddr.sin_port = htons(get_C_ushort(taskData, portNumber)); + sockaddr.sin_addr.s_addr = htonl(get_C_unsigned(taskData, ip4Address)); + result = SAVE(C_string_to_Poly(taskData, (char*)&sockaddr, sizeof(sockaddr))); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +// Return the value of INADDR_ANY. +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReturnIP4AddressAny(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + result = Make_arbitrary_precision(taskData, INADDR_ANY); // IPv4 addr is LargeInt.int + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddressAndPortFromIP6(FirstArgument threadId, PolyWord sockAddress) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + PolyStringObject* psAddr = (PolyStringObject*)sockAddress.AsObjPtr(); + if (psAddr->length != sizeof(struct sockaddr_in6)) + raise_fail(taskData, "Invalid length"); + struct sockaddr_in6* psock = (struct sockaddr_in6*) & psAddr->chars; + Handle ipAddr = SAVE(C_string_to_Poly(taskData, (const char*)&psock->sin6_addr, sizeof(struct in6_addr))); + result = alloc_and_save(taskData, 2); + result->WordP()->Set(0, ipAddr->Word()); + result->WordP()->Set(1, TAGGED(ntohs(psock->sin6_port))); + + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateIP6Address(FirstArgument threadId, PolyWord ip6Address, PolyWord portNumber) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + struct sockaddr_in6 addr; + memset(&addr, 0, sizeof(addr)); + result = SAVE(C_string_to_Poly(taskData, (const char*)&addr, sizeof(struct in6_addr))); + addr.sin6_family = AF_INET6; + addr.sin6_port = htons(get_C_ushort(taskData, portNumber)); + PolyStringObject* addrAsString = (PolyStringObject*)ip6Address.AsObjPtr(); + if (addrAsString->length != sizeof(addr.sin6_addr)) + raise_fail(taskData, "Invalid address length"); + memcpy(&addr.sin6_addr, addrAsString->chars, sizeof(addr.sin6_addr)); + result = SAVE(C_string_to_Poly(taskData, (char*)&addr, sizeof(addr))); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReturnIP6AddressAny(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + result = SAVE(C_string_to_Poly(taskData, (const char*)&in6addr_any, sizeof(struct in6_addr))); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +// Convert an IPV6 address to string. This could be done in ML but the rules +// for converting zeros to double-colon are complicated. +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkIP6AddressToString(FirstArgument threadId, PolyWord ip6Address) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + char buffer[80]; // 40 should actually be enough: 32 hex bytes, 7 colons and a null. + PolyStringObject* addrAsString = (PolyStringObject*)ip6Address.AsObjPtr(); + if (addrAsString->length != sizeof(struct in6_addr)) + raise_fail(taskData, "Invalid address length"); + if (inet_ntop(AF_INET6, addrAsString->chars, buffer, sizeof(buffer)) == 0) + raise_syscall(taskData, "inet_ntop", GETERROR); + result = SAVE(C_string_to_Poly(taskData, buffer)); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +// Convert a string to an IPv6 address. The parsing has to be done in ML. +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkStringToIP6Address(FirstArgument threadId, PolyWord stringRep) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + struct in6_addr address; + TempCString stringAddr(Poly_string_to_C_alloc(stringRep)); + if (inet_pton(AF_INET6, stringAddr, &address) != 1) + raise_fail(taskData, "Invalid IPv6 address"); + result = taskData->saveVec.push(C_string_to_Poly(taskData, (const char *)&address, sizeof(struct in6_addr))); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + struct _entrypts networkingEPT[] = { - { "PolyNetworkGeneral", (polyRTSFunction)&PolyNetworkGeneral}, + { "PolyNetworkGetAddrList", (polyRTSFunction)&PolyNetworkGetAddrList}, + { "PolyNetworkGetSockTypeList", (polyRTSFunction)&PolyNetworkGetSockTypeList}, + { "PolyNetworkCreateSocket", (polyRTSFunction)&PolyNetworkCreateSocket}, + { "PolyNetworkSetOption", (polyRTSFunction)&PolyNetworkSetOption}, + { "PolyNetworkGetOption", (polyRTSFunction)&PolyNetworkGetOption}, + { "PolyNetworkSetLinger", (polyRTSFunction)&PolyNetworkSetLinger}, + { "PolyNetworkGetLinger", (polyRTSFunction)&PolyNetworkGetLinger}, + { "PolyNetworkGetPeerName", (polyRTSFunction)&PolyNetworkGetPeerName}, + { "PolyNetworkGetSockName", (polyRTSFunction)&PolyNetworkGetSockName}, + { "PolyNetworkBytesAvailable", (polyRTSFunction)&PolyNetworkBytesAvailable}, + { "PolyNetworkGetAtMark", (polyRTSFunction)&PolyNetworkGetAtMark}, + { "PolyNetworkBind", (polyRTSFunction)&PolyNetworkBind}, + { "PolyNetworkListen", (polyRTSFunction)&PolyNetworkListen}, + { "PolyNetworkShutdown", (polyRTSFunction)&PolyNetworkShutdown}, + { "PolyNetworkCreateSocketPair", (polyRTSFunction)&PolyNetworkCreateSocketPair}, + { "PolyNetworkUnixPathToSockAddr", (polyRTSFunction)&PolyNetworkUnixPathToSockAddr}, + { "PolyNetworkUnixSockAddrToPath", (polyRTSFunction)&PolyNetworkUnixSockAddrToPath}, { "PolyNetworkGetServByName", (polyRTSFunction)&PolyNetworkGetServByName}, { "PolyNetworkGetServByNameAndProtocol", (polyRTSFunction)&PolyNetworkGetServByNameAndProtocol}, { "PolyNetworkGetServByPort", (polyRTSFunction)&PolyNetworkGetServByPort}, { "PolyNetworkGetServByPortAndProtocol", (polyRTSFunction)&PolyNetworkGetServByPortAndProtocol}, { "PolyNetworkGetProtByName", (polyRTSFunction)&PolyNetworkGetProtByName}, { "PolyNetworkGetProtByNo", (polyRTSFunction)&PolyNetworkGetProtByNo}, { "PolyNetworkGetHostName", (polyRTSFunction)&PolyNetworkGetHostName}, - { "PolyNetworkGetHostByName", (polyRTSFunction)&PolyNetworkGetHostByName}, - { "PolyNetworkGetHostByAddr", (polyRTSFunction)&PolyNetworkGetHostByAddr}, + { "PolyNetworkGetNameInfo", (polyRTSFunction)&PolyNetworkGetNameInfo}, { "PolyNetworkCloseSocket", (polyRTSFunction)&PolyNetworkCloseSocket }, + { "PolyNetworkSelect", (polyRTSFunction)&PolyNetworkSelect }, + { "PolyNetworkGetSocketError", (polyRTSFunction)&PolyNetworkGetSocketError }, + { "PolyNetworkConnect", (polyRTSFunction)&PolyNetworkConnect }, + { "PolyNetworkAccept", (polyRTSFunction)&PolyNetworkAccept }, + { "PolyNetworkSend", (polyRTSFunction)&PolyNetworkSend }, + { "PolyNetworkSendTo", (polyRTSFunction)&PolyNetworkSendTo }, + { "PolyNetworkReceive", (polyRTSFunction)&PolyNetworkReceive }, + { "PolyNetworkReceiveFrom", (polyRTSFunction)&PolyNetworkReceiveFrom }, + { "PolyNetworkGetAddrInfo", (polyRTSFunction)&PolyNetworkGetAddrInfo }, + { "PolyNetworkGetFamilyFromAddress", (polyRTSFunction)&PolyNetworkGetFamilyFromAddress }, + { "PolyNetworkGetAddressAndPortFromIP4", (polyRTSFunction)&PolyNetworkGetAddressAndPortFromIP4 }, + { "PolyNetworkCreateIP4Address", (polyRTSFunction)&PolyNetworkCreateIP4Address }, + { "PolyNetworkReturnIP4AddressAny", (polyRTSFunction)&PolyNetworkReturnIP4AddressAny }, + { "PolyNetworkGetAddressAndPortFromIP6", (polyRTSFunction)&PolyNetworkGetAddressAndPortFromIP6 }, + { "PolyNetworkCreateIP6Address", (polyRTSFunction)&PolyNetworkCreateIP6Address }, + { "PolyNetworkReturnIP6AddressAny", (polyRTSFunction)&PolyNetworkReturnIP4AddressAny }, + { "PolyNetworkIP6AddressToString", (polyRTSFunction)&PolyNetworkIP6AddressToString }, + { "PolyNetworkStringToIP6Address", (polyRTSFunction)&PolyNetworkStringToIP6Address }, { NULL, NULL} // End of list. }; class Networking: public RtsModule { public: virtual void Init(void); virtual void Stop(void); }; // Declare this. It will be automatically added to the table. static Networking networkingModule; void Networking::Init(void) { #if (defined(_WIN32)) #define WINSOCK_MAJOR_VERSION 2 #define WINSOCK_MINOR_VERSION 2 WSADATA wsaData; WORD wVersion = MAKEWORD(WINSOCK_MINOR_VERSION, WINSOCK_MAJOR_VERSION); /* Initialise the system and check that the version it supplied is the one we requested. */ if(WSAStartup(wVersion, &wsaData) == 0) { if (wsaData.wVersion == wVersion) winsock_init = 1; else WSACleanup(); } #endif } void Networking::Stop(void) { #if (defined(_WIN32)) if (winsock_init) WSACleanup(); winsock_init = 0; #endif } diff --git a/libpolyml/objsize.cpp b/libpolyml/objsize.cpp index ec2892ac..a39dc18d 100644 --- a/libpolyml/objsize.cpp +++ b/libpolyml/objsize.cpp @@ -1,432 +1,432 @@ /* Title: Object size Copyright (c) 2000 Cambridge University Technical Services Limited Further development David C.J. Matthews 2016, 2017 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #include "globals.h" #include "arb.h" #include "run_time.h" #include "machine_dep.h" #include "objsize.h" #include "scanaddrs.h" #include "polystring.h" #include "save_vec.h" #include "bitmap.h" #include "memmgr.h" #include "mpoly.h" #include "processes.h" #include "rtsentry.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyObjSize(PolyObject *threadId, PolyWord obj); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyShowSize(PolyObject *threadId, PolyWord obj); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyObjProfile(PolyObject *threadId, PolyWord obj); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyObjSize(FirstArgument threadId, PolyWord obj); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyShowSize(FirstArgument threadId, PolyWord obj); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyObjProfile(FirstArgument threadId, PolyWord obj); } extern FILE *polyStdout; #define MAX_PROF_LEN 100 // Profile lengths between 1 and this class ProcessVisitAddresses: public ScanAddress { public: virtual POLYUNSIGNED ScanAddressAt(PolyWord *pt) { return ShowWord(*pt); } virtual POLYUNSIGNED ScanCodeAddressAt(PolyObject **pt) { return ShowObject(*pt); } virtual PolyObject *ScanObjectAddress(PolyObject *base); POLYUNSIGNED ShowWord(PolyWord w) { if (w.IsTagged() || w == PolyWord::FromUnsigned(0)) return 0; else return ShowObject(w.AsObjPtr()); } POLYUNSIGNED ShowObject(PolyObject *p); ProcessVisitAddresses(bool show); ~ProcessVisitAddresses(); VisitBitmap *FindBitmap(PolyWord p); void ShowBytes(PolyObject *start); void ShowCode(PolyObject *start); void ShowWords(PolyObject *start); POLYUNSIGNED total_length; bool show_size; VisitBitmap **bitmaps; unsigned nBitmaps; // Counts of objects of each size for mutable and immutable data. unsigned iprofile[MAX_PROF_LEN+1]; unsigned mprofile[MAX_PROF_LEN+1]; }; ProcessVisitAddresses::ProcessVisitAddresses(bool show) { // Need to get the allocation lock here. Another thread // could allocate new local areas resulting in gMem.nlSpaces // and gMem.lSpaces changing under our feet. PLocker lock(&gMem.allocLock); total_length = 0; show_size = show; // Create a bitmap for each of the areas apart from the IO area nBitmaps = (unsigned)(gMem.lSpaces.size()+gMem.pSpaces.size()+gMem.cSpaces.size()); // bitmaps = new VisitBitmap*[nBitmaps]; unsigned bm = 0; for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { MemSpace *space = *i; // Permanent areas are filled with objects from the bottom. bitmaps[bm++] = new VisitBitmap(space->bottom, space->top); } for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *space = *i; bitmaps[bm++] = new VisitBitmap(space->bottom, space->top); } for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { CodeSpace *space = *i; bitmaps[bm++] = new VisitBitmap(space->bottom, space->top); } ASSERT(bm == nBitmaps); // Clear the profile counts. for (unsigned i = 0; i < MAX_PROF_LEN+1; i++) { iprofile[i] = mprofile[i] = 0; } } ProcessVisitAddresses::~ProcessVisitAddresses() { if (bitmaps) { for (unsigned i = 0; i < nBitmaps; i++) delete(bitmaps[i]); delete[](bitmaps); } } // Return the bitmap corresponding to the address or NULL if it isn't there. VisitBitmap *ProcessVisitAddresses::FindBitmap(PolyWord p) { for (unsigned i = 0; i < nBitmaps; i++) { VisitBitmap *bm = bitmaps[i]; if (bm->InRange(p.AsStackAddr())) return bm; } return 0; } void ProcessVisitAddresses::ShowBytes(PolyObject *start) { POLYUNSIGNED bytes = start->Length() * sizeof(PolyWord); char *array = (char *) start; putc('\n', polyStdout); if (start->IsMutable()) fprintf(polyStdout, "MUTABLE "); fprintf(polyStdout, "BYTES:%p:%" POLYUFMT "\n", array, bytes); POLYUNSIGNED i, n; for (i = 0, n = 0; n < bytes; n++) { fprintf(polyStdout, "%02x ",array[n] & 0xff); i++; if (i == 16) { putc('\n', polyStdout); i = 0; } } if (i != 0) putc('\n', polyStdout); } #define MAXNAME 500 void ProcessVisitAddresses::ShowCode(PolyObject *start) { POLYUNSIGNED length = start->Length(); putc('\n', polyStdout); if (start->IsMutable()) fprintf(polyStdout, "MUTABLE "); char buffer[MAXNAME+1]; PolyWord *consts = start->ConstPtrForCode(); PolyWord string = consts[0]; if (string == TAGGED(0)) strcpy(buffer, ""); else (void) Poly_string_to_C(string, buffer, sizeof(buffer)); fprintf(polyStdout, "CODE:%p:%" POLYUFMT " %s\n", start, length, buffer); POLYUNSIGNED i, n; for (i = 0, n = 0; n < length; n++) { if (i != 0) putc('\t', polyStdout); fprintf(polyStdout, "%8p ", start->Get(n).AsObjPtr()); i++; if (i == 4) { putc('\n', polyStdout); i = 0; } } if (i != 0) putc('\n', polyStdout); } void ProcessVisitAddresses::ShowWords(PolyObject *start) { POLYUNSIGNED length = start->Length(); putc('\n', polyStdout); if (start->IsMutable()) fprintf(polyStdout, "MUTABLE "); fprintf(polyStdout, "%s:%p:%" POLYUFMT "\n", start->IsClosureObject() ? "CLOSURE" : "WORDS", start, length); POLYUNSIGNED i, n; for (i = 0, n = 0; n < length; ) { if (i != 0) putc('\t', polyStdout); if (start->IsClosureObject() && n == 0) { fprintf(polyStdout, "%8p ", *(PolyObject**)start); n += sizeof(PolyObject*) / sizeof(PolyWord); } else { PolyWord p = start->Get(n); if (p.IsTagged()) fprintf(polyStdout, "%08" POLYUFMT " ", p.AsUnsigned()); else fprintf(polyStdout, "%8p ", p.AsObjPtr()); n++; } i++; if (i == 4) { putc('\n', polyStdout); i = 0; } } if (i != 0) putc('\n', polyStdout); } // This is called initially to print the top-level object. // Since we don't process stacks it probably doesn't get called elsewhere. PolyObject *ProcessVisitAddresses::ScanObjectAddress(PolyObject *base) { POLYUNSIGNED lengthWord = ShowWord(base); if (lengthWord) ScanAddressesInObject(base, lengthWord); return base; } // Handle the normal case. Print the object at this word and // return true is it must be handled recursively. POLYUNSIGNED ProcessVisitAddresses::ShowObject(PolyObject *p) { VisitBitmap *bm = FindBitmap(p); if (bm == 0) { fprintf(polyStdout, "Bad address " ZERO_X "%p found\n", p); return 0; } /* Have we already visited this object? */ if (bm->AlreadyVisited(p)) return 0; bm->SetVisited(p); POLYUNSIGNED obj_length = p->Length(); // Increment the appropriate size profile count. if (p->IsMutable()) { if (obj_length > MAX_PROF_LEN) mprofile[MAX_PROF_LEN]++; else mprofile[obj_length]++; } else { if (obj_length > MAX_PROF_LEN) iprofile[MAX_PROF_LEN]++; else iprofile[obj_length]++; } total_length += obj_length + 1; /* total space needed for object */ if (p->IsByteObject()) { if (show_size) ShowBytes(p); return 0; } else if (p->IsCodeObject()) { PolyWord *cp; POLYUNSIGNED const_count; p->GetConstSegmentForCode(cp, const_count); if (show_size) ShowCode(p); return p->LengthWord(); // Process addresses in it. } else // Word or closure object { if (show_size) ShowWords(p); return p->LengthWord(); // Process addresses in it. } } Handle ObjSize(TaskData *taskData, Handle obj) { ProcessVisitAddresses process(false); process.ScanObjectAddress(obj->WordP()); return Make_arbitrary_precision(taskData, process.total_length); } Handle ShowSize(TaskData *taskData, Handle obj) { ProcessVisitAddresses process(true); process.ScanObjectAddress(obj->WordP()); fflush(polyStdout); /* We need this for Windows at least. */ return Make_arbitrary_precision(taskData, process.total_length); } static void printfprof(unsigned *counts) { for(unsigned i = 0; i < MAX_PROF_LEN+1; i++) { if (counts[i] != 0) { if (i == MAX_PROF_LEN) fprintf(polyStdout, ">%d\t%u\n", MAX_PROF_LEN, counts[i]); else fprintf(polyStdout, "%d\t%u\n", i, counts[i]); } } } -POLYUNSIGNED PolyObjSize(PolyObject *threadId, PolyWord obj) +POLYUNSIGNED PolyObjSize(FirstArgument threadId, PolyWord obj) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); ProcessVisitAddresses process(false); if (!obj.IsTagged()) process.ScanObjectAddress(obj.AsObjPtr()); Handle result = Make_arbitrary_precision(taskData, process.total_length); taskData->PostRTSCall(); return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyShowSize(PolyObject *threadId, PolyWord obj) +POLYUNSIGNED PolyShowSize(FirstArgument threadId, PolyWord obj) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); ProcessVisitAddresses process(true); if (!obj.IsTagged()) process.ScanObjectAddress(obj.AsObjPtr()); fflush(polyStdout); /* We need this for Windows at least. */ Handle result = Make_arbitrary_precision(taskData, process.total_length); taskData->PostRTSCall(); return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyObjProfile(PolyObject *threadId, PolyWord obj) +POLYUNSIGNED PolyObjProfile(FirstArgument threadId, PolyWord obj) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); ProcessVisitAddresses process(false); if (!obj.IsTagged()) process.ScanObjectAddress(obj.AsObjPtr()); fprintf(polyStdout, "\nImmutable object sizes and counts\n"); printfprof(process.iprofile); fprintf(polyStdout, "\nMutable object sizes and counts\n"); printfprof(process.mprofile); fflush(polyStdout); /* We need this for Windows at least. */ Handle result = Make_arbitrary_precision(taskData, process.total_length); taskData->PostRTSCall(); return result->Word().AsUnsigned(); } struct _entrypts objSizeEPT[] = { { "PolyObjSize", (polyRTSFunction)&PolyObjSize}, { "PolyShowSize", (polyRTSFunction)&PolyShowSize}, { "PolyObjProfile", (polyRTSFunction)&PolyObjProfile}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/pexport.cpp b/libpolyml/pexport.cpp index 6af4918c..b9978e81 100644 --- a/libpolyml/pexport.cpp +++ b/libpolyml/pexport.cpp @@ -1,823 +1,822 @@ /* Title: Export and import memory in a portable format Author: David C. J. Matthews. Copyright (c) 2006-7, 2015-8 David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR H PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #include "globals.h" #include "pexport.h" #include "machine_dep.h" #include "scanaddrs.h" #include "run_time.h" #include "../polyexports.h" #include "version.h" #include "sys.h" #include "polystring.h" #include "memmgr.h" #include "rtsentry.h" #include "mpoly.h" // For polyStderr /* This file contains the code both to export the file and to import it in a new session. */ PExport::PExport() { } PExport::~PExport() { } // Get the index corresponding to an address. size_t PExport::getIndex(PolyObject *p) { // Binary chop to find the index from the address. size_t lower = 0, upper = pMap.size(); while (1) { ASSERT(lower < upper); size_t middle = (lower+upper)/2; ASSERT(middle < pMap.size()); if (p < pMap[middle]) { // Use lower to middle upper = middle; } else if (p > pMap[middle]) { // Use middle+1 to upper lower = middle+1; } else // Found it return middle; } } /* Get the index corresponding to an address. */ void PExport::printAddress(void *p) { fprintf(exportFile, "@%" PRI_SIZET "", getIndex((PolyObject*)p)); } void PExport::printValue(PolyWord q) { if (IS_INT(q) || q == PolyWord::FromUnsigned(0)) fprintf(exportFile, "%" POLYSFMT, UNTAGGED(q)); else printAddress(q.AsAddress()); } void PExport::printObject(PolyObject *p) { POLYUNSIGNED length = p->Length(); POLYUNSIGNED i; size_t myIndex = getIndex(p); fprintf(exportFile, "%" PRI_SIZET ":", myIndex); if (p->IsMutable()) putc('M', exportFile); if (OBJ_IS_NEGATIVE(p->LengthWord())) putc('N', exportFile); if (OBJ_IS_WEAKREF_OBJECT(p->LengthWord())) putc('W', exportFile); if (OBJ_IS_NO_OVERWRITE(p->LengthWord())) putc('V', exportFile); if (p->IsByteObject()) { if (p->IsMutable() && p->IsWeakRefObject()) { // This is either an entry point or a weak ref used in the FFI. // Clear the first word if (p->Length() == 1) p->Set(0, PolyWord::FromSigned(0)); // Weak ref else if (p->Length() > 1) *(uintptr_t*)p = 0; // Entry point } /* May be a string, a long format arbitrary precision number or a real number. */ PolyStringObject* ps = (PolyStringObject*)p; /* This is not infallible but it seems to be good enough to detect the strings. */ POLYUNSIGNED bytes = length * sizeof(PolyWord); if (length >= 2 && ps->length <= bytes - sizeof(POLYUNSIGNED) && ps->length > bytes - 2 * sizeof(POLYUNSIGNED)) { /* Looks like a string. */ fprintf(exportFile, "S%" POLYUFMT "|", ps->length); for (unsigned i = 0; i < ps->length; i++) { char ch = ps->chars[i]; fprintf(exportFile, "%02x", ch & 0xff); } } else { /* Not a string. May be an arbitrary precision integer. If the source and destination word lengths differ we could find that some long-format arbitrary precision numbers could be represented in the tagged short form or vice-versa. The former case might give rise to errors because when comparing two arbitrary precision numbers for equality we assume that they are not equal if they have different representation. The latter case could be a problem because we wouldn't know whether to convert the tagged form to long form, which would be correct if the value has type "int" or to truncate it which would be correct for "word". It could also be a real number but that doesn't matter if we recompile everything on the new machine. */ byte *u = (byte*)p; putc('B', exportFile); fprintf(exportFile, "%" PRI_SIZET "|", length*sizeof(PolyWord)); for (unsigned i = 0; i < (unsigned)(length*sizeof(PolyWord)); i++) { fprintf(exportFile, "%02x", u[i]); } } } else if (p->IsCodeObject()) { POLYUNSIGNED constCount, i; PolyWord *cp; ASSERT(! p->IsMutable() ); /* Work out the number of bytes in the code and the number of constants. */ p->GetConstSegmentForCode(cp, constCount); /* The byte count is the length of the segment minus the number of constants minus one for the constant count. It includes the marker word, byte count, profile count and, on the X86/64 at least, any non-address constants. These are actually word values. */ POLYUNSIGNED byteCount = (length - constCount - 1) * sizeof(PolyWord); fprintf(exportFile, "D%" POLYUFMT ",%" POLYUFMT "|", constCount, byteCount); // First the code. byte *u = (byte*)p; for (i = 0; i < byteCount; i++) fprintf(exportFile, "%02x", u[i]); putc('|', exportFile); // Now the constants. for (i = 0; i < constCount; i++) { printValue(cp[i]); if (i < constCount-1) putc(',', exportFile); } putc('|', exportFile); // Finally any constants in the code object. machineDependent->ScanConstantsWithinCode(p, this); } else // Ordinary objects, essentially tuples, or closures. { fprintf(exportFile, "%c%" POLYUFMT "|", p->IsClosureObject() ? 'L' : 'O', length); if (p->IsClosureObject()) { // The first word is always a code address. printAddress(*(PolyObject**)p); i = sizeof(PolyObject*)/sizeof(PolyWord); if (i < length) putc(',', exportFile); } else i = 0; while (i < length) { printValue(p->Get(i)); if (i < length-1) putc(',', exportFile); i++; } } fprintf(exportFile, "\n"); } /* This is called for each constant within the code. Print a relocation entry for the word and return a value that means that the offset is saved in original word. */ void PExport::ScanConstant(PolyObject *base, byte *addr, ScanRelocationKind code) { PolyObject *p = GetConstantValue(addr, code); if (p == 0) return; // Don't put in tagged constants // Put in the byte offset and the relocation type code. POLYUNSIGNED offset = (POLYUNSIGNED)(addr - (byte*)base); ASSERT (offset < base->Length() * sizeof(POLYUNSIGNED)); fprintf(exportFile, "%" POLYUFMT ",%d,", (POLYUNSIGNED)(addr - (byte*)base), code); printAddress(p); // The value to plug in. fprintf(exportFile, " "); } void PExport::exportStore(void) { // We want the entries in pMap to be in ascending // order of address to make searching easy so we need to process the areas // in order of increasing address, which may not be the order in memTable. std::vector indexOrder; indexOrder.reserve(memTableEntries); for (size_t i = 0; i < memTableEntries; i++) { std::vector::iterator it; for (it = indexOrder.begin(); it != indexOrder.end(); it++) { if (memTable[*it].mtOriginalAddr >= memTable[i].mtOriginalAddr) break; } indexOrder.insert(it, i); } // Process the area in order of ascending address. for (std::vector::iterator i = indexOrder.begin(); i != indexOrder.end(); i++) { size_t index = *i; char *start = (char*)memTable[index].mtOriginalAddr; char *end = start + memTable[index].mtLength; for (PolyWord *p = (PolyWord*)start; p < (PolyWord*)end; ) { p++; PolyObject *obj = (PolyObject*)p; POLYUNSIGNED length = obj->Length(); pMap.push_back(obj); p += length; } } /* Start writing the information. */ fprintf(exportFile, "Objects\t%" PRI_SIZET "\n", pMap.size()); fprintf(exportFile, "Root\t%" PRI_SIZET "\n", getIndex(rootFunction)); // Generate each of the areas. for (size_t i = 0; i < memTableEntries; i++) { char *start = (char*)memTable[i].mtOriginalAddr; char *end = start + memTable[i].mtLength; for (PolyWord *p = (PolyWord*)start; p < (PolyWord*)end; ) { p++; PolyObject *obj = (PolyObject*)p; POLYUNSIGNED length = obj->Length(); #ifdef POLYML32IN64 // We may have filler cells to get the alignment right. // We mustn't try to print them. if (((uintptr_t)obj & 4) != 0 && length == 0) continue; #endif printObject(obj); p += length; } } fclose(exportFile); exportFile = NULL; } /* Import a portable export file and load it into memory. Creates "permanent" address entries in the global memory table. */ class SpaceAlloc { public: SpaceAlloc(unsigned *indexCtr, unsigned perms, POLYUNSIGNED def); PolyObject *NewObj(POLYUNSIGNED objWords); size_t defaultSize; PermanentMemSpace *memSpace; size_t used; unsigned permissions; unsigned *spaceIndexCtr; }; SpaceAlloc::SpaceAlloc(unsigned *indexCtr, unsigned perms, POLYUNSIGNED def) { permissions = perms; defaultSize = def; memSpace = 0; used = 0; spaceIndexCtr = indexCtr; } // Allocate a new object. May create a new space and add the old one to the permanent // memory table if this is exhausted. #ifndef POLYML32IN64 PolyObject *SpaceAlloc::NewObj(POLYUNSIGNED objWords) { if (memSpace == 0 || memSpace->spaceSize() - used <= objWords) { // Need some more space. size_t size = defaultSize; if (size <= objWords) size = objWords+1; memSpace = gMem.AllocateNewPermanentSpace(size * sizeof(PolyWord), permissions, *spaceIndexCtr); (*spaceIndexCtr)++; // The memory is writable until CompletePermanentSpaceAllocation is called if (memSpace == 0) { fprintf(polyStderr, "Unable to allocate memory\n"); return 0; } used = 0; } ASSERT(memSpace->spaceSize() - used > objWords); PolyObject *newObj = (PolyObject*)(memSpace->bottom + used+1); used += objWords+1; return newObj; } #else // With 32in64 we need to allocate on 8-byte boundaries. PolyObject *SpaceAlloc::NewObj(POLYUNSIGNED objWords) { size_t rounded = objWords; if ((objWords & 1) == 0) rounded++; if (memSpace == 0 || memSpace->spaceSize() - used <= rounded) { // Need some more space. size_t size = defaultSize; if (size <= rounded) size = rounded + 1; memSpace = gMem.AllocateNewPermanentSpace(size * sizeof(PolyWord), permissions, *spaceIndexCtr); (*spaceIndexCtr)++; // The memory is writable until CompletePermanentSpaceAllocation is called if (memSpace == 0) { fprintf(stderr, "Unable to allocate memory\n"); return 0; } memSpace->bottom[0] = PolyWord::FromUnsigned(0); used = 1; } PolyObject *newObj = (PolyObject*)(memSpace->bottom + used + 1); if (rounded != objWords) newObj->Set(objWords, PolyWord::FromUnsigned(0)); used += rounded + 1; ASSERT(((uintptr_t)newObj & 0x7) == 0); return newObj; } #endif class PImport { public: PImport(); ~PImport(); bool DoImport(void); FILE *f; PolyObject *Root(void) { return objMap[nRoot]; } private: bool ReadValue(PolyObject *p, POLYUNSIGNED i); bool GetValue(PolyWord *result); POLYUNSIGNED nObjects, nRoot; PolyObject **objMap; unsigned spaceIndex; SpaceAlloc mutSpace, immutSpace, codeSpace; }; PImport::PImport(): mutSpace(&spaceIndex, MTF_WRITEABLE, 1024*1024), immutSpace(&spaceIndex, 0, 1024*1024), codeSpace(&spaceIndex, MTF_EXECUTABLE, 1024 * 1024) { f = NULL; objMap = 0; spaceIndex = 1; } PImport::~PImport() { if (f) fclose(f); free(objMap); } bool PImport::GetValue(PolyWord *result) { int ch = getc(f); if (ch == '@') { /* Address of an object. */ POLYUNSIGNED obj; fscanf(f, "%" POLYUFMT, &obj); ASSERT(obj < nObjects); *result = objMap[obj]; } else if ((ch >= '0' && ch <= '9') || ch == '-') { /* Tagged integer. */ POLYSIGNED j; ungetc(ch, f); fscanf(f, "%" POLYSFMT, &j); /* The assertion may be false if we are porting to a machine with a shorter tagged representation. */ ASSERT(j >= -MAXTAGGED-1 && j <= MAXTAGGED); *result = TAGGED(j); } else { fprintf(polyStderr, "Unexpected character in stream"); return false; } return true; } /* Read a value and store it at the specified word. */ bool PImport::ReadValue(PolyObject *p, POLYUNSIGNED i) { PolyWord result = TAGGED(0); if (GetValue(&result)) { p->Set(i, result); return true; } else return false; } bool PImport::DoImport() { int ch; POLYUNSIGNED objNo; ASSERT(gMem.pSpaces.size() == 0); ASSERT(gMem.eSpaces.size() == 0); ch = getc(f); ASSERT(ch == 'O'); /* Number of objects. */ while (getc(f) != '\t') ; fscanf(f, "%" POLYUFMT, &nObjects); /* Create a mapping table. */ objMap = (PolyObject**)calloc(nObjects, sizeof(PolyObject*)); if (objMap == 0) { fprintf(polyStderr, "Unable to allocate memory\n"); return false; } do { ch = getc(f); } while (ch == '\n'); ASSERT(ch == 'R'); /* Root object number. */ while (getc(f) != '\t') ; fscanf(f, "%" POLYUFMT, &nRoot); /* Now the objects themselves. */ while (1) { unsigned objBits = 0; POLYUNSIGNED nWords, nBytes; do { ch = getc(f); } while (ch == '\r' || ch == '\n'); if (ch == EOF) break; ungetc(ch, f); fscanf(f, "%" POLYUFMT, &objNo); ch = getc(f); ASSERT(ch == ':'); ASSERT(objNo < nObjects); /* Modifiers, MNVW. */ do { ch = getc(f); if (ch == 'M') objBits |= F_MUTABLE_BIT; else if (ch == 'N') objBits |= F_NEGATIVE_BIT; if (ch == 'V') objBits |= F_NO_OVERWRITE; if (ch == 'W') objBits |= F_WEAK_BIT; } while (ch == 'M' || ch == 'N' || ch == 'V' || ch == 'W'); /* Object type. */ switch (ch) { case 'O': /* Simple object. */ fscanf(f, "%" POLYUFMT, &nWords); break; case 'B': /* Byte segment. */ objBits |= F_BYTE_OBJ; fscanf(f, "%" POLYUFMT, &nBytes); /* Round up to appropriate number of words. */ nWords = (nBytes + sizeof(PolyWord) -1) / sizeof(PolyWord); break; case 'S': /* String. */ objBits |= F_BYTE_OBJ; /* The length is the number of characters. */ fscanf(f, "%" POLYUFMT, &nBytes); /* Round up to appropriate number of words. Need to add one PolyWord for the length PolyWord. */ nWords = (nBytes + sizeof(PolyWord) -1) / sizeof(PolyWord) + 1; break; case 'C': /* Code segment (old form). */ case 'D': /* Code segment (new form). */ objBits |= F_CODE_OBJ; /* Read the number of bytes of code and the number of words for constants. */ fscanf(f, "%" POLYUFMT ",%" POLYUFMT, &nWords, &nBytes); nWords += ch == 'C' ? 4 : 1; /* Add words for extras. */ /* Add in the size of the code itself. */ nWords += (nBytes + sizeof(PolyWord) -1) / sizeof(PolyWord); break; case 'L': // Closure objBits |= F_CLOSURE_OBJ; fscanf(f, "%" POLYUFMT, &nWords); break; default: fprintf(polyStderr, "Invalid object type\n"); return false; } PolyObject *p; if (objBits & F_MUTABLE_BIT) p = mutSpace.NewObj(nWords); else if ((objBits & 3) == F_CODE_OBJ) p = codeSpace.NewObj(nWords); else p = immutSpace.NewObj(nWords); if (p == 0) return false; objMap[objNo] = p; /* Put in length PolyWord and flag bits. */ p->SetLengthWord(nWords, objBits); /* Skip the object contents. */ while (getc(f) != '\n') ; } /* Second pass - fill in the contents. */ fseek(f, 0, SEEK_SET); /* Skip the information at the start. */ ch = getc(f); ASSERT(ch == 'O'); /* Number of objects. */ while (getc(f) != '\n'); ch = getc(f); ASSERT(ch == 'R'); /* Root object number. */ while (getc(f) != '\n') ; while (1) { if (feof(f)) break; fscanf(f, "%" POLYUFMT, &objNo); if (feof(f)) break; ch = getc(f); ASSERT(ch == ':'); ASSERT(objNo < nObjects); PolyObject * p = objMap[objNo]; /* Modifiers, M or N. */ do { ch = getc(f); } while (ch == 'M' || ch == 'N' || ch == 'V' || ch == 'W'); /* Object type. */ switch (ch) { case 'O': /* Simple object. */ case 'L': // Closure { POLYUNSIGNED nWords; bool isClosure = ch == 'L'; fscanf(f, "%" POLYUFMT, &nWords); ch = getc(f); ASSERT(ch == '|'); ASSERT(nWords == p->Length()); POLYUNSIGNED i = 0; if (isClosure) { int ch = getc(f); // This should be an address if (ch != '@') return false; POLYUNSIGNED obj; fscanf(f, "%" POLYUFMT, &obj); ASSERT(obj < nObjects); *(PolyObject**)p = objMap[obj]; ch = getc(f); i = sizeof(PolyObject*) / sizeof(PolyWord); } while (i < nWords) { if (!ReadValue(p, i)) return false; ch = getc(f); ASSERT((ch == ',' && i < nWords - 1) || (ch == '\n' && i == nWords - 1)); i++; } break; } case 'B': /* Byte segment. */ { byte *u = (byte*)p; POLYUNSIGNED nBytes; fscanf(f, "%" POLYUFMT, &nBytes); ch = getc(f); ASSERT(ch == '|'); for (POLYUNSIGNED i = 0; i < nBytes; i++) { int n; fscanf(f, "%02x", &n); u[i] = n; } ch = getc(f); ASSERT(ch == '\n'); // If this is an entry point object set its value. //if (p->IsMutable() && p->IsWeakRefObject() && p->Length() > 2 && p->Get(2).AsUnsigned() != 0) if (p->IsMutable() && p->IsWeakRefObject() && p->Length() > sizeof(uintptr_t)/sizeof(PolyWord)) { bool loadEntryPt = setEntryPoint(p); ASSERT(loadEntryPt); } break; } case 'S': /* String. */ { PolyStringObject * ps = (PolyStringObject *)p; /* The length is the number of characters. */ POLYUNSIGNED nBytes; fscanf(f, "%" POLYUFMT, &nBytes); ch = getc(f); ASSERT(ch == '|'); ps->length = nBytes; for (POLYUNSIGNED i = 0; i < nBytes; i++) { int n; fscanf(f, "%02x", &n); ps->chars[i] = n; } ch = getc(f); ASSERT(ch == '\n'); break; } case 'C': /* Code segment. */ case 'D': { bool oldForm = ch == 'C'; byte *u = (byte*)p; POLYUNSIGNED length = p->Length(); POLYUNSIGNED nWords, nBytes; /* Read the number of bytes of code and the number of words for constants. */ fscanf(f, "%" POLYUFMT ",%" POLYUFMT, &nWords, &nBytes); /* Read the code. */ ch = getc(f); ASSERT(ch == '|'); for (POLYUNSIGNED i = 0; i < nBytes; i++) { int n; fscanf(f, "%02x", &n); u[i] = n; } - machineDependent->FlushInstructionCache(u, nBytes); ch = getc(f); ASSERT(ch == '|'); /* Set the constant count. */ p->Set(length-1, PolyWord::FromUnsigned(nWords)); if (oldForm) { p->Set(length-1-nWords-1, PolyWord::FromUnsigned(0)); /* Profile count. */ p->Set(length-1-nWords-3, PolyWord::FromUnsigned(0)); /* Marker word. */ p->Set(length-1-nWords-2, PolyWord::FromUnsigned((length-1-nWords-2)*sizeof(PolyWord))); /* Check - the code should end at the marker word. */ ASSERT(nBytes == ((length-1-nWords-3)*sizeof(PolyWord))); } /* Read in the constants. */ for (POLYUNSIGNED i = 0; i < nWords; i++) { if (! ReadValue(p, i+length-nWords-1)) return false; ch = getc(f); ASSERT((ch == ',' && i < nWords-1) || ((ch == '\n' || ch == '|') && i == nWords-1)); } // Read in any constants in the code. if (ch == '|') { ch = getc(f); while (ch != '\n') { ungetc(ch, f); POLYUNSIGNED offset; int code; fscanf(f, "%" POLYUFMT ",%d", &offset, &code); ch = getc(f); ASSERT(ch == ','); // This should be an address. ch = getc(f); if (ch == '@') { POLYUNSIGNED obj; fscanf(f, "%" POLYUFMT, &obj); ASSERT(obj < nObjects); PolyObject *addr = objMap[obj]; byte *toPatch = (byte*)p + offset; ScanAddress::SetConstantValue(toPatch, addr, (ScanRelocationKind)code); } else { // Previously we also included tagged constants but they are // already in the code. ungetc(ch, f); PolyWord w; if (!GetValue(&w)) return false; } do ch = getc(f); while (ch == ' '); } } // Clear the mutable bit p->SetLengthWord(p->Length(), F_CODE_OBJ); break; } default: fprintf(polyStderr, "Invalid object type\n"); return false; } } // Now remove write access from immutable spaces. for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) gMem.CompletePermanentSpaceAllocation(*i); return true; } // Import a file in the portable format and return a pointer to the root object. PolyObject *ImportPortable(const TCHAR *fileName) { PImport pImport; #if (defined(_WIN32) && defined(UNICODE)) pImport.f = _wfopen(fileName, L"r"); if (pImport.f == 0) { fprintf(polyStderr, "Unable to open file: %S\n", fileName); return 0; } #else pImport.f = fopen(fileName, "r"); if (pImport.f == 0) { fprintf(polyStderr, "Unable to open file: %s\n", fileName); return 0; } #endif if (pImport.DoImport()) return pImport.Root(); else return 0; } diff --git a/libpolyml/poly_specific.cpp b/libpolyml/poly_specific.cpp index b3e5630b..89c7a8e9 100644 --- a/libpolyml/poly_specific.cpp +++ b/libpolyml/poly_specific.cpp @@ -1,420 +1,447 @@ /* Title: poly_specific.cpp - Poly/ML specific RTS calls. Copyright (c) 2006, 2015-17, 2019 David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ /* This module is used for various run-time calls that are either in the PolyML structure or otherwise specific to Poly/ML. */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_STRING_H #include #endif #include "globals.h" #include "poly_specific.h" #include "arb.h" #include "mpoly.h" #include "sys.h" #include "machine_dep.h" #include "polystring.h" #include "run_time.h" #include "version.h" #include "save_vec.h" #include "version.h" #include "memmgr.h" #include "processes.h" #include "gc.h" #include "rtsentry.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolySpecificGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolySpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetABI(); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableCode(PolyObject * threadId, PolyWord byteSeg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableClosure(PolyObject * threadId, PolyWord closure); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToCode(PolyObject *threadId, PolyWord byteVec); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToClosure(PolyObject *threadId, PolyWord byteVec, PolyWord closure); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableCode(FirstArgument threadId, PolyWord byteSeg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableClosure(FirstArgument threadId, PolyWord closure); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToCode(FirstArgument threadId, PolyWord byteVec); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToClosure(FirstArgument threadId, PolyWord byteVec, PolyWord closure); POLYEXTERNALSYMBOL POLYUNSIGNED PolySetCodeConstant(PolyWord closure, PolyWord offset, PolyWord c, PolyWord flags); POLYEXTERNALSYMBOL POLYUNSIGNED PolySetCodeByte(PolyWord closure, PolyWord offset, PolyWord c); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetCodeByte(PolyWord closure, PolyWord offset); POLYEXTERNALSYMBOL POLYUNSIGNED PolySortArrayOfAddresses(PolyWord array); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest4(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest5(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4, PolyWord arg5); } #define SAVE(x) taskData->saveVec.push(x) #ifndef GIT_VERSION #define GIT_VERSION "" #endif Handle poly_dispatch_c(TaskData *taskData, Handle args, Handle code) { unsigned c = get_C_unsigned(taskData, DEREFWORD(code)); switch (c) { case 9: // Return the GIT version if appropriate { return SAVE(C_string_to_Poly(taskData, GIT_VERSION)); } case 10: // Return the RTS version string. { const char *version; switch (machineDependent->MachineArchitecture()) { case MA_Interpreted: version = "Portable-" TextVersion; break; case MA_I386: version = "I386-" TextVersion; break; case MA_X86_64: version = "X86_64-" TextVersion; break; default: version = "Unknown-" TextVersion; break; } return SAVE(C_string_to_Poly(taskData, version)); } case 12: // Return the architecture // Used in InitialPolyML.ML for PolyML.architecture { const char *arch; switch (machineDependent->MachineArchitecture()) { case MA_Interpreted: arch = "Interpreted"; break; case MA_I386: arch = "I386"; break; case MA_X86_64: arch = "X86_64"; break; case MA_X86_64_32: arch = "X86_64_32"; break; default: arch = "Unknown"; break; } return SAVE(C_string_to_Poly(taskData, arch)); } case 19: // Return the RTS argument help string. return SAVE(C_string_to_Poly(taskData, RTSArgHelp())); default: { char msg[100]; sprintf(msg, "Unknown poly-specific function: %d", c); raise_exception_string(taskData, EXC_Fail, msg); return 0; } } } // General interface to poly-specific. Ideally the various cases will be made into // separate functions. -POLYUNSIGNED PolySpecificGeneral(PolyObject *threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolySpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCode = taskData->saveVec.push(code); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = poly_dispatch_c(taskData, pushedArg, pushedCode); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Return the ABI - i.e. the calling conventions used when calling external functions. POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetABI() { // Return the ABI. For 64-bit we need to know if this is Windows. #if (SIZEOF_VOIDP == 8) #if (defined(_WIN32) || defined(__CYGWIN__)) return TAGGED(2).AsUnsigned(); // 64-bit Windows #else return TAGGED(1).AsUnsigned(); // 64-bit Unix #endif #else return TAGGED(0).AsUnsigned(); // 32-bit Unix and Windows #endif } // Code generation - Code is initially allocated in a byte segment. When all the // values have been set apart from any addresses the byte segment is copied into // a mutable code segment. // PolyCopyByteVecToCode is now replaced by PolyCopyByteVecToClosure -POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToCode(PolyObject * threadId, PolyWord byteVec) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToCode(FirstArgument threadId, PolyWord byteVec) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(byteVec); PolyObject *result = 0; try { if (!pushedArg->WordP()->IsByteObject()) raise_fail(taskData, "Not byte data area"); do { PolyObject *initCell = pushedArg->WordP(); POLYUNSIGNED requiredSize = initCell->Length(); result = gMem.AllocCodeSpace(requiredSize); if (result == 0) { // Could not allocate - must GC. if (!QuickGC(taskData, pushedArg->WordP()->Length())) raise_fail(taskData, "Insufficient memory"); } else memcpy(result, initCell, requiredSize * sizeof(PolyWord)); } while (result == 0); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return ((PolyWord)result).AsUnsigned(); } // Copy the byte vector into code space. -POLYUNSIGNED PolyCopyByteVecToClosure(PolyObject *threadId, PolyWord byteVec, PolyWord closure) +POLYUNSIGNED PolyCopyByteVecToClosure(FirstArgument threadId, PolyWord byteVec, PolyWord closure) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedByteVec = taskData->saveVec.push(byteVec); Handle pushedClosure = taskData->saveVec.push(closure); PolyObject *result = 0; try { if (!pushedByteVec->WordP()->IsByteObject()) raise_fail(taskData, "Not byte data area"); if (pushedClosure->WordP()->Length() != sizeof(PolyObject*)/sizeof(PolyWord)) raise_fail(taskData, "Invalid closure size"); if (!pushedClosure->WordP()->IsMutable()) raise_fail(taskData, "Closure is not mutable"); do { PolyObject *initCell = pushedByteVec->WordP(); POLYUNSIGNED requiredSize = initCell->Length(); result = gMem.AllocCodeSpace(requiredSize); if (result == 0) { // Could not allocate - must GC. if (!QuickGC(taskData, pushedByteVec->WordP()->Length())) raise_fail(taskData, "Insufficient memory"); } else memcpy(result, initCell, requiredSize * sizeof(PolyWord)); } while (result == 0); } catch (...) {} // If an ML exception is raised // Store the code address in the closure. *((PolyObject**)pushedClosure->WordP()) = result; // Lock the closure. pushedClosure->WordP()->SetLengthWord(pushedClosure->WordP()->LengthWord() & ~_OBJ_MUTABLE_BIT); taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } // Code generation - Lock a mutable code segment and return the original address. // Currently this does not allocate so other than the exception it could // be a fast call. -POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableCode(PolyObject * threadId, PolyWord byteSeg) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableCode(FirstArgument threadId, PolyWord byteSeg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(byteSeg); Handle result = 0; try { PolyObject *codeObj = pushedArg->WordP(); if (!codeObj->IsCodeObject() || !codeObj->IsMutable()) raise_fail(taskData, "Not mutable code area"); POLYUNSIGNED segLength = codeObj->Length(); codeObj->SetLengthWord(segLength, F_CODE_OBJ); - // This is really a legacy of the PPC code-generator. - machineDependent->FlushInstructionCache(codeObj, segLength * sizeof(PolyWord)); // In the future it may be necessary to return a different address here. // N.B. The code area should only have execute permission in the native // code version, not the interpreted version. result = pushedArg; // Return the original address. } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Replacement for above -POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableClosure(PolyObject * threadId, PolyWord closure) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableClosure(FirstArgument threadId, PolyWord closure) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); PolyObject *codeObj = *(PolyObject**)(closure.AsObjPtr()); try { if (!codeObj->IsCodeObject() || !codeObj->IsMutable()) raise_fail(taskData, "Not mutable code area"); POLYUNSIGNED segLength = codeObj->Length(); codeObj->SetLengthWord(segLength, F_CODE_OBJ); - // This is really a legacy of the PPC code-generator. - machineDependent->FlushInstructionCache(codeObj, segLength * sizeof(PolyWord)); // In the future it may be necessary to return a different address here. // N.B. The code area should only have execute permission in the native // code version, not the interpreted version. } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } // Set code constant. This can be a fast call. // This is in the RTS both because we pass a closure in here and cannot have // code addresses in 32-in-64 and also because we need to ensure there is no // possibility of a GC while the code is an inconsistent state. POLYUNSIGNED PolySetCodeConstant(PolyWord closure, PolyWord offset, PolyWord cWord, PolyWord flags) { byte *pointer; // Previously we passed the code address in here and we need to // retain that for legacy code. This is now the closure. if (closure.AsObjPtr()->IsCodeObject()) pointer = closure.AsCodePtr(); else pointer = *(POLYCODEPTR*)(closure.AsObjPtr()); // pointer is the start of the code segment. // c will usually be an address. // offset is a byte offset pointer += offset.UnTaggedUnsigned(); switch (UNTAGGED(flags)) { case 0: // Absolute constant - size PolyWord { POLYUNSIGNED c = cWord.AsUnsigned(); #ifdef WORDS_BIGENDIAN // This is used to store constants in the constant area // on the interpreted version. for (unsigned i = sizeof(PolyWord); i > 0; i--) { pointer[i-1] = (byte)(c & 255); c >>= 8; } #else for (unsigned i = 0; i < sizeof(PolyWord); i++) { pointer[i] = (byte)(c & 255); c >>= 8; } #endif break; } case 1: // Relative constant - X86 - size 4 bytes { // The offset is relative to the END of the constant. byte *target; // In 32-in-64 we pass in the closure address here // rather than the code address. if (cWord.AsObjPtr()->IsCodeObject()) target = cWord.AsCodePtr(); else target = *(POLYCODEPTR*)(cWord.AsObjPtr()); size_t c = target - pointer - 4; for (unsigned i = 0; i < sizeof(PolyWord); i++) { pointer[i] = (byte)(c & 255); c >>= 8; } break; } } return TAGGED(0).AsUnsigned(); } // Set a code byte. This needs to be in the RTS because it uses the closure POLYEXTERNALSYMBOL POLYUNSIGNED PolySetCodeByte(PolyWord closure, PolyWord offset, PolyWord cWord) { byte *pointer = *(POLYCODEPTR*)(closure.AsObjPtr()); pointer[UNTAGGED_UNSIGNED(offset)] = (byte)UNTAGGED_UNSIGNED(cWord); return TAGGED(0).AsUnsigned(); } POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetCodeByte(PolyWord closure, PolyWord offset) { byte *pointer = *(POLYCODEPTR*)(closure.AsObjPtr()); return TAGGED(pointer[UNTAGGED_UNSIGNED(offset)]).AsUnsigned(); } static int compare(const void *a, const void *b) { PolyWord *av = (PolyWord*)a; PolyWord *bv = (PolyWord*)b; if ((*av).IsTagged() || (*bv).IsTagged()) return 0; // Shouldn't happen PolyObject *ao = (*av).AsObjPtr(), *bo = (*bv).AsObjPtr(); if (ao->Length() < 1 || bo->Length() < 1) return 0; // Shouldn't happen if (ao->Get(0).AsUnsigned() < bo->Get(0).AsUnsigned()) return -1; if (ao->Get(0).AsUnsigned() > bo->Get(0).AsUnsigned()) return 1; return 0; } // Sort an array of addresses. This is used in the code-generator to search for // duplicates in the address area. The argument is an array of pairs. The first // item of each pair is an address, the second is an identifier of some kind. POLYEXTERNALSYMBOL POLYUNSIGNED PolySortArrayOfAddresses(PolyWord array) { if (!array.IsDataPtr()) return(TAGGED(0)).AsUnsigned(); PolyObject *arrayP = array.AsObjPtr(); POLYUNSIGNED numberOfItems = arrayP->Length(); if (!arrayP->IsMutable()) return(TAGGED(0)).AsUnsigned(); qsort(arrayP, numberOfItems, sizeof(PolyWord), compare); return (TAGGED(1)).AsUnsigned(); } +POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest4(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4) +{ + switch (arg1.UnTaggedUnsigned()) + { + case 1: return arg1.AsUnsigned(); + case 2: return arg2.AsUnsigned(); + case 3: return arg3.AsUnsigned(); + case 4: return arg4.AsUnsigned(); + default: return TAGGED(0).AsUnsigned(); + } +} + +POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest5(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4, PolyWord arg5) +{ + switch (arg1.UnTaggedUnsigned()) + { + case 1: return arg1.AsUnsigned(); + case 2: return arg2.AsUnsigned(); + case 3: return arg3.AsUnsigned(); + case 4: return arg4.AsUnsigned(); + case 5: return arg5.AsUnsigned(); + default: return TAGGED(0).AsUnsigned(); + } + +} + + struct _entrypts polySpecificEPT[] = { { "PolySpecificGeneral", (polyRTSFunction)&PolySpecificGeneral}, { "PolyGetABI", (polyRTSFunction)&PolyGetABI }, { "PolyCopyByteVecToCode", (polyRTSFunction)&PolyCopyByteVecToCode }, { "PolyCopyByteVecToClosure", (polyRTSFunction)&PolyCopyByteVecToClosure }, { "PolyLockMutableCode", (polyRTSFunction)&PolyLockMutableCode }, { "PolyLockMutableClosure", (polyRTSFunction)&PolyLockMutableClosure }, { "PolySetCodeConstant", (polyRTSFunction)&PolySetCodeConstant }, { "PolySetCodeByte", (polyRTSFunction)&PolySetCodeByte }, { "PolyGetCodeByte", (polyRTSFunction)&PolyGetCodeByte }, { "PolySortArrayOfAddresses", (polyRTSFunction)&PolySortArrayOfAddresses }, + { "PolyTest4", (polyRTSFunction)&PolyTest4 }, + { "PolyTest5", (polyRTSFunction)&PolyTest5 }, { NULL, NULL} // End of list. }; diff --git a/libpolyml/polyffi.cpp b/libpolyml/polyffi.cpp index 64ac1418..4d3d9353 100644 --- a/libpolyml/polyffi.cpp +++ b/libpolyml/polyffi.cpp @@ -1,664 +1,664 @@ /* Title: New Foreign Function Interface Copyright (c) 2015, 2018, 2019 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_DLFCN_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_MALLOC_H #include #endif #ifdef HAVE_STRING_H #include #endif #include "globals.h" // TODO: Do we need this?? // We need to include globals.h before in mingw64 otherwise // it messes up POLYUFMT/POLYSFMT. #include #include #include "arb.h" #include "save_vec.h" #include "polyffi.h" #include "run_time.h" #include "sys.h" #include "processes.h" #include "polystring.h" #if (defined(_WIN32)) #include #include "winstartup.h" /* For hApplicationInstance. */ #endif #include "scanaddrs.h" #include "diagnostics.h" #include "reals.h" #include "rts_module.h" #include "rtsentry.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolySizeFloat(); POLYEXTERNALSYMBOL POLYUNSIGNED PolySizeDouble(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIGetError(PolyWord addr); POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFISetError(PolyWord err); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtFn(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtData(PolyObject *threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtFn(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtData(FirstArgument threadId, PolyWord arg); } static struct _abiTable { const char *abiName; ffi_abi abiCode; } abiTable[] = { // Unfortunately the ABI entries are enums rather than #defines so we // can't test individual entries. #ifdef X86_WIN32 {"sysv", FFI_SYSV}, {"stdcall", FFI_STDCALL}, {"thiscall", FFI_THISCALL}, {"fastcall", FFI_FASTCALL}, {"ms_cdecl", FFI_MS_CDECL}, #elif defined(X86_WIN64) {"win64", FFI_WIN64}, #elif defined(X86_ANY) {"unix64", FFI_UNIX64}, #endif { "default", FFI_DEFAULT_ABI} }; // Table of constants returned by call 51 static int constantTable[] = { FFI_DEFAULT_ABI, // Default ABI FFI_TYPE_VOID, // Type codes FFI_TYPE_INT, FFI_TYPE_FLOAT, FFI_TYPE_DOUBLE, FFI_TYPE_UINT8, FFI_TYPE_SINT8, FFI_TYPE_UINT16, FFI_TYPE_SINT16, FFI_TYPE_UINT32, FFI_TYPE_SINT32, FFI_TYPE_UINT64, FFI_TYPE_SINT64, FFI_TYPE_STRUCT, FFI_TYPE_POINTER, FFI_SIZEOF_ARG // Minimum size for result space }; // Table of predefined ffi types static ffi_type *ffiTypeTable[] = { &ffi_type_void, &ffi_type_uint8, &ffi_type_sint8, &ffi_type_uint16, &ffi_type_sint16, &ffi_type_uint32, &ffi_type_sint32, &ffi_type_uint64, &ffi_type_sint64, &ffi_type_float, &ffi_type_double, &ffi_type_pointer, &ffi_type_uchar, // These are all aliases for the above &ffi_type_schar, &ffi_type_ushort, &ffi_type_sshort, &ffi_type_uint, &ffi_type_sint, &ffi_type_ulong, &ffi_type_slong }; // Callback entry table static struct _cbStructEntry { PolyWord mlFunction; // The ML function to call void *closureSpace; // Space allocated for the closure void *resultFunction; // Executable address for the function. Needed to free. } *callbackTable; static unsigned callBackEntries = 0; static PLock callbackTableLock; // Mutex to protect table. static Handle mkAbitab(TaskData *taskData, void*, char *p); static void callbackEntryPt(ffi_cif *cif, void *ret, void* args[], void *data); static Handle toSysWord(TaskData *taskData, void *p) { return Make_sysword(taskData, (uintptr_t)p); } static Handle poly_ffi(TaskData *taskData, Handle args, Handle code) { unsigned c = get_C_unsigned(taskData, code->Word()); switch (c) { case 0: // malloc { POLYUNSIGNED size = getPolyUnsigned(taskData, args->Word()); return toSysWord(taskData, malloc(size)); } case 1: // free { void *mem = *(void**)(args->WordP()); free(mem); return taskData->saveVec.push(TAGGED(0)); } case 2: // Load library { TempString libName(args->Word()); #if (defined(_WIN32)) HINSTANCE lib = LoadLibrary(libName); if (lib == NULL) { char buf[256]; #if (defined(UNICODE)) _snprintf(buf, sizeof(buf), "Loading <%S> failed. Error %lu", (LPCTSTR)libName, GetLastError()); #else _snprintf(buf, sizeof(buf), "Loading <%s> failed. Error %lu", (const char*)libName, GetLastError()); #endif buf[sizeof(buf)-1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #else void *lib = dlopen(libName, RTLD_LAZY); if (lib == NULL) { char buf[256]; snprintf(buf, sizeof(buf), "Loading <%s> failed: %s", (const char *)libName, dlerror()); buf[sizeof(buf)-1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #endif return toSysWord(taskData, lib); } case 3: // Load address of executable. { #if (defined(_WIN32)) HINSTANCE lib = hApplicationInstance; #else void *lib = dlopen(NULL, RTLD_LAZY); if (lib == NULL) { char buf[256]; snprintf(buf, sizeof(buf), "Loading address of executable failed: %s", dlerror()); buf[sizeof(buf)-1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #endif return toSysWord(taskData, lib); } case 4: // Unload library - Is this actually going to be used? { #if (defined(_WIN32)) HMODULE hMod = *(HMODULE*)(args->WordP()); if (! FreeLibrary(hMod)) raise_syscall(taskData, "FreeLibrary failed", GetLastError()); #else void *lib = *(void**)(args->WordP()); if (dlclose(lib) != 0) { char buf[256]; snprintf(buf, sizeof(buf), "dlclose failed: %s", dlerror()); buf[sizeof(buf)-1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #endif return taskData->saveVec.push(TAGGED(0)); } case 5: // Load the address of a symbol from a library. { TempCString symName(args->WordP()->Get(1)); #if (defined(_WIN32)) HMODULE hMod = *(HMODULE*)(args->WordP()->Get(0).AsAddress()); void *sym = (void*)GetProcAddress(hMod, symName); if (sym == NULL) { char buf[256]; _snprintf(buf, sizeof(buf), "Loading symbol <%s> failed. Error %lu", (LPCSTR)symName, GetLastError()); buf[sizeof(buf)-1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #else void *lib = *(void**)(args->WordP()->Get(0).AsAddress()); void *sym = dlsym(lib, symName); if (sym == NULL) { char buf[256]; snprintf(buf, sizeof(buf), "load_sym <%s> : %s", (const char *)symName, dlerror()); buf[sizeof(buf)-1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #endif return toSysWord(taskData, sym); } // Libffi functions case 50: // Return a list of available ABIs return makeList(taskData, sizeof(abiTable)/sizeof(abiTable[0]), (char*)abiTable, sizeof(abiTable[0]), 0, mkAbitab); case 51: // A constant from the table { unsigned index = get_C_unsigned(taskData, args->Word()); if (index >= sizeof(constantTable) / sizeof(constantTable[0])) raise_exception_string(taskData, EXC_foreign, "Index out of range"); return Make_arbitrary_precision(taskData, constantTable[index]); } case 52: // Return an FFI type { unsigned index = get_C_unsigned(taskData, args->Word()); if (index >= sizeof(ffiTypeTable) / sizeof(ffiTypeTable[0])) raise_exception_string(taskData, EXC_foreign, "Index out of range"); return toSysWord(taskData, ffiTypeTable[index]); } case 53: // Extract fields from ffi type. { ffi_type *ffit = *(ffi_type**)(args->WordP()); Handle sizeHandle = Make_arbitrary_precision(taskData, ffit->size); Handle alignHandle = Make_arbitrary_precision(taskData, ffit->alignment); Handle typeHandle = Make_arbitrary_precision(taskData, ffit->type); Handle elemHandle = toSysWord(taskData, ffit->elements); Handle resHandle = alloc_and_save(taskData, 4); resHandle->WordP()->Set(0, sizeHandle->Word()); resHandle->WordP()->Set(1, alignHandle->Word()); resHandle->WordP()->Set(2, typeHandle->Word()); resHandle->WordP()->Set(3, elemHandle->Word()); return resHandle; } case 54: // Construct an ffi type. { // This is probably only used to create structs. size_t size = getPolyUnsigned(taskData, args->WordP()->Get(0)); unsigned short align = get_C_ushort(taskData, args->WordP()->Get(1)); unsigned short type = get_C_ushort(taskData, args->WordP()->Get(2)); unsigned nElems = 0; for (PolyWord p = args->WordP()->Get(3); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) nElems++; size_t space = sizeof(ffi_type); // If we need the elements add space for the elements plus // one extra for the zero terminator. if (nElems != 0) space += (nElems+1) * sizeof(ffi_type *); ffi_type *result = (ffi_type*)calloc(1, space); // Raise an exception rather than returning zero. if (result == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); ffi_type **elem = 0; if (nElems != 0) elem = (ffi_type **)(result+1); result->size = size; result->alignment = align; result->type = type; result->elements = elem; if (elem != 0) { for (PolyWord p = args->WordP()->Get(3); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h; *elem++ = *(ffi_type**)(e.AsAddress()); } *elem = 0; } return toSysWord(taskData, result); } case 55: // Create a CIF. This contains all the types and some extra information. // The result is in allocated memory followed immediately by the argument type vector. { ffi_abi abi = (ffi_abi)get_C_ushort(taskData, args->WordP()->Get(0)); ffi_type *rtype = *(ffi_type **)args->WordP()->Get(1).AsAddress(); unsigned nArgs = 0; for (PolyWord p = args->WordP()->Get(2); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) nArgs++; // Allocate space for the cif followed by the argument type vector size_t space = sizeof(ffi_cif) + nArgs * sizeof(ffi_type*); ffi_cif *cif = (ffi_cif *)malloc(space); if (cif == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); ffi_type **atypes = (ffi_type **)(cif+1); // Copy the arguments types. ffi_type **at = atypes; for (PolyWord p = args->WordP()->Get(2); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h; *at++ = *(ffi_type**)(e.AsAddress()); } ffi_status status = ffi_prep_cif(cif, abi, nArgs, rtype, atypes); if (status == FFI_BAD_TYPEDEF) raise_exception_string(taskData, EXC_foreign, "Bad typedef in ffi_prep_cif"); else if (status == FFI_BAD_ABI) raise_exception_string(taskData, EXC_foreign, "Bad ABI in ffi_prep_cif"); else if (status != FFI_OK) raise_exception_string(taskData, EXC_foreign, "Error in ffi_prep_cif"); return toSysWord(taskData, cif); } case 56: // Call a function. { ffi_cif *cif = *(ffi_cif **)args->WordP()->Get(0).AsAddress(); void *f = *(void**)args->WordP()->Get(1).AsAddress(); void *res = *(void**)args->WordP()->Get(2).AsAddress(); void **arg = *(void***)args->WordP()->Get(3).AsAddress(); ffi_call(cif, FFI_FN(f), res, arg); // Do we need to save the value of errno/GetLastError here? return taskData->saveVec.push(TAGGED(0)); } case 57: // Create a callback. { #ifdef INTERPRETED raise_exception_string(taskData, EXC_foreign, "Callbacks are not implemented in the byte code interpreter"); #endif Handle mlFunction = taskData->saveVec.push(args->WordP()->Get(0)); ffi_cif *cif = *(ffi_cif **)args->WordP()->Get(1).AsAddress(); void *resultFunction; // Allocate the memory. resultFunction is set to the executable address in or related to // the memory. ffi_closure *closure = (ffi_closure *)ffi_closure_alloc(sizeof(ffi_closure), &resultFunction); if (closure == 0) raise_exception_string(taskData, EXC_foreign, "Callbacks not implemented or insufficient memory"); PLocker pLocker(&callbackTableLock); // Find a free entry in the table if there is one. unsigned entryNo = 0; while (entryNo < callBackEntries && callbackTable[entryNo].closureSpace != 0) entryNo++; if (entryNo == callBackEntries) { // Need to grow the table. struct _cbStructEntry *newTable = (struct _cbStructEntry*)realloc(callbackTable, (callBackEntries+1)*sizeof(struct _cbStructEntry)); if (newTable == 0) raise_exception_string(taskData, EXC_foreign, "Unable to allocate memory for callback table"); callbackTable = newTable; callBackEntries++; } callbackTable[entryNo].mlFunction = mlFunction->Word(); callbackTable[entryNo].closureSpace = closure; callbackTable[entryNo].resultFunction = resultFunction; if (ffi_prep_closure_loc(closure, cif, callbackEntryPt, (void*)((uintptr_t)entryNo), resultFunction) != FFI_OK) raise_exception_string(taskData, EXC_foreign,"libffi error: ffi_prep_closure_loc failed"); return toSysWord(taskData, resultFunction); } case 58: // Free an existing callback. { // The address returned from call 57 above is the executable address that can // be passed as a callback function. The writable memory address returned // as the result of ffi_closure_alloc may or may not be the same. To be safe // we need to search the table. void *resFun = *(void**)args->Word().AsAddress(); PLocker pLocker(&callbackTableLock); for (unsigned i = 0; i < callBackEntries; i++) { if (callbackTable[i].resultFunction == resFun) { ffi_closure_free(callbackTable[i].closureSpace); callbackTable[i].closureSpace = 0; callbackTable[i].resultFunction = 0; callbackTable[i].mlFunction = TAGGED(0); // Release the ML function return taskData->saveVec.push(TAGGED(0)); } } raise_exception_string(taskData, EXC_foreign, "Invalid callback entry"); } default: { char msg[100]; sprintf(msg, "Unknown ffi function: %d", c); raise_exception_string(taskData, EXC_foreign, msg); return 0; } } } // Construct an entry in the ABI table. static Handle mkAbitab(TaskData *taskData, void *arg, char *p) { struct _abiTable *ab = (struct _abiTable *)p; // Construct a pair of the string and the code Handle name = taskData->saveVec.push(C_string_to_Poly(taskData, ab->abiName)); Handle code = Make_arbitrary_precision(taskData, ab->abiCode); Handle result = alloc_and_save(taskData, 2); result->WordP()->Set(0, name->Word()); result->WordP()->Set(1, code->Word()); return result; } // This is the C function that will get control when any callback is made. The "data" // argument is the index of the entry in the callback table. static void callbackEntryPt(ffi_cif *cif, void *ret, void* args[], void *data) { uintptr_t cbIndex = (uintptr_t)data; ASSERT(cbIndex < callBackEntries); // We should get the task data for the thread that is running this code. // If this thread has been created by the foreign code we will have to // create a new one here. TaskData *taskData = processes->GetTaskDataForThread(); if (taskData == 0) { try { taskData = processes->CreateNewTaskData(0, 0, 0, TAGGED(0)); } catch (std::bad_alloc &) { ::Exit("Unable to create thread data - insufficient memory"); } catch (MemoryException &) { ::Exit("Unable to create thread data - insufficient memory"); } } taskData->PreRTSCall(); // We may get multiple calls to call-backs and we mustn't risk // overflowing the save-vec. Handle mark = taskData->saveVec.mark(); // In the future we might want to call C functions without some of the // overhead that comes with an RTS call which may allocate in ML // memory. If we do that we also have to ensure that callbacks // don't allocate, so this code would have to change. Handle mlEntryHandle; { // Get the ML function. Lock to avoid another thread moving // callbackTable under our feet. PLocker pLocker(&callbackTableLock); struct _cbStructEntry *cbEntry = &callbackTable[cbIndex]; mlEntryHandle = taskData->saveVec.push(cbEntry->mlFunction); } // Create a pair of the arg vector and the result pointer. Handle argHandle = toSysWord(taskData, args); Handle resHandle = toSysWord(taskData, ret); // Result must go in here. Handle pairHandle = alloc_and_save(taskData, 2); pairHandle->WordP()->Set(0, argHandle->Word()); pairHandle->WordP()->Set(1, resHandle->Word()); taskData->EnterCallbackFunction(mlEntryHandle, pairHandle); taskData->PostRTSCall(); taskData->saveVec.reset(mark); } class PolyFFI: public RtsModule { public: virtual void GarbageCollect(ScanAddress *process); }; // Declare this. It will be automatically added to the table. static PolyFFI polyFFIModule; // We need to scan the callback table. void PolyFFI::GarbageCollect(ScanAddress *process) { for (unsigned i = 0; i < callBackEntries; i++) process->ScanRuntimeWord(&callbackTable[i].mlFunction); } // General interface to IO. Ideally the various cases will be made into // separate functions. -POLYUNSIGNED PolyFFIGeneral(PolyObject *threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyFFIGeneral(FirstArgument threadId, PolyWord code, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCode = taskData->saveVec.push(code); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = poly_ffi(taskData, pushedArg, pushedCode); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // These functions are needed in the compiler POLYUNSIGNED PolySizeFloat() { return TAGGED((POLYSIGNED)ffi_type_float.size).AsUnsigned(); } POLYUNSIGNED PolySizeDouble() { return TAGGED((POLYSIGNED)ffi_type_double.size).AsUnsigned(); } // Get either errno or GetLastError POLYUNSIGNED PolyFFIGetError(PolyWord addr) { #if (defined(_WIN32)) addr.AsObjPtr()->Set(0, PolyWord::FromUnsigned(GetLastError())); #else addr.AsObjPtr()->Set(0, PolyWord::FromUnsigned((POLYUNSIGNED)errno)); #endif return 0; } // The argument is a SysWord.word value i.e. the address of a byte cell. POLYUNSIGNED PolyFFISetError(PolyWord err) { #if (defined(_WIN32)) SetLastError((DWORD)(err.AsObjPtr()->Get(0).AsUnsigned())); #else errno = err.AsObjPtr()->Get(0).AsSigned(); #endif return 0; } // Create an external function reference. The value returned has space for // an address followed by the name of the external symbol. Because the // address comes at the beginning it can be used in the same way as the // SysWord value returned by the get-symbol call from a library. -POLYUNSIGNED PolyFFICreateExtFn(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyFFICreateExtFn(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = creatEntryPointObject(taskData, pushedArg, true); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Create an external reference to data. On a small number of platforms // different forms of relocation are needed for data and for functions. -POLYUNSIGNED PolyFFICreateExtData(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyFFICreateExtData(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = creatEntryPointObject(taskData, pushedArg, false); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } struct _entrypts polyFFIEPT[] = { { "PolyFFIGeneral", (polyRTSFunction)&PolyFFIGeneral}, { "PolySizeFloat", (polyRTSFunction)&PolySizeFloat}, { "PolySizeDouble", (polyRTSFunction)&PolySizeDouble}, { "PolyFFIGetError", (polyRTSFunction)&PolyFFIGetError}, { "PolyFFISetError", (polyRTSFunction)&PolyFFISetError}, { "PolyFFICreateExtFn", (polyRTSFunction)&PolyFFICreateExtFn}, { "PolyFFICreateExtData", (polyRTSFunction)&PolyFFICreateExtData }, { NULL, NULL} // End of list. }; diff --git a/libpolyml/process_env.cpp b/libpolyml/process_env.cpp index 57cb77a3..5c309476 100644 --- a/libpolyml/process_env.cpp +++ b/libpolyml/process_env.cpp @@ -1,763 +1,721 @@ /* Title: Process environment. - Copyright (c) 2000-8, 2016-17 + Copyright (c) 2000-8, 2016-17, 2019 + David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_SYS_WAIT_H #include #endif #if (defined(__CYGWIN__) || defined(_WIN32)) #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif // Include this next before errors.h since in WinCE at least the winsock errors are defined there. #if (defined(_WIN32)) #include #include #define NOMEMORY ERROR_NOT_ENOUGH_MEMORY #undef ENOMEM #else typedef char TCHAR; #define _tgetenv getenv #define NOMEMORY ENOMEM #endif #include "globals.h" #include "sys.h" #include "run_time.h" #include "process_env.h" #include "arb.h" #include "mpoly.h" #include "gc.h" #include "scanaddrs.h" #include "polystring.h" #include "save_vec.h" #include "process_env.h" #include "rts_module.h" #include "machine_dep.h" #include "processes.h" #include "locking.h" #include "errors.h" #include "rtsentry.h" #include "version.h" extern "C" { - POLYEXTERNALSYMBOL void PolyFinish(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL void PolyTerminate(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorName(PolyObject *threadId, PolyWord syserr); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorMessage(PolyObject *threadId, PolyWord syserr); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorFromString(PolyObject *threadId, PolyWord string); + POLYEXTERNALSYMBOL void PolyFinish(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL void PolyTerminate(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorName(FirstArgument threadId, PolyWord syserr); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorMessage(FirstArgument threadId, PolyWord syserr); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorFromString(FirstArgument threadId, PolyWord string); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetMaxAllocationSize(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetMaxStringSize(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetPolyVersionNumber(); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetFunctionName(PolyObject *threadId, PolyWord fnAddr); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetFunctionName(FirstArgument threadId, PolyWord fnAddr); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyCommandLineName(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyCommandLineArgs(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetEnv(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetEnvironment(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvSuccessValue(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvFailureValue(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvSystem(FirstArgument threadId, PolyWord arg); } -#define SAVE(x) mdTaskData->saveVec.push(x) -#define ALLOC(n) alloc_and_save(mdTaskData, n) +#define SAVE(x) taskData->saveVec.push(x) +#define ALLOC(n) alloc_and_save(taskData, n) #if (defined(_WIN32)) #define ISPATHSEPARATOR(c) ((c) == '\\' || (c) == '/') #define DEFAULTSEPARATOR "\\" #else #define ISPATHSEPARATOR(c) ((c) == '/') #define DEFAULTSEPARATOR "/" #endif #ifdef _MSC_VER // Don't tell me about ISO C++ changes. #pragma warning(disable:4996) #endif // "environ" is declared in the headers on some systems but not all. // Oddly, declaring it within process_env_dispatch_c causes problems // on mingw where "environ" is actually a function. #if __APPLE__ // On Mac OS X there may be problems accessing environ directly. #include #define environ (*_NSGetEnviron()) #else extern char **environ; #endif /* Functions registered with atExit are added to this list. */ static PolyWord at_exit_list = TAGGED(0); /* Once "exit" is called this flag is set and no further calls to atExit are allowed. */ static bool exiting = false; static PLock atExitLock; // Thread lock for above. #ifdef __CYGWIN__ // Cygwin requires spawnvp to avoid the significant overhead of vfork // but it doesn't seem to be thread-safe. Run it on the main thread // to be sure. class CygwinSpawnRequest: public MainThreadRequest { public: CygwinSpawnRequest(char **argv): MainThreadRequest(MTP_CYGWINSPAWN), spawnArgv(argv) {} virtual void Perform(); char **spawnArgv; int pid; }; void CygwinSpawnRequest::Perform() { pid = spawnvp(_P_NOWAIT, "/bin/sh", spawnArgv); } #endif -static Handle process_env_dispatch_c(TaskData *mdTaskData, Handle args, Handle code) +// These are now just legacy calls. +static Handle process_env_dispatch_c(TaskData *taskData, Handle args, Handle code) { - unsigned c = get_C_unsigned(mdTaskData, DEREFWORD(code)); + unsigned c = get_C_unsigned(taskData, DEREFWORD(code)); switch (c) { - case 0: /* Return the program name. */ - return SAVE(C_string_to_Poly(mdTaskData, userOptions.programName)); - case 1: /* Return the argument list. */ - return convert_string_list(mdTaskData, userOptions.user_arg_count, userOptions.user_arg_strings); - - case 14: /* Return a string from the environment. */ - { - TempString buff(args->Word()); - if (buff == 0) raise_syscall(mdTaskData, "Insufficient memory", NOMEMORY); - TCHAR *res = _tgetenv(buff); - if (res == NULL) raise_syscall(mdTaskData, "Not Found", 0); - else return SAVE(C_string_to_Poly(mdTaskData, res)); - } - - case 21: // Return the whole environment. Only available in Posix.ProcEnv. - { - /* Count the environment strings */ - int env_count = 0; - while (environ[env_count] != NULL) env_count++; - return convert_string_list(mdTaskData, env_count, environ); - } - - case 15: /* Return the success value. */ - return Make_fixed_precision(mdTaskData, EXIT_SUCCESS); - - case 16: /* Return a failure value. */ - return Make_fixed_precision(mdTaskData, EXIT_FAILURE); - - case 17: /* Run command. */ - { - TempString buff(args->Word()); - if (buff == 0) raise_syscall(mdTaskData, "Insufficient memory", NOMEMORY); - int res = -1; -#if (defined(_WIN32)) - // Windows. - TCHAR *argv[4]; - argv[0] = _tgetenv(_T("COMSPEC")); // Default CLI. - if (argv[0] == 0) argv[0] = (TCHAR*)_T("cmd.exe"); // Win NT etc. - argv[1] = (TCHAR*)_T("/c"); - argv[2] = buff; - argv[3] = NULL; - // If _P_NOWAIT is given the result is the process handle. - // spawnvp does any necessary path searching if argv[0] - // does not contain a full path. - intptr_t pid = _tspawnvp(_P_NOWAIT, argv[0], argv); - if (pid == -1) - raise_syscall(mdTaskData, "Function system failed", errno); -#else - // Cygwin and Unix - char *argv[4]; - argv[0] = (char*)"sh"; - argv[1] = (char*)"-c"; - argv[2] = buff; - argv[3] = NULL; -#if (defined(__CYGWIN__)) - CygwinSpawnRequest request(argv); - processes->MakeRootRequest(mdTaskData, &request); - int pid = request.pid; - if (pid < 0) - raise_syscall(mdTaskData, "Function system failed", errno); -#else - // We need to break this down so that we can unblock signals in the - // child process. - // The Unix "system" function seems to set SIGINT and SIGQUIT to - // SIG_IGN in the parent so that the wait will not be interrupted. - // That may make sense in a single-threaded application but is - // that right here? - int pid = vfork(); - if (pid == -1) - raise_syscall(mdTaskData, "Function system failed", errno); - else if (pid == 0) - { // In child - sigset_t sigset; - sigemptyset(&sigset); - sigprocmask(SIG_SETMASK, &sigset, 0); - // Reset other signals? - execv("/bin/sh", argv); - _exit(1); - } -#endif -#endif - while (true) - { - try - { - // Test to see if the child has returned. -#if (defined(_WIN32)) - switch (WaitForSingleObject((HANDLE)pid, 0)) - { - case WAIT_OBJECT_0: - { - DWORD result; - BOOL fResult = GetExitCodeProcess((HANDLE)pid, &result); - if (! fResult) - raise_syscall(mdTaskData, "Function system failed", GetLastError()); - CloseHandle((HANDLE)pid); - return Make_fixed_precision(mdTaskData, result); - } - case WAIT_FAILED: - raise_syscall(mdTaskData, "Function system failed", GetLastError()); - } - // Wait for the process to exit or for the timeout - WaitHandle waiter((HANDLE)pid); - processes->ThreadPauseForIO(mdTaskData, &waiter); -#else - int wRes = waitpid(pid, &res, WNOHANG); - if (wRes > 0) - break; - else if (wRes < 0) - { - raise_syscall(mdTaskData, "Function system failed", errno); - } - // In Unix the best we can do is wait. This may be interrupted - // by SIGCHLD depending on where signals are processed. - // One possibility is for the main thread to somehow wake-up - // the thread when it processes a SIGCHLD. - processes->ThreadPause(mdTaskData); -#endif - } - catch (...) - { - // Either IOException or KillException. - // We're abandoning the wait. This will leave - // a zombie in Unix. -#if (defined(_WIN32)) - CloseHandle((HANDLE)pid); -#endif - throw; - } - } - return Make_fixed_precision(mdTaskData, res); - } + return convert_string_list(taskData, userOptions.user_arg_count, userOptions.user_arg_strings); case 18: /* Register function to run at exit. */ { PLocker locker(&atExitLock); if (! exiting) { - PolyObject *cell = alloc(mdTaskData, 2); + PolyObject *cell = alloc(taskData, 2); cell->Set(0, at_exit_list); cell->Set(1, args->Word()); at_exit_list = cell; } - return Make_fixed_precision(mdTaskData, 0); + return Make_fixed_precision(taskData, 0); } case 19: /* Return the next function in the atExit list and set the "exiting" flag to true. */ { PLocker locker(&atExitLock); Handle res; exiting = true; /* Ignore further calls to atExit. */ if (at_exit_list == TAGGED(0)) - raise_syscall(mdTaskData, "List is empty", 0); + raise_syscall(taskData, "List is empty", 0); PolyObject *cell = at_exit_list.AsObjPtr(); res = SAVE(cell->Get(1)); at_exit_list = cell->Get(0); return res; } - case 20: /* Terminate without running the atExit list or flushing buffers. */ - { - /* I don't like terminating without some sort of clean up - but we'll do it this way for the moment. */ - int i = get_C_int(mdTaskData, args->Word()); - _exit(i); - } - - /************ Error codes **************/ - - - - /************ Directory/file paths **************/ - - case 5: /* Return the string representing the current arc. */ - return SAVE(C_string_to_Poly(mdTaskData, ".")); - - case 6: /* Return the string representing the parent arc. */ - /* I don't know that this exists in MacOS. */ - return SAVE(C_string_to_Poly(mdTaskData, "..")); - - case 7: /* Return the string representing the directory separator. */ - return SAVE(C_string_to_Poly(mdTaskData, DEFAULTSEPARATOR)); - - case 8: /* Test the character to see if it matches a separator. */ - { - int e = get_C_int(mdTaskData, args->Word()); - if (ISPATHSEPARATOR(e)) - return Make_fixed_precision(mdTaskData, 1); - else return Make_fixed_precision(mdTaskData, 0); - } - - case 9: /* Are names case-sensitive? */ -#if (defined(_WIN32)) - /* Windows - no. */ - return Make_fixed_precision(mdTaskData, 0); -#else - /* Unix - yes. */ - return Make_fixed_precision(mdTaskData, 1); -#endif - - // These are no longer used. The code is handled entirely in ML. - case 10: /* Are empty arcs redundant? */ - /* Unix and Windows - yes. */ - return Make_fixed_precision(mdTaskData, 1); - - case 11: /* Match the volume name part of a path. */ - { - const TCHAR *volName = NULL; - int isAbs = 0; - int toRemove = 0; - PolyWord path = args->Word(); - /* This examines the start of a string and determines - how much of it represents the volume name and returns - the number of characters to remove, the volume name - and whether it is absolute. - One would assume that if there is a volume name then it - is absolute but there is a peculiar form in Windows/DOS - (e.g. A:b\c) which means the file b\c relative to the - currently selected directory on the volume A. - */ -#if (defined(_WIN32)) - TempString buff(path); - if (buff == 0) raise_syscall(mdTaskData, "Insufficient memory", NOMEMORY); - size_t length = _tcslen(buff); - if (length >= 2 && buff[1] == ':') - { /* Volume name? */ - if (length >= 3 && ISPATHSEPARATOR(buff[2])) - { - /* Absolute path. */ - toRemove = 3; isAbs = 1; - } - else { toRemove = 2; isAbs = 0; } - volName = buff; buff[2] = '\0'; - } - else if (length > 3 && - ISPATHSEPARATOR(buff[0]) && - ISPATHSEPARATOR(buff[1]) && - ! ISPATHSEPARATOR(buff[2])) - { /* UNC name? */ - int i; - /* Skip the server name. */ - for (i = 3; buff[i] != 0 && !ISPATHSEPARATOR(buff[i]); i++); - if (ISPATHSEPARATOR(buff[i])) - { - i++; - /* Skip the share name. */ - for (; buff[i] != 0 && !ISPATHSEPARATOR(buff[i]); i++); - toRemove = i; - if (buff[i] != 0) toRemove++; - isAbs = 1; - volName = buff; - buff[i] = '\0'; - } - } - else if (ISPATHSEPARATOR(buff[0])) - /* \a\b strictly speaking is relative to the - current drive. It's much easier to treat it - as absolute. */ - { toRemove = 1; isAbs = 1; volName = _T(""); } -#else - /* Unix - much simpler. */ - char toTest = 0; - if (IS_INT(path)) toTest = UNTAGGED(path); - else { - PolyStringObject * ps = (PolyStringObject *)path.AsObjPtr(); - if (ps->length > 1) toTest = ps->chars[0]; - } - if (ISPATHSEPARATOR(toTest)) - { toRemove = 1; isAbs = 1; volName = ""; } -#endif - /* Construct the result. */ - { - Handle sVol = SAVE(C_string_to_Poly(mdTaskData, volName)); - Handle sRes = ALLOC(3); - DEREFWORDHANDLE(sRes)->Set(0, TAGGED(toRemove)); - DEREFHANDLE(sRes)->Set(1, sVol->Word()); - DEREFWORDHANDLE(sRes)->Set(2, TAGGED(isAbs)); - return sRes; - } - } - - case 12: /* Construct a name from a volume and whether it is - absolute. */ - { - unsigned isAbs = get_C_unsigned(mdTaskData, DEREFHANDLE(args)->Get(1)); - PolyWord volName = DEREFHANDLE(args)->Get(0); - /* In Unix the volume name will always be empty. */ - if (isAbs == 0) - return SAVE(volName); - /* N.B. The arguments to strconcatc are in reverse. */ - else return strconcatc(mdTaskData, - SAVE(C_string_to_Poly(mdTaskData, DEFAULTSEPARATOR)), - SAVE(volName)); - } - - case 13: /* Is the string a valid file name? */ - { - PolyWord volName = DEREFWORD(args); - // First check for NULL. This is not allowed in either Unix or Windows. - if (IS_INT(volName)) - { - if (volName == TAGGED(0)) - return Make_fixed_precision(mdTaskData, 0); - } - else - { - PolyStringObject * volume = (PolyStringObject *)(volName.AsObjPtr()); - for (POLYUNSIGNED i = 0; i < volume->length; i++) - { - if (volume->chars[i] == '\0') - return Make_fixed_precision(mdTaskData, 0); - } - } -#if (defined(_WIN32)) - // We need to look for certain invalid characters but only after - // we've converted it to Unicode if necessary. - TempString name(volName); - for (const TCHAR *p = name; *p != 0; p++) - { - switch (*p) - { - case '<': case '>': case ':': case '"': - case '\\': case '|': case '?': case '*': case '\0': -#if (0) - // This currently breaks the build. - case '/': -#endif - return Make_fixed_precision(mdTaskData, 0); - } - if (*p >= 0 && *p <= 31) return Make_fixed_precision(mdTaskData, 0); - } - // Should we check for special names such as aux, con, prn ?? - return Make_fixed_precision(mdTaskData, 1); -#else - // That's all we need for Unix. - // TODO: Check for /. It's invalid in a file name arc. - return Make_fixed_precision(mdTaskData, 1); -#endif - } - - case 104: return Make_arbitrary_precision(mdTaskData, POLY_version_number); - - case 105: /* Get the name of the function. */ - { - PolyObject *pt = DEREFWORDHANDLE(args); - if (pt->IsCodeObject()) /* Should now be a code object. */ - { - /* Compiled code. This is the first constant in the constant area. */ - PolyWord *codePt = pt->ConstPtrForCode(); - PolyWord name = codePt[0]; - /* May be zero indicating an anonymous segment - return null string. */ - if (name == PolyWord::FromUnsigned(0)) - return SAVE(C_string_to_Poly(mdTaskData, "")); - else return SAVE(name); - } - else raise_syscall(mdTaskData, "Not a code pointer", 0); - } - default: { char msg[100]; sprintf(msg, "Unknown environment function: %d", c); - raise_exception_string(mdTaskData, EXC_Fail, msg); + raise_exception_string(taskData, EXC_Fail, msg); return 0; } } } // General interface to process-env. Ideally the various cases will be made into // separate functions. -POLYUNSIGNED PolyProcessEnvGeneral(PolyObject *threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyProcessEnvGeneral(FirstArgument threadId, PolyWord code, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCode = taskData->saveVec.push(code); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = process_env_dispatch_c(taskData, pushedArg, pushedCode); } catch (KillException &) { processes->ThreadExit(taskData); // May test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Terminate normally with a result code. -void PolyFinish(PolyObject *threadId, PolyWord arg) +void PolyFinish(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); int i = get_C_int(taskData, arg); // Cause the other threads to exit and set the result code. processes->RequestProcessExit(i); // Exit this thread processes->ThreadExit(taskData); // Doesn't return. } // Terminate without running the atExit list or flushing buffers -void PolyTerminate(PolyObject *threadId, PolyWord arg) +void PolyTerminate(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); int i = get_C_int(taskData, arg); _exit(i); // Doesn't return. } // Get the name of a numeric error message. -POLYUNSIGNED PolyProcessEnvErrorName(PolyObject *threadId, PolyWord syserr) +POLYUNSIGNED PolyProcessEnvErrorName(FirstArgument threadId, PolyWord syserr) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { int e = (int)syserr.AsObjPtr()->Get(0).AsSigned(); // First look to see if we have the name in the error table. They should generally all be there. const char *errorMsg = stringFromErrorCode(e); if (errorMsg != NULL) result = taskData->saveVec.push(C_string_to_Poly(taskData, errorMsg)); else { // If it isn't in the table. char buff[40]; sprintf(buff, "ERROR%0d", e); result = taskData->saveVec.push(C_string_to_Poly(taskData, buff)); } } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } /* Get the explanatory message for an error. */ -POLYUNSIGNED PolyProcessEnvErrorMessage(PolyObject *threadId, PolyWord syserr) +POLYUNSIGNED PolyProcessEnvErrorMessage(FirstArgument threadId, PolyWord syserr) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = errorMsg(taskData, (int)syserr.AsObjPtr()->Get(0).AsSigned()); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Try to convert an error string to an error number. -POLYUNSIGNED PolyProcessEnvErrorFromString(PolyObject *threadId, PolyWord string) +POLYUNSIGNED PolyProcessEnvErrorFromString(FirstArgument threadId, PolyWord string) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { char buff[40]; // Get the string. Poly_string_to_C(string, buff, sizeof(buff)); // Look the string up in the table. int err = 0; if (errorCodeFromString(buff, &err)) result = Make_sysword(taskData, err); else if (strncmp(buff, "ERROR", 5) == 0) // If we don't find it then it may have been a constructed error name. result = Make_sysword(taskData, atoi(buff+5)); else result = Make_sysword(taskData, 0); // Return 0w0 if it isn't there. } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Return the maximum size of a cell that can be allocated on the heap. POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetMaxAllocationSize() { return TAGGED(MAX_OBJECT_SIZE).AsUnsigned(); } // Return the maximum string size (in bytes). // It is the maximum number of bytes in a segment less one word for the length field. POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetMaxStringSize() { return TAGGED((MAX_OBJECT_SIZE) * sizeof(PolyWord) - sizeof(PolyWord)).AsUnsigned(); } POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetPolyVersionNumber() { return TAGGED(POLY_version_number).AsUnsigned(); } // Return the function name associated with a piece of compiled code. -POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetFunctionName(PolyObject *threadId, PolyWord fnAddr) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetFunctionName(FirstArgument threadId, PolyWord fnAddr) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { if (fnAddr.IsTagged()) raise_fail(taskData, "Not a code pointer"); PolyObject *pt = fnAddr.AsObjPtr(); // In 32-in-64 this may be a closure and the first word is the absolute address of the code. if (pt->IsClosureObject()) { // It may not be set yet. pt = *(PolyObject**)pt; if (((uintptr_t)pt & 1) == 1) raise_fail(taskData, "Not a code pointer"); } if (pt->IsCodeObject()) /* Should now be a code object. */ { /* Compiled code. This is the first constant in the constant area. */ PolyWord *codePt = pt->ConstPtrForCode(); PolyWord name = codePt[0]; /* May be zero indicating an anonymous segment - return null string. */ if (name == PolyWord::FromUnsigned(0)) result = taskData->saveVec.push(C_string_to_Poly(taskData, "")); else result = taskData->saveVec.push(name); } else raise_fail(taskData, "Not a code pointer"); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } +/* Return the program name. */ +POLYUNSIGNED PolyCommandLineName(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + result = taskData->saveVec.push(C_string_to_Poly(taskData, userOptions.programName)); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Return the argument list. */ +POLYUNSIGNED PolyCommandLineArgs(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + result = convert_string_list(taskData, userOptions.user_arg_count, userOptions.user_arg_strings); + } + catch (KillException&) { + processes->ThreadExit(taskData); // May test for kill + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Return a string from the environment. */ +POLYUNSIGNED PolyGetEnv(FirstArgument threadId, PolyWord arg) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle pushedArg = taskData->saveVec.push(arg); + Handle result = 0; + + try { + TempString buff(pushedArg->Word()); + if (buff == 0) + raise_syscall(taskData, "Insufficient memory", NOMEMORY); + TCHAR * res = _tgetenv(buff); + if (res == NULL) + raise_syscall(taskData, "Not Found", 0); + result = taskData->saveVec.push(C_string_to_Poly(taskData, res)); + } + catch (KillException&) { + processes->ThreadExit(taskData); // May test for kill + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +// Return the whole environment. Only available in Posix.ProcEnv. +POLYUNSIGNED PolyGetEnvironment(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + /* Count the environment strings */ + int env_count = 0; + while (environ[env_count] != NULL) env_count++; + result = convert_string_list(taskData, env_count, environ); + } + catch (KillException&) { + processes->ThreadExit(taskData); // May test for kill + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Return the success value. */ +POLYUNSIGNED PolyProcessEnvSuccessValue(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + result = Make_fixed_precision(taskData, EXIT_SUCCESS); + } + catch (KillException&) { + processes->ThreadExit(taskData); // May test for kill + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Return a failure value. */ +POLYUNSIGNED PolyProcessEnvFailureValue(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + result = Make_fixed_precision(taskData, EXIT_FAILURE); + } + catch (KillException&) { + processes->ThreadExit(taskData); // May test for kill + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Run command. */ +POLYUNSIGNED PolyProcessEnvSystem(FirstArgument threadId, PolyWord arg) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle pushedArg = taskData->saveVec.push(arg); + Handle result = 0; + + try { + TempString buff(pushedArg->Word()); + if (buff == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); + int res = -1; +#if (defined(_WIN32) && ! defined(__CYGWIN__)) + // Windows. + TCHAR * argv[4]; + argv[0] = _tgetenv(_T("COMSPEC")); // Default CLI. + if (argv[0] == 0) argv[0] = (TCHAR*)_T("cmd.exe"); // Win NT etc. + argv[1] = (TCHAR*)_T("/c"); + argv[2] = buff; + argv[3] = NULL; + // If _P_NOWAIT is given the result is the process handle. + // spawnvp does any necessary path searching if argv[0] + // does not contain a full path. + intptr_t pid = _tspawnvp(_P_NOWAIT, argv[0], argv); + if (pid == -1) + raise_syscall(taskData, "Function system failed", errno); +#else + // Cygwin and Unix + char* argv[4]; + argv[0] = (char*)"sh"; + argv[1] = (char*)"-c"; + argv[2] = buff; + argv[3] = NULL; +#if (defined(__CYGWIN__)) + CygwinSpawnRequest request(argv); + processes->MakeRootRequest(taskData, &request); + int pid = request.pid; + if (pid < 0) + raise_syscall(taskData, "Function system failed", errno); +#else + // We need to break this down so that we can unblock signals in the + // child process. + // The Unix "system" function seems to set SIGINT and SIGQUIT to + // SIG_IGN in the parent so that the wait will not be interrupted. + // That may make sense in a single-threaded application but is + // that right here? + int pid = vfork(); + if (pid == -1) + raise_syscall(taskData, "Function system failed", errno); + else if (pid == 0) + { // In child + sigset_t sigset; + sigemptyset(&sigset); + sigprocmask(SIG_SETMASK, &sigset, 0); + // Reset other signals? + execv("/bin/sh", argv); + _exit(1); + } +#endif +#endif + while (true) + { + try + { + // Test to see if the child has returned. +#if (defined(_WIN32) && ! defined(__CYGWIN__)) + DWORD dwWait = WaitForSingleObject((HANDLE)pid, 0); + if (dwWait == WAIT_OBJECT_0) + { + DWORD dwResult; + BOOL fResult = GetExitCodeProcess((HANDLE)pid, &dwResult); + if (!fResult) + raise_syscall(taskData, "Function system failed", GetLastError()); + CloseHandle((HANDLE)pid); + result = Make_fixed_precision(taskData, dwResult); + break; + } + else if (dwWait == WAIT_FAILED) + raise_syscall(taskData, "Function system failed", GetLastError()); + else + { + // Wait for the process to exit or for the timeout + WaitHandle waiter((HANDLE)pid, 1000); + processes->ThreadPauseForIO(taskData, &waiter); + } +#else + int wRes = waitpid(pid, &res, WNOHANG); + if (wRes > 0) + break; + else if (wRes < 0) + { + raise_syscall(taskData, "Function system failed", errno); + } + // In Unix the best we can do is wait. This may be interrupted + // by SIGCHLD depending on where signals are processed. + // One possibility is for the main thread to somehow wake-up + // the thread when it processes a SIGCHLD. + else processes->ThreadPause(taskData); +#endif + } + catch (...) + { + // Either IOException or KillException. + // We're abandoning the wait. This will leave + // a zombie in Unix. +#if (defined(_WIN32) && ! defined(__CYGWIN__)) + CloseHandle((HANDLE)pid); +#endif + throw; + } + } + result = Make_fixed_precision(taskData, res); + + } + catch (KillException&) { + processes->ThreadExit(taskData); // May test for kill + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + struct _entrypts processEnvEPT[] = { { "PolyFinish", (polyRTSFunction)&PolyFinish}, { "PolyTerminate", (polyRTSFunction)&PolyTerminate}, { "PolyProcessEnvGeneral", (polyRTSFunction)&PolyProcessEnvGeneral}, { "PolyProcessEnvErrorName", (polyRTSFunction)&PolyProcessEnvErrorName}, { "PolyProcessEnvErrorMessage", (polyRTSFunction)&PolyProcessEnvErrorMessage}, { "PolyProcessEnvErrorFromString", (polyRTSFunction)&PolyProcessEnvErrorFromString}, { "PolyGetMaxAllocationSize", (polyRTSFunction)&PolyGetMaxAllocationSize }, { "PolyGetMaxStringSize", (polyRTSFunction)&PolyGetMaxStringSize }, { "PolyGetPolyVersionNumber", (polyRTSFunction)&PolyGetPolyVersionNumber }, { "PolyGetFunctionName", (polyRTSFunction)&PolyGetFunctionName }, + { "PolyCommandLineName", (polyRTSFunction)& PolyCommandLineName }, + { "PolyCommandLineArgs", (polyRTSFunction)& PolyCommandLineArgs }, + { "PolyGetEnv", (polyRTSFunction)& PolyGetEnv }, + { "PolyGetEnvironment", (polyRTSFunction)& PolyGetEnvironment }, + { "PolyProcessEnvSuccessValue", (polyRTSFunction)& PolyProcessEnvSuccessValue }, + { "PolyProcessEnvFailureValue", (polyRTSFunction)& PolyProcessEnvFailureValue }, + { "PolyProcessEnvSystem", (polyRTSFunction)& PolyProcessEnvSystem }, { NULL, NULL} // End of list. }; class ProcessEnvModule: public RtsModule { public: void GarbageCollect(ScanAddress *process); }; // Declare this. It will be automatically added to the table. static ProcessEnvModule processModule; void ProcessEnvModule::GarbageCollect(ScanAddress *process) /* Ensures that all the objects are retained and their addresses updated. */ { if (at_exit_list.IsDataPtr()) { PolyObject *obj = at_exit_list.AsObjPtr(); process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_STRONG); at_exit_list = obj; } } diff --git a/libpolyml/processes.cpp b/libpolyml/processes.cpp index c00bd9f1..10752ebd 100644 --- a/libpolyml/processes.cpp +++ b/libpolyml/processes.cpp @@ -1,2234 +1,2208 @@ /* Title: Thread functions Author: David C.J. Matthews Copyright (c) 2007,2008,2013-15, 2017, 2019 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_LIMITS_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #ifdef HAVE_PROCESS_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_STAT_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_UNISTD_H #include // Want unistd for _SC_NPROCESSORS_ONLN at least #endif #ifdef HAVE_SYS_SELECT_H #include #endif #ifdef HAVE_WINDOWS_H #include #endif #if (!defined(_WIN32)) #include #endif #ifdef HAVE_SYS_SYSCTL_H // Used determine number of processors in Mac OS X. #include #endif #if (defined(_WIN32)) #include #endif #include #include /************************************************************************ * * Include runtime headers * ************************************************************************/ #include "globals.h" #include "gc.h" #include "mpoly.h" #include "arb.h" #include "machine_dep.h" #include "diagnostics.h" #include "processes.h" #include "run_time.h" #include "sys.h" #include "sighandler.h" #include "scanaddrs.h" #include "save_vec.h" #include "rts_module.h" #include "noreturn.h" #include "memmgr.h" #include "locking.h" #include "profiling.h" #include "sharedata.h" #include "exporter.h" #include "statistics.h" #include "rtsentry.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadKillSelf(PolyObject *threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMutexBlock(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMutexUnlock(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadCondVarWait(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadCondVarWaitUntil(PolyObject *threadId, PolyWord lockArg, PolyWord timeArg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadKillSelf(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMutexBlock(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMutexUnlock(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadCondVarWait(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadCondVarWaitUntil(FirstArgument threadId, PolyWord lockArg, PolyWord timeArg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadCondVarWake(PolyWord targetThread); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadForkThread(PolyObject *threadId, PolyWord function, PolyWord attrs, PolyWord stack); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadForkThread(FirstArgument threadId, PolyWord function, PolyWord attrs, PolyWord stack); POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadIsActive(PolyWord targetThread); POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadInterruptThread(PolyWord targetThread); POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadKillThread(PolyWord targetThread); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadBroadcastInterrupt(PolyObject *threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadTestInterrupt(PolyObject *threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadBroadcastInterrupt(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadTestInterrupt(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadNumProcessors(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadNumPhysicalProcessors(); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMaxStackSize(PolyObject *threadId, PolyWord newSize); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMaxStackSize(FirstArgument threadId, PolyWord newSize); } #define SAVE(x) taskData->saveVec.push(x) #define SIZEOF(x) (sizeof(x)/sizeof(PolyWord)) // These values are stored in the second word of thread id object as // a tagged integer. They may be set and read by the thread in the ML // code. #define PFLAG_BROADCAST 1 // If set, accepts a broadcast // How to handle interrrupts #define PFLAG_IGNORE 0 // Ignore interrupts completely #define PFLAG_SYNCH 2 // Handle synchronously #define PFLAG_ASYNCH 4 // Handle asynchronously #define PFLAG_ASYNCH_ONCE 6 // First handle asynchronously then switch to synch. #define PFLAG_INTMASK 6 // Mask of the above bits struct _entrypts processesEPT[] = { - { "PolyThreadGeneral", (polyRTSFunction)&PolyThreadGeneral}, { "PolyThreadKillSelf", (polyRTSFunction)&PolyThreadKillSelf}, { "PolyThreadMutexBlock", (polyRTSFunction)&PolyThreadMutexBlock}, { "PolyThreadMutexUnlock", (polyRTSFunction)&PolyThreadMutexUnlock}, { "PolyThreadCondVarWait", (polyRTSFunction)&PolyThreadCondVarWait}, { "PolyThreadCondVarWaitUntil", (polyRTSFunction)&PolyThreadCondVarWaitUntil}, { "PolyThreadCondVarWake", (polyRTSFunction)&PolyThreadCondVarWake}, { "PolyThreadForkThread", (polyRTSFunction)&PolyThreadForkThread}, { "PolyThreadIsActive", (polyRTSFunction)&PolyThreadIsActive}, { "PolyThreadInterruptThread", (polyRTSFunction)&PolyThreadInterruptThread}, { "PolyThreadKillThread", (polyRTSFunction)&PolyThreadKillThread}, { "PolyThreadBroadcastInterrupt", (polyRTSFunction)&PolyThreadBroadcastInterrupt}, { "PolyThreadTestInterrupt", (polyRTSFunction)&PolyThreadTestInterrupt}, { "PolyThreadNumProcessors", (polyRTSFunction)&PolyThreadNumProcessors}, { "PolyThreadNumPhysicalProcessors",(polyRTSFunction)&PolyThreadNumPhysicalProcessors}, { "PolyThreadMaxStackSize", (polyRTSFunction)&PolyThreadMaxStackSize}, { NULL, NULL} // End of list. }; class Processes: public ProcessExternal, public RtsModule { public: Processes(); virtual void Init(void); virtual void Stop(void); void GarbageCollect(ScanAddress *process); public: void BroadcastInterrupt(void); void BeginRootThread(PolyObject *rootFunction); void RequestProcessExit(int n); // Request all ML threads to exit and set the process result code. // Called when a thread has completed - doesn't return. virtual NORETURNFN(void ThreadExit(TaskData *taskData)); // Called when a thread may block. Returns some time later when perhaps // the input is available. virtual void ThreadPauseForIO(TaskData *taskData, Waiter *pWait); // Return the task data for the current thread. virtual TaskData *GetTaskDataForThread(void); // Create a new task data object for the current thread. virtual TaskData *CreateNewTaskData(Handle threadId, Handle threadFunction, Handle args, PolyWord flags); // ForkFromRTS. Creates a new thread from within the RTS. virtual bool ForkFromRTS(TaskData *taskData, Handle proc, Handle arg); // Create a new thread. The "args" argument is only used for threads // created in the RTS by the signal handler. Handle ForkThread(TaskData *taskData, Handle threadFunction, Handle args, PolyWord flags, PolyWord stacksize); // Process general RTS requests from ML. Handle ThreadDispatch(TaskData *taskData, Handle args, Handle code); virtual void ThreadUseMLMemory(TaskData *taskData); virtual void ThreadReleaseMLMemory(TaskData *taskData); virtual poly_exn* GetInterrupt(void) { return interrupt_exn; } // If the schedule lock is already held we need to use these functions. void ThreadUseMLMemoryWithSchedLock(TaskData *taskData); void ThreadReleaseMLMemoryWithSchedLock(TaskData *taskData); // Requests from the threads for actions that need to be performed by // the root thread. Make the request and wait until it has completed. virtual void MakeRootRequest(TaskData *taskData, MainThreadRequest *request); // Deal with any interrupt or kill requests. virtual bool ProcessAsynchRequests(TaskData *taskData); // Process an interrupt request synchronously. virtual void TestSynchronousRequests(TaskData *taskData); // Process any events, synchronous or asynchronous. virtual void TestAnyEvents(TaskData *taskData); // Set a thread to be interrupted or killed. Wakes up the // thread if necessary. MUST be called with schedLock held. void MakeRequest(TaskData *p, ThreadRequests request); // Profiling control. virtual void StartProfiling(void); virtual void StopProfiling(void); #ifdef HAVE_WINDOWS_H // Windows: Called every millisecond while profiling is on. void ProfileInterrupt(void); #else // Unix: Start a profile timer for a thread. void StartProfilingTimer(void); #endif // Memory allocation. Tries to allocate space. If the allocation succeeds it // may update the allocation values in the taskData object. If the heap is exhausted // it may set this thread (or other threads) to raise an exception. PolyWord *FindAllocationSpace(TaskData *taskData, POLYUNSIGNED words, bool alwaysInSeg); // Get the task data value from the task reference. // The task data reference is a volatile ref containing the // address of the C++ task data. // N.B. This is updated when the thread exits and the TaskData object // is deleted. TaskData *TaskForIdentifier(PolyObject *taskId) { return *(TaskData**)(((ThreadObject*)taskId)->threadRef.AsObjPtr()); } // Signal handling support. The ML signal handler thread blocks until it is // woken up by the signal detection thread. virtual bool WaitForSignal(TaskData *taskData, PLock *sigLock); virtual void SignalArrived(void); virtual void SetSingleThreaded(void) { singleThreaded = true; } // Operations on mutexes void MutexBlock(TaskData *taskData, Handle hMutex); void MutexUnlock(TaskData *taskData, Handle hMutex); // Operations on condition variables. void WaitInfinite(TaskData *taskData, Handle hMutex); void WaitUntilTime(TaskData *taskData, Handle hMutex, Handle hTime); bool WakeThread(PolyObject *targetThread); // Generally, the system runs with multiple threads. After a // fork, though, there is only one thread. bool singleThreaded; // Each thread has an entry in this vector. std::vector taskArray; /* schedLock: This lock must be held when making scheduling decisions. It must also be held before adding items to taskArray, removing them or scanning the vector. It must also be held before deleting a TaskData object or using it in a thread other than the "owner" */ PLock schedLock; #if (!defined(_WIN32)) pthread_key_t tlsId; #else DWORD tlsId; #endif // We make an exception packet for Interrupt and store it here. // This exception can be raised if we run out of store so we need to // make sure we have the packet before we do. poly_exn *interrupt_exn; /* initialThreadWait: The initial thread waits on this for wake-ups from the ML threads requesting actions such as GC or close-down. */ PCondVar initialThreadWait; // A requesting thread sets this to indicate the request. This value // is only reset once the request has been satisfied. MainThreadRequest *threadRequest; PCondVar mlThreadWait; // All the threads block on here until the request has completed. int exitResult; bool exitRequest; #ifdef HAVE_WINDOWS_H /* Windows including Cygwin */ // Used in profiling HANDLE hStopEvent; /* Signalled to stop all threads. */ HANDLE profilingHd; HANDLE mainThreadHandle; // Handle for main thread LONGLONG lastCPUTime; // CPU used by main thread. #endif TaskData *sigTask; // Pointer to current signal task. }; // Global process data. static Processes processesModule; ProcessExternal *processes = &processesModule; Processes::Processes(): singleThreaded(false), schedLock("Scheduler"), interrupt_exn(0), threadRequest(0), exitResult(0), exitRequest(false), sigTask(0) { #ifdef HAVE_WINDOWS_H hStopEvent = NULL; profilingHd = NULL; lastCPUTime = 0; mainThreadHandle = NULL; #endif } enum _mainThreadPhase mainThreadPhase = MTP_USER_CODE; // Get the attribute flags. static POLYUNSIGNED ThreadAttrs(TaskData *taskData) { return UNTAGGED_UNSIGNED(taskData->threadObject->flags); } -// General interface to thread. Ideally the various cases will be made into -// separate functions. -POLYUNSIGNED PolyThreadGeneral(PolyObject *threadId, PolyWord code, PolyWord arg) -{ - TaskData *taskData = TaskData::FindTaskForId(threadId); - ASSERT(taskData != 0); - taskData->PreRTSCall(); - Handle reset = taskData->saveVec.mark(); - Handle pushedCode = taskData->saveVec.push(code); - Handle pushedArg = taskData->saveVec.push(arg); - Handle result = 0; - - try { - result = processesModule.ThreadDispatch(taskData, pushedArg, pushedCode); - } - catch (KillException &) { - processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill - } - catch (...) { } // If an ML exception is raised - - taskData->saveVec.reset(reset); - taskData->PostRTSCall(); - if (result == 0) return TAGGED(0).AsUnsigned(); - else return result->Word().AsUnsigned(); -} - -POLYUNSIGNED PolyThreadMutexBlock(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyThreadMutexBlock(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); if (profileMode == kProfileMutexContention) taskData->addProfileCount(1); try { processesModule.MutexBlock(taskData, pushedArg); } catch (KillException &) { processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } -POLYUNSIGNED PolyThreadMutexUnlock(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyThreadMutexUnlock(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); try { processesModule.MutexUnlock(taskData, pushedArg); } catch (KillException &) { processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } /* A mutex was locked i.e. the count was ~1 or less. We will have set it to ~1. This code blocks if the count is still ~1. It does actually return if another thread tries to lock the mutex and hasn't yet set the value to ~1 but that doesn't matter since whenever we return we simply try to get the lock again. */ void Processes::MutexBlock(TaskData *taskData, Handle hMutex) { schedLock.Lock(); // We have to check the value again with schedLock held rather than // simply waiting because otherwise the unlocking thread could have // set the variable back to 1 (unlocked) and signalled any waiters // before we actually got to wait. if (UNTAGGED(DEREFHANDLE(hMutex)->Get(0)) < 0) { // Set this so we can see what we're blocked on. taskData->blockMutex = DEREFHANDLE(hMutex); // Now release the ML memory. A GC can start. ThreadReleaseMLMemoryWithSchedLock(taskData); // Wait until we're woken up. We mustn't block if we have been // interrupted, and are processing interrupts asynchronously, or // we've been killed. switch (taskData->requests) { case kRequestKill: // We've been killed. Handle this later. break; case kRequestInterrupt: { // We've been interrupted. POLYUNSIGNED attrs = ThreadAttrs(taskData) & PFLAG_INTMASK; if (attrs == PFLAG_ASYNCH || attrs == PFLAG_ASYNCH_ONCE) break; // If we're ignoring interrupts or handling them synchronously // we don't do anything here. } case kRequestNone: globalStats.incCount(PSC_THREADS_WAIT_MUTEX); taskData->threadLock.Wait(&schedLock); globalStats.decCount(PSC_THREADS_WAIT_MUTEX); } taskData->blockMutex = 0; // No longer blocked. ThreadUseMLMemoryWithSchedLock(taskData); } // Return and try and get the lock again. schedLock.Unlock(); // Test to see if we have been interrupted and if this thread // processes interrupts asynchronously we should raise an exception // immediately. Perhaps we do that whenever we exit from the RTS. } /* Unlock a mutex. Called after incrementing the count and discovering that at least one other thread has tried to lock it. We may need to wake up threads that are blocked. */ void Processes::MutexUnlock(TaskData *taskData, Handle hMutex) { // The caller has already set the variable to 1 (unlocked). // We need to acquire schedLock so that we can // be sure that any thread that is trying to lock sees either // the updated value (and so doesn't wait) or has successfully // waited on its threadLock (and so will be woken up). schedLock.Lock(); // Unlock any waiters. for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { TaskData *p = *i; // If the thread is blocked on this mutex we can signal the thread. if (p && p->blockMutex == DEREFHANDLE(hMutex)) p->threadLock.Signal(); } schedLock.Unlock(); } -POLYUNSIGNED PolyThreadCondVarWait(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyThreadCondVarWait(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); try { processesModule.WaitInfinite(taskData, pushedArg); } catch (KillException &) { processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } -POLYUNSIGNED PolyThreadCondVarWaitUntil(PolyObject *threadId, PolyWord lockArg, PolyWord timeArg) +POLYUNSIGNED PolyThreadCondVarWaitUntil(FirstArgument threadId, PolyWord lockArg, PolyWord timeArg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedLockArg = taskData->saveVec.push(lockArg); Handle pushedTimeArg = taskData->saveVec.push(timeArg); try { processesModule.WaitUntilTime(taskData, pushedLockArg, pushedTimeArg); } catch (KillException &) { processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } // Atomically drop a mutex and wait for a wake up. // It WILL NOT RAISE AN EXCEPTION unless it is set to handle exceptions // asynchronously (which it shouldn't do if the ML caller code is correct). // It may return as a result of any of the following: // an explicit wake up. // an interrupt, either direct or broadcast // a trap i.e. a request to handle an asynchronous event. void Processes::WaitInfinite(TaskData *taskData, Handle hMutex) { schedLock.Lock(); // Atomically release the mutex. This is atomic because we hold schedLock // so no other thread can call signal or broadcast. Handle decrResult = taskData->AtomicIncrement(hMutex); if (UNTAGGED(decrResult->Word()) != 1) { taskData->AtomicReset(hMutex); // The mutex was locked so we have to release any waiters. // Unlock any waiters. for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { TaskData *p = *i; // If the thread is blocked on this mutex we can signal the thread. if (p && p->blockMutex == DEREFHANDLE(hMutex)) p->threadLock.Signal(); } } // Wait until we're woken up. Don't block if we have been interrupted // or killed. if (taskData->requests == kRequestNone) { // Now release the ML memory. A GC can start. ThreadReleaseMLMemoryWithSchedLock(taskData); globalStats.incCount(PSC_THREADS_WAIT_CONDVAR); taskData->threadLock.Wait(&schedLock); globalStats.decCount(PSC_THREADS_WAIT_CONDVAR); // We want to use the memory again. ThreadUseMLMemoryWithSchedLock(taskData); } schedLock.Unlock(); } // Atomically drop a mutex and wait for a wake up or a time to wake up void Processes::WaitUntilTime(TaskData *taskData, Handle hMutex, Handle hWakeTime) { // Convert the time into the correct format for WaitUntil before acquiring // schedLock. div_longc could do a GC which requires schedLock. #if (defined(_WIN32)) // On Windows it is the number of 100ns units since the epoch FILETIME tWake; getFileTimeFromArb(taskData, hWakeTime, &tWake); #else // Unix style times. struct timespec tWake; // On Unix we represent times as a number of microseconds. Handle hMillion = Make_arbitrary_precision(taskData, 1000000); tWake.tv_sec = get_C_ulong(taskData, DEREFWORD(div_longc(taskData, hMillion, hWakeTime))); tWake.tv_nsec = 1000*get_C_ulong(taskData, DEREFWORD(rem_longc(taskData, hMillion, hWakeTime))); #endif schedLock.Lock(); // Atomically release the mutex. This is atomic because we hold schedLock // so no other thread can call signal or broadcast. Handle decrResult = taskData->AtomicIncrement(hMutex); if (UNTAGGED(decrResult->Word()) != 1) { taskData->AtomicReset(hMutex); // The mutex was locked so we have to release any waiters. // Unlock any waiters. for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { TaskData *p = *i; // If the thread is blocked on this mutex we can signal the thread. if (p && p->blockMutex == DEREFHANDLE(hMutex)) p->threadLock.Signal(); } } // Wait until we're woken up. Don't block if we have been interrupted // or killed. if (taskData->requests == kRequestNone) { // Now release the ML memory. A GC can start. ThreadReleaseMLMemoryWithSchedLock(taskData); globalStats.incCount(PSC_THREADS_WAIT_CONDVAR); (void)taskData->threadLock.WaitUntil(&schedLock, &tWake); globalStats.decCount(PSC_THREADS_WAIT_CONDVAR); // We want to use the memory again. ThreadUseMLMemoryWithSchedLock(taskData); } schedLock.Unlock(); } bool Processes::WakeThread(PolyObject *targetThread) { bool result = false; // Default to failed. // Acquire the schedLock first. This ensures that this is // atomic with respect to waiting. schedLock.Lock(); TaskData *p = TaskForIdentifier(targetThread); if (p && p->threadObject == targetThread) { POLYUNSIGNED attrs = ThreadAttrs(p) & PFLAG_INTMASK; if (p->requests == kRequestNone || (p->requests == kRequestInterrupt && attrs == PFLAG_IGNORE)) { p->threadLock.Signal(); result = true; } } schedLock.Unlock(); return result; } POLYUNSIGNED PolyThreadCondVarWake(PolyWord targetThread) { if (processesModule.WakeThread(targetThread.AsObjPtr())) return TAGGED(1).AsUnsigned(); else return TAGGED(0).AsUnsigned(); } // Test if a thread is active. POLYUNSIGNED PolyThreadIsActive(PolyWord targetThread) { // There's a race here: the thread may be exiting but since we're not doing // anything with the TaskData object we don't need a lock. TaskData *p = processesModule.TaskForIdentifier(targetThread.AsObjPtr()); if (p != 0) return TAGGED(1).AsUnsigned(); else return TAGGED(0).AsUnsigned(); } // Send an interrupt to a specific thread POLYUNSIGNED PolyThreadInterruptThread(PolyWord targetThread) { // Must lock here because the thread may be exiting. processesModule.schedLock.Lock(); TaskData *p = processesModule.TaskForIdentifier(targetThread.AsObjPtr()); if (p) processesModule.MakeRequest(p, kRequestInterrupt); processesModule.schedLock.Unlock(); // If the thread cannot be identified return false. // The caller can then raise an exception if (p == 0) return TAGGED(0).AsUnsigned(); else return TAGGED(1).AsUnsigned(); } // Kill a specific thread POLYUNSIGNED PolyThreadKillThread(PolyWord targetThread) { processesModule.schedLock.Lock(); TaskData *p = processesModule.TaskForIdentifier(targetThread.AsObjPtr()); if (p) processesModule.MakeRequest(p, kRequestKill); processesModule.schedLock.Unlock(); // If the thread cannot be identified return false. // The caller can then raise an exception if (p == 0) return TAGGED(0).AsUnsigned(); else return TAGGED(1).AsUnsigned(); } -POLYUNSIGNED PolyThreadBroadcastInterrupt(PolyObject * /*threadId*/) +POLYUNSIGNED PolyThreadBroadcastInterrupt(FirstArgument /*threadId*/) { processesModule.BroadcastInterrupt(); return TAGGED(0).AsUnsigned(); } -POLYUNSIGNED PolyThreadTestInterrupt(PolyObject *threadId) +POLYUNSIGNED PolyThreadTestInterrupt(FirstArgument threadId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { processesModule.TestSynchronousRequests(taskData); // Also process any asynchronous requests that may be pending. // These will be handled "soon" but if we have just switched from deferring // interrupts this guarantees that any deferred interrupts will be handled now. if (processesModule.ProcessAsynchRequests(taskData)) throw IOException(); } catch (KillException &) { processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } // Return the number of processors. // Returns 1 if there is any problem. POLYUNSIGNED PolyThreadNumProcessors(void) { return TAGGED(NumberOfProcessors()).AsUnsigned(); } // Return the number of physical processors. // Returns 0 if there is any problem. POLYUNSIGNED PolyThreadNumPhysicalProcessors(void) { return TAGGED(NumberOfPhysicalProcessors()).AsUnsigned(); } // Set the maximum stack size. -POLYUNSIGNED PolyThreadMaxStackSize(PolyObject *threadId, PolyWord newSize) +POLYUNSIGNED PolyThreadMaxStackSize(FirstArgument threadId, PolyWord newSize) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { taskData->threadObject->mlStackSize = newSize; if (newSize != TAGGED(0)) { uintptr_t current = taskData->currentStackSpace(); // Current size in words uintptr_t newWords = getPolyUnsigned(taskData, newSize); if (current > newWords) raise_exception0(taskData, EXC_interrupt); } } catch (KillException &) { processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } // Old dispatch function. This is only required because the pre-built compiler // may use some of these e.g. fork. Handle Processes::ThreadDispatch(TaskData *taskData, Handle args, Handle code) { unsigned c = get_C_unsigned(taskData, code->Word()); TaskData *ptaskData = taskData; switch (c) { case 1: MutexBlock(taskData, args); return SAVE(TAGGED(0)); case 2: MutexUnlock(taskData, args); return SAVE(TAGGED(0)); case 7: // Fork a new thread. The arguments are the function to run and the attributes. return ForkThread(ptaskData, SAVE(args->WordP()->Get(0)), (Handle)0, args->WordP()->Get(1), // For backwards compatibility we check the length here args->WordP()->Length() <= 2 ? TAGGED(0) : args->WordP()->Get(2)); case 10: // Broadcast an interrupt to all threads that are interested. BroadcastInterrupt(); return SAVE(TAGGED(0)); default: { char msg[100]; sprintf(msg, "Unknown thread function: %u", c); raise_fail(taskData, msg); return 0; } } } // Fill unused allocation space with a dummy object to preserve the invariant // that memory is always valid. void TaskData::FillUnusedSpace(void) { if (allocPointer > allocLimit) gMem.FillUnusedSpace(allocLimit, allocPointer-allocLimit); } TaskData::TaskData(): allocPointer(0), allocLimit(0), allocSize(MIN_HEAP_SIZE), allocCount(0), stack(0), threadObject(0), signalStack(0), inML(false), requests(kRequestNone), blockMutex(0), inMLHeap(false), runningProfileTimer(false) { #ifdef HAVE_WINDOWS_H lastCPUTime = 0; #endif #ifdef HAVE_WINDOWS_H threadHandle = 0; #endif threadExited = false; } TaskData::~TaskData() { if (signalStack) free(signalStack); if (stack) gMem.DeleteStackSpace(stack); #ifdef HAVE_WINDOWS_H if (threadHandle) CloseHandle(threadHandle); #endif } // Broadcast an interrupt to all relevant threads. void Processes::BroadcastInterrupt(void) { // If a thread is set to accept broadcast interrupts set it to // "interrupted". schedLock.Lock(); for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { TaskData *p = *i; if (p) { POLYUNSIGNED attrs = ThreadAttrs(p); if (attrs & PFLAG_BROADCAST) MakeRequest(p, kRequestInterrupt); } } schedLock.Unlock(); } // Set the asynchronous request variable for the thread. Must be called // with the schedLock held. Tries to wake the thread up if possible. void Processes::MakeRequest(TaskData *p, ThreadRequests request) { // We don't override a request to kill by an interrupt request. if (p->requests < request) { p->requests = request; p->InterruptCode(); p->threadLock.Signal(); // Set the value in the ML object as well so the ML code can see it p->threadObject->requestCopy = TAGGED(request); } } void Processes::ThreadExit(TaskData *taskData) { if (debugOptions & DEBUG_THREADS) Log("THREAD: Thread %p exiting\n", taskData); #if (!defined(_WIN32)) // Block any profile interrupt from now on. We're deleting the ML stack for this thread. sigset_t block_sigs; sigemptyset(&block_sigs); sigaddset(&block_sigs, SIGVTALRM); pthread_sigmask(SIG_BLOCK, &block_sigs, NULL); // Remove the thread-specific data since it's no // longer valid. pthread_setspecific(tlsId, 0); #endif if (singleThreaded) finish(0); schedLock.Lock(); ThreadReleaseMLMemoryWithSchedLock(taskData); // Allow a GC if it was waiting for us. taskData->threadExited = true; initialThreadWait.Signal(); // Tell it we've finished. schedLock.Unlock(); #if (!defined(_WIN32)) pthread_exit(0); #else ExitThread(0); #endif } // These two functions are used for calls from outside where // the lock has not yet been acquired. void Processes::ThreadUseMLMemory(TaskData *taskData) { // Trying to acquire the lock here may block if a GC is in progress schedLock.Lock(); ThreadUseMLMemoryWithSchedLock(taskData); schedLock.Unlock(); } void Processes::ThreadReleaseMLMemory(TaskData *taskData) { schedLock.Lock(); ThreadReleaseMLMemoryWithSchedLock(taskData); schedLock.Unlock(); } // Called when a thread wants to resume using the ML heap. That could // be after a wait for some reason or after executing some foreign code. // Since there could be a GC in progress already at this point we may either // be blocked waiting to acquire schedLock or we may need to wait until // we are woken up at the end of the GC. void Processes::ThreadUseMLMemoryWithSchedLock(TaskData *taskData) { TaskData *ptaskData = taskData; // If there is a request outstanding we have to wait for it to // complete. We notify the root thread and wait for it. while (threadRequest != 0) { initialThreadWait.Signal(); // Wait for the GC to happen mlThreadWait.Wait(&schedLock); } ASSERT(! ptaskData->inMLHeap); ptaskData->inMLHeap = true; } // Called to indicate that the thread has temporarily finished with the // ML memory either because it is going to wait for something or because // it is going to run foreign code. If there is an outstanding GC request // that can proceed. void Processes::ThreadReleaseMLMemoryWithSchedLock(TaskData *taskData) { TaskData *ptaskData = taskData; ASSERT(ptaskData->inMLHeap); ptaskData->inMLHeap = false; // Put a dummy object in any unused space. This maintains the // invariant that the allocated area is filled with valid objects. ptaskData->FillUnusedSpace(); // if (threadRequest != 0) initialThreadWait.Signal(); } // Make a request to the root thread. void Processes::MakeRootRequest(TaskData *taskData, MainThreadRequest *request) { if (singleThreaded) { mainThreadPhase = request->mtp; ThreadReleaseMLMemoryWithSchedLock(taskData); // Primarily to call FillUnusedSpace request->Perform(); ThreadUseMLMemoryWithSchedLock(taskData); mainThreadPhase = MTP_USER_CODE; } else { PLocker locker(&schedLock); // Wait for any other requests. while (threadRequest != 0) { // Deal with any pending requests. ThreadReleaseMLMemoryWithSchedLock(taskData); ThreadUseMLMemoryWithSchedLock(taskData); // Drops schedLock while waiting. } // Now the other requests have been dealt with (and we have schedLock). request->completed = false; threadRequest = request; // Wait for it to complete. while (! request->completed) { ThreadReleaseMLMemoryWithSchedLock(taskData); ThreadUseMLMemoryWithSchedLock(taskData); // Drops schedLock while waiting. } } } // Find space for an object. Returns a pointer to the start. "words" must include // the length word and the result points at where the length word will go. PolyWord *Processes::FindAllocationSpace(TaskData *taskData, POLYUNSIGNED words, bool alwaysInSeg) { bool triedInterrupt = false; #ifdef POLYML32IN64 if (words & 1) words++; // Must always be an even number of words. #endif while (1) { // After a GC allocPointer and allocLimit are zero and when allocating the // heap segment we request a minimum of zero words. if (taskData->allocPointer != 0 && taskData->allocPointer >= taskData->allocLimit + words) { // There's space in the current segment, taskData->allocPointer -= words; #ifdef POLYML32IN64 // Zero the last word. If we've rounded up an odd number the caller won't set it. if (words != 0) taskData->allocPointer[words-1] = PolyWord::FromUnsigned(0); ASSERT((uintptr_t)taskData->allocPointer & 4); // Must be odd-word aligned #endif return taskData->allocPointer; } else // Insufficient space in this area. { if (words > taskData->allocSize && ! alwaysInSeg) { // If the object we want is larger than the heap segment size // we allocate it separately rather than in the segment. PolyWord *foundSpace = gMem.AllocHeapSpace(words); if (foundSpace) return foundSpace; } else { // Fill in any unused space in the existing segment taskData->FillUnusedSpace(); // Get another heap segment with enough space for this object. uintptr_t requestSpace = taskData->allocSize+words; uintptr_t spaceSize = requestSpace; // Get the space and update spaceSize with the actual size. PolyWord *space = gMem.AllocHeapSpace(words, spaceSize); if (space) { // Double the allocation size for the next time if // we succeeded in allocating the whole space. taskData->allocCount++; if (spaceSize == requestSpace) taskData->allocSize = taskData->allocSize*2; taskData->allocLimit = space; taskData->allocPointer = space+spaceSize; // Actually allocate the object taskData->allocPointer -= words; #ifdef POLYML32IN64 ASSERT((uintptr_t)taskData->allocPointer & 4); // Must be odd-word aligned #endif return taskData->allocPointer; } } // It's possible that another thread has requested a GC in which case // we will have memory when that happens. We don't want to start // another GC. if (! singleThreaded) { PLocker locker(&schedLock); if (threadRequest != 0) { ThreadReleaseMLMemoryWithSchedLock(taskData); ThreadUseMLMemoryWithSchedLock(taskData); continue; // Try again } } // Try garbage-collecting. If this failed return 0. if (! QuickGC(taskData, words)) { extern FILE *polyStderr; if (! triedInterrupt) { triedInterrupt = true; fprintf(polyStderr,"Run out of store - interrupting threads\n"); if (debugOptions & DEBUG_THREADS) Log("THREAD: Run out of store, interrupting threads\n"); BroadcastInterrupt(); try { if (ProcessAsynchRequests(taskData)) return 0; // Has been interrupted. } catch(KillException &) { // The thread may have been killed. ThreadExit(taskData); } // Not interrupted: pause this thread to allow for other // interrupted threads to free something. #if defined(_WIN32) Sleep(5000); #else sleep(5); #endif // Try again. } else { // That didn't work. Exit. fprintf(polyStderr,"Failed to recover - exiting\n"); RequestProcessExit(1); // Begins the shutdown process ThreadExit(taskData); // And terminate this thread. } } // Try again. There should be space now. } } } #ifdef _MSC_VER // Don't tell me that exitThread has a non-void type. #pragma warning(disable:4646) #endif Handle exitThread(TaskData *taskData) /* A call to this is put on the stack of a new thread so when the thread function returns the thread goes away. */ { processesModule.ThreadExit(taskData); } // Terminate the current thread. Never returns. -POLYUNSIGNED PolyThreadKillSelf(PolyObject *threadId) +POLYUNSIGNED PolyThreadKillSelf(FirstArgument threadId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); // Possibly not needed since we never return processesModule.ThreadExit(taskData); return 0; } /* Called when a thread is about to block, usually because of IO. If this is interruptable (currently only used for Posix functions) the process will be set to raise an exception if any signal is handled. It may also raise an exception if another thread has called broadcastInterrupt. */ void Processes::ThreadPauseForIO(TaskData *taskData, Waiter *pWait) { TestAnyEvents(taskData); // Consider this a blocking call that may raise Interrupt ThreadReleaseMLMemory(taskData); globalStats.incCount(PSC_THREADS_WAIT_IO); pWait->Wait(1000); // Wait up to a second globalStats.decCount(PSC_THREADS_WAIT_IO); ThreadUseMLMemory(taskData); TestAnyEvents(taskData); // Check if we've been interrupted. } // Default waiter: simply wait for the time. In Unix it may be woken // up by a signal. void Waiter::Wait(unsigned maxMillisecs) { // Since this is used only when we can't monitor the source directly // we set this to 10ms so that we're not waiting too long. if (maxMillisecs > 10) maxMillisecs = 10; #if (defined(_WIN32)) Sleep(maxMillisecs); #else // Unix fd_set read_fds, write_fds, except_fds; struct timeval toWait = { 0, 0 }; toWait.tv_sec = maxMillisecs / 1000; toWait.tv_usec = (maxMillisecs % 1000) * 1000; FD_ZERO(&read_fds); FD_ZERO(&write_fds); FD_ZERO(&except_fds); select(FD_SETSIZE, &read_fds, &write_fds, &except_fds, &toWait); #endif } static Waiter defWait; Waiter *Waiter::defaultWaiter = &defWait; #ifdef _WIN32 // Wait for the specified handle to be signalled. void WaitHandle::Wait(unsigned maxMillisecs) { // Wait until we get input or we're woken up. + if (maxMillisecs > m_maxWait) + maxMillisecs = m_maxWait; if (m_Handle == NULL) Sleep(maxMillisecs); else WaitForSingleObject(m_Handle, maxMillisecs); } #else // Unix and Cygwin: Wait for a file descriptor on input. void WaitInputFD::Wait(unsigned maxMillisecs) { fd_set read_fds, write_fds, except_fds; struct timeval toWait = { 0, 0 }; toWait.tv_sec = maxMillisecs / 1000; toWait.tv_usec = (maxMillisecs % 1000) * 1000; FD_ZERO(&read_fds); if (m_waitFD >= 0) FD_SET(m_waitFD, &read_fds); FD_ZERO(&write_fds); FD_ZERO(&except_fds); select(FD_SETSIZE, &read_fds, &write_fds, &except_fds, &toWait); } #endif // Get the task data for the current thread. This is held in // thread-local storage. Normally this is passed in taskData but // in a few cases this isn't available. TaskData *Processes::GetTaskDataForThread(void) { #if (!defined(_WIN32)) return (TaskData *)pthread_getspecific(tlsId); #else return (TaskData *)TlsGetValue(tlsId); #endif } // Called to create a task data object in the current thread. // This is currently only used if a thread created in foreign code calls // a callback. TaskData *Processes::CreateNewTaskData(Handle threadId, Handle threadFunction, Handle args, PolyWord flags) { TaskData *taskData = machineDependent->CreateTaskData(); #if defined(HAVE_WINDOWS_H) HANDLE thisProcess = GetCurrentProcess(); DuplicateHandle(thisProcess, GetCurrentThread(), thisProcess, &(taskData->threadHandle), THREAD_ALL_ACCESS, FALSE, 0); #endif unsigned thrdIndex; { PLocker lock(&schedLock); // See if there's a spare entry in the array. for (thrdIndex = 0; thrdIndex < taskArray.size() && taskArray[thrdIndex] != 0; thrdIndex++); if (thrdIndex == taskArray.size()) // Need to expand the array { try { taskArray.push_back(taskData); } catch (std::bad_alloc&) { delete(taskData); throw MemoryException(); } } else { taskArray[thrdIndex] = taskData; } } taskData->stack = gMem.NewStackSpace(machineDependent->InitialStackSize()); if (taskData->stack == 0) { delete(taskData); throw MemoryException(); } // TODO: Check that there isn't a problem if we try to allocate // memory here and result in a GC. taskData->InitStackFrame(taskData, threadFunction, args); ThreadUseMLMemory(taskData); // If the forking thread has created an ML thread object use that // otherwise create a new one in the current context. if (threadId != 0) taskData->threadObject = (ThreadObject*)threadId->WordP(); else { // Make a thread reference to point to this taskData object. Handle threadRef = MakeVolatileWord(taskData, taskData); // Make a thread object. Since it's in the thread table it can't be garbage collected. taskData->threadObject = (ThreadObject*)alloc(taskData, sizeof(ThreadObject)/sizeof(PolyWord), F_MUTABLE_BIT); taskData->threadObject->threadRef = threadRef->Word(); taskData->threadObject->flags = flags != TAGGED(0) ? TAGGED(PFLAG_SYNCH): flags; taskData->threadObject->threadLocal = TAGGED(0); // Empty thread-local store taskData->threadObject->requestCopy = TAGGED(0); // Cleared interrupt state taskData->threadObject->mlStackSize = TAGGED(0); // Unlimited stack size for (unsigned i = 0; i < sizeof(taskData->threadObject->debuggerSlots)/sizeof(PolyWord); i++) taskData->threadObject->debuggerSlots[i] = TAGGED(0); } #if (!defined(_WIN32)) initThreadSignals(taskData); pthread_setspecific(tlsId, taskData); #else TlsSetValue(tlsId, taskData); #endif globalStats.incCount(PSC_THREADS); return taskData; } // This function is run when a new thread has been forked. The // parameter is the taskData value for the new thread. This function // is also called directly for the main thread. #if (!defined(_WIN32)) static void *NewThreadFunction(void *parameter) { TaskData *taskData = (TaskData *)parameter; #ifdef HAVE_WINDOWS_H // Cygwin: Get the Windows thread handle in case it's needed for profiling. HANDLE thisProcess = GetCurrentProcess(); DuplicateHandle(thisProcess, GetCurrentThread(), thisProcess, &(taskData->threadHandle), THREAD_ALL_ACCESS, FALSE, 0); #endif initThreadSignals(taskData); pthread_setspecific(processesModule.tlsId, taskData); taskData->saveVec.init(); // Remove initial data globalStats.incCount(PSC_THREADS); processes->ThreadUseMLMemory(taskData); try { (void)taskData->EnterPolyCode(); // Will normally (always?) call ExitThread. } catch (KillException &) { processesModule.ThreadExit(taskData); } return 0; } #else static DWORD WINAPI NewThreadFunction(void *parameter) { TaskData *taskData = (TaskData *)parameter; TlsSetValue(processesModule.tlsId, taskData); taskData->saveVec.init(); // Removal initial data globalStats.incCount(PSC_THREADS); processes->ThreadUseMLMemory(taskData); try { (void)taskData->EnterPolyCode(); } catch (KillException &) { processesModule.ThreadExit(taskData); } return 0; } #endif // Sets up the initial thread from the root function. This is run on // the initial thread of the process so it will work if we don't // have pthreads. // When multithreading this thread also deals with all garbage-collection // and similar operations and the ML threads send it requests to deal with // that. These require all the threads to pause until the operation is complete // since they affect all memory but they are also sometimes highly recursive. // On Mac OS X and on Linux if the stack limit is set to unlimited only the // initial thread has a large stack and newly created threads have smaller // stacks. We need to make sure that any significant stack usage occurs only // on the inital thread. void Processes::BeginRootThread(PolyObject *rootFunction) { int exitLoopCount = 100; // Maximum 100 * 400 ms. if (taskArray.size() < 1) { try { taskArray.push_back(0); } catch (std::bad_alloc&) { ::Exit("Unable to create the initial thread - insufficient memory"); } } try { // We can't use ForkThread because we don't have a taskData object before we start TaskData *taskData = machineDependent->CreateTaskData(); Handle threadRef = MakeVolatileWord(taskData, taskData); taskData->threadObject = (ThreadObject*)alloc(taskData, sizeof(ThreadObject) / sizeof(PolyWord), F_MUTABLE_BIT); taskData->threadObject->threadRef = threadRef->Word(); // The initial thread is set to accept broadcast interrupt requests // and handle them synchronously. This is for backwards compatibility. taskData->threadObject->flags = TAGGED(PFLAG_BROADCAST|PFLAG_ASYNCH); // Flags taskData->threadObject->threadLocal = TAGGED(0); // Empty thread-local store taskData->threadObject->requestCopy = TAGGED(0); // Cleared interrupt state taskData->threadObject->mlStackSize = TAGGED(0); // Unlimited stack size for (unsigned i = 0; i < sizeof(taskData->threadObject->debuggerSlots)/sizeof(PolyWord); i++) taskData->threadObject->debuggerSlots[i] = TAGGED(0); #if defined(HAVE_WINDOWS_H) taskData->threadHandle = mainThreadHandle; #endif taskArray[0] = taskData; taskData->stack = gMem.NewStackSpace(machineDependent->InitialStackSize()); if (taskData->stack == 0) ::Exit("Unable to create the initial thread - insufficient memory"); taskData->InitStackFrame(taskData, taskData->saveVec.push(rootFunction), (Handle)0); // Create a packet for the Interrupt exception once so that we don't have to // allocate when we need to raise it. // We can only do this once the taskData object has been created. if (interrupt_exn == 0) interrupt_exn = makeExceptionPacket(taskData, EXC_interrupt); if (singleThreaded) { // If we don't have threading enter the code as if this were a new thread. // This will call finish so will never return. NewThreadFunction(taskData); } schedLock.Lock(); int errorCode = 0; #if (!defined(_WIN32)) if (pthread_create(&taskData->threadId, NULL, NewThreadFunction, taskData) != 0) errorCode = errno; #else taskData->threadHandle = CreateThread(NULL, 0, NewThreadFunction, taskData, 0, NULL); if (taskData->threadHandle == NULL) errorCode = GetLastError(); #endif if (errorCode != 0) { // Thread creation failed. taskArray[0] = 0; delete(taskData); ExitWithError("Unable to create initial thread:", errorCode); } if (debugOptions & DEBUG_THREADS) Log("THREAD: Forked initial root thread %p\n", taskData); } catch (std::bad_alloc &) { ::Exit("Unable to create the initial thread - insufficient memory"); } // Wait until the threads terminate or make a request. // We only release schedLock while waiting. while (1) { // Look at the threads to see if they are running. bool allStopped = true; bool noUserThreads = true; bool signalThreadRunning = false; for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { TaskData *p = *i; if (p) { if (p == sigTask) signalThreadRunning = true; else if (! p->threadExited) noUserThreads = false; if (p->inMLHeap) { allStopped = false; // It must be running - interrupt it if we are waiting. if (threadRequest != 0) p->InterruptCode(); } else if (p->threadExited) // Has the thread terminated? { // Wait for it to actually stop then delete the task data. #if (!defined(_WIN32)) pthread_join(p->threadId, NULL); #else WaitForSingleObject(p->threadHandle, INFINITE); #endif // The thread ref is no longer valid. *(TaskData**)(p->threadObject->threadRef.AsObjPtr()) = 0; delete(p); // Delete the task Data *i = 0; globalStats.decCount(PSC_THREADS); } } } if (noUserThreads) { // If all threads apart from the signal thread have exited then // we can finish but we must make sure that the signal thread has // exited before we finally finish and deallocate the memory. if (signalThreadRunning) exitRequest = true; else break; // Really no threads. } if (allStopped && threadRequest != 0) { mainThreadPhase = threadRequest->mtp; gMem.ProtectImmutable(false); // GC, sharing and export may all write to the immutable area threadRequest->Perform(); gMem.ProtectImmutable(true); mainThreadPhase = MTP_USER_CODE; threadRequest->completed = true; threadRequest = 0; // Allow a new request. mlThreadWait.Signal(); } // Have we had a request to stop? This may have happened while in the GC. if (exitRequest) { // Set this to kill the threads. for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { TaskData *taskData = *i; if (taskData && taskData->requests != kRequestKill) MakeRequest(taskData, kRequestKill); } // Leave exitRequest set so that if we're in the process of // creating a new thread we will request it to stop when the // taskData object has been added to the table. } // Now release schedLock and wait for a thread // to wake us up or for the timer to expire to update the statistics. if (! initialThreadWait.WaitFor(&schedLock, 400)) { // We didn't receive a request in the last 400ms if (exitRequest) { if (--exitLoopCount < 0) { // The loop count has expired and there is at least one thread that hasn't exited. // Assume we've deadlocked. #if defined(HAVE_WINDOWS_H) ExitProcess(1); #else _exit(1); // Something is stuck. Get out without calling destructors. #endif } } } // Update the periodic stats. // Calculate the free memory. We have to be careful here because although // we have the schedLock we don't have any lock that prevents a thread // from allocating a new segment. Since these statistics are only // very rough it doesn't matter if there's a glitch. // One possibility would be see if the value of // gMem.GetFreeAllocSpace() has changed from what it was at the // start and recalculate if it has. // We also count the number of threads in ML code. Taking the // lock in EnterPolyCode on every RTS call turned out to be // expensive. uintptr_t freeSpace = 0; unsigned threadsInML = 0; for (std::vector::iterator j = taskArray.begin(); j != taskArray.end(); j++) { TaskData *taskData = *j; if (taskData) { // This gets the values last time it was in the RTS. PolyWord *limit = taskData->allocLimit, *ptr = taskData->allocPointer; if (limit < ptr && (uintptr_t)(ptr-limit) < taskData->allocSize) freeSpace += ptr-limit; if (taskData->inML) threadsInML++; } } // Add the space in the allocation areas after calculating the sizes for the // threads in case a thread has allocated some more. freeSpace += gMem.GetFreeAllocSpace(); globalStats.updatePeriodicStats(freeSpace, threadsInML); } schedLock.Unlock(); finish(exitResult); // Close everything down and exit. } // Create a new thread. Returns the ML thread identifier object if it succeeds. // May raise an exception. Handle Processes::ForkThread(TaskData *taskData, Handle threadFunction, Handle args, PolyWord flags, PolyWord stacksize) { if (singleThreaded) raise_exception_string(taskData, EXC_thread, "Threads not available"); try { // Create a taskData object for the new thread TaskData *newTaskData = machineDependent->CreateTaskData(); // We allocate the thread object in the PARENT's space Handle threadRef = MakeVolatileWord(taskData, newTaskData); Handle threadId = alloc_and_save(taskData, sizeof(ThreadObject) / sizeof(PolyWord), F_MUTABLE_BIT); newTaskData->threadObject = (ThreadObject*)DEREFHANDLE(threadId); newTaskData->threadObject->threadRef = threadRef->Word(); newTaskData->threadObject->flags = flags; // Flags newTaskData->threadObject->threadLocal = TAGGED(0); // Empty thread-local store newTaskData->threadObject->requestCopy = TAGGED(0); // Cleared interrupt state newTaskData->threadObject->mlStackSize = stacksize; for (unsigned i = 0; i < sizeof(newTaskData->threadObject->debuggerSlots)/sizeof(PolyWord); i++) newTaskData->threadObject->debuggerSlots[i] = TAGGED(0); unsigned thrdIndex; schedLock.Lock(); // Before forking a new thread check to see whether we have been asked // to exit. Processes::Exit sets the current set of threads to exit but won't // see a new thread. if (taskData->requests == kRequestKill) { schedLock.Unlock(); // Raise an exception although the thread may exit before we get there. raise_exception_string(taskData, EXC_thread, "Thread is exiting"); } // See if there's a spare entry in the array. for (thrdIndex = 0; thrdIndex < taskArray.size() && taskArray[thrdIndex] != 0; thrdIndex++); if (thrdIndex == taskArray.size()) // Need to expand the array { try { taskArray.push_back(newTaskData); } catch (std::bad_alloc&) { delete(newTaskData); schedLock.Unlock(); raise_exception_string(taskData, EXC_thread, "Too many threads"); } } else { taskArray[thrdIndex] = newTaskData; } schedLock.Unlock(); newTaskData->stack = gMem.NewStackSpace(machineDependent->InitialStackSize()); if (newTaskData->stack == 0) { delete(newTaskData); raise_exception_string(taskData, EXC_thread, "Unable to allocate thread stack"); } // Allocate anything needed for the new stack in the parent's heap. // The child still has inMLHeap set so mustn't GC. newTaskData->InitStackFrame(taskData, threadFunction, args); // Now actually fork the thread. bool success = false; schedLock.Lock(); #if (!defined(_WIN32)) success = pthread_create(&newTaskData->threadId, NULL, NewThreadFunction, newTaskData) == 0; #else newTaskData->threadHandle = CreateThread(NULL, 0, NewThreadFunction, newTaskData, 0, NULL); success = newTaskData->threadHandle != NULL; #endif if (success) { schedLock.Unlock(); if (debugOptions & DEBUG_THREADS) Log("THREAD: Forking new thread %p from thread %p\n", newTaskData, taskData); return threadId; } // Thread creation failed. taskArray[thrdIndex] = 0; delete(newTaskData); schedLock.Unlock(); if (debugOptions & DEBUG_THREADS) Log("THREAD: Fork from thread %p failed\n", taskData); raise_exception_string(taskData, EXC_thread, "Thread creation failed"); } catch (std::bad_alloc &) { raise_exception_string(taskData, EXC_thread, "Insufficient memory"); } } // ForkFromRTS. Creates a new thread from within the RTS. This is currently used // only to run a signal function. bool Processes::ForkFromRTS(TaskData *taskData, Handle proc, Handle arg) { try { (void)ForkThread(taskData, proc, arg, TAGGED(PFLAG_SYNCH), TAGGED(0)); return true; } catch (IOException &) { // If it failed return false; } } -POLYUNSIGNED PolyThreadForkThread(PolyObject *threadId, PolyWord function, PolyWord attrs, PolyWord stack) +POLYUNSIGNED PolyThreadForkThread(FirstArgument threadId, PolyWord function, PolyWord attrs, PolyWord stack) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedFunction = taskData->saveVec.push(function); Handle result = 0; try { result = processesModule.ForkThread(taskData, pushedFunction, (Handle)0, attrs, stack); } catch (KillException &) { processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Deal with any interrupt or kill requests. bool Processes::ProcessAsynchRequests(TaskData *taskData) { bool wasInterrupted = false; TaskData *ptaskData = taskData; schedLock.Lock(); switch (ptaskData->requests) { case kRequestNone: schedLock.Unlock(); break; case kRequestInterrupt: { // Handle asynchronous interrupts only. // We've been interrupted. POLYUNSIGNED attrs = ThreadAttrs(ptaskData); POLYUNSIGNED intBits = attrs & PFLAG_INTMASK; if (intBits == PFLAG_ASYNCH || intBits == PFLAG_ASYNCH_ONCE) { if (intBits == PFLAG_ASYNCH_ONCE) { // Set this so from now on it's synchronous. // This word is only ever set by the thread itself so // we don't need to synchronise. attrs = (attrs & (~PFLAG_INTMASK)) | PFLAG_SYNCH; ptaskData->threadObject->flags = TAGGED(attrs); } ptaskData->requests = kRequestNone; // Clear this ptaskData->threadObject->requestCopy = TAGGED(0); // And in the ML copy schedLock.Unlock(); // Don't actually throw the exception here. taskData->SetException(interrupt_exn); wasInterrupted = true; } else schedLock.Unlock(); } break; case kRequestKill: // The thread has been asked to stop. schedLock.Unlock(); throw KillException(); // Doesn't return. } #ifndef HAVE_WINDOWS_H // Start the profile timer if needed. if (profileMode == kProfileTime) { if (! ptaskData->runningProfileTimer) { ptaskData->runningProfileTimer = true; StartProfilingTimer(); } } else ptaskData->runningProfileTimer = false; // The timer will be stopped next time it goes off. #endif return wasInterrupted; } // If this thread is processing interrupts synchronously and has been // interrupted clear the interrupt and raise the exception. This is // called from IO routines which may block. void Processes::TestSynchronousRequests(TaskData *taskData) { TaskData *ptaskData = taskData; schedLock.Lock(); switch (ptaskData->requests) { case kRequestNone: schedLock.Unlock(); break; case kRequestInterrupt: { // Handle synchronous interrupts only. // We've been interrupted. POLYUNSIGNED attrs = ThreadAttrs(ptaskData); POLYUNSIGNED intBits = attrs & PFLAG_INTMASK; if (intBits == PFLAG_SYNCH) { ptaskData->requests = kRequestNone; // Clear this ptaskData->threadObject->requestCopy = TAGGED(0); schedLock.Unlock(); taskData->SetException(interrupt_exn); throw IOException(); } else schedLock.Unlock(); } break; case kRequestKill: // The thread has been asked to stop. schedLock.Unlock(); throw KillException(); // Doesn't return. } } // Check for asynchronous or synchronous events void Processes::TestAnyEvents(TaskData *taskData) { TestSynchronousRequests(taskData); if (ProcessAsynchRequests(taskData)) throw IOException(); } // Request that the process should exit. // This will usually be called from an ML thread as a result of // a call to OS.Process.exit but on Windows it can be called from the GUI thread. void Processes::RequestProcessExit(int n) { if (singleThreaded) finish(n); exitResult = n; exitRequest = true; PLocker lock(&schedLock); // Lock so we know the main thread is waiting initialThreadWait.Signal(); // Wake it if it's sleeping. } /******************************************************************************/ /* */ /* catchVTALRM - handler for alarm-clock signal */ /* */ /******************************************************************************/ #if !defined(HAVE_WINDOWS_H) // N.B. This may be called either by an ML thread or by the main thread. // On the main thread taskData will be null. static void catchVTALRM(SIG_HANDLER_ARGS(sig, context)) { ASSERT(sig == SIGVTALRM); if (profileMode != kProfileTime) { // We stop the timer for this thread on the next signal after we end profile static struct itimerval stoptime = {{0, 0}, {0, 0}}; /* Stop the timer */ setitimer(ITIMER_VIRTUAL, & stoptime, NULL); } else { TaskData *taskData = processes->GetTaskDataForThread(); handleProfileTrap(taskData, (SIGNALCONTEXT*)context); } } #else /* Windows including Cygwin */ // This runs as a separate thread. Every millisecond it checks the CPU time used // by each ML thread and increments the count for each thread that has used a // millisecond of CPU time. static bool testCPUtime(HANDLE hThread, LONGLONG &lastCPUTime) { FILETIME cTime, eTime, kTime, uTime; // Try to get the thread CPU time if possible. This isn't supported // in Windows 95/98 so if it fails we just include this thread anyway. if (GetThreadTimes(hThread, &cTime, &eTime, &kTime, &uTime)) { LONGLONG totalTime = 0; LARGE_INTEGER li; li.LowPart = kTime.dwLowDateTime; li.HighPart = kTime.dwHighDateTime; totalTime += li.QuadPart; li.LowPart = uTime.dwLowDateTime; li.HighPart = uTime.dwHighDateTime; totalTime += li.QuadPart; if (totalTime - lastCPUTime >= 10000) { lastCPUTime = totalTime; return true; } return false; } else return true; // Failed to get thread time, maybe Win95. } void Processes::ProfileInterrupt(void) { // Wait for millisecond or until the stop event is signalled. while (WaitForSingleObject(hStopEvent, 1) == WAIT_TIMEOUT) { // We need to hold schedLock to examine the taskArray but // that is held during garbage collection. if (schedLock.Trylock()) { for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { TaskData *p = *i; if (p && p->threadHandle) { if (testCPUtime(p->threadHandle, p->lastCPUTime)) { CONTEXT context; SuspendThread(p->threadHandle); context.ContextFlags = CONTEXT_CONTROL; /* Get Eip and Esp */ if (GetThreadContext(p->threadHandle, &context)) { handleProfileTrap(p, &context); } ResumeThread(p->threadHandle); } } } schedLock.Unlock(); } // Check the CPU time used by the main thread. This is used for GC // so we need to check that as well. if (testCPUtime(mainThreadHandle, lastCPUTime)) handleProfileTrap(NULL, NULL); } } DWORD WINAPI ProfilingTimer(LPVOID parm) { processesModule.ProfileInterrupt(); return 0; } #endif // Profiling control. Called by the root thread. void Processes::StartProfiling(void) { #ifdef HAVE_WINDOWS_H DWORD threadId; extern FILE *polyStdout; if (profilingHd) return; ResetEvent(hStopEvent); profilingHd = CreateThread(NULL, 0, ProfilingTimer, NULL, 0, &threadId); if (profilingHd == NULL) { fputs("Creating ProfilingTimer thread failed.\n", polyStdout); return; } /* Give this a higher than normal priority so it pre-empts the main thread. Without this it will tend only to be run when the main thread blocks for some reason. */ SetThreadPriority(profilingHd, THREAD_PRIORITY_ABOVE_NORMAL); #else // In Linux, at least, we need to run a timer in each thread. // We request each to enter the RTS so that it will start the timer. // Since this is being run by the main thread while all the ML threads // are paused this may not actually be necessary. for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { TaskData *taskData = *i; if (taskData) { taskData->InterruptCode(); } } StartProfilingTimer(); // Start the timer in the root thread. #endif } void Processes::StopProfiling(void) { #ifdef HAVE_WINDOWS_H if (hStopEvent) SetEvent(hStopEvent); // Wait for the thread to stop if (profilingHd) { WaitForSingleObject(profilingHd, 10000); CloseHandle(profilingHd); } profilingHd = NULL; #endif } // Called by the ML signal handling thread. It blocks until a signal // arrives. There should only be a single thread waiting here. bool Processes::WaitForSignal(TaskData *taskData, PLock *sigLock) { TaskData *ptaskData = taskData; // We need to hold the signal lock until we have acquired schedLock. schedLock.Lock(); sigLock->Unlock(); if (sigTask != 0) { schedLock.Unlock(); return false; } sigTask = ptaskData; if (ptaskData->requests == kRequestNone) { // Now release the ML memory. A GC can start. ThreadReleaseMLMemoryWithSchedLock(ptaskData); globalStats.incCount(PSC_THREADS_WAIT_SIGNAL); ptaskData->threadLock.Wait(&schedLock); globalStats.decCount(PSC_THREADS_WAIT_SIGNAL); // We want to use the memory again. ThreadUseMLMemoryWithSchedLock(ptaskData); } sigTask = 0; schedLock.Unlock(); return true; } // Called by the signal detection thread to wake up the signal handler // thread. Must be called AFTER releasing sigLock. void Processes::SignalArrived(void) { PLocker locker(&schedLock); if (sigTask) sigTask->threadLock.Signal(); } #if (!defined(_WIN32)) // This is called when the thread exits in foreign code and // ThreadExit has not been called. static void threaddata_destructor(void *p) { TaskData *pt = (TaskData *)p; pt->threadExited = true; // This doesn't actually wake the main thread and relies on the // regular check to release the task data. } #endif void Processes::Init(void) { #if (!defined(_WIN32)) pthread_key_create(&tlsId, threaddata_destructor); #else tlsId = TlsAlloc(); #endif #if defined(HAVE_WINDOWS_H) /* Windows including Cygwin. */ // Create stop event for time profiling. hStopEvent = CreateEvent(NULL, TRUE, FALSE, NULL); // Get the thread handle for this thread. HANDLE thisProcess = GetCurrentProcess(); DuplicateHandle(thisProcess, GetCurrentThread(), thisProcess, &mainThreadHandle, THREAD_ALL_ACCESS, FALSE, 0); #else // Set up a signal handler. This will be the same for all threads. markSignalInuse(SIGVTALRM); setSignalHandler(SIGVTALRM, catchVTALRM); #endif } #ifndef HAVE_WINDOWS_H // On Linux, at least, each thread needs to run this. void Processes::StartProfilingTimer(void) { // set virtual timer to go off every millisecond struct itimerval starttime; starttime.it_interval.tv_sec = starttime.it_value.tv_sec = 0; starttime.it_interval.tv_usec = starttime.it_value.tv_usec = 1000; setitimer(ITIMER_VIRTUAL,&starttime,NULL); } #endif void Processes::Stop(void) { #if (!defined(_WIN32)) pthread_key_delete(tlsId); #else TlsFree(tlsId); #endif #if defined(HAVE_WINDOWS_H) /* Stop the timer and profiling threads. */ if (hStopEvent) SetEvent(hStopEvent); if (profilingHd) { WaitForSingleObject(profilingHd, 10000); CloseHandle(profilingHd); profilingHd = NULL; } if (hStopEvent) CloseHandle(hStopEvent); hStopEvent = NULL; if (mainThreadHandle) CloseHandle(mainThreadHandle); mainThreadHandle = NULL; #else profileMode = kProfileOff; // Make sure the timer is not running struct itimerval stoptime; memset(&stoptime, 0, sizeof(stoptime)); setitimer(ITIMER_VIRTUAL, &stoptime, NULL); #endif } void Processes::GarbageCollect(ScanAddress *process) /* Ensures that all the objects are retained and their addresses updated. */ { /* The interrupt exn */ if (interrupt_exn != 0) { PolyObject *p = interrupt_exn; process->ScanRuntimeAddress(&p, ScanAddress::STRENGTH_STRONG); interrupt_exn = (PolyException*)p; } for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { if (*i) (*i)->GarbageCollect(process); } } void TaskData::GarbageCollect(ScanAddress *process) { saveVec.gcScan(process); if (threadObject != 0) { PolyObject *p = threadObject; process->ScanRuntimeAddress(&p, ScanAddress::STRENGTH_STRONG); threadObject = (ThreadObject*)p; } if (blockMutex != 0) process->ScanRuntimeAddress(&blockMutex, ScanAddress::STRENGTH_STRONG); // The allocation spaces are no longer valid. allocPointer = 0; allocLimit = 0; // Divide the allocation size by four. If we have made a single allocation // since the last GC the size will have been doubled after the allocation. // On average for each thread, apart from the one that ran out of space // and requested the GC, half of the space will be unused so reducing by // four should give a good estimate for next time. if (allocCount != 0) { // Do this only once for each GC. allocCount = 0; allocSize = allocSize/4; if (allocSize < MIN_HEAP_SIZE) allocSize = MIN_HEAP_SIZE; } } // Return the number of processors. extern unsigned NumberOfProcessors(void) { #if (defined(_WIN32)) SYSTEM_INFO info; memset(&info, 0, sizeof(info)); GetSystemInfo(&info); if (info.dwNumberOfProcessors == 0) // Just in case info.dwNumberOfProcessors = 1; return info.dwNumberOfProcessors; #elif(defined(_SC_NPROCESSORS_ONLN)) long res = sysconf(_SC_NPROCESSORS_ONLN); if (res <= 0) res = 1; return res; #elif(defined(HAVE_SYSCTL) && defined(CTL_HW) && defined(HW_NCPU)) static int mib[2] = { CTL_HW, HW_NCPU }; int nCPU = 1; size_t len = sizeof(nCPU); if (sysctl(mib, 2, &nCPU, &len, NULL, 0) == 0 && len == sizeof(nCPU)) return nCPU; else return 1; #else // Can't determine. return 1; #endif } // Return the number of physical processors. If hyperthreading is // enabled this returns less than NumberOfProcessors. Returns zero if // it cannot be determined. // This can be used in Cygwin as well as native Windows. #if (defined(HAVE_SYSTEM_LOGICAL_PROCESSOR_INFORMATION)) typedef BOOL (WINAPI *GETP)(SYSTEM_LOGICAL_PROCESSOR_INFORMATION*, PDWORD); // Windows - use GetLogicalProcessorInformation if it's available. static unsigned WinNumPhysicalProcessors(void) { GETP getProcInfo = (GETP) GetProcAddress(GetModuleHandle(_T("kernel32")), "GetLogicalProcessorInformation"); if (getProcInfo == 0) return 0; // It's there - use it. SYSTEM_LOGICAL_PROCESSOR_INFORMATION *buff = 0; DWORD space = 0; while (getProcInfo(buff, &space) == FALSE) { if (GetLastError() != ERROR_INSUFFICIENT_BUFFER) { free(buff); return 0; } free(buff); buff = (PSYSTEM_LOGICAL_PROCESSOR_INFORMATION)malloc(space); if (buff == 0) return 0; } // Calculate the number of full entries in case it's truncated. unsigned nItems = space / sizeof(SYSTEM_LOGICAL_PROCESSOR_INFORMATION); unsigned numProcs = 0; for (unsigned i = 0; i < nItems; i++) { if (buff[i].Relationship == RelationProcessorCore) numProcs++; } free(buff); return numProcs; } #endif // Read and parse /proc/cpuinfo static unsigned LinuxNumPhysicalProcessors(void) { // Find out the total. This should be the maximum. unsigned nProcs = NumberOfProcessors(); // If there's only one we don't need to check further. if (nProcs <= 1) return nProcs; long *cpus = (long*)calloc(nProcs, sizeof(long)); if (cpus == 0) return 0; FILE *cpuInfo = fopen("/proc/cpuinfo", "r"); if (cpuInfo == NULL) { free(cpus); return 0; } char line[40]; unsigned count = 0; while (fgets(line, sizeof(line), cpuInfo) != NULL) { if (strncmp(line, "core id\t\t:", 10) == 0) { long n = strtol(line+10, NULL, 10); unsigned i = 0; // Skip this id if we've seen it already while (i < count && cpus[i] != n) i++; if (i == count) cpus[count++] = n; } if (strchr(line, '\n') == 0) { int ch; do { ch = getc(cpuInfo); } while (ch != '\n' && ch != EOF); } } fclose(cpuInfo); free(cpus); return count; } extern unsigned NumberOfPhysicalProcessors(void) { unsigned numProcs = 0; #if (defined(HAVE_SYSTEM_LOGICAL_PROCESSOR_INFORMATION)) numProcs = WinNumPhysicalProcessors(); if (numProcs != 0) return numProcs; #endif #if (defined(HAVE_SYSCTLBYNAME) && defined(HAVE_SYS_SYSCTL_H)) // Mac OS X int nCores; size_t len = sizeof(nCores); if (sysctlbyname("hw.physicalcpu", &nCores, &len, NULL, 0) == 0) return (unsigned)nCores; #endif numProcs = LinuxNumPhysicalProcessors(); if (numProcs != 0) return numProcs; // Any other cases? return numProcs; } diff --git a/libpolyml/processes.h b/libpolyml/processes.h index b9511263..486bde0d 100644 --- a/libpolyml/processes.h +++ b/libpolyml/processes.h @@ -1,361 +1,362 @@ /* Title: Lightweight process library Author: David C.J. Matthews Copyright (c) 2007-8, 2012, 2015, 2017, 2019 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifndef _PROCESSES_H_ #define _PROCESSES_H_ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #include "globals.h" #include "rts_module.h" #include "save_vec.h" #include "noreturn.h" #include "locking.h" class SaveVecEntry; typedef SaveVecEntry *Handle; class StackSpace; class PolyWord; class ScanAddress; class MDTaskData; class Exporter; class StackObject; #ifdef HAVE_WINDOWS_H typedef void *HANDLE; #endif #ifdef HAVE_SIGNAL_H #include #endif #ifdef HAVE_UCONTEXT_H #include #endif #ifdef HAVE_PTHREAD_H #include #endif // SIGNALCONTEXT is the argument type that is passed to GetPCandSPFromContext // to get the actual PC and SP in a profiling trap. #if defined(HAVE_WINDOWS_H) // First because it's used in both native Windows and Cygwin. #include #define SIGNALCONTEXT CONTEXT // This is the thread context. #elif defined(HAVE_UCONTEXT_T) #define SIGNALCONTEXT ucontext_t #elif defined(HAVE_STRUCT_SIGCONTEXT) #define SIGNALCONTEXT struct sigcontext #else #define SIGNALCONTEXT void #endif #define MIN_HEAP_SIZE 4096 // Minimum and initial heap segment size (words) // This is the ML "thread identifier" object. The fields // are read and set by the ML code. class ThreadObject: public PolyObject { public: PolyWord threadRef; // Weak ref containing the address of the thread data. Not used by ML PolyWord flags; // Tagged integer containing flags indicating how interrupts // are handled. Set by ML but only by the thread itself PolyWord threadLocal; // Head of a list of thread-local store items. // Handled entirely by ML but only by the thread. PolyWord requestCopy; // A tagged integer copy of the "requests" field. // This is provided so that ML can easily test if there // is an interrupt pending. PolyWord mlStackSize; // A tagged integer with the maximum ML stack size in bytes PolyWord debuggerSlots[4]; // These are used by the debugger. }; // Other threads may make requests to a thread. typedef enum { kRequestNone = 0, // Increasing severity kRequestInterrupt = 1, kRequestKill = 2 } ThreadRequests; // Per-thread data. This is subclassed for each architecture. class TaskData { public: TaskData(); virtual ~TaskData(); void FillUnusedSpace(void); virtual void GarbageCollect(ScanAddress *process); virtual Handle EnterPolyCode() = 0; // Start running ML virtual void InterruptCode() = 0; virtual bool AddTimeProfileCount(SIGNALCONTEXT *context) = 0; // Initialise the stack for a new thread. The parent task object is passed in because any // allocation that needs to be made must be made in the parent. virtual void InitStackFrame(TaskData *parentTask, Handle proc, Handle arg) = 0; virtual void SetException(poly_exn *exc) = 0; // If a foreign function calls back to ML we need to set up the call to the // ML callback function. virtual Handle EnterCallbackFunction(Handle func, Handle args) = 0; // The scheduler needs versions of atomic increment and atomic reset that // work in exactly the same way as the code-generated versions (if any). // Atomic decrement isn't needed since it only ever releases a mutex. virtual Handle AtomicIncrement(Handle mutexp) = 0; // Reset a mutex to one. This needs to be atomic with respect to the // atomic increment and decrement instructions. virtual void AtomicReset(Handle mutexp) = 0; virtual void CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length) = 0; virtual uintptr_t currentStackSpace(void) const = 0; // Add a count to the local function if we are using store profiling. virtual void addProfileCount(POLYUNSIGNED words) = 0; // Functions called before and after an RTS call. virtual void PreRTSCall(void) { inML = false; } virtual void PostRTSCall(void) { inML = true; } SaveVec saveVec; PolyWord *allocPointer; // Allocation pointer - decremented towards... PolyWord *allocLimit; // ... lower limit of allocation uintptr_t allocSize; // The preferred heap segment size unsigned allocCount; // The number of allocations since the last GC StackSpace *stack; ThreadObject *threadObject; // Pointer to the thread object. int lastError; // Last error from foreign code. void *signalStack; // Stack to handle interrupts (Unix only) bool inML; // True when this is in ML, false in the RTS // Get a TaskData pointer given the ML taskId. // This is called at the start of every RTS function that may allocate memory. // It is can be called safely to get the thread's own TaskData object without // a lock but any call to get the TaskData for another thread must take the // schedLock first in case the thread is exiting. - static TaskData *FindTaskForId(PolyObject *taskId) { - return *(TaskData**)(((ThreadObject*)taskId)->threadRef.AsObjPtr()); + static TaskData *FindTaskForId(PolyWord taskId) { + return *(TaskData**)(((ThreadObject*)taskId.AsObjPtr())->threadRef.AsObjPtr()); } private: // If a thread has to block it will block on this. PCondVar threadLock; // External requests made are stored here until they // can be actioned. ThreadRequests requests; // Pointer to the mutex when blocked. Set to NULL when it doesn't apply. PolyObject *blockMutex; // This is set to false when a thread blocks or enters foreign code, // While it is true the thread can manipulate ML memory so no other // thread can garbage collect. bool inMLHeap; // In Linux, at least, we need to run a separate timer in each thread bool runningProfileTimer; #ifdef HAVE_WINDOWS_H LONGLONG lastCPUTime; // Used for profiling #endif public: bool threadExited; private: #ifdef HAVE_PTHREAD_H pthread_t threadId; #endif #ifdef HAVE_WINDOWS_H public: // Because, on Cygwin, it's used in NewThreadFunction HANDLE threadHandle; private: #endif friend class Processes; }; NORETURNFN(extern Handle exitThread(TaskData *mdTaskData)); class ScanAddress; // Indicate what the main thread is doing if the profile // timer goes off. extern enum _mainThreadPhase { MTP_USER_CODE=0, MTP_GCPHASESHARING, MTP_GCPHASEMARK, MTP_GCPHASECOMPACT, MTP_GCPHASEUPDATE, MTP_GCQUICK, MTP_SHARING, MTP_EXPORTING, MTP_SAVESTATE, MTP_LOADSTATE, MTP_PROFILING, MTP_SIGHANDLER, MTP_CYGWINSPAWN, MTP_STOREMODULE, MTP_LOADMODULE, MTP_MAXENTRY } mainThreadPhase; // Data structure used for requests from a thread to the root // thread. These are GCs or similar. class MainThreadRequest { public: MainThreadRequest (enum _mainThreadPhase phase): mtp(phase), completed(false) {} virtual ~MainThreadRequest () {} // Suppress silly GCC warning const enum _mainThreadPhase mtp; bool completed; virtual void Perform() = 0; }; class PLock; // Class to wait for a given time or for an event, whichever comes first. // // A pointer to this class or a subclass is passed to ThreadPauseForIO. // Because a thread may be interrupted or killed by another ML thread we // don't allow any thread to block indefinitely. Instead whenever a // thread wants to do an operation that may block we have it enter a // loop that polls for the desired condition and if it is not ready it // calls ThreadPauseForIO. The default action is to block for a short // period and then return so that the caller can poll again. That can // limit performance when, for example, reading from a pipe so where possible // we use a sub-class that waits until either input is available or it times // out, whichever comes first, using "select" in Unix or MsgWaitForMultipleObjects // in Windows. // During a call to Waiter::Wait the thread is set as "not using ML memory" // so a GC can happen while this thread is blocked. class Waiter { public: Waiter() {} virtual ~Waiter() {} virtual void Wait(unsigned maxMillisecs); static Waiter *defaultWaiter; }; #ifdef _WIN32 class WaitHandle: public Waiter { public: - WaitHandle(HANDLE h): m_Handle(h) {} + WaitHandle(HANDLE h, unsigned maxWait): m_Handle(h), m_maxWait(maxWait) {} virtual void Wait(unsigned maxMillisecs); private: HANDLE m_Handle; + unsigned m_maxWait; }; #else // Unix: Wait until a file descriptor is available for input class WaitInputFD: public Waiter { public: WaitInputFD(int fd): m_waitFD(fd) {} virtual void Wait(unsigned maxMillisecs); private: int m_waitFD; }; #endif // External interface to the Process module. These functions are all implemented // by the Processes class. class ProcessExternal { public: virtual ~ProcessExternal() {} // Defined to suppress a warning from GCC virtual TaskData *GetTaskDataForThread(void) = 0; virtual TaskData *CreateNewTaskData(Handle threadId, Handle threadFunction, Handle args, PolyWord flags) = 0; // Request all ML threads to exit and set the result code. Does not cause // the calling thread itself to exit since this may be called on the GUI thread. virtual void RequestProcessExit(int n) = 0; // Exit from this thread. virtual NORETURNFN(void ThreadExit(TaskData *taskData)) = 0; virtual void BroadcastInterrupt(void) = 0; virtual void BeginRootThread(PolyObject *rootFunction) = 0; // Called when a thread may block. Returns some time later when perhaps // the input is available. virtual void ThreadPauseForIO(TaskData *taskData, Waiter *pWait) = 0; // As ThreadPauseForIO but when there is no stream virtual void ThreadPause(TaskData *taskData) { ThreadPauseForIO(taskData, Waiter::defaultWaiter); } // If a thread is blocking for some time it should release its use // of the ML memory. That allows a GC. ThreadUseMLMemory returns true if // a GC was in progress. virtual void ThreadUseMLMemory(TaskData *taskData) = 0; virtual void ThreadReleaseMLMemory(TaskData *taskData) = 0; // Requests from the threads for actions that need to be performed by // the root thread. virtual void MakeRootRequest(TaskData *taskData, MainThreadRequest *request) = 0; // Deal with any interrupt or kill requests. virtual bool ProcessAsynchRequests(TaskData *taskData) = 0; // Process an interrupt request synchronously. virtual void TestSynchronousRequests(TaskData *taskData) = 0; // Process any events, synchronous or asynchronous. virtual void TestAnyEvents(TaskData *taskData) = 0; // ForkFromRTS. Creates a new thread from within the RTS. virtual bool ForkFromRTS(TaskData *taskData, Handle proc, Handle arg) = 0; // Profiling control. virtual void StartProfiling(void) = 0; virtual void StopProfiling(void) = 0; // Find space for an object. Returns a pointer to the start. "words" must include // the length word and the result points at where the length word will go. // If the allocation succeeds it may update the allocation values in the taskData object. // If the heap is exhausted it may set this thread (or other threads) to raise an exception. virtual PolyWord *FindAllocationSpace(TaskData *taskData, POLYUNSIGNED words, bool alwaysInSeg) = 0; // Signal handling support. The ML signal handler thread blocks until it is // woken up by the signal detection thread. virtual bool WaitForSignal(TaskData *taskData, PLock *sigLock) = 0; virtual void SignalArrived(void) = 0; // After a Unix fork we only have a single thread in the new process. virtual void SetSingleThreaded(void) = 0; virtual poly_exn* GetInterrupt(void) = 0; }; // Return the number of processors. Used when configuring multi-threaded GC. extern unsigned NumberOfProcessors(void); extern unsigned NumberOfPhysicalProcessors(void); extern ProcessExternal *processes; extern struct _entrypts processesEPT[]; #endif diff --git a/libpolyml/profiling.cpp b/libpolyml/profiling.cpp index 713e3f53..92791daa 100644 --- a/libpolyml/profiling.cpp +++ b/libpolyml/profiling.cpp @@ -1,564 +1,564 @@ /* Title: Profiling Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000-7 Cambridge University Technical Services Limited Further development copyright (c) David C.J. Matthews 2011, 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 */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_MALLOC_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #include "globals.h" #include "arb.h" #include "processes.h" #include "polystring.h" #include "profiling.h" #include "save_vec.h" #include "rts_module.h" #include "memmgr.h" #include "scanaddrs.h" #include "locking.h" #include "run_time.h" #include "sys.h" #include "rtsentry.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProfiling(PolyObject *threadId, PolyWord mode); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyProfiling(FirstArgument threadId, PolyWord mode); } static POLYUNSIGNED mainThreadCounts[MTP_MAXENTRY]; static const char* const mainThreadText[MTP_MAXENTRY] = { "UNKNOWN", "GARBAGE COLLECTION (sharing phase)", "GARBAGE COLLECTION (mark phase)", "GARBAGE COLLECTION (copy phase)", "GARBAGE COLLECTION (update phase)", "GARBAGE COLLECTION (minor collection)", "Common data sharing", "Exporting", "Saving state", "Loading saved state", "Profiling", "Setting signal handler", "Cygwin spawn", "Storing module", "Loading module" }; // Entries for store profiling enum _extraStore { EST_CODE = 0, EST_STRING, EST_BYTE, EST_WORD, EST_MUTABLE, EST_MUTABLEBYTE, EST_MAX_ENTRY }; static POLYUNSIGNED extraStoreCounts[EST_MAX_ENTRY]; static const char * const extraStoreText[EST_MAX_ENTRY] = { "Function code", "Strings", "Byte data (long precision ints etc)", "Unidentified word data", "Unidentified mutable data", "Mutable byte data (profiling counts)" }; // Poly strings for "standard" counts. These are generated from the C strings // above the first time profiling is activated. static PolyWord psRTSString[MTP_MAXENTRY], psExtraStrings[EST_MAX_ENTRY], psGCTotal; ProfileMode profileMode; // If we are just profiling a single thread, this is the thread data. static TaskData *singleThreadProfile = 0; typedef struct _PROFENTRY { POLYUNSIGNED count; PolyWord functionName; struct _PROFENTRY *nextEntry; } PROFENTRY, *PPROFENTRY; class ProfileRequest: public MainThreadRequest { public: ProfileRequest(unsigned prof, TaskData *pTask): MainThreadRequest(MTP_PROFILING), mode(prof), pCallingThread(pTask), pTab(0), errorMessage(0) {} ~ProfileRequest(); virtual void Perform(); Handle extractAsList(TaskData *taskData); private: void getResults(void); void getProfileResults(PolyWord *bottom, PolyWord *top); PPROFENTRY newProfileEntry(void); private: unsigned mode; TaskData *pCallingThread; PPROFENTRY pTab; public: const char *errorMessage; }; ProfileRequest::~ProfileRequest() { PPROFENTRY p = pTab; while (p != 0) { PPROFENTRY toFree = p; p = p->nextEntry; free(toFree); } } // Lock to serialise updates of counts. Only used during update. // Not required when we print the counts since there's only one thread // running then. static PLock countLock; // Get the profile object associated with a piece of code. Returns null if // there isn't one, in particular if this is in the old format. static PolyObject *getProfileObjectForCode(PolyObject *code) { ASSERT(code->IsCodeObject()); PolyWord *consts; POLYUNSIGNED constCount; code->GetConstSegmentForCode(consts, constCount); if (constCount < 3 || ! consts[2].IsDataPtr()) return 0; PolyObject *profObject = consts[2].AsObjPtr(); if (profObject->IsMutable() && profObject->IsByteObject() && profObject->Length() == 1) return profObject; else return 0; } // Adds incr to the profile count for the function pointed at by // pc or by one of its callers. // This is called from a signal handler in the case of time profiling. void add_count(TaskData *taskData, POLYCODEPTR fpc, POLYUNSIGNED incr) { // Check that the pc value is within the heap. It could be // in the assembly code. PolyObject *codeObj = gMem.FindCodeObject(fpc); if (codeObj) { PolyObject *profObject = getProfileObjectForCode(codeObj); PLocker locker(&countLock); if (profObject) profObject->Set(0, PolyWord::FromUnsigned(profObject->Get(0).AsUnsigned() + incr)); return; } // Didn't find it. { PLocker locker(&countLock); mainThreadCounts[MTP_USER_CODE] += incr; } } // newProfileEntry - Make a new entry in the list PPROFENTRY ProfileRequest::newProfileEntry(void) { PPROFENTRY newEntry = (PPROFENTRY)malloc(sizeof(PROFENTRY)); if (newEntry == 0) { errorMessage = "Insufficient memory"; return 0; } newEntry->nextEntry = pTab; pTab = newEntry; return newEntry; } // We don't use ScanAddress here because we're only interested in the // objects themselves not the addresses in them. // We have to build the list of results in C memory rather than directly in // ML memory because we can't allocate in ML memory in the root thread. void ProfileRequest::getProfileResults(PolyWord *bottom, PolyWord *top) { PolyWord *ptr = bottom; while (ptr < top) { ptr++; // Skip the length word PolyObject *obj = (PolyObject*)ptr; if (obj->ContainsForwardingPtr()) { // This used to be necessary when code objects were held in the // general heap. Now that we only ever scan code and permanent // areas it's probably not needed. while (obj->ContainsForwardingPtr()) obj = obj->GetForwardingPtr(); ASSERT(obj->ContainsNormalLengthWord()); ptr += obj->Length(); } else { ASSERT(obj->ContainsNormalLengthWord()); if (obj->IsCodeObject()) { PolyWord *firstConstant = obj->ConstPtrForCode(); PolyWord name = firstConstant[0]; PolyObject *profCount = getProfileObjectForCode(obj); if (profCount) { POLYUNSIGNED count = profCount->Get(0).AsUnsigned(); if (count != 0) { if (name != TAGGED(0)) { PPROFENTRY pEnt = newProfileEntry(); if (pEnt == 0) return; pEnt->count = count; pEnt->functionName = name; } profCount->Set(0, PolyWord::FromUnsigned(0)); } } } /* code object */ ptr += obj->Length(); } /* else */ } /* while */ } void ProfileRequest::getResults(void) // Print profiling information and reset profile counts. { for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { MemSpace *space = *i; // Permanent areas are filled with objects from the bottom. getProfileResults(space->bottom, space->top); // Bottom to top } for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { CodeSpace *space = *i; getProfileResults(space->bottom, space->top); } { POLYUNSIGNED gc_count = mainThreadCounts[MTP_GCPHASESHARING]+ mainThreadCounts[MTP_GCPHASEMARK]+ mainThreadCounts[MTP_GCPHASECOMPACT] + mainThreadCounts[MTP_GCPHASEUPDATE] + mainThreadCounts[MTP_GCQUICK]; if (gc_count) { PPROFENTRY pEnt = newProfileEntry(); if (pEnt == 0) return; // Report insufficient memory? pEnt->count = gc_count; pEnt->functionName = psGCTotal; } } for (unsigned k = 0; k < MTP_MAXENTRY; k++) { if (mainThreadCounts[k]) { PPROFENTRY pEnt = newProfileEntry(); if (pEnt == 0) return; // Report insufficient memory? pEnt->count = mainThreadCounts[k]; pEnt->functionName = psRTSString[k]; mainThreadCounts[k] = 0; } } for (unsigned l = 0; l < EST_MAX_ENTRY; l++) { if (extraStoreCounts[l]) { PPROFENTRY pEnt = newProfileEntry(); if (pEnt == 0) return; // Report insufficient memory? pEnt->count = extraStoreCounts[l]; pEnt->functionName = psExtraStrings[l]; extraStoreCounts[l] = 0; } } } // Extract the accumulated results as an ML list of pairs of the count and the string. Handle ProfileRequest::extractAsList(TaskData *taskData) { Handle saved = taskData->saveVec.mark(); Handle list = taskData->saveVec.push(ListNull); for (PPROFENTRY p = pTab; p != 0; p = p->nextEntry) { Handle pair = alloc_and_save(taskData, 2); Handle countValue = Make_arbitrary_precision(taskData, p->count); pair->WordP()->Set(0, countValue->Word()); pair->WordP()->Set(1, p->functionName); Handle next = alloc_and_save(taskData, sizeof(ML_Cons_Cell) / sizeof(PolyWord)); DEREFLISTHANDLE(next)->h = pair->Word(); DEREFLISTHANDLE(next)->t =list->Word(); taskData->saveVec.reset(saved); list = taskData->saveVec.push(next->Word()); } return list; } void handleProfileTrap(TaskData *taskData, SIGNALCONTEXT *context) { if (singleThreadProfile != 0 && singleThreadProfile != taskData) return; /* If we are in the garbage-collector add the count to "gc_count" otherwise try to find out where we are. */ if (mainThreadPhase == MTP_USER_CODE) { if (taskData == 0 || ! taskData->AddTimeProfileCount(context)) mainThreadCounts[MTP_USER_CODE]++; // On Mac OS X all virtual timer interrupts seem to be directed to the root thread // so all the counts will be "unknown". } else mainThreadCounts[mainThreadPhase]++; } // Called from the GC when allocation profiling is on. void AddObjectProfile(PolyObject *obj) { ASSERT(obj->ContainsNormalLengthWord()); POLYUNSIGNED length = obj->Length(); if (obj->IsWordObject() && OBJ_HAS_PROFILE(obj->LengthWord())) { // It has a profile pointer. The last word should point to the // closure or code of the allocating function. Add the size of this to the count. ASSERT(length != 0); PolyWord profWord = obj->Get(length-1); ASSERT(profWord.IsDataPtr()); PolyObject *profObject = profWord.AsObjPtr(); ASSERT(profObject->IsMutable() && profObject->IsByteObject() && profObject->Length() == 1); profObject->Set(0, PolyWord::FromUnsigned(profObject->Get(0).AsUnsigned() + length + 1)); } // If it doesn't have a profile pointer add it to the appropriate count. else if (obj->IsMutable()) { if (obj->IsByteObject()) extraStoreCounts[EST_MUTABLEBYTE] += length+1; else extraStoreCounts[EST_MUTABLE] += length+1; } else if (obj->IsCodeObject()) extraStoreCounts[EST_CODE] += length+1; else if (obj->IsClosureObject()) { ASSERT(0); } else if (obj->IsByteObject()) { // Try to separate strings from other byte data. This is only // approximate. if (OBJ_IS_NEGATIVE(obj->LengthWord())) extraStoreCounts[EST_BYTE] += length+1; else { PolyStringObject *possString = (PolyStringObject*)obj; POLYUNSIGNED bytes = length * sizeof(PolyWord); // If the length of the string as given in the first word is sufficient // to fit in the exact number of words then it's probably a string. if (length >= 2 && possString->length <= bytes - sizeof(POLYUNSIGNED) && possString->length > bytes - 2 * sizeof(POLYUNSIGNED)) extraStoreCounts[EST_STRING] += length+1; else { extraStoreCounts[EST_BYTE] += length+1; } } } else extraStoreCounts[EST_WORD] += length+1; } // Called from ML to control profiling. static Handle profilerc(TaskData *taskData, Handle mode_handle) /* Profiler - generates statistical profiles of the code. The parameter is an integer which determines the value to be profiled. When profiler is called it always resets the profiling and prints out any values which have been accumulated. If the parameter is 0 this is all it does, if the parameter is 1 then it produces time profiling, if the parameter is 2 it produces store profiling. 3 - arbitrary precision emulation traps. */ { unsigned mode = get_C_unsigned(taskData, mode_handle->Word()); { // Create any strings we need. We only need to do this once but // it must be done by a non-root thread since it needs a taskData object. // Don't bother locking. At worst we'll create some garbage. for (unsigned k = 0; k < MTP_MAXENTRY; k++) { if (psRTSString[k] == TAGGED(0)) psRTSString[k] = C_string_to_Poly(taskData, mainThreadText[k]); } for (unsigned k = 0; k < EST_MAX_ENTRY; k++) { if (psExtraStrings[k] == TAGGED(0)) psExtraStrings[k] = C_string_to_Poly(taskData, extraStoreText[k]); } if (psGCTotal == TAGGED(0)) psGCTotal = C_string_to_Poly(taskData, "GARBAGE COLLECTION (total)"); } // All these actions are performed by the root thread. Only profile // printing needs to be performed with all the threads stopped but it's // simpler to serialise all requests. ProfileRequest request(mode, taskData); processes->MakeRootRequest(taskData, &request); if (request.errorMessage != 0) raise_exception_string(taskData, EXC_Fail, request.errorMessage); return request.extractAsList(taskData); } -POLYUNSIGNED PolyProfiling(PolyObject *threadId, PolyWord mode) +POLYUNSIGNED PolyProfiling(FirstArgument threadId, PolyWord mode) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedMode = taskData->saveVec.push(mode); Handle result = 0; try { result = profilerc(taskData, pushedMode); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // This is called from the root thread when all the ML threads have been paused. void ProfileRequest::Perform() { if (mode != kProfileOff && profileMode != kProfileOff) { // Profiling must be stopped first. errorMessage = "Profiling is currently active"; return; } singleThreadProfile = 0; // Unless kProfileTimeThread is given this should be 0 switch (mode) { case kProfileOff: // Turn off old profiling mechanism and print out accumulated results profileMode = kProfileOff; processes->StopProfiling(); getResults(); // Remove all the bitmaps to free up memory gMem.RemoveProfilingBitmaps(); break; case kProfileTimeThread: singleThreadProfile = pCallingThread; // And drop through to kProfileTime case kProfileTime: profileMode = kProfileTime; processes->StartProfiling(); break; case kProfileStoreAllocation: profileMode = kProfileStoreAllocation; break; case kProfileEmulation: profileMode = kProfileEmulation; break; case kProfileLiveData: profileMode = kProfileLiveData; break; case kProfileLiveMutables: profileMode = kProfileLiveMutables; break; case kProfileMutexContention: profileMode = kProfileMutexContention; break; default: /* do nothing */ break; } } struct _entrypts profilingEPT[] = { // Profiling { "PolyProfiling", (polyRTSFunction)&PolyProfiling}, { NULL, NULL} // End of list. }; class Profiling: public RtsModule { public: virtual void Init(void); virtual void GarbageCollect(ScanAddress *process); }; // Declare this. It will be automatically added to the table. static Profiling profileModule; void Profiling::Init(void) { // Reset profiling counts. profileMode = kProfileOff; for (unsigned k = 0; k < MTP_MAXENTRY; k++) mainThreadCounts[k] = 0; } void Profiling::GarbageCollect(ScanAddress *process) { // Process any strings in the table. for (unsigned k = 0; k < MTP_MAXENTRY; k++) process->ScanRuntimeWord(&psRTSString[k]); for (unsigned k = 0; k < EST_MAX_ENTRY; k++) process->ScanRuntimeWord(&psExtraStrings[k]); process->ScanRuntimeWord(&psGCTotal); } diff --git a/libpolyml/reals.cpp b/libpolyml/reals.cpp index 0b955e3a..4d06a194 100644 --- a/libpolyml/reals.cpp +++ b/libpolyml/reals.cpp @@ -1,1070 +1,1070 @@ /* Title: Real number package. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000 Cambridge University Technical Services Limited - Further work copyright David C.J. Matthews 2011, 2016-18 + Further work copyright David C.J. Matthews 2011, 2016-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 */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_IEEEFP_H /* Other operating systems include "finite" in math.h, but Solaris doesn't? */ #include #endif #ifdef HAVE_FPU_CONTROL_H #include #endif #ifdef HAVE_FENV_H #include #endif #ifdef HAVE_FLOAT_H #include #endif #ifdef HAVE_MATH_H #include #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_STDINT_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #include // Currently just for isnan. #include "globals.h" #include "run_time.h" #include "reals.h" #include "arb.h" #include "sys.h" #include "realconv.h" #include "polystring.h" #include "save_vec.h" #include "rts_module.h" #include "machine_dep.h" #include "processes.h" #include "rtsentry.h" /* The Standard Basis Library assumes IEEE representation for reals. Among other things it does not permit equality on reals. That simplifies things considerably since we don't have to worry about there being two different representations of zero as 0 and ~0. We also don't need to check that the result is finite since NaN is allowed as a result. This code could do with being checked by someone who really understands IEEE floating point arithmetic. */ extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealBoxedToString(PolyObject *threadId, PolyWord arg, PolyWord mode, PolyWord digits); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealBoxedFromString(PolyObject *threadId, PolyWord str); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealBoxedToLongInt(PolyObject *threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealBoxedToString(FirstArgument threadId, PolyWord arg, PolyWord mode, PolyWord digits); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealBoxedFromString(FirstArgument threadId, PolyWord str); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealBoxedToLongInt(FirstArgument threadId, PolyWord arg); POLYEXTERNALSYMBOL double PolyRealSqrt(double arg); POLYEXTERNALSYMBOL double PolyRealSin(double arg); POLYEXTERNALSYMBOL double PolyRealCos(double arg); POLYEXTERNALSYMBOL double PolyRealArctan(double arg); POLYEXTERNALSYMBOL double PolyRealExp(double arg); POLYEXTERNALSYMBOL double PolyRealLog(double arg); POLYEXTERNALSYMBOL double PolyRealTan(double arg); POLYEXTERNALSYMBOL double PolyRealArcSin(double arg); POLYEXTERNALSYMBOL double PolyRealArcCos(double arg); POLYEXTERNALSYMBOL double PolyRealLog10(double arg); POLYEXTERNALSYMBOL double PolyRealSinh(double arg); POLYEXTERNALSYMBOL double PolyRealCosh(double arg); POLYEXTERNALSYMBOL double PolyRealTanh(double arg); POLYEXTERNALSYMBOL double PolyRealFloor(double arg); POLYEXTERNALSYMBOL double PolyRealCeil(double arg); POLYEXTERNALSYMBOL double PolyRealTrunc(double arg); POLYEXTERNALSYMBOL double PolyRealRound(double arg); POLYEXTERNALSYMBOL double PolyRealRem(double arg1, double arg2); POLYEXTERNALSYMBOL double PolyFloatArbitraryPrecision(PolyWord arg); POLYEXTERNALSYMBOL POLYSIGNED PolyGetRoundingMode(PolyWord); POLYEXTERNALSYMBOL POLYSIGNED PolySetRoundingMode(PolyWord); POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealSize(PolyWord); POLYEXTERNALSYMBOL double PolyRealAtan2(double arg1, double arg2); POLYEXTERNALSYMBOL double PolyRealPow(double arg1, double arg2); POLYEXTERNALSYMBOL double PolyRealCopySign(double arg1, double arg2); POLYEXTERNALSYMBOL double PolyRealNextAfter(double arg1, double arg2); POLYEXTERNALSYMBOL double PolyRealLdexp(double arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealFrexp(PolyObject *threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealFrexp(FirstArgument threadId, PolyWord arg); POLYEXTERNALSYMBOL float PolyRealFSqrt(float arg); POLYEXTERNALSYMBOL float PolyRealFSin(float arg); POLYEXTERNALSYMBOL float PolyRealFCos(float arg); POLYEXTERNALSYMBOL float PolyRealFArctan(float arg); POLYEXTERNALSYMBOL float PolyRealFExp(float arg); POLYEXTERNALSYMBOL float PolyRealFLog(float arg); POLYEXTERNALSYMBOL float PolyRealFTan(float arg); POLYEXTERNALSYMBOL float PolyRealFArcSin(float arg); POLYEXTERNALSYMBOL float PolyRealFArcCos(float arg); POLYEXTERNALSYMBOL float PolyRealFLog10(float arg); POLYEXTERNALSYMBOL float PolyRealFSinh(float arg); POLYEXTERNALSYMBOL float PolyRealFCosh(float arg); POLYEXTERNALSYMBOL float PolyRealFTanh(float arg); POLYEXTERNALSYMBOL float PolyRealFAtan2(float arg1, float arg2); POLYEXTERNALSYMBOL float PolyRealFPow(float arg1, float arg2); POLYEXTERNALSYMBOL float PolyRealFCopySign(float arg1, float arg2); POLYEXTERNALSYMBOL float PolyRealFFloor(float arg); POLYEXTERNALSYMBOL float PolyRealFCeil(float arg); POLYEXTERNALSYMBOL float PolyRealFTrunc(float arg); POLYEXTERNALSYMBOL float PolyRealFRound(float arg); POLYEXTERNALSYMBOL float PolyRealFRem(float arg1, float arg2); POLYEXTERNALSYMBOL float PolyRealFNextAfter(float arg1, float arg2); } static Handle Real_strc(TaskData *mdTaskData, Handle hDigits, Handle hMode, Handle arg); static Handle Real_convc(TaskData *mdTaskData, Handle str); // Positive and negative infinities and (positive) NaN. double posInf, negInf, notANumber; float posInfF, negInfF, notANumberF; /* Real numbers are represented by the address of the value. */ #define DBLE sizeof(double)/sizeof(POLYUNSIGNED) union db { double dble; POLYUNSIGNED words[DBLE]; }; double real_arg(Handle x) { union db r_arg_x; for (unsigned i = 0; i < DBLE; i++) { r_arg_x.words[i] = x->WordP()->Get(i).AsUnsigned(); } return r_arg_x.dble; } Handle real_result(TaskData *mdTaskData, double x) { union db argx; argx.dble = x; PolyObject *v = alloc(mdTaskData, DBLE, F_BYTE_OBJ); /* Copy as words in case the alignment is wrong. */ for(unsigned i = 0; i < DBLE; i++) { v->Set(i, PolyWord::FromUnsigned(argx.words[i])); } return mdTaskData->saveVec.push(v); } // We're using float for Real32 so it needs to be 32-bits. // Assume that's true for the moment. #if (SIZEOF_FLOAT != 4) #error "Float is not 32-bits. Please report this" #endif union flt { float fl; int32_t i; }; #if (SIZEOF_FLOAT < SIZEOF_POLYWORD) // Typically for 64-bit mode. Use a tagged representation. // The code-generator on the X86/64 assumes the float is in the // high order word. #define FLT_SHIFT ((SIZEOF_POLYWORD-SIZEOF_FLOAT)*8) float float_arg(Handle x) { union flt argx; argx.i = x->Word().AsSigned() >> FLT_SHIFT; return argx.fl; } Handle float_result(TaskData *mdTaskData, float x) { union flt argx; argx.fl = x; return mdTaskData->saveVec.push(PolyWord::FromSigned(((POLYSIGNED)argx.i << FLT_SHIFT) + 1)); } #else // Typically for 32-bit mode. Use a boxed representation. float float_arg(Handle x) { union flt argx; argx.i = (int32_t)x->WordP()->Get(0).AsSigned(); return argx.fl; } Handle float_result(TaskData *mdTaskData, float x) { union flt argx; argx.fl = x; PolyObject *v = alloc(mdTaskData, 1, F_BYTE_OBJ); v->Set(0, PolyWord::FromSigned(argx.i)); return mdTaskData->saveVec.push(v); } #endif POLYEXTERNALSYMBOL double PolyFloatArbitraryPrecision(PolyWord arg) { return get_arbitrary_precision_as_real(arg); } // Convert a boxed real to a long precision int. -POLYUNSIGNED PolyRealBoxedToLongInt(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyRealBoxedToLongInt(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); double dx = real_arg(pushedArg); int64_t i = (int64_t)dx; Handle result = Make_arbitrary_precision(taskData, i); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // RTS call for square-root. double PolyRealSqrt(double arg) { return sqrt(arg); } // RTS call for sine. double PolyRealSin(double arg) { return sin(arg); } // RTS call for cosine. double PolyRealCos(double arg) { return cos(arg); } // RTS call for arctan. double PolyRealArctan(double arg) { return atan(arg); } // RTS call for exp. double PolyRealExp(double arg) { return exp(arg); } // RTS call for ln. double PolyRealLog(double arg) { // Make sure the result conforms to the definition. // If the argument is a Nan each of the first two tests will fail. if (arg > 0.0) return log(arg); else if (arg == 0.0) // x may be +0.0 or -0.0 return negInf; // -infinity. else return notANumber; } // These were handled by the general dispatch function double PolyRealTan(double arg) { return tan(arg); } double PolyRealArcSin(double arg) { if (arg >= -1.0 && arg <= 1.0) return asin(arg); else return notANumber; } double PolyRealArcCos(double arg) { if (arg >= -1.0 && arg <= 1.0) return acos(arg); else return notANumber; } double PolyRealLog10(double arg) { // Make sure the result conforms to the definition. // If the argument is a Nan each of the first two tests will fail. if (arg > 0.0) return log10(arg); else if (arg == 0.0) // x may be +0.0 or -0.0 return negInf; // -infinity. else return notANumber; } double PolyRealSinh(double arg) { return sinh(arg); } double PolyRealCosh(double arg) { return cosh(arg); } double PolyRealTanh(double arg) { return tanh(arg); } double PolyRealFloor(double arg) { return floor(arg); } double PolyRealCeil(double arg) { return ceil(arg); } double PolyRealTrunc(double arg) { // Truncate towards zero if (arg >= 0.0) return floor(arg); else return ceil(arg); } double PolyRealRound(double arg) { // Round to nearest integral value. double drem = fmod(arg, 2.0); if (drem == 0.5 || drem == -1.5) // If the value was exactly positive even + 0.5 or // negative odd -0.5 round it down, otherwise round it up. return ceil(arg-0.5); else return floor(arg+0.5); } double PolyRealRem(double arg1, double arg2) { return fmod(arg1, arg2); } double PolyRealAtan2(double arg1, double arg2) { return atan2(arg1, arg2); } double PolyRealPow(double x, double y) { /* Some of the special cases are defined and don't seem to match the C pow function (at least as implemented in MS C). */ /* Maybe handle all this in ML? */ if (std::isnan(x)) { if (y == 0.0) return 1.0; else return notANumber; } else if (std::isnan(y)) return y; /* i.e. nan. */ else if (x == 0.0 && y < 0.0) { /* This case is not handled correctly in Solaris. It always returns -infinity. */ int iy = (int)floor(y); /* If x is -0.0 and y is an odd integer the result is -infinity. */ if (copysign(1.0, x) < 0.0 && (double)iy == y && (iy & 1)) return negInf; /* -infinity. */ else return posInf; /* +infinity. */ } return pow(x, y); } double PolyRealCopySign(double arg1, double arg2) { return copysign(arg1, arg2); } double PolyRealNextAfter(double arg1, double arg2) { return nextafter(arg1, arg2); } double PolyRealLdexp(double arg1, PolyWord arg2) { POLYSIGNED exponent = arg2.UnTagged(); #if (SIZEOF_POLYWORD > SIZEOF_INT) // We've already checked for arbitrary precision values where necessary and // for zero and non-finite mantissa. Check the exponent fits in an int. if (exponent > 2 * DBL_MAX_EXP) return copysign(INFINITY, arg1); if (exponent < -2 * DBL_MAX_EXP) return copysign(0.0, arg1); #endif return ldexp(arg1, (int)exponent); } // Return the normalised fraction and the exponent. -POLYUNSIGNED PolyRealFrexp(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyRealFrexp(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { int exp = 0; // The value of exp is not always defined. Handle mantH = real_result(taskData, frexp(real_arg(pushedArg), &exp)); // Allocate a pair for the result result = alloc_and_save(taskData, 2); result->WordP()->Set(0, TAGGED(exp)); result->WordP()->Set(1, mantH->Word()); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // RTS call for square-root. float PolyRealFSqrt(float arg) { return sqrtf(arg); } // RTS call for sine. float PolyRealFSin(float arg) { return sinf(arg); } // RTS call for cosine. float PolyRealFCos(float arg) { return cosf(arg); } // RTS call for arctan. float PolyRealFArctan(float arg) { return atanf(arg); } // RTS call for exp. float PolyRealFExp(float arg) { return expf(arg); } // RTS call for ln. float PolyRealFLog(float arg) { // Make sure the result conforms to the definition. // If the argument is a Nan each of the first two tests will fail. if (arg > 0.0) return logf(arg); else if (arg == 0.0) // x may be +0.0 or -0.0 return negInfF; // -infinity. else return notANumberF; } float PolyRealFTan(float arg) { return tanf(arg); } float PolyRealFArcSin(float arg) { if (arg >= -1.0 && arg <= 1.0) return asinf(arg); else return notANumberF; } float PolyRealFArcCos(float arg) { if (arg >= -1.0 && arg <= 1.0) return acosf(arg); else return notANumberF; } float PolyRealFLog10(float arg) { // Make sure the result conforms to the definition. // If the argument is a Nan each of the first two tests will fail. if (arg > 0.0) return log10f(arg); else if (arg == 0.0) // x may be +0.0 or -0.0 return negInfF; // -infinity. else return notANumberF; } float PolyRealFSinh(float arg) { return sinhf(arg); } float PolyRealFCosh(float arg) { return coshf(arg); } float PolyRealFTanh(float arg) { return tanhf(arg); } float PolyRealFAtan2(float arg1, float arg2) { return atan2f(arg1, arg2); } float PolyRealFPow(float x, float y) { /* Some of the special cases are defined and don't seem to match the C pow function (at least as implemented in MS C). */ /* Maybe handle all this in ML? */ if (std::isnan(x)) { if (y == 0.0) return 1.0; else return notANumberF; } else if (std::isnan(y)) return y; /* i.e. nan. */ else if (x == 0.0 && y < 0.0) { /* This case is not handled correctly in Solaris. It always returns -infinity. */ int iy = (int)floorf(y); /* If x is -0.0 and y is an odd integer the result is -infinity. */ if (copysign(1.0, x) < 0.0 && (float)iy == y && (iy & 1)) return negInfF; /* -infinity. */ else return posInfF; /* +infinity. */ } return powf(x, y); } float PolyRealFFloor(float arg) { return floorf(arg); } float PolyRealFCeil(float arg) { return ceilf(arg); } float PolyRealFTrunc(float arg) { // Truncate towards zero if (arg >= 0.0) return floorf(arg); else return ceilf(arg); } float PolyRealFRound(float arg) { // Round to nearest integral value. float drem = fmodf(arg, 2.0); if (drem == 0.5 || drem == -1.5) // If the value was exactly positive even + 0.5 or // negative odd -0.5 round it down, otherwise round it up. return ceilf(arg - 0.5f); else return floorf(arg + 0.5f); } float PolyRealFRem(float arg1, float arg2) { return fmodf(arg1, arg2); } float PolyRealFCopySign(float arg1, float arg2) { return copysignf(arg1, arg2); } float PolyRealFNextAfter(float arg1, float arg2) { return nextafterf(arg1, arg2); } /* CALL_IO1(Real_conv, REF, NOIND) */ Handle Real_convc(TaskData *mdTaskData, Handle str) /* string to real */ { double result; int i; char *finish; TempCString string_buffer(Poly_string_to_C_alloc(str->Word())); /* Scan the string turning '~' into '-' */ for(i = 0; string_buffer[i] != '\0'; i ++) { if (string_buffer[i] == '~') string_buffer[i] = '-'; } /* Now convert it */ #ifdef HAVE_STRTOD result = strtod(string_buffer, &finish); #else result = poly_strtod(string_buffer, &finish); #endif // We no longer detect overflow and underflow and instead return // (signed) zeros for underflow and (signed) infinities for overflow. if (*finish != '\0') raise_exception_string(mdTaskData, EXC_conversion, ""); return real_result(mdTaskData, result); }/* Real_conv */ // Convert a string to a boxed real. This should really return an unboxed real. -POLYUNSIGNED PolyRealBoxedFromString(PolyObject *threadId, PolyWord str) +POLYUNSIGNED PolyRealBoxedFromString(FirstArgument threadId, PolyWord str) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedString = taskData->saveVec.push(str); Handle result = 0; try { result = Real_convc(taskData, pushedString); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } #if defined(__SOFTFP__) // soft-float lacks proper rounding mode support // While some systems will support fegetround/fesetround, it will have no // effect on the actual rounding performed, as the software implementation only // ever rounds to nearest. int getrounding() { return POLY_ROUND_TONEAREST; } int setrounding(int rounding) { switch (rounding) { case POLY_ROUND_TONEAREST: return 0; // The only mode supported } return -1; // Error - unsupported } // It would be nice to be able to use autoconf to test for these as functions // but they are frequently inlined #elif defined(HAVE_FENV_H) // C99 version. This is becoming the most common. int getrounding() { switch (fegetround()) { case FE_TONEAREST: return POLY_ROUND_TONEAREST; #ifndef HOSTARCHITECTURE_SH case FE_DOWNWARD: return POLY_ROUND_DOWNWARD; case FE_UPWARD: return POLY_ROUND_UPWARD; #endif case FE_TOWARDZERO: return POLY_ROUND_TOZERO; } return POLY_ROUND_TONEAREST; } int setrounding(int rounding) { switch (rounding) { case POLY_ROUND_TONEAREST: fesetround(FE_TONEAREST); return 0; // Choose nearest #ifndef HOSTARCHITECTURE_SH case POLY_ROUND_DOWNWARD: fesetround(FE_DOWNWARD); return 0; // Towards negative infinity case POLY_ROUND_UPWARD: fesetround(FE_UPWARD); return 0; // Towards positive infinity #endif case POLY_ROUND_TOZERO: fesetround(FE_TOWARDZERO); return 0; // Truncate towards zero default: return -1; } } #elif (defined(HAVE_IEEEFP_H) && ! defined(__CYGWIN__)) // Older FreeBSD. Cygwin has the ieeefp.h header but not the functions! int getrounding() { switch (fpgetround()) { case FP_RN: return POLY_ROUND_TONEAREST; case FP_RM: return POLY_ROUND_DOWNWARD; case FP_RP: return POLY_ROUND_UPWARD; case FP_RZ: return POLY_ROUND_TOZERO; default: return POLY_ROUND_TONEAREST; /* Shouldn't happen. */ } } int setrounding(int rounding) { switch (rounding) { case POLY_ROUND_TONEAREST: fpsetround(FP_RN); break; /* Choose nearest */ case POLY_ROUND_DOWNWARD: fpsetround(FP_RM); break; /* Towards negative infinity */ case POLY_ROUND_UPWARD: fpsetround(FP_RP); break; /* Towards positive infinity */ case POLY_ROUND_TOZERO: fpsetround(FP_RZ); break; /* Truncate towards zero */ } return 0 } #elif defined(_WIN32) // Windows version int getrounding() { switch (_controlfp(0,0) & _MCW_RC) { case _RC_NEAR: return POLY_ROUND_TONEAREST; case _RC_DOWN: return POLY_ROUND_DOWNWARD; case _RC_UP: return POLY_ROUND_UPWARD; case _RC_CHOP: return POLY_ROUND_TOZERO; } return POLY_ROUND_TONEAREST; } int setrounding(int rounding) { switch (rounding) { case POLY_ROUND_TONEAREST: _controlfp(_RC_NEAR, _MCW_RC); return 0; // Choose nearest case POLY_ROUND_DOWNWARD: _controlfp(_RC_DOWN, _MCW_RC); return 0; // Towards negative infinity case POLY_ROUND_UPWARD: _controlfp(_RC_UP, _MCW_RC); return 0; // Towards positive infinity case POLY_ROUND_TOZERO: _controlfp(_RC_CHOP, _MCW_RC); return 0; // Truncate towards zero } return -1; } #elif defined(_FPU_GETCW) && defined(_FPU_SETCW) // Older Linux version int getrounding() { fpu_control_t ctrl; _FPU_GETCW(ctrl); switch (ctrl & _FPU_RC_ZERO) { case _FPU_RC_NEAREST: return POLY_ROUND_TONEAREST; case _FPU_RC_DOWN: return POLY_ROUND_DOWNWARD; case _FPU_RC_UP: return POLY_ROUND_UPWARD; case _FPU_RC_ZERO: return POLY_ROUND_TOZERO; } return POLY_ROUND_TONEAREST; /* Never reached but this avoids warning message. */ } int setrounding(int rounding) { fpu_control_t ctrl; _FPU_GETCW(ctrl); ctrl &= ~_FPU_RC_ZERO; /* Mask off any existing rounding. */ switch (rounding) { case POLY_ROUND_TONEAREST: ctrl |= _FPU_RC_NEAREST; case POLY_ROUND_DOWNWARD: ctrl |= _FPU_RC_DOWN; case POLY_ROUND_UPWARD: ctrl |= _FPU_RC_UP; case POLY_ROUND_TOZERO: ctrl |= _FPU_RC_ZERO; } _FPU_SETCW(ctrl); return 0; } #else // Give up. Assume that we only support TO_NEAREST int getrounding() { return POLY_ROUND_TONEAREST; } int setrounding(int rounding) { if (rounding == POLY_ROUND_TONEAREST) return 0; else return -1; } #endif POLYSIGNED PolyGetRoundingMode(PolyWord) { // Get the rounding and turn the result into a tagged integer. return TAGGED(getrounding()).AsSigned(); } POLYSIGNED PolySetRoundingMode(PolyWord arg) { return TAGGED(setrounding((int)arg.UnTagged())).AsSigned(); } Handle Real_strc(TaskData *mdTaskData, Handle hDigits, Handle hMode, Handle arg) { double dx = real_arg(arg); int decpt, sign; int mode = get_C_int(mdTaskData, hMode->Word()); int digits = get_C_int(mdTaskData, hDigits->Word()); /* Compute the shortest string which gives the required value. */ /* */ char *chars = poly_dtoa(dx, mode, digits, &decpt, &sign, NULL); /* We have to be careful in case an allocation causes a garbage collection. */ PolyWord pStr = C_string_to_Poly(mdTaskData, chars); poly_freedtoa(chars); Handle ppStr = mdTaskData->saveVec.push(pStr); /* Allocate a triple for the results. */ PolyObject *result = alloc(mdTaskData, 3); result->Set(0, ppStr->Word()); result->Set(1, TAGGED(decpt)); result->Set(2, TAGGED(sign)); return mdTaskData->saveVec.push(result); } // Convert boxed real to string. This should be changed to use an unboxed real argument. -POLYUNSIGNED PolyRealBoxedToString(PolyObject *threadId, PolyWord arg, PolyWord mode, PolyWord digits) +POLYUNSIGNED PolyRealBoxedToString(FirstArgument threadId, PolyWord arg, PolyWord mode, PolyWord digits) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle pushedMode = taskData->saveVec.push(mode); Handle pushedDigits = taskData->saveVec.push(digits); Handle result = 0; try { result = Real_strc(taskData, pushedDigits, pushedMode, pushedArg); } catch (...) { } // Can this raise an exception? taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // This used to be used for all the functions. It now only contains calls // used when the Real structure is defined to get the values of constants. static Handle Real_dispatchc(TaskData *mdTaskData, Handle args, Handle code) { unsigned c = get_C_unsigned(mdTaskData, code->Word()); switch (c) { /* Floating point representation queries. */ #ifdef _DBL_RADIX case 11: /* Value of radix */ return mdTaskData->saveVec.push(TAGGED(_DBL_RADIX)); #else case 11: /* Value of radix */ return mdTaskData->saveVec.push(TAGGED(FLT_RADIX)); #endif case 12: /* Value of precision */ return mdTaskData->saveVec.push(TAGGED(DBL_MANT_DIG)); case 13: /* Maximum number */ return real_result(mdTaskData, DBL_MAX); case 14: /* Minimum normalised number. */ return real_result(mdTaskData, DBL_MIN); case 15: // Minimum number. #ifdef DBL_TRUE_MIN return real_result(mdTaskData, DBL_TRUE_MIN); #else return real_result(mdTaskData, DBL_MIN*DBL_EPSILON); #endif // Constants for float (Real32.real) case 30: /* Value of radix */ return mdTaskData->saveVec.push(TAGGED(FLT_RADIX)); case 31: /* Value of precision */ return mdTaskData->saveVec.push(TAGGED(FLT_MANT_DIG)); case 32: /* Maximum number */ return float_result(mdTaskData, FLT_MAX); case 33: /* Minimum normalised number. */ return float_result(mdTaskData, FLT_MIN); case 34: // Minimum number. #ifdef FLT_TRUE_MIN return float_result(mdTaskData, FLT_TRUE_MIN); #else return float_result(mdTaskData, FLT_MIN*FLT_EPSILON); #endif default: { char msg[100]; sprintf(msg, "Unknown real arithmetic function: %d", c); raise_exception_string(mdTaskData, EXC_Fail, msg); return 0; } } } POLYUNSIGNED PolyRealSize(PolyWord) { // Return the number of bytes for a real. This is used in PackRealBig/Little. return TAGGED(sizeof(double)).AsUnsigned(); } -POLYUNSIGNED PolyRealGeneral(PolyObject *threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyRealGeneral(FirstArgument threadId, PolyWord code, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCode = taskData->saveVec.push(code); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = Real_dispatchc(taskData, pushedArg, pushedCode); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } struct _entrypts realsEPT[] = { { "PolyRealBoxedToString", (polyRTSFunction)&PolyRealBoxedToString}, { "PolyRealGeneral", (polyRTSFunction)&PolyRealGeneral}, { "PolyRealBoxedFromString", (polyRTSFunction)&PolyRealBoxedFromString}, { "PolyRealBoxedToLongInt", (polyRTSFunction)&PolyRealBoxedToLongInt}, { "PolyRealSqrt", (polyRTSFunction)&PolyRealSqrt}, { "PolyRealSin", (polyRTSFunction)&PolyRealSin}, { "PolyRealCos", (polyRTSFunction)&PolyRealCos}, { "PolyRealArctan", (polyRTSFunction)&PolyRealArctan}, { "PolyRealExp", (polyRTSFunction)&PolyRealExp}, { "PolyRealLog", (polyRTSFunction)&PolyRealLog}, { "PolyRealTan", (polyRTSFunction)&PolyRealTan}, { "PolyRealArcSin", (polyRTSFunction)&PolyRealArcSin}, { "PolyRealArcCos", (polyRTSFunction)&PolyRealArcCos}, { "PolyRealLog10", (polyRTSFunction)&PolyRealLog10}, { "PolyRealSinh", (polyRTSFunction)&PolyRealSinh}, { "PolyRealCosh", (polyRTSFunction)&PolyRealCosh}, { "PolyRealTanh", (polyRTSFunction)&PolyRealTanh}, { "PolyRealFloor", (polyRTSFunction)&PolyRealFloor}, { "PolyRealCeil", (polyRTSFunction)&PolyRealCeil}, { "PolyRealTrunc", (polyRTSFunction)&PolyRealTrunc}, { "PolyRealRound", (polyRTSFunction)&PolyRealRound}, { "PolyRealRem", (polyRTSFunction)&PolyRealRem }, { "PolyFloatArbitraryPrecision", (polyRTSFunction)&PolyFloatArbitraryPrecision}, { "PolyGetRoundingMode", (polyRTSFunction)&PolyGetRoundingMode}, { "PolySetRoundingMode", (polyRTSFunction)&PolySetRoundingMode}, { "PolyRealSize", (polyRTSFunction)&PolyRealSize}, { "PolyRealAtan2", (polyRTSFunction)&PolyRealAtan2 }, { "PolyRealPow", (polyRTSFunction)&PolyRealPow }, { "PolyRealCopySign", (polyRTSFunction)&PolyRealCopySign }, { "PolyRealNextAfter", (polyRTSFunction)&PolyRealNextAfter }, { "PolyRealLdexp", (polyRTSFunction)&PolyRealLdexp }, { "PolyRealFrexp", (polyRTSFunction)&PolyRealFrexp }, { "PolyRealFSqrt", (polyRTSFunction)&PolyRealFSqrt }, { "PolyRealFSin", (polyRTSFunction)&PolyRealFSin }, { "PolyRealFCos", (polyRTSFunction)&PolyRealFCos }, { "PolyRealFArctan", (polyRTSFunction)&PolyRealFArctan }, { "PolyRealFExp", (polyRTSFunction)&PolyRealFExp }, { "PolyRealFLog", (polyRTSFunction)&PolyRealFLog }, { "PolyRealFTan", (polyRTSFunction)&PolyRealFTan }, { "PolyRealFArcSin", (polyRTSFunction)&PolyRealFArcSin }, { "PolyRealFArcCos", (polyRTSFunction)&PolyRealFArcCos }, { "PolyRealFLog10", (polyRTSFunction)&PolyRealFLog10 }, { "PolyRealFSinh", (polyRTSFunction)&PolyRealFSinh }, { "PolyRealFCosh", (polyRTSFunction)&PolyRealFCosh }, { "PolyRealFTanh", (polyRTSFunction)&PolyRealFTanh }, { "PolyRealFAtan2", (polyRTSFunction)&PolyRealFAtan2 }, { "PolyRealFPow", (polyRTSFunction)&PolyRealFPow }, { "PolyRealFCopySign", (polyRTSFunction)&PolyRealFCopySign }, { "PolyRealFFloor", (polyRTSFunction)&PolyRealFFloor }, { "PolyRealFCeil", (polyRTSFunction)&PolyRealFCeil }, { "PolyRealFTrunc", (polyRTSFunction)&PolyRealFTrunc }, { "PolyRealFRound", (polyRTSFunction)&PolyRealFRound }, { "PolyRealFRem", (polyRTSFunction)&PolyRealFRem }, { "PolyRealFNextAfter", (polyRTSFunction)&PolyRealFNextAfter }, { NULL, NULL} // End of list. }; class RealArithmetic: public RtsModule { public: virtual void Init(void); }; // Declare this. It will be automatically added to the table. static RealArithmetic realModule; void RealArithmetic::Init(void) { /* Some compilers object to overflow in constants so we compute the values here. */ #if (HAVE_DECL_FPSETMASK && ! defined(__CYGWIN__)) /* In FreeBSD 3.4 at least, we sometimes get floating point exceptions if we don't clear the mask. Maybe need to do this on other platforms as well just to be sure. */ // N.B. fpsetmask is defined in the headers on Cygwin but there's no function! fpsetmask(0); #endif // NAN and INFINITY are defined in GCC but not in Visual C++. #if (defined(INFINITY)) posInf = INFINITY; negInf = -(INFINITY); posInfF = INFINITY; negInfF = -(INFINITY); #else { double zero = 0.0; posInf = 1.0 / zero; negInf = -1.0 / zero; float zeroF = 0.0; posInfF = 1.0 / zeroF; negInfF = -1.0 / zeroF; } #endif #if (defined(NAN)) notANumber = NAN; #else { double zero = 0.0; notANumber = zero / zero; float zeroF = 0.0; notANumberF = zeroF / zeroF; } #endif // Make sure this is a positive NaN since we return it from "abs". // "Positive" in this context is copysign(1.0, x) > 0.0 because that's // how we test the sign so we test it first and then try to change the // sign if it's wrong. if (copysign(1.0, notANumber) < 0) notANumber = copysign(notANumber, 1.0); if (copysignf(1.0, notANumberF) < 0) notANumberF = copysignf(notANumberF, 1.0); } diff --git a/libpolyml/rtsentry.cpp b/libpolyml/rtsentry.cpp index 5a8f73b0..2d403638 100644 --- a/libpolyml/rtsentry.cpp +++ b/libpolyml/rtsentry.cpp @@ -1,191 +1,191 @@ /* Title: rtsentry.cpp - Entry points to the run-time system Copyright (c) 2016, 2017 David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #include "globals.h" #include "rtsentry.h" #include "save_vec.h" #include "processes.h" #include "run_time.h" #include "polystring.h" #include "arb.h" #include "basicio.h" #include "polyffi.h" #include "xwindows.h" #include "os_specific.h" #include "timing.h" #include "sighandler.h" #include "sharedata.h" #include "run_time.h" #include "reals.h" #include "profiling.h" #include "processes.h" #include "process_env.h" #include "poly_specific.h" #include "objsize.h" #include "network.h" #include "exporter.h" #include "statistics.h" #include "savestate.h" extern struct _entrypts rtsCallEPT[]; static entrypts entryPointTable[] = { rtsCallEPT, arbitraryPrecisionEPT, basicIOEPT, polyFFIEPT, xwindowsEPT, osSpecificEPT, timingEPT, sigHandlerEPT, shareDataEPT, runTimeEPT, realsEPT, profilingEPT, processesEPT, processEnvEPT, polySpecificEPT, objSizeEPT, networkingEPT, exporterEPT, statisticsEPT, savestateEPT, NULL }; extern "C" { #ifdef _MSC_VER __declspec(dllexport) #endif - POLYUNSIGNED PolyCreateEntryPointObject(PolyObject *threadId, PolyWord arg); + POLYUNSIGNED PolyCreateEntryPointObject(FirstArgument threadId, PolyWord arg); }; // Create an entry point containing the address of the entry and the // string name. Having the string in there allows us to export the entry. Handle creatEntryPointObject(TaskData *taskData, Handle entryH, bool isFuncPtr) { TempCString entryName(Poly_string_to_C_alloc(entryH->Word())); if ((const char *)entryName == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); // Create space for the address followed by the name as a C string. uintptr_t space = 1 + (strlen(entryName) + 1 + (isFuncPtr ? 0 : 1) + sizeof(polyRTSFunction*) - 1) / sizeof(PolyWord); // Allocate a byte, weak, mutable, no-overwrite cell. It's not clear if // it actually needs to be mutable but if it is it needs to be no-overwrite. Handle refH = alloc_and_save(taskData, space, F_BYTE_OBJ|F_WEAK_BIT|F_MUTABLE_BIT|F_NO_OVERWRITE); PolyObject *p = refH->WordP(); *(polyRTSFunction*)p = 0; // Clear it char *entryPtr = (char*)(p->AsBytePtr() + sizeof(polyRTSFunction*)); if (! isFuncPtr) *entryPtr++ = 1; // Put in a type entry strcpy(entryPtr, entryName); return refH; } // Return the string entry point. const char *getEntryPointName(PolyObject *p, bool *isFuncPtr) { if (p->Length() <= sizeof(polyRTSFunction*)/sizeof(PolyWord)) return 0; // Doesn't contain an entry point const char *entryPtr = (const char*)(p->AsBytePtr() + sizeof(polyRTSFunction*)); *isFuncPtr = *entryPtr != 1; // If the type is 1 it is a data entry point if (*entryPtr < ' ') entryPtr++; // Skip the type byte return entryPtr; } // Sets the address of the entry point in an entry point object. bool setEntryPoint(PolyObject *p) { if (p->Length() == 0) return false; *(polyRTSFunction*)p = 0; // Clear it by default if (p->Length() == 1) return false; const char *entryName = (const char*)(p->AsBytePtr()+sizeof(polyRTSFunction*)); if (*entryName < ' ') entryName++; // Skip the type byte // Search the entry point table list. for (entrypts *ept=entryPointTable; *ept != NULL; ept++) { entrypts entryPtTable = *ept; if (entryPtTable != 0) { for (struct _entrypts *ep = entryPtTable; ep->entry != NULL; ep++) { if (strcmp(entryName, ep->name) == 0) { polyRTSFunction entry = ep->entry; *(polyRTSFunction*)p = entry; return true; } } } } return false; } // External call -POLYUNSIGNED PolyCreateEntryPointObject(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyCreateEntryPointObject(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = creatEntryPointObject(taskData, pushedArg, true /* Always functions */); if (!setEntryPoint(result->WordP())) raise_fail(taskData, "entry point not found"); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } struct _entrypts rtsCallEPT[] = { { "PolyCreateEntryPointObject", (polyRTSFunction)&PolyCreateEntryPointObject}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/rtsentry.h b/libpolyml/rtsentry.h index 61e84e50..abeaa269 100644 --- a/libpolyml/rtsentry.h +++ b/libpolyml/rtsentry.h @@ -1,49 +1,65 @@ /* Title: rtsentry.h - Entry points to the run-time system Copyright (c) 2016 David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifndef RTSENTRY_H_INCLUDED #define RTSENTRY_H_INCLUDED class SaveVecEntry; class TaskData; class PolyObject; typedef SaveVecEntry *Handle; extern Handle creatEntryPointObject(TaskData *taskData, Handle entryH, bool isFuncPtr); extern const char *getEntryPointName(PolyObject *p, bool *isFuncPtr); extern bool setEntryPoint(PolyObject *p); typedef void (*polyRTSFunction)(); typedef struct _entrypts { const char *name; polyRTSFunction entry; } *entrypts; // Ensure that the RTS calls can be found by the linker. #ifndef POLYEXTERNALSYMBOL #ifdef _MSC_VER #define POLYEXTERNALSYMBOL __declspec(dllexport) #else #define POLYEXTERNALSYMBOL #endif #endif +#ifdef POLYML32IN64 +// This is needed for legacy only. RTS calls previously passed the +// real address of the thread ID. They now pass a PolyWord containing +// the thread ID. +// Once we've fully bootstrapped FirstArgument can be replaced with PolyWord. +union firstArgFull +{ + operator PolyWord() + { if (value >= 0x100000000) return (PolyWord)((PolyObject*)value); else return PolyWord::FromUnsigned((POLYUNSIGNED)value); } + uintptr_t value; +}; +typedef union firstArgFull FirstArgument; +#else +typedef PolyWord FirstArgument; +#endif + #endif diff --git a/libpolyml/run_time.cpp b/libpolyml/run_time.cpp index ce0751de..3bc894f4 100644 --- a/libpolyml/run_time.cpp +++ b/libpolyml/run_time.cpp @@ -1,417 +1,417 @@ /* Title: Run-time system. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000 Cambridge University Technical Services Limited Further work copyright David C. J. Matthews 2009, 2012, 2015-18 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #include "globals.h" #include "gc.h" #include "mpoly.h" #include "arb.h" #include "diagnostics.h" #include "processes.h" #include "profiling.h" #include "run_time.h" #include "sys.h" #include "polystring.h" #include "save_vec.h" #include "rtsentry.h" #include "memmgr.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFullGC(PolyObject *threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFullGC(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyIsBigEndian(); } #define SAVE(x) taskData->saveVec.push(x) #define SIZEOF(x) (sizeof(x)/sizeof(PolyWord)) // This is the storage allocator for allocating heap objects in the RTS. PolyObject *alloc(TaskData *taskData, uintptr_t data_words, unsigned flags) /* Allocate a number of words. */ { // Check the size. This might possibly happen with a long string. if (data_words > MAX_OBJECT_SIZE) raise_exception0(taskData, EXC_size); POLYUNSIGNED words = (POLYUNSIGNED)data_words + 1; if (profileMode == kProfileStoreAllocation) taskData->addProfileCount(words); PolyWord *foundSpace = processes->FindAllocationSpace(taskData, words, false); if (foundSpace == 0) { // Failed - the thread is set to raise an exception. throw IOException(); } PolyObject *pObj = (PolyObject*)(foundSpace + 1); pObj->SetLengthWord((POLYUNSIGNED)data_words, flags); // Must initialise object here, because GC doesn't clean store. // Is this necessary any more? This used to be necessary when we used // structural equality and wanted to make sure that unused bytes were cleared. // N.B. This sets the store to zero NOT TAGGED(0). for (POLYUNSIGNED i = 0; i < data_words; i++) pObj->Set(i, PolyWord::FromUnsigned(0)); return pObj; } Handle alloc_and_save(TaskData *taskData, uintptr_t size, unsigned flags) /* Allocate and save the result on the vector. */ { return taskData->saveVec.push(alloc(taskData, size, flags)); } -POLYUNSIGNED PolyFullGC(PolyObject *threadId) +POLYUNSIGNED PolyFullGC(FirstArgument threadId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); try { // Can this raise an exception e.g. if there is insufficient memory? FullGC(taskData); } catch (...) { } // If an ML exception is raised taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); // Returns unit. } /******************************************************************************/ /* */ /* Error Messages */ /* */ /******************************************************************************/ // Return the handle to a string error message. This will return // something like "Unknown error" from strerror if it doesn't match // anything. Handle errorMsg(TaskData *taskData, int err) { #if (defined(_WIN32)) LPTSTR lpMsg = NULL; TCHAR *p; if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_IGNORE_INSERTS, NULL, (DWORD)err, 0, (LPTSTR)&lpMsg, 1, NULL) > 0) { /* The message is returned with CRLF at the end. Remove them. */ for (p = lpMsg; *p != '\0' && *p != '\n' && *p != '\r'; p++); *p = '\0'; Handle res = SAVE(C_string_to_Poly(taskData, lpMsg)); LocalFree(lpMsg); return res; } #endif // Unix and unknown Windows errors. return SAVE(C_string_to_Poly(taskData, strerror(err))); } #define DEREFEXNHANDLE(_x) ((poly_exn *)DEREFHANDLE(_x)) static Handle make_exn(TaskData *taskData, int id, Handle arg, const char *fileName, int lineNo) { const char *exName; switch (id) { case EXC_interrupt: exName = "Interrupt"; break; case EXC_syserr: exName = "SysErr"; break; case EXC_size: exName = "Size"; break; case EXC_overflow: exName = "Overflow"; break; case EXC_underflow: exName = "Underflow"; break; case EXC_divide: exName = "Div"; break; case EXC_conversion: exName = "Conversion"; break; case EXC_XWindows: exName = "XWindows"; break; case EXC_subscript: exName = "Subscript"; break; case EXC_foreign: exName = "Foreign"; break; case EXC_Fail: exName = "Fail"; break; case EXC_thread: exName = "Thread"; break; case EXC_extrace: exName = "ExTrace"; break; default: ASSERT(0); exName = "Unknown"; // Shouldn't happen. } Handle pushed_name = SAVE(C_string_to_Poly(taskData, exName)); Handle exnHandle = alloc_and_save(taskData, SIZEOF(poly_exn)); Handle location; // The location data in an exception packet is either "NoLocation" (tagged 0) // or the address of a record. if (fileName == 0) location = taskData->saveVec.push(TAGGED(0)); else { Handle file = taskData->saveVec.push(C_string_to_Poly(taskData, fileName)); Handle line = Make_fixed_precision(taskData, lineNo); location = alloc_and_save(taskData, 5); location->WordP()->Set(0, file->Word()); // file location->WordP()->Set(1, line->Word()); // startLine location->WordP()->Set(2, line->Word()); // endLine location->WordP()->Set(3, TAGGED(0)); // startPosition location->WordP()->Set(4, TAGGED(0)); // endPosition } DEREFEXNHANDLE(exnHandle)->ex_id = TAGGED(id); DEREFEXNHANDLE(exnHandle)->ex_name = pushed_name->Word(); DEREFEXNHANDLE(exnHandle)->arg = arg->Word(); DEREFEXNHANDLE(exnHandle)->ex_location = location->Word(); return exnHandle; } // Create an exception packet, e.g. Interrupt, for later use. This does not have a // location. poly_exn *makeExceptionPacket(TaskData *taskData, int id) { Handle exn = make_exn(taskData, id, taskData->saveVec.push(TAGGED(0)), 0, 0); return DEREFEXNHANDLE(exn); } static NORETURNFN(void raise_exception(TaskData *taskData, int id, Handle arg, const char *file, int line)); void raise_exception(TaskData *taskData, int id, Handle arg, const char *file, int line) /* Raise an exception with no arguments. */ { Handle exn = make_exn(taskData, id, arg, file, line); taskData->SetException(DEREFEXNHANDLE(exn)); throw IOException(); /* Return to Poly code immediately. */ /*NOTREACHED*/ } void raiseException0WithLocation(TaskData *taskData, int id, const char *file, int line) /* Raise an exception with no arguments. */ { raise_exception(taskData, id, SAVE(TAGGED(0)), file, line); /*NOTREACHED*/ } void raiseExceptionStringWithLocation(TaskData *taskData, int id, const char *str, const char *file, int line) /* Raise an exception with a C string as the argument. */ { raise_exception(taskData, id, SAVE(C_string_to_Poly(taskData, str)), file, line); /*NOTREACHED*/ } // This is called via a macro that puts in the file name and line number. void raiseSycallWithLocation(TaskData *taskData, const char *errmsg, int err, const char *file, int line) { if (err == 0) { Handle pushed_option = SAVE(NONE_VALUE); /* NONE */ Handle pushed_name = SAVE(C_string_to_Poly(taskData, errmsg)); Handle pair = alloc_and_save(taskData, 2); DEREFHANDLE(pair)->Set(0, pushed_name->Word()); DEREFHANDLE(pair)->Set(1, pushed_option->Word()); raise_exception(taskData, EXC_syserr, pair, file, line); } else { Handle errornum = Make_sysword(taskData, err); Handle pushed_option = alloc_and_save(taskData, 1); DEREFHANDLE(pushed_option)->Set(0, errornum->Word()); /* SOME err */ Handle pushed_name = errorMsg(taskData, err); // Generate the string. Handle pair = alloc_and_save(taskData, 2); DEREFHANDLE(pair)->Set(0, pushed_name->Word()); DEREFHANDLE(pair)->Set(1, pushed_option->Word()); raise_exception(taskData, EXC_syserr, pair, file, line); } } void raiseExceptionFailWithLocation(TaskData *taskData, const char *str, const char *file, int line) { raiseExceptionStringWithLocation(taskData, EXC_Fail, str, file, line); } /* "Polymorphic" function to generate a list. */ Handle makeList(TaskData *taskData, int count, char *p, int size, void *arg, Handle (mkEntry)(TaskData *, void*, char*)) { Handle saved = taskData->saveVec.mark(); Handle list = SAVE(ListNull); /* Start from the end of the list. */ p += count*size; while (count > 0) { Handle value, next; p -= size; /* Back up to the last entry. */ value = mkEntry(taskData, arg, p); next = alloc_and_save(taskData, SIZEOF(ML_Cons_Cell)); DEREFLISTHANDLE(next)->h = value->Word(); DEREFLISTHANDLE(next)->t = list->Word(); taskData->saveVec.reset(saved); list = SAVE(next->Word()); count--; } return list; } void CheckAndGrowStack(TaskData *taskData, uintptr_t minSize) /* Expands the current stack if it has grown. We cannot shrink a stack segment when it grows smaller because the frame is checked only at the beginning of a function to ensure that there is enough space for the maximum that can be allocated. */ { /* Get current size of new stack segment. */ uintptr_t old_len = taskData->stack->spaceSize(); if (old_len >= minSize) return; /* Ok with present size. */ // If it is too small double its size. uintptr_t new_len; /* New size */ for (new_len = old_len; new_len < minSize; new_len *= 2); uintptr_t limitSize = getPolyUnsigned(taskData, taskData->threadObject->mlStackSize); // Do not grow the stack if its size is already too big. if ((limitSize != 0 && old_len >= limitSize) || ! gMem.GrowOrShrinkStack(taskData, new_len)) { /* Cannot expand the stack any further. */ extern FILE *polyStderr; fprintf(polyStderr, "Warning - Unable to increase stack - interrupting thread\n"); if (debugOptions & DEBUG_THREADS) Log("THREAD: Unable to grow stack for thread %p from %lu to %lu\n", taskData, old_len, new_len); // We really should do this only if the thread is handling interrupts // asynchronously. On the other hand what else do we do? taskData->SetException(processes->GetInterrupt()); } else { if (debugOptions & DEBUG_THREADS) Log("THREAD: Growing stack for thread %p from %lu to %lu\n", taskData, old_len, new_len); } } Handle Make_fixed_precision(TaskData *taskData, int val) { if (val > MAXTAGGED || val < -MAXTAGGED-1) raise_exception0(taskData, EXC_overflow); return taskData->saveVec.push(TAGGED(val)); } Handle Make_fixed_precision(TaskData *taskData, unsigned uval) { if (uval > MAXTAGGED) raise_exception0(taskData, EXC_overflow); return taskData->saveVec.push(TAGGED(uval)); } Handle Make_fixed_precision(TaskData *taskData, long val) { if (val > MAXTAGGED || val < -MAXTAGGED-1) raise_exception0(taskData, EXC_overflow); return taskData->saveVec.push(TAGGED(val)); } Handle Make_fixed_precision(TaskData *taskData, unsigned long uval) { if (uval > MAXTAGGED) raise_exception0(taskData, EXC_overflow); return taskData->saveVec.push(TAGGED(uval)); } #ifdef HAVE_LONG_LONG Handle Make_fixed_precision(TaskData *taskData, long long val) { if (val > MAXTAGGED || val < -MAXTAGGED-1) raise_exception0(taskData, EXC_overflow); return taskData->saveVec.push(TAGGED((POLYSIGNED)val)); } Handle Make_fixed_precision(TaskData *taskData, unsigned long long uval) { if (uval > MAXTAGGED) raise_exception0(taskData, EXC_overflow); return taskData->saveVec.push(TAGGED((POLYUNSIGNED)uval)); } #endif Handle Make_sysword(TaskData *taskData, uintptr_t p) { Handle result = alloc_and_save(taskData, sizeof(uintptr_t)/sizeof(PolyWord), F_BYTE_OBJ); *(uintptr_t*)(result->Word().AsCodePtr()) = p; return result; } // A volatile ref is used for data that is not valid in a different session. // When loaded from a saved state it is cleared to zero. Handle MakeVolatileWord(TaskData *taskData, void *p) { Handle result = alloc_and_save(taskData, WORDS(SIZEOF_VOIDP), F_BYTE_OBJ | F_WEAK_BIT | F_MUTABLE_BIT | F_NO_OVERWRITE); *(void**)(result->Word().AsCodePtr()) = p; return result; } Handle MakeVolatileWord(TaskData *taskData, uintptr_t p) { return MakeVolatileWord(taskData, (void*)p); } // This is used to determine the endian-ness that Poly/ML is running under. // It's really only needed for the interpreter. In particular the pre-built // compiler may be running under either byte order and has to check at // run-time. POLYUNSIGNED PolyIsBigEndian() { #ifdef WORDS_BIGENDIAN return TAGGED(1).AsUnsigned(); #else return TAGGED(0).AsUnsigned(); #endif } struct _entrypts runTimeEPT[] = { { "PolyFullGC", (polyRTSFunction)&PolyFullGC}, { "PolyIsBigEndian", (polyRTSFunction)&PolyIsBigEndian}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/scanaddrs.cpp b/libpolyml/scanaddrs.cpp index 479a6f88..d6c5992c 100644 --- a/libpolyml/scanaddrs.cpp +++ b/libpolyml/scanaddrs.cpp @@ -1,496 +1,288 @@ /* Title: Address scanner Copyright (c) 2006-8, 2012, 2019 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License 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 */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #include #include "globals.h" #include "scanaddrs.h" #include "machine_dep.h" #include "diagnostics.h" #include "memmgr.h" // Process the value at a given location and update it as necessary. POLYUNSIGNED ScanAddress::ScanAddressAt(PolyWord *pt) { PolyWord val = *pt; PolyWord newVal = val; if (IS_INT(val) || val == PolyWord::FromUnsigned(0)) { // We can get zeros in the constant area if we garbage collect // while compiling some code. */ } else { ASSERT(OBJ_IS_DATAPTR(val)); // Any sort of address newVal = ScanObjectAddress(val.AsObjPtr()); } if (newVal != val) // Only update if we need to. *pt = newVal; return 0; } // General purpose object processor, Processes all the addresses in an object. // Handles the various kinds of object that may contain addresses. void ScanAddress::ScanAddressesInObject(PolyObject *obj, POLYUNSIGNED lengthWord) { do { ASSERT (OBJ_IS_LENGTH(lengthWord)); if (OBJ_IS_BYTE_OBJECT(lengthWord)) return; /* Nothing more to do */ POLYUNSIGNED length = OBJ_OBJECT_LENGTH(lengthWord); PolyWord *baseAddr = (PolyWord*)obj; if (OBJ_IS_CODE_OBJECT(lengthWord)) { // Scan constants within the code. machineDependent->ScanConstantsWithinCode(obj, obj, length, this); // Skip to the constants and get ready to scan them. obj->GetConstSegmentForCode(length, baseAddr, length); } else if (OBJ_IS_CLOSURE_OBJECT(lengthWord)) { // The first word is a code pointer so we need to treat it specially // but it is possible it hasn't yet been set. if ((*(uintptr_t*)baseAddr & 1) == 0) { POLYUNSIGNED lengthWord = ScanCodeAddressAt((PolyObject**)baseAddr); // N.B. This could side-effect *baseAddr if (lengthWord != 0) ScanAddressesInObject(*(PolyObject**)baseAddr, lengthWord); } baseAddr += sizeof(PolyObject*) / sizeof(PolyWord); length -= sizeof(PolyObject*) / sizeof(PolyWord); } PolyWord *endWord = baseAddr + length; // We want to minimise the actual recursion we perform so we try to // use tail recursion if we can. We first scan from the end and // remove any words that don't need recursion. POLYUNSIGNED lastLengthWord = 0; while (endWord != baseAddr) { PolyWord wordAt = endWord[-1]; if (IS_INT(wordAt) || wordAt == PolyWord::FromUnsigned(0)) endWord--; // Don't need to look at this. else if ((lastLengthWord = ScanAddressAt(endWord-1)) != 0) // We need to process this one break; else endWord--; // We're not interested in this. } if (endWord == baseAddr) return; // We've done everything. // There is at least one word that needs to be processed, the // one at endWord-1. // Now process from the beginning forward to see if there are // any words before this that need to be handled. This way we are more // likely to handle the head of a list by recursion and the // tail by looping (tail recursion). while (baseAddr < endWord-1) { PolyWord wordAt = *baseAddr; if (IS_INT(wordAt) || wordAt == PolyWord::FromUnsigned(0)) baseAddr++; // Don't need to look at this. else { POLYUNSIGNED lengthWord = ScanAddressAt(baseAddr); if (lengthWord != 0) { wordAt = *baseAddr; // Reload because it may have been side-effected // We really have to process this recursively. ASSERT(wordAt.IsDataPtr()); ScanAddressesInObject(wordAt.AsObjPtr(), lengthWord); baseAddr++; } else baseAddr++; } } // Finally process the last word we found that has to be processed. // Do this by looping rather than recursion. PolyWord wordAt = *baseAddr; // Last word to do. // This must be an address ASSERT(wordAt.IsDataPtr()); obj = wordAt.AsObjPtr(); lengthWord = lastLengthWord; } while(1); } void ScanAddress::ScanAddressesInRegion(PolyWord *region, PolyWord *end) { PolyWord *pt = region; while (pt < end) { #ifdef POLYML32IN64 if ((((uintptr_t)pt) & 4) == 0) { // Skip any padding. The length word should be on an odd-word boundary. pt++; continue; } #endif pt++; // Skip length word. // pt actually points AT the object here. PolyObject *obj = (PolyObject*)pt; if (obj->ContainsForwardingPtr()) /* skip over moved object */ { // We can now get multiple forwarding pointers as a result // of applying ShareData repeatedly. Perhaps we should // turn the forwarding pointers back into normal words in // an extra pass. obj = obj->FollowForwardingChain(); ASSERT(obj->ContainsNormalLengthWord()); pt += obj->Length(); } else { ASSERT(obj->ContainsNormalLengthWord()); POLYUNSIGNED length = obj->Length(); if (pt+length > end) Crash("Malformed object at %p - length %lu\n", pt, length); if (length != 0) ScanAddressesInObject(obj); pt += length; } } } // Extract a constant from the code. PolyObject *ScanAddress::GetConstantValue(byte *addressOfConstant, ScanRelocationKind code, PolyWord *base) { switch (code) { case PROCESS_RELOC_DIRECT: // 32 or 64 bit address of target { POLYUNSIGNED valu; unsigned i; byte *pt = addressOfConstant; if (pt[3] & 0x80) valu = 0-1; else valu = 0; for (i = sizeof(PolyWord); i > 0; i--) valu = (valu << 8) | pt[i-1]; if (valu == 0 || PolyWord::FromUnsigned(valu).IsTagged()) return 0; else return PolyWord::FromUnsigned(valu).AsObjPtr(base); } case PROCESS_RELOC_I386RELATIVE: // 32 bit relative address { POLYSIGNED disp; byte *pt = addressOfConstant; // Get the displacement. This is signed. if (pt[3] & 0x80) disp = -1; else disp = 0; // Set the sign just in case. for(unsigned i = 4; i > 0; i--) disp = (disp << 8) | pt[i-1]; byte *absAddr = pt + disp + 4; // The address is relative to AFTER the constant return (PolyObject*)absAddr; } default: ASSERT(false); return 0; } } // Store a constant value. Also used with a patch table when importing a saved heap which has // been exported using the C exporter. void ScanAddress::SetConstantValue(byte *addressOfConstant, PolyObject *p, ScanRelocationKind code) { switch (code) { case PROCESS_RELOC_DIRECT: // 32 or 64 bit address of target { POLYUNSIGNED valu = ((PolyWord)p).AsUnsigned(); for (unsigned i = 0; i < sizeof(PolyWord); i++) { addressOfConstant[i] = (byte)(valu & 255); valu >>= 8; } } break; case PROCESS_RELOC_I386RELATIVE: // 32 bit relative address { // This offset may be positive or negative intptr_t newDisp = (byte*)p - addressOfConstant - 4; #if (SIZEOF_VOIDP != 4) ASSERT(newDisp < (intptr_t)0x80000000 && newDisp >= -(intptr_t)0x80000000); #endif for (unsigned i = 0; i < 4; i++) { addressOfConstant[i] = (byte)(newDisp & 0xff); newDisp >>= 8; } } break; } } void ScanAddress::ScanConstant(PolyObject *base, byte *addressOfConstant, ScanRelocationKind code) { PolyObject *p = GetConstantValue(addressOfConstant, code); if (p != 0) { PolyObject *oldValue = p; // If this was a relative address we must have a code address. if (code == PROCESS_RELOC_I386RELATIVE) ScanCodeAddressAt(&p); else p = ScanObjectAddress(p); if (p != oldValue) // Update it if it has changed. SetConstantValue(addressOfConstant, p, code); } } void ScanAddress::ScanRuntimeWord(PolyWord *w) { if (w->IsTagged()) {} // Don't need to do anything else { ASSERT(w->IsDataPtr()); *w = ScanObjectAddress(w->AsObjPtr()); } } - -// This gets called in two circumstances. It may be called for the roots -// in which case the stack will be empty and we want to process it completely -// or it is called for a constant address in which case it will have been -// called from RecursiveScan::ScanAddressesInObject and that can process -// any addresses. -PolyObject *RecursiveScan::ScanObjectAddress(PolyObject *obj) -{ - PolyWord pWord = obj; - // Test to see if this needs to be scanned. - // It may update the word. - bool test = TestForScan(&pWord); - obj = pWord.AsObjPtr(); - - if (test) - { - MarkAsScanning(obj); - if (obj->IsByteObject()) - Completed(obj); // Don't need to put it on the stack - // If we already have something on the stack we must being called - // recursively to process a constant in a code segment. Just push - // it on the stack and let the caller deal with it. - else if (StackIsEmpty()) - RecursiveScan::ScanAddressesInObject(obj, obj->LengthWord()); - else - PushToStack(obj, (PolyWord*)obj); - } - - return obj; -} - -// This is called via ScanAddressesInRegion to process the permanent mutables. It is -// also called from ScanObjectAddress to process root addresses. -// It processes all the addresses reachable from the object. -// This is almost the same as MTGCProcessMarkPointers::ScanAddressesInObject. -void RecursiveScan::ScanAddressesInObject(PolyObject *obj, POLYUNSIGNED lengthWord) -{ - if (OBJ_IS_BYTE_OBJECT(lengthWord)) - return; // Ignore byte cells and don't call Completed on them - - PolyWord *baseAddr = (PolyWord*)obj; - - while (true) - { - ASSERT (OBJ_IS_LENGTH(lengthWord)); - - // Get the length and base address. N.B. If this is a code segment - // these will be side-effected by GetConstSegmentForCode. - POLYUNSIGNED length = OBJ_OBJECT_LENGTH(lengthWord); - - if (OBJ_IS_CODE_OBJECT(lengthWord) || OBJ_IS_CLOSURE_OBJECT(lengthWord)) - { - // It's better to process the whole code object in one go. - // For the moment do that for closure objects as well. - ScanAddress::ScanAddressesInObject(obj, lengthWord); - length = 0; // Finished - } - - // else it's a normal object, - - // If there are only two addresses in this cell that need to be - // followed we follow them immediately and treat this cell as done. - // If there are more than two we push the address of this cell on - // the stack, follow the first address and then rescan it. That way - // list cells are processed once only but we don't overflow the - // stack by pushing all the addresses in a very large vector. - PolyWord *endWord = (PolyWord*)obj + length; - PolyObject *firstWord = 0; - PolyObject *secondWord = 0; - PolyWord *restartFrom = baseAddr; - - while (baseAddr != endWord) - { - PolyWord wordAt = *baseAddr; - - if (wordAt.IsDataPtr() && wordAt != PolyWord::FromUnsigned(0)) - { - // Normal address. We can have words of all zeros at least in the - // situation where we have a partially constructed code segment where - // the constants at the end of the code have not yet been filled in. - if (TestForScan(baseAddr)) // Test value at baseAddr (may side-effect it) - { - PolyObject *wObj = (*baseAddr).AsObjPtr(); - if (wObj->IsByteObject()) - { - // Can do this now - don't need to push it - MarkAsScanning(wObj); - Completed(wObj); - } - else if (firstWord == 0) - { - firstWord = wObj; - // We mark the word immediately. We can have - // two words in an object that are the same - // and we don't want to process it again. - MarkAsScanning(firstWord); - } - else if (secondWord == 0) - { - secondWord = wObj; - restartFrom = baseAddr; - } - else break; // More than two words. - } - } - baseAddr++; - } - - if (baseAddr == endWord) - { - // We have done everything except possibly firstWord and secondWord. - // Note: Unfortunately the way that ScanAddressesInRegion works means that - // we call Completed on the addresses of cells in the permanent areas without - // having called TestForScan. - Completed(obj); - if (secondWord != 0) - { - MarkAsScanning(secondWord); - // Put this on the stack. If this is a list node we will be - // pushing the tail. - PushToStack(secondWord, (PolyWord*)secondWord); - } - } - else // Put this back on the stack while we process the first word - PushToStack(obj, restartFrom); - - if (firstWord != 0) - { - // Process it immediately. - obj = firstWord; - baseAddr = (PolyWord*)obj; - } - else if (StackIsEmpty()) - return; - else - PopFromStack(obj, baseAddr); - - lengthWord = obj->LengthWord(); - } -} - -// The stack is allocated as a series of blocks chained together. -#define RSTACK_SEGMENT_SIZE 1000 - -class RScanStack { -public: - RScanStack(): nextStack(0), lastStack(0), sp(0) {} - ~RScanStack() { delete(nextStack); } - - RScanStack *nextStack; - RScanStack *lastStack; - unsigned sp; - struct { PolyObject *obj; PolyWord *base; } stack[RSTACK_SEGMENT_SIZE]; -}; - -RecursiveScanWithStack::~RecursiveScanWithStack() -{ - delete(stack); -} - -bool RecursiveScanWithStack::StackIsEmpty(void) -{ - return stack == 0 || (stack->sp == 0 && stack->lastStack == 0); -} - -void RecursiveScanWithStack::PushToStack(PolyObject *obj, PolyWord *base) -{ - if (stack == 0 || stack->sp == RSTACK_SEGMENT_SIZE) - { - if (stack != 0 && stack->nextStack != 0) - stack = stack->nextStack; - else - { - // Need a new segment - try { - RScanStack *s = new RScanStack; - s->lastStack = stack; - if (stack != 0) - stack->nextStack = s; - stack = s; - } - catch (std::bad_alloc &) { - StackOverflow(); - return; - } - } - } - stack->stack[stack->sp].obj = obj; - stack->stack[stack->sp].base = base; - stack->sp++; -} - -void RecursiveScanWithStack::PopFromStack(PolyObject *&obj, PolyWord *&base) -{ - if (stack->sp == 0) - { - // Chain to the previous stack if any - ASSERT(stack->lastStack != 0); - // Before we do, delete any further one to free some memory - delete(stack->nextStack); - stack->nextStack = 0; - stack = stack->lastStack; - ASSERT(stack->sp == RSTACK_SEGMENT_SIZE); - } - --stack->sp; - obj = stack->stack[stack->sp].obj; - base = stack->stack[stack->sp].base; -} diff --git a/libpolyml/scanaddrs.h b/libpolyml/scanaddrs.h index adab0186..ff7c3482 100644 --- a/libpolyml/scanaddrs.h +++ b/libpolyml/scanaddrs.h @@ -1,149 +1,102 @@ /* Title: scanaddrs.h - Scan addresses in objects Copyright (c) 2006-8, 2012, 2015, 2018 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifndef SCANADDRS_H_INCLUDED #define SCANADDRS_H_INCLUDED #include "globals.h" // Type of relocations. typedef enum { PROCESS_RELOC_DIRECT = 0, // 32 or 64 bit address of target PROCESS_RELOC_I386RELATIVE // 32 or 64 bit relative address } ScanRelocationKind; class StackSpace; class ScanAddress { public: virtual ~ScanAddress() {} // Keeps gcc happy protected: // Scan an address in the memory. "pt" always points into an object. // It is not called with pt pointing at a C++ automatic variable. // Tagged integers have already been filtered out. // The result is the length word of the object to use if the object // is to be processed recursively or 0 if it should not be. // Default action - call ScanObjectAddress for the base object address of // the address. virtual POLYUNSIGNED ScanAddressAt(PolyWord *pt); // As for ScanAddressAt except that the value is a pointer to the first word in a closure object. // In most cases we're just scanning the heap we don't need to do anything and we scan // the code area separately. virtual POLYUNSIGNED ScanCodeAddressAt(PolyObject **pt) { return 0; } public: // The fundamental overridable for this class. Takes the object address and returns // the updated address. If nothing else is overridden everything eventually comes here. virtual PolyObject *ScanObjectAddress(PolyObject *base) = 0;// { return base; } typedef enum { STRENGTH_STRONG = 0, STRENGTH_WEAK = 1 } RtsStrength; // Scan an address in the run-time system. This normally just applies ScanObjectAddress // but if this is a weak reference it can set *pt to NULL virtual void ScanRuntimeAddress(PolyObject **pt, RtsStrength weak) { *pt = ScanObjectAddress(*pt); } // Scan a word in the run-time system. This is the preferred call for non-weak // references and deals with the general case of a word. void ScanRuntimeWord(PolyWord *w); // Process a constant within the code. // The default action is to call the DEFAULT ScanAddressAt NOT the virtual which means that it calls // ScanObjectAddress for the base address of the object referred to. virtual void ScanConstant(PolyObject *base, byte *addressOfConstant, ScanRelocationKind code); // Scan the objects in the region and process their addresses. Applies ScanAddressesInObject // to each of the objects. The "region" argument points AT the first length word. // Typically used to scan or update addresses in the mutable area. void ScanAddressesInRegion(PolyWord *region, PolyWord *endOfRegion); // General object processor. // If the object is a word object calls ScanAddressesAt for all the addresses. // // If the object is a code object calls ScanAddressesAt for the constant area and // calls (indirectly) ScanConstant, and by default ScanObjectAddress for addresses within // the code // // If the object is a stack calls ScanStackAddress which calls ScanObjectAddress for // addresses within the code. virtual void ScanAddressesInObject(PolyObject *base, POLYUNSIGNED lengthWord); void ScanAddressesInObject(PolyObject *base) { ScanAddressesInObject(base, base->LengthWord()); } // Extract a constant from the code. #ifdef POLYML32IN64 static PolyObject *GetConstantValue(byte *addressOfConstant, ScanRelocationKind code, PolyWord *base = globalHeapBase); #else static PolyObject *GetConstantValue(byte *addressOfConstant, ScanRelocationKind code, PolyWord *base = 0); #endif // Store a constant in the code. static void SetConstantValue(byte *addressOfConstant, PolyObject *p, ScanRelocationKind code); }; -// Recursive scan over a data structure. -class RecursiveScan: public ScanAddress -{ -public: - virtual PolyObject *ScanObjectAddress(PolyObject *base); - virtual void ScanAddressesInObject(PolyObject *base, POLYUNSIGNED lengthWord); - // Have to redefine this for some reason. - void ScanAddressesInObject(PolyObject *base) - { ScanAddressesInObject(base, base->LengthWord()); } - -protected: - // The derived class must provide a stack. - virtual void PushToStack(PolyObject *obj, PolyWord *base) = 0; - virtual void PopFromStack(PolyObject *&obj, PolyWord *&base) = 0; - virtual bool StackIsEmpty(void) = 0; - - // Test the word at the location to see if it points to - // something that may have to be scanned. We pass in the - // pointer here because the called may side-effect it. - virtual bool TestForScan(PolyWord *) = 0; - // If we are definitely scanning the address we mark it. - virtual void MarkAsScanning(PolyObject *) = 0; - // Called when the object has been completed. - virtual void Completed(PolyObject *) {} -}; - -// Recursive scan with a dynamically allocated stack -class RScanStack; - -class RecursiveScanWithStack: public RecursiveScan -{ -public: - RecursiveScanWithStack(): stack(0) {} - ~RecursiveScanWithStack(); - -protected: - // StackOverflow is called if allocating a new stack - // segment fails. - virtual void StackOverflow(void) = 0; - - virtual void PushToStack(PolyObject *obj, PolyWord *base); - virtual void PopFromStack(PolyObject *&obj, PolyWord *&base); - virtual bool StackIsEmpty(void); - - RScanStack *stack; -}; - #endif diff --git a/libpolyml/sharedata.cpp b/libpolyml/sharedata.cpp index ce39b3c7..dc16aa03 100644 --- a/libpolyml/sharedata.cpp +++ b/libpolyml/sharedata.cpp @@ -1,1135 +1,1135 @@ /* Title: Share common immutable data Copyright (c) 2000 Cambridge University Technical Services Limited and David C. J. Matthews 2006, 2010-13, 2016-17 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #ifdef HAVE_STRING_H #include #endif #include "globals.h" #include "save_vec.h" #include "machine_dep.h" #include "scanaddrs.h" #include "run_time.h" #include "sys.h" #include "gc.h" #include "rtsentry.h" #include "memmgr.h" #include "processes.h" #include "gctaskfarm.h" #include "diagnostics.h" #include "sharedata.h" /* This code was largely written by Simon Finn as a database improver for the memory-mapped persistent store version. The aim is that where two immutable objects (cells) contain the same data (i.e. where ML equality would say they were equal) they should be merged so that only a single object is retained. The basic algorithm works like this: 1. From the root, recursively process all objects and calculate a "depth" for each object. Mutable data and code segments have depth 0 and cannot be merged. Byte segments (e.g. strings and long-format arbitrary precision values) have depth 1. Other cells have depths of 1 or greater, the depth being the maximum recursion depth until a byte segment or an object with depth 0 is reached. Cycles of immutable data don't arise normally in ML but could be produced as a result of locking mutable objects. To avoid infinite recursion cycles are broken by setting the depth of an object to zero before processing it. The depth of each object is stored in the length word of the object. This ensures each object is processed once only. 2. Vectors are created containing objects of the same depth, from 1 to the maximum depth found. 3. We begin a loop starting at depth 1. 4. The length words are restored, replacing the depth count in the header. 5. The objects are sorted by their contents so bringing together objects with the same contents. The contents are considered simply as uninterpreted bits. 6. The sorted vector is processed to find those objects that are actually bitwise equal. One object is selected to be retained and other objects have their length words turned into tombstones pointing at the retained object. 7. Objects at the next depth are first processed to find pointers to objects that moved in the previous step (or that step with a lower depth). The addresses are updated to point to the retained object. The effect of this step is to ensure that now two objects that are equal in ML terms have identical contents. e.g. If we have val a = ("abc", "def") and b = ("abc", "def") then we will have merged the two occurrences of "abc" and "def" in the previous pass of level 1 objects. This step ensures that the two cells containing the pairs both hold pointers to the same objects and so are bitwise equal. 8. Repeat with 4, 5 and 6 until all the levels have been processed. Each object is processed once and at the end most of the objects have been updated with the shared addresses. We have to scan all the mutable and code objects to update the addresses but also have to scan the immutables because of the possibility of missing an update as a result of breaking a loop (see SPF's comment below). DCJM 3/8/06 This has been substantially updated while retaining the basic algorithm. Sorting is now done in parallel by the GC task farm and the stack is now in dynamic memory. That avoids a possible segfault if the normal C stack overflows. A further problem is that the vectors can get very large and this can cause problems if there is insufficient contiguous space. The code has been modified to reduce the size of the vectors at the cost of increasing the total memory requirement. */ extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyShareCommonData(PolyObject *threadId, PolyWord root); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyShareCommonData(FirstArgument threadId, PolyWord root); } // The depth is stored in the length field. If the Weak bit is set but the Mutable bit // is clear the value in the length word is a depth rather than a real length. // The tombstone bit is zero. // Previously "depth" values were encoded with the tombstone bit set but that isn't // possible in 32-in-64 because we need 31 bits in a forwarding pointer. inline bool OBJ_IS_DEPTH(POLYUNSIGNED L) { return (L & (_OBJ_WEAK_BIT| _OBJ_MUTABLE_BIT)) == _OBJ_WEAK_BIT; } inline POLYUNSIGNED OBJ_GET_DEPTH(POLYUNSIGNED L) { return OBJ_OBJECT_LENGTH(L); } inline POLYUNSIGNED OBJ_SET_DEPTH(POLYUNSIGNED n) { return n | _OBJ_WEAK_BIT; } // The DepthVector type contains all the items of a particular depth. // This is the abstract class. There are variants for the case where all // the cells have the same size and where they may vary. class DepthVector { public: DepthVector() : nitems(0), vsize(0), ptrVector(0) {} virtual ~DepthVector() { free(ptrVector); } virtual POLYUNSIGNED MergeSameItems(void); virtual void Sort(void); virtual POLYUNSIGNED ItemCount(void) { return nitems; } virtual void AddToVector(POLYUNSIGNED L, PolyObject *pt) = 0; void FixLengthAndAddresses(ScanAddress *scan); virtual void RestoreForwardingPointers() = 0; protected: POLYUNSIGNED nitems; POLYUNSIGNED vsize; PolyObject **ptrVector; // This must only be called BEFORE sorting. The pointer vector will be // modified by sorting but the length vector is not. virtual void RestoreLengthWords(void) = 0; static void SortRange(PolyObject * *first, PolyObject * *last); static int CompareItems(const PolyObject * const *a, const PolyObject * const *b); static int qsCompare(const void *a, const void *b) { return CompareItems((const PolyObject * const*)a, (const PolyObject *const *)b); } static void sortTask(GCTaskId*, void *s, void *l) { SortRange((PolyObject **)s, (PolyObject **)l); } }; // DepthVector where the size needs to be held for each item. class DepthVectorWithVariableLength: public DepthVector { public: DepthVectorWithVariableLength() : lengthVector(0) {} virtual ~DepthVectorWithVariableLength() { free(lengthVector); } virtual void RestoreLengthWords(void); virtual void AddToVector(POLYUNSIGNED L, PolyObject *pt); virtual void RestoreForwardingPointers(); protected: POLYUNSIGNED *lengthVector; // Same size as the ptrVector }; class DepthVectorWithFixedLength : public DepthVector { public: DepthVectorWithFixedLength(POLYUNSIGNED l) : length(l) {} virtual void RestoreLengthWords(void); virtual void AddToVector(POLYUNSIGNED L, PolyObject *pt); // It's safe to run this again for the fixed length vectors. virtual void RestoreForwardingPointers() { RestoreLengthWords(); } protected: POLYUNSIGNED length; }; // We have special vectors for the sizes from 1 to FIXEDLENGTHSIZE-1. // Zero-sized and large objects go in depthVectorArray[0]. #define FIXEDLENGTHSIZE 10 class ShareDataClass { public: ShareDataClass(); ~ShareDataClass(); bool RunShareData(PolyObject *root); void AddToVector(POLYUNSIGNED depth, POLYUNSIGNED length, PolyObject *pt); private: struct _depthVector { DepthVector **vector; POLYUNSIGNED vectorSize; } depthVectorArray[FIXEDLENGTHSIZE]; POLYUNSIGNED maxVectorSize; }; ShareDataClass::ShareDataClass() { maxVectorSize = 0; for (unsigned i = 0; i < FIXEDLENGTHSIZE; i++) { depthVectorArray[i].vector = 0; depthVectorArray[i].vectorSize = 0; } } ShareDataClass::~ShareDataClass() { // Free the bitmaps associated with the permanent spaces. for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) (*i)->shareBitmap.Destroy(); // Free the depth vectors and vector of vectors. for (unsigned i = 0; i < FIXEDLENGTHSIZE; i++) { for (unsigned j = 0; j < depthVectorArray[i].vectorSize; j++) delete(depthVectorArray[i].vector[j]); free(depthVectorArray[i].vector); } } // Grow the appropriate depth vector if necessary and add the item to it. void ShareDataClass::AddToVector(POLYUNSIGNED depth, POLYUNSIGNED length, PolyObject *pt) { // Select the appropriate vector. Element zero is the variable length vector and is // also used for the, rare, zero length objects. struct _depthVector *vectorToUse = &(depthVectorArray[length < FIXEDLENGTHSIZE ? length : 0]); if (depth >= maxVectorSize) maxVectorSize = depth+1; if (depth >= vectorToUse->vectorSize) { POLYUNSIGNED newDepth = depth+1; DepthVector **newVec = (DepthVector **)realloc(vectorToUse->vector, sizeof(DepthVector*)*newDepth); if (newVec == 0) throw MemoryException(); vectorToUse->vector = newVec; // Clear new entries first for (POLYUNSIGNED d = vectorToUse->vectorSize; d < newDepth; d++) vectorToUse->vector[d] = 0; for (POLYUNSIGNED d = vectorToUse->vectorSize; d < newDepth; d++) { try { if (length != 0 && length < FIXEDLENGTHSIZE) vectorToUse->vector[d] = new DepthVectorWithFixedLength(length); else vectorToUse->vector[d] = new DepthVectorWithVariableLength; } catch (std::bad_alloc &) { throw MemoryException(); } } vectorToUse->vectorSize = newDepth; } vectorToUse->vector[depth]->AddToVector(length, pt); } // Add an object to a depth vector void DepthVectorWithVariableLength::AddToVector(POLYUNSIGNED L, PolyObject *pt) { ASSERT (this->nitems <= this->vsize); if (this->nitems == this->vsize) { // The vector is full or has not yet been allocated. Grow it by 50%. POLYUNSIGNED new_vsize = this->vsize + this->vsize / 2 + 1; if (new_vsize < 15) new_vsize = 15; // First the length vector. POLYUNSIGNED *newLength = (POLYUNSIGNED *)realloc(this->lengthVector, new_vsize * sizeof(POLYUNSIGNED)); if (newLength == 0) { // The vectors can get large and we may not be able to grow them // particularly if the address space is limited in 32-bit mode. // Try again with just a small increase. new_vsize = this->vsize + 15; newLength = (POLYUNSIGNED *)realloc(this->lengthVector, new_vsize * sizeof(POLYUNSIGNED)); // If that failed give up. if (newLength == 0) throw MemoryException(); } PolyObject **newPtrVector = (PolyObject * *)realloc (this->ptrVector, new_vsize*sizeof(PolyObject *)); if (newPtrVector == 0) { new_vsize = this->vsize + 15; newPtrVector = (PolyObject **)realloc (this->ptrVector, new_vsize*sizeof(PolyObject *)); // If that failed give up. if (newPtrVector == 0) throw MemoryException(); } this->lengthVector = newLength; this->ptrVector = newPtrVector; this->vsize = new_vsize; } ASSERT (this->nitems < this->vsize); this->lengthVector[this->nitems] = L; this->ptrVector[this->nitems] = pt; this->nitems++; ASSERT (this->nitems <= this->vsize); } // Add an object to a depth vector void DepthVectorWithFixedLength::AddToVector(POLYUNSIGNED L, PolyObject *pt) { ASSERT(this->nitems <= this->vsize); ASSERT(L == length); if (this->nitems == this->vsize) { // The vector is full or has not yet been allocated. Grow it by 50%. POLYUNSIGNED new_vsize = this->vsize + this->vsize / 2 + 1; if (new_vsize < 15) new_vsize = 15; PolyObject **newPtrVector = (PolyObject * *)realloc(this->ptrVector, new_vsize * sizeof(PolyObject *)); if (newPtrVector == 0) { new_vsize = this->vsize + 15; newPtrVector = (PolyObject **)realloc(this->ptrVector, new_vsize * sizeof(PolyObject *)); // If that failed give up. if (newPtrVector == 0) throw MemoryException(); } this->ptrVector = newPtrVector; this->vsize = new_vsize; } ASSERT(this->nitems < this->vsize); this->ptrVector[this->nitems] = pt; this->nitems++; ASSERT(this->nitems <= this->vsize); } // Comparison function used for sorting and also to test whether // two cells can be merged. int DepthVector::CompareItems(const PolyObject *const *a, const PolyObject *const *b) { const PolyObject *x = *a; const PolyObject *y = *b; POLYUNSIGNED lX = x->LengthWord(); POLYUNSIGNED lY = y->LengthWord(); // ASSERT (OBJ_IS_LENGTH(lX)); // ASSERT (OBJ_IS_LENGTH(lY)); if (lX > lY) return 1; // These tests include the flag bits if (lX < lY) return -1; // Return simple bitwise equality. return memcmp(x, y, OBJ_OBJECT_LENGTH(lX)*sizeof(PolyWord)); } // Merge cells with the same contents. POLYUNSIGNED DepthVector::MergeSameItems() { POLYUNSIGNED N = this->nitems; POLYUNSIGNED n = 0; POLYUNSIGNED i = 0; while (i < N) { PolyObject *bestShare = 0; // Candidate to share. MemSpace *bestSpace = 0; POLYUNSIGNED j; for (j = i; j < N; j++) { ASSERT (OBJ_IS_LENGTH(ptrVector[i]->LengthWord())); // Search for identical objects. Don't bother to compare it with itself. if (i != j && CompareItems (&ptrVector[i], &ptrVector[j]) != 0) break; // The order of sharing is significant. // Choose an object in the permanent memory if that is available. // This is necessary to retain the invariant that no object in // the permanent memory points to an object in the temporary heap. // (There may well be pointers to this object elsewhere in the permanent // heap). // Choose the lowest hierarchy value for preference since that // may reduce the size of saved state when resaving already saved // data. // If we can't find a permanent space choose a space that isn't // an allocation space. Otherwise we could break the invariant // that immutable areas never point into the allocation area. MemSpace *space = gMem.SpaceForAddress((PolyWord*)ptrVector[j]-1); if (bestSpace == 0) { bestShare = ptrVector[j]; bestSpace = space; } else if (bestSpace->spaceType == ST_PERMANENT) { // Only update if the current space is also permanent and a lower hierarchy if (space->spaceType == ST_PERMANENT && ((PermanentMemSpace *)space)->hierarchy < ((PermanentMemSpace *)bestSpace)->hierarchy) { bestShare = ptrVector[j]; bestSpace = space; } } else if (bestSpace->spaceType == ST_LOCAL) { // Update if the current space is not an allocation space if (space->spaceType != ST_LOCAL || ! ((LocalMemSpace*)space)->allocationSpace) { bestShare = ptrVector[j]; bestSpace = space; } } } POLYUNSIGNED k = j; // Remember the first object that didn't match. // For each identical object set all but the one we want to point to // the shared object. for (j = i; j < k; j++) { ASSERT (OBJ_IS_LENGTH(ptrVector[j]->LengthWord())); if (ptrVector[j] != bestShare) { ptrVector[j]->SetForwardingPtr(bestShare); /* an indirection */ n++; } } i = k; } return n; } // Sort this vector void DepthVector::Sort() { if (nitems > 1) { SortRange(ptrVector, ptrVector + (nitems - 1)); gpTaskFarm->WaitForCompletion(); } // Check // for (POLYUNSIGNED i = 0; i < nitems-1; i++) // ASSERT(CompareItems(vector+i, vector+i+1) <= 0); } inline void swapItems(PolyObject * *i, PolyObject * *j) { PolyObject * t = *i; *i = *j; *j = t; } // Simple parallel quick-sort. "first" and "last" are the first // and last items (inclusive) in the vector. void DepthVector::SortRange(PolyObject * *first, PolyObject * *last) { while (first < last) { if (last-first <= 100) { // Use the standard library function for small ranges. qsort(first, last-first+1, sizeof(PolyObject *), qsCompare); return; } // Select the best pivot from the first, last and middle item // by sorting these three items. We use the middle item as // the pivot and since the first and last items are sorted // by this we can skip them when we start the partitioning. PolyObject * *middle = first + (last-first)/2; if (CompareItems(first, middle) > 0) swapItems(first, middle); if (CompareItems(middle, last) > 0) { swapItems(middle, last); if (CompareItems(first, middle) > 0) swapItems(first, middle); } // Partition the data about the pivot. This divides the // vector into two partitions with all items <= pivot to // the left and all items >= pivot to the right. // Note: items equal to the pivot could be in either partition. PolyObject * *f = first+1; PolyObject * *l = last-1; do { // Find an item we have to move. These loops will always // terminate because testing the middle with itself // will return == 0. while (CompareItems(f, middle/* pivot*/) < 0) f++; while (CompareItems(middle/* pivot*/, l) < 0) l--; // If we haven't finished we need to swap the items. if (f < l) { swapItems(f, l); // If one of these was the pivot item it will have moved to // the other position. if (middle == f) middle = l; else if (middle == l) middle = f; f++; l--; } else if (f == l) { f++; l--; break; } } while (f <= l); // Process the larger partition as a separate task or // by recursion and do the smaller partition by tail // recursion. if (l-first > last-f) { // Lower part is larger gpTaskFarm->AddWorkOrRunNow(sortTask, first, l); first = f; } else { // Upper part is larger gpTaskFarm->AddWorkOrRunNow(sortTask, f, last); last = l; } } } // Set the genuine length word. This overwrites both depth words and forwarding pointers. void DepthVectorWithVariableLength::RestoreLengthWords() { for (POLYUNSIGNED i = 0; i < this->nitems; i++) ptrVector[i]->SetLengthWord(lengthVector[i]); // restore genuine length word } void DepthVectorWithFixedLength::RestoreLengthWords() { for (POLYUNSIGNED i = 0; i < this->nitems; i++) ptrVector[i]->SetLengthWord(length); // restore genuine length word } // Fix up the length word. Then update all addresses to their new location if // we have shared the original destination of the address with something else. void DepthVector::FixLengthAndAddresses(ScanAddress *scan) { RestoreLengthWords(); for (POLYUNSIGNED i = 0; i < this->nitems; i++) { // Fix up all addresses. scan->ScanAddressesInObject(ptrVector[i]); } } // Restore the original length words on forwarding pointers. // After sorting the pointer vector and length vector are no longer // matched so we have to follow the pointers. void DepthVectorWithVariableLength::RestoreForwardingPointers() { for (POLYUNSIGNED i = 0; i < this->nitems; i++) { PolyObject *obj = ptrVector[i]; if (obj->ContainsForwardingPtr()) obj->SetLengthWord(obj->GetForwardingPtr()->LengthWord()); } } // This class is used in two places and is called to ensure that all // object length words have been restored. // Before we actually try to share the immutable objects at a particular depth it // is called to update addresses in those objects to take account of // sharing at lower depths. // When all sharing is complete it is called to update the addresses in // level zero objects, i.e. mutables and code. class ProcessFixupAddress: public ScanAddress { protected: virtual POLYUNSIGNED ScanAddressAt(PolyWord *pt); virtual POLYUNSIGNED ScanCodeAddressAt(PolyObject **pt); virtual PolyObject *ScanObjectAddress(PolyObject *base) { return GetNewAddress(base).AsObjPtr(); } PolyWord GetNewAddress(PolyWord old); }; POLYUNSIGNED ProcessFixupAddress::ScanAddressAt(PolyWord *pt) { *pt = GetNewAddress(*pt); return 0; } // Don't have to do anything for code since it isn't moved. POLYUNSIGNED ProcessFixupAddress::ScanCodeAddressAt(PolyObject **pt) { return 0; } // Returns the new address if the argument is the address of an object that // has moved, otherwise returns the original. PolyWord ProcessFixupAddress::GetNewAddress(PolyWord old) { if (old.IsTagged() || old == PolyWord::FromUnsigned(0)) return old; // Nothing to do. ASSERT(old.IsDataPtr()); PolyObject *obj = old.AsObjPtr(); POLYUNSIGNED L = obj->LengthWord(); if (obj->ContainsForwardingPtr()) // tombstone is a pointer to a shared object { PolyObject *newp = obj->GetForwardingPtr(); // ASSERT (newp->ContainsNormalLengthWord()); return newp; } // Generally each address will point to an object processed at a lower depth. // The exception is if we have a cycle and have assigned the rest of the // structure to a higher depth. // N.B. We return the original address here but this could actually share // with something else and not be retained. if (OBJ_IS_DEPTH(L)) return old; ASSERT (obj->ContainsNormalLengthWord()); // object is not shared return old; } // This class is used to set up the depth vectors for sorting. It subclasses ScanAddress // in order to be able to use that for code objects since they are complicated but it // handles all the other object types itself. It scans them depth-first using an explicit stack. class ProcessAddToVector: public ScanAddress { public: ProcessAddToVector(ShareDataClass *p): m_parent(p), addStack(0), stackSize(0), asp(0) {} ~ProcessAddToVector(); // These are used when scanning code areas. They return either // a length or a possibly updated address. virtual POLYUNSIGNED ScanAddressAt(PolyWord *pt) { (void)AddPolyWordToDepthVectors(*pt); return 0; } virtual PolyObject *ScanObjectAddress(PolyObject *base) { (void)AddObjectToDepthVector(base); return base; } void ProcessRoot(PolyObject *root); protected: // Process an address and return the "depth". POLYUNSIGNED AddPolyWordToDepthVectors(PolyWord old); POLYUNSIGNED AddObjectToDepthVector(PolyObject *obj); void PushToStack(PolyObject *obj); ShareDataClass *m_parent; PolyObject **addStack; unsigned stackSize; unsigned asp; }; ProcessAddToVector::~ProcessAddToVector() { // Normally the stack will be empty. However if we have run out of // memory and thrown an exception we may well have items left. // We have to remove the mark bits otherwise it will mess up any // subsequent GC. for (unsigned i = 0; i < asp; i++) { PolyObject *obj = addStack[i]; if (obj->LengthWord() & _OBJ_GC_MARK) obj->SetLengthWord(obj->LengthWord() & (~_OBJ_GC_MARK)); } free(addStack); // Now free the stack } POLYUNSIGNED ProcessAddToVector::AddPolyWordToDepthVectors(PolyWord old) { // If this is a tagged integer or an IO pointer that's simply a constant. if (old.IsTagged() || old == PolyWord::FromUnsigned(0)) return 0; return AddObjectToDepthVector(old.AsObjPtr()); } // Either adds an object to the stack or, if its depth is known, adds it // to the depth vector and returns the depth. // We use _OBJ_GC_MARK to detect when we have visited a cell but not yet // computed the depth. We have to be careful that this bit is removed // before we finish in the case that we run out of memory and throw an // exception. PushToStack may throw the exception if the stack needs to // grow. POLYUNSIGNED ProcessAddToVector::AddObjectToDepthVector(PolyObject *obj) { MemSpace *space = gMem.SpaceForAddress(((PolyWord*)obj)-1); if (space == 0) return 0; POLYUNSIGNED L = obj->LengthWord(); if (OBJ_IS_DEPTH(L)) // tombstone contains genuine depth or 0. return OBJ_GET_DEPTH(L); if (obj->LengthWord() & _OBJ_GC_MARK) return 0; // Marked but not yet scanned. Circular structure. ASSERT (OBJ_IS_LENGTH(L)); if (obj->IsMutable()) { // Mutable data in the local or permanent areas. Ignore byte objects or // word objects containing only ints. if (obj->IsWordObject()) { bool containsAddress = false; for (POLYUNSIGNED j = 0; j < OBJ_OBJECT_LENGTH(L) && !containsAddress; j++) containsAddress = ! obj->Get(j).IsTagged(); if (containsAddress) { // Add it to the vector so we will update any addresses it contains. m_parent->AddToVector(0, L, obj); // and follow any addresses to try to merge those. PushToStack(obj); obj->SetLengthWord(L | _OBJ_GC_MARK); // To prevent rescan } // If we don't add it to the vector we mustn't set _OBJ_GC_MARK. } return 0; // Level is zero } if (space->spaceType == ST_PERMANENT && ((PermanentMemSpace*)space)->hierarchy == 0) { // Immutable data in the permanent area can't be merged // because it's read only. We need to follow the addresses // because they may point to mutable areas containing data // that can be. A typical case is the root function pointing // at the global name table containing new declarations. Bitmap *bm = &((PermanentMemSpace*)space)->shareBitmap; if (! bm->TestBit((PolyWord*)obj - space->bottom)) { bm->SetBit((PolyWord*)obj - space->bottom); if (! obj->IsByteObject()) PushToStack(obj); } return 0; } /* There's a problem sharing code objects if they have relative calls/jumps in them to other code. The code of two functions may be identical (e.g. they both call functions 100 bytes ahead) and so they will appear the same but if the functions they jump to are different they are actually different. For that reason we don't share code segments. DCJM 4/1/01 */ if (obj->IsCodeObject()) { // We want to update addresses in the code segment. m_parent->AddToVector(0, L, obj); PushToStack(obj); obj->SetLengthWord(L | _OBJ_GC_MARK); // To prevent rescan return 0; } // Byte objects always have depth 1 and can't contain addresses. if (obj->IsByteObject()) { m_parent->AddToVector (1, L, obj);// add to vector at correct depth obj->SetLengthWord(OBJ_SET_DEPTH(1)); return 1; } ASSERT(OBJ_IS_WORD_OBJECT(L) || OBJ_IS_CLOSURE_OBJECT(L)); // That leaves immutable data objects. PushToStack(obj); obj->SetLengthWord(L | _OBJ_GC_MARK); // To prevent rescan return 0; } // Adds an object to the stack. void ProcessAddToVector::PushToStack(PolyObject *obj) { if (asp == stackSize) { if (addStack == 0) { addStack = (PolyObject**)malloc(sizeof(PolyObject*) * 100); if (addStack == 0) throw MemoryException(); stackSize = 100; } else { unsigned newSize = stackSize+100; PolyObject** newStack = (PolyObject**)realloc(addStack, sizeof(PolyObject*) * newSize); if (newStack == 0) throw MemoryException(); stackSize = newSize; addStack = newStack; } } ASSERT(asp < stackSize); addStack[asp++] = obj; } // Processes the root and anything reachable from it. Addresses are added to the // explicit stack if an object has not yet been processed. Most of this function // is about processing the stack. void ProcessAddToVector::ProcessRoot(PolyObject *root) { // Mark the initial object AddObjectToDepthVector(root); // Process the stack until it's empty. while (asp != 0) { // Pop it from the stack. PolyObject *obj = addStack[asp-1]; if (obj->IsCodeObject()) { // Code cells are now only found in the code area. /* There's a problem sharing code objects if they have relative calls/jumps in them to other code. The code of two functions may be identical (e.g. they both call functions 100 bytes ahead) and so they will appear the same but if the functions they jump to are different they are actually different. For that reason we don't share code segments. DCJM 4/1/01 */ asp--; // Pop it because we'll process it completely ScanAddressesInObject(obj); // If it's local set the depth with the value zero. It has already been // added to the zero depth vector. if (obj->LengthWord() & _OBJ_GC_MARK) obj->SetLengthWord(OBJ_SET_DEPTH(0)); // Now scanned } else { POLYUNSIGNED length = obj->Length(); PolyWord *pt = (PolyWord*)obj; unsigned osp = asp; if (obj->IsClosureObject()) { // The first word of a closure is a code pointer. We don't share code but // we do want to share anything reachable from the constants. AddObjectToDepthVector(*(PolyObject**)pt); pt += sizeof(PolyObject*) / sizeof(PolyWord); length -= sizeof(PolyObject*) / sizeof(PolyWord); } if (((obj->LengthWord() & _OBJ_GC_MARK) && !obj->IsMutable())) { // Immutable local objects. These can be shared. We need to compute the // depth by computing the maximum of the depth of all the addresses in it. POLYUNSIGNED depth = 0; while (length != 0 && osp == asp) { POLYUNSIGNED d = AddPolyWordToDepthVectors(*pt); if (d > depth) depth = d; pt++; length--; } if (osp == asp) { // We've finished it asp--; // Pop this item. depth++; // One more for this object obj->SetLengthWord(obj->LengthWord() & (~_OBJ_GC_MARK)); m_parent->AddToVector(depth, obj->LengthWord() & (~_OBJ_GC_MARK), obj); obj->SetLengthWord(OBJ_SET_DEPTH(depth)); } } else { // Mutable or non-local objects. These have depth zero. Local objects have // _OBJ_GC_MARK in their header. Immutable permanent objects cannot be // modified so we don't set the depth. Mutable objects are added to the // depth vectors even though they aren't shared so that they will be // updated if they point to immutables that have been shared. while (length != 0) { if (!(*pt).IsTagged()) { // If we've already pushed an address break now if (osp != asp) break; // Process the address and possibly push it AddPolyWordToDepthVectors(*pt); } pt++; length--; } if (length == 0) { // We've finished it if (osp != asp) { ASSERT(osp == asp - 1); addStack[osp - 1] = addStack[osp]; } asp--; // Pop this item. if (obj->LengthWord() & _OBJ_GC_MARK) obj->SetLengthWord(OBJ_SET_DEPTH(0)); } } } } } // This is called by the root thread to do the work. bool ShareDataClass::RunShareData(PolyObject *root) { // We use a bitmap to indicate when we've visited an object to avoid // infinite recursion in cycles in the data. for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { PermanentMemSpace *space = *i; if (!space->isMutable && space->hierarchy == 0) { if (! space->shareBitmap.Create(space->spaceSize())) return false; } } POLYUNSIGNED totalObjects = 0; POLYUNSIGNED totalShared = 0; // Build the vectors from the immutable objects. bool success = true; try { ProcessAddToVector addToVector(this); addToVector.ProcessRoot(root); } catch (MemoryException &) { // If we ran out of memory we may still be able to process what we have. // That will also do any clean-up. success = false; } ProcessFixupAddress fixup; for (POLYUNSIGNED depth = 1; depth < maxVectorSize; depth++) { for (unsigned j = 0; j < FIXEDLENGTHSIZE; j++) { if (depth < depthVectorArray[j].vectorSize) { DepthVector *vec = depthVectorArray[j].vector[depth]; // Set the length word and update all addresses. vec->FixLengthAndAddresses(&fixup); vec->Sort(); POLYUNSIGNED n = vec->MergeSameItems(); if ((debugOptions & DEBUG_SHARING) && n > 0) Log("Sharing: Level %4" POLYUFMT ", size %3u, Objects %6" POLYUFMT ", Shared %6" POLYUFMT " (%1.0f%%)\n", depth, j, vec->ItemCount(), n, (float)n / (float)vec->ItemCount() * 100.0); totalObjects += vec->ItemCount(); totalShared += n; } } } if (debugOptions & DEBUG_SHARING) Log("Sharing: Maximum level %4" POLYUFMT ",\n", maxVectorSize); /* At this stage, we have fixed up most but not all of the forwarding pointers. The ones that we haven't fixed up arise from situations such as the following: X -> Y <-> Z i.e. Y and Z form a loop, and X is isomorphic to Z. When we assigned the depths, we have to arbitrarily break the loop between Y and Z. Suppose Y is assigned to level 1, and Z is assigned to level 2. When we process level 1 and fixup Y, there's nothing to do, since Z is still an ordinary object. However when we process level 2, we find that X and Z are isomorphic so we arbitrarily choose one of them and turn it into a "tombstone" pointing at the other. If we change Z into the tombstone, then Y now contains a pointer that needs fixing up. That's why we need the second fixup pass. Note also that if we had broken the loop the other way, we would have assigned Z to level 1, Y to level 2 and X to level 3, so we would have missed the chance to share Z and X. Perhaps that's why running the program repeatedly sometimes finds extra things to share? SPF 26/1/95 */ /* We have updated the addresses in objects with non-zero level so they point to the single occurrence but we need to do the same with level 0 objects (mutables and code). */ for (unsigned j = 0; j < FIXEDLENGTHSIZE; j++) { if (depthVectorArray[j].vectorSize > 0) { DepthVector *v = depthVectorArray[j].vector[0]; // Log this because it could be very large. if (debugOptions & DEBUG_SHARING) Log("Sharing: Level %4" POLYUFMT ", size %3u, Objects %6" POLYUFMT "\n", 0ul, j, v->ItemCount()); v->FixLengthAndAddresses(&fixup); } } /* Previously we made a complete scan over the memory updating any addresses so that if we have shared two substructures within our root we would also share any external pointers. This has been removed but we have to reinstate the length words we've overwritten with forwarding pointers because there may be references to unshared objects from outside. */ for (POLYUNSIGNED d = 1; d < maxVectorSize; d++) { for (unsigned j = 0; j < FIXEDLENGTHSIZE; j++) { if (d < depthVectorArray[j].vectorSize) { DepthVector *v = depthVectorArray[j].vector[d]; v->RestoreForwardingPointers(); } } } if (debugOptions & DEBUG_SHARING) Log ("Sharing: Total Objects %6" POLYUFMT ", Total Shared %6" POLYUFMT " (%1.0f%%)\n", totalObjects, totalShared, (float)totalShared / (float)totalObjects * 100.0); return success; // Succeeded. } class ShareRequest: public MainThreadRequest { public: ShareRequest(Handle root): MainThreadRequest(MTP_SHARING), shareRoot(root), result(false) {} virtual void Perform() { ShareDataClass s; // Do a full GC. If we have a large heap the allocation of the vectors // can cause paging. Doing this now reduces the heap and discards the // allocation spaces. It may be overkill if we are applying the sharing // to a small root but generally it seems to be applied to the whole heap. FullGCForShareCommonData(); // Now do the sharing. result = s.RunShareData(shareRoot->WordP()); } Handle shareRoot; bool result; }; // ShareData. This is the main entry point. // Because this can recurse deeply it needs to be run by the main thread. // Also it manipulates the heap in ways that could mess up other threads // so we need to stop them before executing this. void ShareData(TaskData *taskData, Handle root) { if (! root->Word().IsDataPtr()) return; // Nothing to do. We could do handle a code pointer but it shouldn't occur. // Request the main thread to do the sharing. ShareRequest request(root); processes->MakeRootRequest(taskData, &request); // Raise an exception if it failed. if (! request.result) raise_exception_string(taskData, EXC_Fail, "Insufficient memory"); } // RTS call entry. -POLYUNSIGNED PolyShareCommonData(PolyObject *threadId, PolyWord root) +POLYUNSIGNED PolyShareCommonData(FirstArgument threadId, PolyWord root) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { if (! root.IsDataPtr()) return TAGGED(0).AsUnsigned(); // Nothing to do. // Request the main thread to do the sharing. ShareRequest request(taskData->saveVec.push(root)); processes->MakeRootRequest(taskData, &request); // Raise an exception if it failed. if (! request.result) raise_exception_string(taskData, EXC_Fail, "Insufficient memory"); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } struct _entrypts shareDataEPT[] = { { "PolyShareCommonData", (polyRTSFunction)&PolyShareCommonData}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/sighandler.cpp b/libpolyml/sighandler.cpp index bc2079a0..cdd22262 100644 --- a/libpolyml/sighandler.cpp +++ b/libpolyml/sighandler.cpp @@ -1,579 +1,579 @@ /* Title: Signal handling Author: David C.J. Matthews Copyright (c) 2000-8, 2016, 2019 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SIGNAL_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_IO_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_STDLIB_H #include // For malloc #endif #if (defined(HAVE_SEMAPHORE_H) && !defined(_WIN32)) // Don't include semaphore.h on Mingw. It's provided but doesn't compile. #include #endif #if (defined(_WIN32)) #define INVALIDSIGNAL ERROR_INVALID_PARAMETER #else #define INVALIDSIGNAL EINVAL #endif /* Signal handling is complicated in a multi-threaded environment. The pthread mutex and condition variables are not safe to use in a signal handler so we need to use POSIX semaphores since sem_post is safe. */ #if (defined(HAVE_STACK_T) && defined(HAVE_SIGALTSTACK)) extern "C" { // This is missing in older versions of Mac OS X int sigaltstack(const stack_t *, stack_t *); } #endif #include "globals.h" #include "arb.h" #include "run_time.h" #include "sighandler.h" #include "processes.h" #include "machine_dep.h" #include "sys.h" #include "save_vec.h" #include "rts_module.h" #include "gc.h" // For convertedWeak #include "scanaddrs.h" #include "locking.h" #include "rtsentry.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolySetSignalHandler(PolyObject *threadId, PolyWord signalNo, PolyWord action); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyWaitForSignal(PolyObject *threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolySetSignalHandler(FirstArgument threadId, PolyWord signalNo, PolyWord action); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWaitForSignal(FirstArgument threadId); } #define SAVE(x) taskData->saveVec.push(x) #define SIZEOF(x) (sizeof(x)/sizeof(word)) #define DEFAULT_SIG 0 #define IGNORE_SIG 1 #define HANDLE_SIG 2 // This is only used in SignalRequest static struct _sigData { bool nonMaskable; // True if this sig is used within the RTS. Must not be ignored or replaced PolyWord handler; // User-installed handler, TAGGED(DEFAULT_SIG) or TAGGED(IGNORE_SIG) int signalCount; } sigData[NSIG]; unsigned receivedSignalCount = 0; // Incremented each time we get a signal // sigLock protects access to the signalCount values in sigData but // not the "handler" field. static PLock sigLock; #if (!defined(_WIN32)) static PSemaphore *waitSema; static int lastSignals[NSIG]; static bool terminate = false; #endif // This must not be called from an asynchronous signal handler. static void signalArrived(int sig) { sigLock.Lock(); receivedSignalCount++; sigData[sig].signalCount++; sigLock.Unlock(); // To avoid deadlock we must release sigLock first. processes->SignalArrived(); } // Called whenever a signal handler is installed other than in this // module. Because modules are initialised in an unspecified order // we may have already masked off this signal. void markSignalInuse(int sig) { sigData[sig].nonMaskable = true; #if (!defined(_WIN32)) // Enable this signal. sigset_t sigset; sigemptyset(&sigset); sigaddset(&sigset, sig); pthread_sigmask(SIG_UNBLOCK, &sigset, NULL); #endif } /* Find the existing handler for this signal. */ static PolyWord findHandler(int sig) { if ((unsigned)sig >= NSIG) // Check it's in range. return TAGGED(DEFAULT_SIG); /* Not there - default action. */ else return sigData[sig].handler; } #if (defined(_WIN32) && ! defined(__CYGWIN__)) // This is called to simulate a SIGINT in Windows. void RequestConsoleInterrupt(void) { // The default action for SIGINT is to exit. if (findHandler(SIGINT) == TAGGED(DEFAULT_SIG)) processes->RequestProcessExit(2); // Exit with the signal value. else signalArrived(SIGINT); } #endif #if (!defined(_WIN32)) // Request the main thread to change the blocking state of a signal. class SignalRequest: public MainThreadRequest { public: SignalRequest(int s, int r): MainThreadRequest(MTP_SIGHANDLER), signl(s), state(r) {} virtual void Perform(); int signl, state; }; // Called whenever a signal is received. static void handle_signal(SIG_HANDLER_ARGS(s, c)) { if (waitSema != 0) { lastSignals[s]++; // Assume this is atomic with respect to reading. // Wake the signal detection thread. waitSema->Signal(); } } void SignalRequest::Perform() { struct sigaction action; memset(&action, 0, sizeof(action)); switch (state) { case DEFAULT_SIG: action.sa_handler = SIG_DFL; sigaction(signl, &action, 0); break; case IGNORE_SIG: action.sa_handler = SIG_IGN; sigaction(signl, &action, 0); break; case HANDLE_SIG: setSignalHandler(signl, handle_signal); break; } } #endif static Handle waitForSignal(TaskData *taskData) { while (true) { processes->ProcessAsynchRequests(taskData); // Check for kill. sigLock.Lock(); // Any pending signals? for (int sig = 0; sig < NSIG; sig++) { if (sigData[sig].signalCount > 0) { sigData[sig].signalCount--; if (!IS_INT(findHandler(sig))) /* If it's not DEFAULT or IGNORE. */ { // Create a pair of the handler and signal and pass // them back to be run. Handle pair = alloc_and_save(taskData, 2); // Have to call findHandler again here because that // allocation could have garbage collected. DEREFHANDLE(pair)->Set(0, findHandler(sig)); DEREFHANDLE(pair)->Set(1, TAGGED(sig)); sigLock.Unlock(); return pair; } } } if (convertedWeak) { // Last GC converted a weak SOME into NONE. This isn't // anything to do with signals but the signal thread can // deal with this. sigLock.Unlock(); convertedWeak = false; return SAVE(TAGGED(0)); } // No pending signal. Wait until we're woken up. // This releases sigLock after acquiring schedLock. if (! processes->WaitForSignal(taskData, &sigLock)) raise_exception_string(taskData, EXC_Fail, "Only one thread may wait for signals"); } } -POLYUNSIGNED PolySetSignalHandler(PolyObject *threadId, PolyWord signalNo, PolyWord action) +POLYUNSIGNED PolySetSignalHandler(FirstArgument threadId, PolyWord signalNo, PolyWord action) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedAction = taskData->saveVec.push(action); Handle oldaction = 0; try { { int sign; int action; { // Lock while we look at the signal vector but release // it before making a root request. PLocker locker(&sigLock); // We have to pass this to the main thread to // set up the signal handler. sign = get_C_int(taskData, signalNo); /* Decode the action if it is Ignore or Default. */ if (pushedAction->Word().IsTagged()) action = (int)pushedAction->Word().UnTagged(); else action = HANDLE_SIG; /* Set the handler. */ if (sign <= 0 || sign >= NSIG) raise_syscall(taskData, "Invalid signal value", INVALIDSIGNAL); /* Get the old action before updating the vector. */ oldaction = SAVE(findHandler(sign)); // Now update it. sigData[sign].handler = pushedAction->Word(); } // Request a change in the masking by the root thread. // This doesn't do anything in Windows so the only "signal" // we affect is SIGINT and that is handled by RequestConsoleInterrupt. if (! sigData[sign].nonMaskable) { #if (!defined(_WIN32)) SignalRequest request(sign, action); processes->MakeRootRequest(taskData, &request); #endif } } } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (oldaction == 0) return TAGGED(0).AsUnsigned(); else return oldaction->Word().AsUnsigned(); } // Called by the signal handler thread. Blocks until a signal is available. -POLYUNSIGNED PolyWaitForSignal(PolyObject *threadId) +POLYUNSIGNED PolyWaitForSignal(FirstArgument threadId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = waitForSignal(taskData); } catch (KillException &) { processes->ThreadExit(taskData); // May test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Set up per-thread signal data: basically signal stack. // This is really only needed for profiling timer signals. void initThreadSignals(TaskData *taskData) { #if (!(defined(_WIN32)||defined(MACOSX))) // On the i386, at least, we need to set up a signal stack for // each thread if it might receive a signal. ML code checks for // stack overflow but a signal could result in C code being // executed on the ML stack. The signal stack avoids this. // On some architectures the C stack pointer is left unused // when executing ML code so this isn't a problem. // In Linux each thread can receive a SIGVTALRM signal when // profiling. // This is currently disabled in Mac OS X. In 10.4 and before // setting a signal stack in a thread seemed to set it for the // whole process and crash with an illegal instruction on the // second signal. This isn't currently a problem since only the // main thread receives signals in Mac OS X. #if (defined(SA_ONSTACK) && defined(HAVE_SIGALTSTACK)) taskData->signalStack = malloc(SIGSTKSZ); #ifdef HAVE_STACK_T stack_t ex_stack; #else // This used to be used in FreeBSD and Mac OS X struct sigaltstack ex_stack; #endif memset(&ex_stack, 0, sizeof(ex_stack)); // Cast to char* because ss_sp is char* in FreeBSD. // Linux simply casts it back to void*. ex_stack.ss_sp = (char*)taskData->signalStack; ex_stack.ss_size = SIGSTKSZ; ex_stack.ss_flags = 0; /* not SS_DISABLE */ int sigaltstack_result = sigaltstack(&ex_stack, NULL); ASSERT(sigaltstack_result == 0); #endif #endif /* not the PC */ #if (!defined(_WIN32)) // Block all signals except those marked as in use by the RTS so // that they will only be picked up by the signal detection thread. // Since the signal mask is inherited we really don't need to do // this for every thread, just the initial one. sigset_t sigset; sigfillset(&sigset); for (int i = 0; i < NSIG; i++) { if (sigData[i].nonMaskable) sigdelset(&sigset, i); } pthread_sigmask(SIG_SETMASK, &sigset, NULL); #endif } /* General purpose function to set up a signal handler. */ #if (!defined(_WIN32)) bool setSignalHandler(int sig, signal_handler_type func) { struct sigaction sigcatch; memset(&sigcatch, 0, sizeof(sigcatch)); sigcatch.sa_sigaction = func; /* Both Linux and FreeBSD now use SA_SIGINFO in a similar way. If SA_SIGINFO is set the handler is supposed to be in sa_sigaction rather than sa_handler (actually this is a union so they're in the same place). */ init_asyncmask(&sigcatch.sa_mask); sigcatch.sa_flags = 0; #if defined(SA_ONSTACK) && defined(HAVE_SIGALTSTACK) sigcatch.sa_flags |= SA_ONSTACK; #endif #ifdef SA_RESTART sigcatch.sa_flags |= SA_RESTART; #endif #ifdef SA_SIGINFO sigcatch.sa_flags |= SA_SIGINFO; #endif #ifdef SV_SAVE_REGS sigcatch.sa_flags |= SV_SAVE_REGS; #endif return sigaction(sig, &sigcatch,NULL) >= 0; } // Signals to mask off when handling a signal. The signal being handled // is always masked off. This really only applied when emulation traps // and requests to GC involved signals. That no longer applies except // on the Sparc. void init_asyncmask(sigset_t *mask) { /* disable asynchronous interrupts while servicing interrupt */ sigemptyset(mask); sigaddset(mask,SIGVTALRM); sigaddset(mask,SIGINT); sigaddset(mask,SIGUSR2); sigaddset(mask,SIGWINCH); // This next used to be needed when emulation traps resulted in // signals. This no longer applies except on the Sparc. #ifdef SPARC sigaddset(mask,SIGILL); sigaddset(mask,SIGFPE); /* Mask off SIGSEGV. This is definitely needed when we are installing a handler for SIGINT under Linux and may also be needed in other cases as well e.g. SIGVTALRM. Without it typing control-C to a program which is taking lots of emulation traps can cause a crash because the signals are delivered in the "wrong" order and the pc value given to catchSEGV can point at the handler for SIGINT. DCJM 7/2/01. */ sigaddset(mask,SIGSEGV); /* And, just to be sure, include SIGBUS. DCJM 22/5/02. */ sigaddset(mask,SIGBUS); #endif } #endif struct _entrypts sigHandlerEPT[] = { { "PolySetSignalHandler", (polyRTSFunction)&PolySetSignalHandler}, { "PolyWaitForSignal", (polyRTSFunction)&PolyWaitForSignal}, { NULL, NULL} // End of list. }; class SigHandler: public RtsModule { public: virtual void Init(void); virtual void Stop(void); virtual void GarbageCollect(ScanAddress * /*process*/); #if (!defined(_WIN32)) SigHandler() { threadRunning = false; } pthread_t detectionThreadId; bool threadRunning; #endif }; // Declare this. It will be automatically added to the table. static SigHandler sighandlerModule; #if (!defined(_WIN32)) // This thread is really only to convert between POSIX semaphores and // pthread condition variables. It waits for a semphore to be released by the // signal handler running on the main thread and then wakes up the ML handler // thread. The ML thread must not wait directly on a POSIX semaphore because it // may also be woken by other events, particularly a kill request when the program // exits. static void *SignalDetectionThread(void *) { // Block all signals so they will be delivered to the main thread. sigset_t active_signals; sigfillset(&active_signals); pthread_sigmask(SIG_SETMASK, &active_signals, NULL); int readSignals[NSIG] = {0}; while (true) { if (waitSema == 0) return 0; // Wait until we are woken up by an arriving signal. // waitSema will be incremented for each signal so we should // not block until we have processed them all. if (! waitSema->Wait() || terminate) return 0; for (int j = 1; j < NSIG; j++) { if (readSignals[j] < lastSignals[j]) { readSignals[j]++; signalArrived(j); } } } } #endif void SigHandler::Init(void) { // Mark certain signals as non-maskable since they really // indicate a fatal error. #ifdef SIGSEGV sigData[SIGSEGV].nonMaskable = true; #endif #ifdef SIGBUS sigData[SIGBUS].nonMaskable = true; #endif #ifdef SIGILL sigData[SIGILL].nonMaskable = true; #endif #if (!defined(_WIN32)) static PSemaphore waitSemaphore; // Initialise the "wait" semaphore so that it blocks immediately. if (! waitSemaphore.Init(0, NSIG)) return; waitSema = &waitSemaphore; // Create a new thread to handle signals synchronously. // for it to finish. pthread_attr_t attrs; pthread_attr_init(&attrs); #ifdef PTHREAD_STACK_MIN #if (PTHREAD_STACK_MIN < 4096) pthread_attr_setstacksize(&attrs, 4096); // But not too small: FreeBSD makes it 2k #else pthread_attr_setstacksize(&attrs, PTHREAD_STACK_MIN); // Only small stack. #endif #endif threadRunning = pthread_create(&detectionThreadId, &attrs, SignalDetectionThread, 0) == 0; pthread_attr_destroy(&attrs); #endif } // Wait for the signal thread to finish before the semaphore is deleted in the // final clean-up. Failing to do this causes a hang in Mac OS X. void SigHandler::Stop(void) { #if (!defined(_WIN32)) terminate = true; waitSema->Signal(); pthread_join(detectionThreadId, NULL); #endif } void SigHandler::GarbageCollect(ScanAddress *process) { for (unsigned i = 0; i < NSIG; i++) { if (sigData[i].handler != PolyWord::FromUnsigned(0)) process->ScanRuntimeWord(&sigData[i].handler); } } diff --git a/libpolyml/timing.cpp b/libpolyml/timing.cpp index 2bd13a97..5af9210f 100644 --- a/libpolyml/timing.cpp +++ b/libpolyml/timing.cpp @@ -1,599 +1,811 @@ /* Title: Time functions. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000 Cambridge University Technical Services Limited - Further development copyright David C.J. Matthews 2011,12,16 + Further development copyright David C.J. Matthews 2011,12,16,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 */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_LOCALE_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_TIME_H #include #endif #ifdef HAVE_SYS_TIMES_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_SYS_RESOURCE_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_STAT_H #include #endif #ifdef HAVE_SYS_SIGNAL_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_LIMITS_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_WINDOWS_H #include #endif #include // Windows headers define min/max macros, which messes up trying to use std::numeric_limits::min/max() #ifdef min #undef min #endif #ifdef max #undef max #endif #include "locking.h" #include "globals.h" #include "arb.h" #include "run_time.h" #include "sys.h" #include "timing.h" #include "polystring.h" #include "save_vec.h" #include "rts_module.h" #include "processes.h" #include "heapsizing.h" #include "rtsentry.h" #include "mpoly.h" // For polyStderr extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingTicksPerMicroSec(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetNow(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingBaseYear(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingYearOffset(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingLocalOffset(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingSummerApplies(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingConvertDateStuct(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetUser(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetSystem(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetGCUser(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetReal(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetChildUser(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetChildSystem(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetGCSystem(FirstArgument threadId); } #if (defined(_WIN32)) /* Windows file times are 64-bit numbers representing times in tenths of a microsecond. */ #define TICKS_PER_MICROSECOND 10 #ifdef __GNUC__ #define SECSSINCE1601 11644473600LL #else #define SECSSINCE1601 11644473600 #endif #else /* For Unix return times in microseconds. */ #define TICKS_PER_MICROSECOND 1 #endif /* The original Poly timing functions used a variety of timing bases (e.g. seconds, tenths of a second). The old functions have been retained but the intention is to phase them out in favour of new functions. Most of these are handled through the timing_dispatch function. The intention behind the timing functions is to make use of the arbitrary precision arithmetic to allow for a wider range of dates than the usual mktime range of 1970 to 2036. We also want to handle more accurate timing than per second or per microsecond where the operating system provides it. */ #if (defined(_WIN32)) static FILETIME startTime; #define StrToLL _strtoi64 #else static struct timeval startTime; #define StrToLL strtoll #endif #if(!(defined(HAVE_GMTIME_R) && defined(HAVE_LOCALTIME_R))) // gmtime and localtime are not re-entrant so if we don't have the // re-entrant versions we need to use a lock. static PLock timeLock("Timing"); #endif #define XSTR(X) STR(X) #define STR(X) #X -static Handle timing_dispatch_c(TaskData *taskData, Handle args, Handle code) + +// Get ticks per microsecond. +POLYUNSIGNED PolyTimingTicksPerMicroSec(FirstArgument threadId) { - unsigned c = get_C_unsigned(taskData, code->Word()); - switch (c) - { - case 0: /* Get ticks per microsecond. */ - return Make_arbitrary_precision(taskData, TICKS_PER_MICROSECOND); - case 1: /* Return time since the time base. */ - { + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + result = Make_arbitrary_precision(taskData, TICKS_PER_MICROSECOND); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Return time since the time base. */ +POLYUNSIGNED PolyTimingGetNow(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { #if (defined(_WIN32)) - FILETIME ft; - GetSystemTimeAsFileTime(&ft); - return Make_arb_from_Filetime(taskData, ft); + FILETIME ft; + GetSystemTimeAsFileTime(&ft); + result = Make_arb_from_Filetime(taskData, ft); #else - struct timeval tv; - if (gettimeofday(&tv, NULL) != 0) - raise_syscall(taskData, "gettimeofday failed", errno); - return Make_arb_from_pair_scaled(taskData, tv.tv_sec, tv.tv_usec, 1000000); + struct timeval tv; + if (gettimeofday(&tv, NULL) != 0) + raise_syscall(taskData, "gettimeofday failed", errno); + result = Make_arb_from_pair_scaled(taskData, tv.tv_sec, tv.tv_usec, 1000000); #endif - } - case 2: /* Return the base year. This is the year which corresponds to - zero in the timing sequence. */ + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Return the base year. This is the year which corresponds to zero in the timing sequence. */ +POLYUNSIGNED PolyTimingBaseYear(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { #if (defined(_WIN32)) - return Make_arbitrary_precision(taskData, 1601); + result = Make_arbitrary_precision(taskData, 1601); + #else - return Make_arbitrary_precision(taskData, 1970); + result = Make_arbitrary_precision(taskData, 1970); #endif + } + catch (...) {} // If an ML exception is raised - case 3: /* In both Windows and Unix the time base is 1st of January - in the base year. This function is provided just in case - we are running on a system with a different base. It - returns the number of seconds after 1st January of the - base year that corresponds to zero of the time base. */ - return Make_arbitrary_precision(taskData, 0); + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} - case 4: /* Return the time offset which applied/will apply at the - specified time (in seconds). */ - { - int localoff = 0; - time_t theTime; - int day = 0; +/* In both Windows and Unix the time base is 1st of January + in the base year. This function is provided just in case + we are running on a system with a different base. It + returns the number of seconds after 1st January of the + base year that corresponds to zero of the time base. */ +POLYUNSIGNED PolyTimingYearOffset(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + result = Make_arbitrary_precision(taskData, 0); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Return the time offset which applied/will apply at the specified time (in seconds). */ +POLYUNSIGNED PolyTimingLocalOffset(FirstArgument threadId, PolyWord arg) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle pushedArg = taskData->saveVec.push(arg); + Handle result = 0; + + try { + int localoff = 0; + time_t theTime; + int day = 0; #if (defined(HAVE_GMTIME_R) || defined(HAVE_LOCALTIME_R)) - struct tm result; + struct tm resultTime; #endif #if (defined(_WIN32)) - /* Although the offset is in seconds it is since 1601. */ - FILETIME ftSeconds; // Not really a file-time because it's a number of seconds. - getFileTimeFromArb(taskData, args, &ftSeconds); /* May raise exception. */ - ULARGE_INTEGER liTime; - liTime.HighPart = ftSeconds.dwHighDateTime; - liTime.LowPart = ftSeconds.dwLowDateTime; - theTime = (long)(liTime.QuadPart - SECSSINCE1601); + /* Although the offset is in seconds it is since 1601. */ + FILETIME ftSeconds; // Not really a file-time because it's a number of seconds. + getFileTimeFromArb(taskData, pushedArg, &ftSeconds); /* May raise exception. */ + ULARGE_INTEGER liTime; + liTime.HighPart = ftSeconds.dwHighDateTime; + liTime.LowPart = ftSeconds.dwLowDateTime; + theTime = (long)(liTime.QuadPart - SECSSINCE1601); #else - theTime = get_C_long(taskData, DEREFWORD(args)); /* May raise exception. */ + theTime = get_C_long(taskData, DEREFWORD(pushedArg)); /* May raise exception. */ #endif - { + { #ifdef HAVE_GMTIME_R - struct tm *loctime = gmtime_r(&theTime, &result); + struct tm* loctime = gmtime_r(&theTime, &resultTime); #else - PLocker lock(&timeLock); - struct tm *loctime = gmtime(&theTime); + PLocker lock(&timeLock); + struct tm* loctime = gmtime(&theTime); #endif - if (loctime == NULL) raise_exception0(taskData, EXC_size); - localoff = (loctime->tm_hour*60 + loctime->tm_min)*60 + loctime->tm_sec; - day = loctime->tm_yday; - } + if (loctime == NULL) raise_exception0(taskData, EXC_size); + localoff = (loctime->tm_hour * 60 + loctime->tm_min) * 60 + loctime->tm_sec; + day = loctime->tm_yday; + } - { + { #ifdef HAVE_LOCALTIME_R - struct tm *loctime = localtime_r(&theTime, &result); + struct tm* loctime = localtime_r(&theTime, &resultTime); #else - PLocker lock(&timeLock); - struct tm *loctime = localtime(&theTime); -#endif - if (loctime == NULL) raise_exception0(taskData, EXC_size); - localoff -= (loctime->tm_hour*60 + loctime->tm_min)*60 + loctime->tm_sec; - if (loctime->tm_yday != day) - { - // Different day - have to correct it. We can assume that there - // is at most one day to correct. - if (day == loctime->tm_yday+1 || (day == 0 && loctime->tm_yday >= 364)) - localoff += 24*60*60; - else localoff -= 24*60*60; - } - } - - return Make_arbitrary_precision(taskData, localoff); - } + PLocker lock(&timeLock); + struct tm* loctime = localtime(&theTime); +#endif + if (loctime == NULL) raise_exception0(taskData, EXC_size); + localoff -= (loctime->tm_hour * 60 + loctime->tm_min) * 60 + loctime->tm_sec; + if (loctime->tm_yday != day) + { + // Different day - have to correct it. We can assume that there + // is at most one day to correct. + if (day == loctime->tm_yday + 1 || (day == 0 && loctime->tm_yday >= 364)) + localoff += 24 * 60 * 60; + else localoff -= 24 * 60 * 60; + } + } + + result = Make_arbitrary_precision(taskData, localoff); + } + catch (...) {} // If an ML exception is raised - case 5: /* Find out if Summer Time (daylight saving) was/will be in effect. */ - { - time_t theTime; + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Find out if Summer Time (daylight saving) was/will be in effect. */ +POLYUNSIGNED PolyTimingSummerApplies(FirstArgument threadId, PolyWord arg) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle pushedArg = taskData->saveVec.push(arg); + Handle result = 0; + + try { + time_t theTime; #if (defined(_WIN32)) - FILETIME ftSeconds; // Not really a file-time because it's a number of seconds. - getFileTimeFromArb(taskData, args, &ftSeconds); /* May raise exception. */ - ULARGE_INTEGER liTime; - liTime.HighPart = ftSeconds.dwHighDateTime; - liTime.LowPart = ftSeconds.dwLowDateTime; - theTime = (long)(liTime.QuadPart - SECSSINCE1601); + FILETIME ftSeconds; // Not really a file-time because it's a number of seconds. + getFileTimeFromArb(taskData, pushedArg, &ftSeconds); /* May raise exception. */ + ULARGE_INTEGER liTime; + liTime.HighPart = ftSeconds.dwHighDateTime; + liTime.LowPart = ftSeconds.dwLowDateTime; + theTime = (long)(liTime.QuadPart - SECSSINCE1601); #else - theTime = get_C_long(taskData, DEREFWORD(args)); /* May raise exception. */ + theTime = get_C_long(taskData, DEREFWORD(pushedArg)); /* May raise exception. */ #endif - int isDst = 0; + int isDst = 0; #ifdef HAVE_LOCALTIME_R - struct tm result; - struct tm *loctime = localtime_r(&theTime, &result); - isDst = loctime->tm_isdst; + struct tm resultTime; + struct tm* loctime = localtime_r(&theTime, &resultTime); + isDst = loctime->tm_isdst; #else - { - PLocker lock(&timeLock); - struct tm *loctime = localtime(&theTime); - if (loctime == NULL) raise_exception0(taskData, EXC_size); - isDst = loctime->tm_isdst; - } -#endif - return Make_arbitrary_precision(taskData, isDst); + { + PLocker lock(&timeLock); + struct tm* loctime = localtime(&theTime); + if (loctime == NULL) raise_exception0(taskData, EXC_size); + isDst = loctime->tm_isdst; } +#endif + result = Make_arbitrary_precision(taskData, isDst); + } + catch (...) {} // If an ML exception is raised - case 6: /* Call strftime. It would be possible to do much of this in - ML except that it requires the current locale. */ - { - struct tm time; - char *format, buff[2048]; - Handle resString; - /* Get the format string. */ - format = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); - - /* Copy the time information. */ - time.tm_year = get_C_int(taskData, DEREFHANDLE(args)->Get(1)) - 1900; - time.tm_mon = get_C_int(taskData, DEREFHANDLE(args)->Get(2)); - time.tm_mday = get_C_int(taskData, DEREFHANDLE(args)->Get(3)); - time.tm_hour = get_C_int(taskData, DEREFHANDLE(args)->Get(4)); - time.tm_min = get_C_int(taskData, DEREFHANDLE(args)->Get(5)); - time.tm_sec = get_C_int(taskData, DEREFHANDLE(args)->Get(6)); - time.tm_wday = get_C_int(taskData, DEREFHANDLE(args)->Get(7)); - time.tm_yday = get_C_int(taskData, DEREFHANDLE(args)->Get(8)); - time.tm_isdst = get_C_int(taskData, DEREFHANDLE(args)->Get(9)); + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Call strftime. It would be possible to do much of this in ML except that it requires the current locale. */ +POLYUNSIGNED PolyTimingConvertDateStuct(FirstArgument threadId, PolyWord arg) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle pushedArg = taskData->saveVec.push(arg); + Handle result = 0; + + try { + struct tm time; + char* format, buff[2048]; + Handle resString; + /* Get the format string. */ + format = Poly_string_to_C_alloc(DEREFHANDLE(pushedArg)->Get(0)); + + /* Copy the time information. */ + time.tm_year = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(1)) - 1900; + time.tm_mon = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(2)); + time.tm_mday = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(3)); + time.tm_hour = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(4)); + time.tm_min = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(5)); + time.tm_sec = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(6)); + time.tm_wday = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(7)); + time.tm_yday = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(8)); + time.tm_isdst = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(9)); #if (defined(_WIN32)) - _tzset(); /* Make sure we set the current locale. */ + _tzset(); /* Make sure we set the current locale. */ #else - setlocale(LC_TIME, ""); -#endif - /* It would be better to dynamically allocate the string rather - than use a fixed size but Unix unlike Windows does not distinguish - between an error in the input and the buffer being too small. */ - if (strftime(buff, sizeof(buff), format, &time) <= 0) - { - /* Error */ - free(format); - raise_exception0(taskData, EXC_size); - } - resString = taskData->saveVec.push(C_string_to_Poly(taskData, buff)); + setlocale(LC_TIME, ""); +#endif + /* It would be better to dynamically allocate the string rather + than use a fixed size but Unix unlike Windows does not distinguish + between an error in the input and the buffer being too small. */ + if (strftime(buff, sizeof(buff), format, &time) <= 0) + { + /* Error */ free(format); - return resString; + raise_exception0(taskData, EXC_size); } + resString = taskData->saveVec.push(C_string_to_Poly(taskData, buff)); + free(format); + result = resString; + } + catch (...) {} // If an ML exception is raised - case 7: /* Return User CPU time since the start. */ - { + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Return User CPU time since the start. */ +POLYUNSIGNED PolyTimingGetUser(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { #if (defined(_WIN32)) - FILETIME ut, ct, et, kt; - if (! GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut)) - raise_syscall(taskData, "GetProcessTimes failed", GetLastError()); - return Make_arb_from_Filetime(taskData, ut); + FILETIME ut, ct, et, kt; + if (!GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut)) + raise_syscall(taskData, "GetProcessTimes failed", GetLastError()); + result = Make_arb_from_Filetime(taskData, ut); #else - struct rusage rusage; - if (getrusage(RUSAGE_SELF, &rusage) != 0) - raise_syscall(taskData, "getrusage failed", errno); - return Make_arb_from_pair_scaled(taskData, rusage.ru_utime.tv_sec, - rusage.ru_utime.tv_usec, 1000000); + struct rusage rusage; + if (getrusage(RUSAGE_SELF, &rusage) != 0) + raise_syscall(taskData, "getrusage failed", errno); + result = Make_arb_from_pair_scaled(taskData, rusage.ru_utime.tv_sec, + rusage.ru_utime.tv_usec, 1000000); #endif - } + } + catch (...) {} // If an ML exception is raised - case 8: /* Return System CPU time since the start. */ - { + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Return System CPU time since the start. */ +POLYUNSIGNED PolyTimingGetSystem(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { #if (defined(_WIN32)) - FILETIME ct, et, kt, ut; - if (! GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut)) - raise_syscall(taskData, "GetProcessTimes failed", GetLastError()); - return Make_arb_from_Filetime(taskData, kt); + FILETIME ct, et, kt, ut; + if (!GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut)) + raise_syscall(taskData, "GetProcessTimes failed", GetLastError()); + result = Make_arb_from_Filetime(taskData, kt); #else - struct rusage rusage; - if (getrusage(RUSAGE_SELF, &rusage) != 0) - raise_syscall(taskData, "getrusage failed", errno); - return Make_arb_from_pair_scaled(taskData, rusage.ru_stime.tv_sec, - rusage.ru_stime.tv_usec, 1000000); + struct rusage rusage; + if (getrusage(RUSAGE_SELF, &rusage) != 0) + raise_syscall(taskData, "getrusage failed", errno); + result = Make_arb_from_pair_scaled(taskData, rusage.ru_stime.tv_sec, + rusage.ru_stime.tv_usec, 1000000); #endif - } + } + catch (...) {} // If an ML exception is raised - case 9: /* Return GC time since the start. */ - return gHeapSizeParameters.getGCUtime(taskData); + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} - case 10: /* Return real time since the start. */ - { +/* Return GC time since the start. */ +POLYUNSIGNED PolyTimingGetGCUser(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + result = gHeapSizeParameters.getGCUtime(taskData); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Return real time since the start. */ +POLYUNSIGNED PolyTimingGetReal(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { #if (defined(_WIN32)) - FILETIME ft; - GetSystemTimeAsFileTime(&ft); - subFiletimes(&ft, &startTime); - return Make_arb_from_Filetime(taskData, ft); + FILETIME ft; + GetSystemTimeAsFileTime(&ft); + subFiletimes(&ft, &startTime); + result = Make_arb_from_Filetime(taskData, ft); #else - struct timeval tv; - if (gettimeofday(&tv, NULL) != 0) - raise_syscall(taskData, "gettimeofday failed", errno); - subTimevals(&tv, &startTime); - return Make_arb_from_pair_scaled(taskData, tv.tv_sec, tv.tv_usec, 1000000); + struct timeval tv; + if (gettimeofday(&tv, NULL) != 0) + raise_syscall(taskData, "gettimeofday failed", errno); + subTimevals(&tv, &startTime); + result = Make_arb_from_pair_scaled(taskData, tv.tv_sec, tv.tv_usec, 1000000); #endif - } + } + catch (...) {} // If an ML exception is raised - /* These next two are used only in the Posix structure. */ - case 11: /* Return User CPU time used by child processes. */ - { + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Return User CPU time used by child processes. (Posix only) */ +POLYUNSIGNED PolyTimingGetChildUser(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { #if (defined(_WIN32)) - return Make_arbitrary_precision(taskData, 0); + result = Make_arbitrary_precision(taskData, 0); #else - struct rusage rusage; - if (getrusage(RUSAGE_CHILDREN, &rusage) != 0) - raise_syscall(taskData, "getrusage failed", errno); - return Make_arb_from_pair_scaled(taskData, rusage.ru_utime.tv_sec, - rusage.ru_utime.tv_usec, 1000000); + struct rusage rusage; + if (getrusage(RUSAGE_CHILDREN, &rusage) != 0) + raise_syscall(taskData, "getrusage failed", errno); + result = Make_arb_from_pair_scaled(taskData, rusage.ru_utime.tv_sec, + rusage.ru_utime.tv_usec, 1000000); #endif - } + } + catch (...) {} // If an ML exception is raised - case 12: /* Return System CPU time used by child processes. */ - { + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Return System CPU time used by child processes. (Posix only) */ +POLYUNSIGNED PolyTimingGetChildSystem(FirstArgument threadId) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { #if (defined(_WIN32)) - return Make_arbitrary_precision(taskData, 0); + result = Make_arbitrary_precision(taskData, 0); #else - struct rusage rusage; - if (getrusage(RUSAGE_CHILDREN, &rusage) != 0) - raise_syscall(taskData, "getrusage failed", errno); - return Make_arb_from_pair_scaled(taskData, rusage.ru_stime.tv_sec, - rusage.ru_stime.tv_usec, 1000000); + struct rusage rusage; + if (getrusage(RUSAGE_CHILDREN, &rusage) != 0) + raise_syscall(taskData, "getrusage failed", errno); + result = Make_arb_from_pair_scaled(taskData, rusage.ru_stime.tv_sec, + rusage.ru_stime.tv_usec, 1000000); #endif - } - - case 13: /* Return GC system time since the start. */ - return gHeapSizeParameters.getGCStime(taskData); - - default: - { - char msg[100]; - sprintf(msg, "Unknown timing function: %d", c); - raise_exception_string(taskData, EXC_Fail, msg); - return 0; - } } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); } -// General interface to timing. Ideally the various cases will be made into -// separate functions. -POLYUNSIGNED PolyTimingGeneral(PolyObject *threadId, PolyWord code, PolyWord arg) +/* Return GC system time since the start. */ +POLYUNSIGNED PolyTimingGetGCSystem(FirstArgument threadId) { - TaskData *taskData = TaskData::FindTaskForId(threadId); + TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); - Handle pushedCode = taskData->saveVec.push(code); - Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { - result = timing_dispatch_c(taskData, pushedArg, pushedCode); - } catch (...) { } // If an ML exception is raised + result = gHeapSizeParameters.getGCStime(taskData); + } + catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } #ifdef _WIN32 void addFiletimes(FILETIME *result, const FILETIME *x) { ULARGE_INTEGER liA, liB; liA.LowPart = result->dwLowDateTime; liA.HighPart = result->dwHighDateTime; liB.LowPart = x->dwLowDateTime; liB.HighPart = x->dwHighDateTime; liA.QuadPart += liB.QuadPart; result->dwLowDateTime = liA.LowPart; result->dwHighDateTime = liA.HighPart; } void subFiletimes(FILETIME *result, const FILETIME *x) { ULARGE_INTEGER liA, liB; liA.LowPart = result->dwLowDateTime; liA.HighPart = result->dwHighDateTime; liB.LowPart = x->dwLowDateTime; liB.HighPart = x->dwHighDateTime; liA.QuadPart -= liB.QuadPart; result->dwLowDateTime = liA.LowPart; result->dwHighDateTime = liA.HighPart; } float filetimeToSeconds(const FILETIME *x) { ULARGE_INTEGER ul; ul.LowPart = x->dwLowDateTime; ul.HighPart = x->dwHighDateTime; return (float)ul.QuadPart / (float)1.0E7; } void FileTimeTime::fromSeconds(unsigned u) { ULARGE_INTEGER li; li.QuadPart = (ULONGLONG)u * TICKS_PER_MICROSECOND * 1000000; t.dwLowDateTime = li.LowPart; t.dwHighDateTime = li.HighPart; } void FileTimeTime::add(const FileTimeTime &f) { addFiletimes(&t, &f.t); } void FileTimeTime::sub(const FileTimeTime &f) { subFiletimes(&t, &f.t); } float FileTimeTime::toSeconds(void) { return filetimeToSeconds(&t); } #endif #ifdef HAVE_SYS_TIME_H void addTimevals(struct timeval *result, const struct timeval *x) { long uSecs = result->tv_usec + x->tv_usec; result->tv_sec += x->tv_sec; if (uSecs >= 1000000) { result->tv_sec++; uSecs -= 1000000; } result->tv_usec = uSecs; } void subTimevals(struct timeval *result, const struct timeval *x) { long uSecs = result->tv_usec - x->tv_usec; result->tv_sec -= x->tv_sec; if (uSecs < 0) { result->tv_sec--; uSecs += 1000000; } result->tv_usec = uSecs; } float timevalToSeconds(const struct timeval *x) { return (float)x->tv_sec + (float)x->tv_usec / 1.0E6; } void TimeValTime::add(const TimeValTime &f) { addTimevals(&t, &f.t); } void TimeValTime::sub(const TimeValTime &f) { subTimevals(&t, &f.t); } #endif struct _entrypts timingEPT[] = { - { "PolyTimingGeneral", (polyRTSFunction)&PolyTimingGeneral}, + { "PolyTimingTicksPerMicroSec", (polyRTSFunction)&PolyTimingTicksPerMicroSec}, + { "PolyTimingGetNow", (polyRTSFunction)&PolyTimingGetNow}, + { "PolyTimingBaseYear", (polyRTSFunction)&PolyTimingBaseYear}, + { "PolyTimingYearOffset", (polyRTSFunction)&PolyTimingYearOffset}, + { "PolyTimingLocalOffset", (polyRTSFunction)&PolyTimingLocalOffset}, + { "PolyTimingSummerApplies", (polyRTSFunction)&PolyTimingSummerApplies}, + { "PolyTimingConvertDateStuct", (polyRTSFunction)&PolyTimingConvertDateStuct}, + { "PolyTimingGetUser", (polyRTSFunction)&PolyTimingGetUser}, + { "PolyTimingGetSystem", (polyRTSFunction)&PolyTimingGetSystem}, + { "PolyTimingGetGCUser", (polyRTSFunction)&PolyTimingGetGCUser}, + { "PolyTimingGetReal", (polyRTSFunction)&PolyTimingGetReal}, + { "PolyTimingGetChildUser", (polyRTSFunction)&PolyTimingGetChildUser}, + { "PolyTimingGetChildSystem", (polyRTSFunction)&PolyTimingGetChildSystem}, + { "PolyTimingGetGCSystem", (polyRTSFunction)&PolyTimingGetGCSystem}, { NULL, NULL} // End of list. }; class Timing: public RtsModule { public: virtual void Init(void); }; // Declare this. It will be automatically added to the table. static Timing timingModule; void Timing::Init(void) { #if (defined(_WIN32)) // Record an initial time of day to use as the basis of real timing GetSystemTimeAsFileTime(&startTime); #else gettimeofday(&startTime, NULL); #endif } time_t getBuildTime(void) { char *source_date_epoch = getenv("SOURCE_DATE_EPOCH"); if (source_date_epoch) { errno = 0; char *endptr; long long epoch = StrToLL(source_date_epoch, &endptr, 10); if ((errno == ERANGE && (epoch == LLONG_MIN || epoch == LLONG_MAX)) || (errno != 0 && epoch == 0)) { fprintf(polyStderr, "Environment variable $SOURCE_DATE_EPOCH: " XSTR(StrToLL) ": %s\n", strerror(errno)); goto err; } if (endptr == source_date_epoch) { fprintf(polyStderr, "Environment variable $SOURCE_DATE_EPOCH: No digits were found: %s\n", endptr); goto err; } if (*endptr != '\0') { fprintf(polyStderr, "Environment variable $SOURCE_DATE_EPOCH: Trailing garbage: %s\n", endptr); goto err; } if (epoch < (long long)std::numeric_limits::min()) { fprintf(polyStderr, "Environment variable $SOURCE_DATE_EPOCH: value must be greater than or equal to: %lld but was found to be: %lld\n", (long long)std::numeric_limits::min(), epoch); goto err; } if (epoch > (long long)std::numeric_limits::max()) { fprintf(polyStderr, "Environment variable $SOURCE_DATE_EPOCH: value must be smaller than or equal to: %lld but was found to be: %lld\n", (long long)std::numeric_limits::max(), epoch); goto err; } return (time_t) epoch; } err: return time(NULL); } diff --git a/libpolyml/unix_specific.cpp b/libpolyml/unix_specific.cpp index 8ea21d9d..57f3165d 100644 --- a/libpolyml/unix_specific.cpp +++ b/libpolyml/unix_specific.cpp @@ -1,2029 +1,2033 @@ /* Title: Operating Specific functions: Unix version. Copyright (c) 2000-8, 2016-17, 2019 David C. J. Matthews Portions of this code are derived from the original stream io package copyright CUTS 1983-2000. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_LIMITS_H #include #endif #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_PWD_H #include #endif #ifdef HAVE_GRP_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_SYS_WAIT_H #include #endif #ifdef HAVE_SYS_IOCTL_H #include #endif #ifdef HAVE_SYS_SIGNAL_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_SYS_TERMIOS_H #include #elif (defined(HAVE_TERMIOS_H)) #include #endif #ifdef HAVE_SYS_STAT_H #include #endif #ifdef HAVE_SYS_UTSNAME_H #include #endif #ifdef HAVE_SIGNAL_H #include #endif #include "globals.h" #include "arb.h" #include "run_time.h" #include "io_internal.h" #include "sys.h" #include "diagnostics.h" #include "machine_dep.h" #include "os_specific.h" #include "gc.h" #include "processes.h" #include "mpoly.h" #include "sighandler.h" #include "polystring.h" #include "save_vec.h" #include "rts_module.h" #include "rtsentry.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyOSSpecificGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyOSSpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetOSType(); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyPosixSleep(FirstArgument threadId, PolyWord maxTime, PolyWord sigCount); } #define SAVE(x) taskData->saveVec.push(x) #define ALLOC(n) alloc_and_save(taskData, n) #define SIZEOF(x) (sizeof(x)/sizeof(PolyWord)) /* Table of constants returned by call 4. */ // This is currently unsigned because that's necessary on the PowerPC for // NOFLUSH. Perhaps there should be separate tables for different kinds // of constants. static unsigned unixConstVec[] = { /* Error codes. */ E2BIG, /* 0 */ EACCES, EAGAIN, EBADF, #ifdef EBADMSG /* This is not defined in FreeBSD. */ EBADMSG, #else 0, #endif EBUSY, #ifdef ECANCELED /* This is not defined in Linux. Perhaps someone knows how to spell "cancelled". */ ECANCELED, #else 0, /* Perhaps some other value. */ #endif ECHILD, EDEADLK, EDOM, EEXIST, EFAULT, EFBIG, EINPROGRESS, EINTR, EINVAL, EIO, EISDIR, ELOOP, EMFILE, EMLINK, /* 20 */ EMSGSIZE, ENAMETOOLONG, ENFILE, ENODEV, ENOENT, ENOEXEC, ENOLCK, ENOMEM, ENOSPC, ENOSYS, ENOTDIR, ENOTEMPTY, #ifdef ENOTSUP /* Not defined in Linux. */ ENOTSUP, #else 0, #endif ENOTTY, ENXIO, EPERM, EPIPE, ERANGE, EROFS, ESPIPE, ESRCH, EXDEV, /* 42 */ /* Signals. */ SIGABRT, /* 43 */ SIGALRM, SIGBUS, SIGFPE, SIGHUP, SIGILL, SIGINT, SIGKILL, SIGPIPE, SIGQUIT, SIGSEGV, SIGTERM, SIGUSR1, SIGUSR2, SIGCHLD, SIGCONT, SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, /* 62 */ /* Open flags. */ O_RDONLY, /* 63 */ O_WRONLY, O_RDWR, O_APPEND, O_EXCL, O_NOCTTY, O_NONBLOCK, #ifdef O_SYNC O_SYNC, /* Not defined in FreeBSD. */ #else 0, #endif O_TRUNC, /* 71 */ /* TTY: Special characters. */ VEOF, /* 72 */ VEOL, VERASE, VINTR, VKILL, VMIN, VQUIT, VSUSP, VTIME, VSTART, VSTOP, NCCS, /* 83 */ /* TTY: Input mode. */ BRKINT, /* 84 */ ICRNL, IGNBRK, IGNCR, IGNPAR, INLCR, INPCK, ISTRIP, IXOFF, IXON, PARMRK, /* 94 */ /* TTY: Output mode. */ OPOST, /* 95 */ /* TTY: Control modes. */ CLOCAL, /* 96 */ CREAD, CS5, CS6, CS7, CS8, CSIZE, CSTOPB, HUPCL, PARENB, PARODD, /* 106 */ /* TTY: Local modes. */ ECHO, /* 107 */ ECHOE, ECHOK, ECHONL, ICANON, IEXTEN, ISIG, (unsigned)NOFLSH, TOSTOP, /* 115 */ /* TTY: Speeds. */ B0, /* 116 */ B50, B75, B110, B134, B150, B200, B300, B600, B1200, B1800, B2400, B4800, B9600, B19200, B38400, /* 131 */ /* FD flags. */ FD_CLOEXEC, /* 132 */ /* Wait flags. */ WUNTRACED, /* 133 */ WNOHANG, /* 134 */ /* tcsetattr flags. */ TCSANOW, /* 135 */ TCSADRAIN, TCSAFLUSH, /* tcflow flags. */ TCOOFF, /* 138 */ TCOON, TCIOFF, TCION, /* tcflush flags. */ TCIFLUSH, /* 142 */ TCOFLUSH, TCIOFLUSH, /* File permissions. */ S_IRUSR, /* 145 */ S_IWUSR, S_IXUSR, S_IRGRP, S_IWGRP, S_IXGRP, S_IROTH, S_IWOTH, S_IXOTH, S_ISUID, S_ISGID, /* 155 */ /* Bits for access function. */ R_OK, /* 156 */ W_OK, X_OK, F_OK, /* 159 */ /* Values for lseek. */ SEEK_SET, /* 160 */ SEEK_CUR, SEEK_END, /* 162 */ /* Values for lock types. */ F_RDLCK, /* 163 */ F_WRLCK, F_UNLCK, /* 165 */ /* Mask for file access. */ O_ACCMODE, /* 166 */ }; /* Auxiliary functions which implement the more complex cases. */ static Handle waitForProcess(TaskData *taskData, Handle args); static Handle makePasswordEntry(TaskData *taskData, struct passwd *pw); static Handle makeGroupEntry(TaskData *taskData, struct group *grp); static Handle getUname(TaskData *taskData); static Handle getSysConf(TaskData *taskData, Handle args); static Handle getTTYattrs(TaskData *taskData, Handle args); static Handle setTTYattrs(TaskData *taskData, Handle args); static Handle getStatInfo(TaskData *taskData, struct stat *buf); static Handle lockCommand(TaskData *taskData, int cmd, Handle args); static int findPathVar(TaskData *taskData, PolyWord ps); // Unmask all signals just before exec. static void restoreSignals(void) { sigset_t sigset; sigemptyset(&sigset); sigprocmask(SIG_SETMASK, &sigset, NULL); } Handle OS_spec_dispatch_c(TaskData *taskData, Handle args, Handle code) { - unsigned lastSigCount = receivedSignalCount; // Have we received a signal? int c = get_C_long(taskData, code->Word()); switch (c) { case 0: /* Return our OS type. Not in any structure. */ return Make_fixed_precision(taskData, 0); /* 0 for Unix. */ case 4: /* Return a constant. */ { unsigned i = get_C_unsigned(taskData, args->Word()); if (i >= sizeof(unixConstVec)/sizeof(unixConstVec[0])) raise_syscall(taskData, "Invalid index", 0); return Make_sysword(taskData, unixConstVec[i]); } case 5: /* fork. */ { pid_t pid = fork(); if (pid < 0) raise_syscall(taskData, "fork failed", errno); if (pid == 0) { // In the child process the only thread is this one. processes->SetSingleThreaded(); GCSetSingleThreadAfterFork(); } return Make_fixed_precision(taskData, pid); } case 6: /* kill */ { int pid = get_C_long(taskData, DEREFHANDLE(args)->Get(0)); int sig = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (kill(pid, sig) < 0) raise_syscall(taskData, "kill failed", errno); return Make_fixed_precision(taskData, 0); } case 7: /* get process id */ { pid_t pid = getpid(); if (pid < 0) raise_syscall(taskData, "getpid failed", errno); return Make_fixed_precision(taskData, pid); } case 8: /* get process id of parent */ { pid_t pid = getppid(); if (pid < 0) raise_syscall(taskData, "getppid failed", errno); return Make_fixed_precision(taskData, pid); } case 9: /* get real user id */ { uid_t uid = getuid(); // This is defined always to succeed return Make_fixed_precision(taskData, uid); } case 10: /* get effective user id */ { uid_t uid = geteuid(); // This is defined always to succeed return Make_fixed_precision(taskData, uid); } case 11: /* get real group id */ { gid_t gid = getgid(); // This is defined always to succeed return Make_fixed_precision(taskData, gid); } case 12: /* get effective group id */ { gid_t gid = getegid(); // This is defined always to succeed return Make_fixed_precision(taskData, gid); } case 13: /* Return process group */ { pid_t pid = getpgrp(); if (pid < 0) raise_syscall(taskData, "getpgrp failed", errno); return Make_fixed_precision(taskData, pid); } case 14: /* Wait for child process to terminate. */ return waitForProcess(taskData, args); case 15: /* Unpack a process result. */ { int resType, resVal; Handle result, typeHandle, resHandle; int status = get_C_long(taskData, args->Word()); if (WIFEXITED(status)) { resType = 1; resVal = WEXITSTATUS(status); } else if (WIFSIGNALED(status)) { resType = 2; resVal = WTERMSIG(status); } else if (WIFSTOPPED(status)) { resType = 3; resVal = WSTOPSIG(status); } else { /* ?? */ resType = 0; resVal = 0; } typeHandle = Make_fixed_precision(taskData, resType); resHandle = Make_fixed_precision(taskData, resVal); result = ALLOC(2); DEREFHANDLE(result)->Set(0, typeHandle->Word()); DEREFHANDLE(result)->Set(1, resHandle->Word()); return result; } case 16: /* Pack up a process result. The inverse of the previous call. */ { int resType = get_C_long(taskData, DEREFHANDLE(args)->Get(0)); int resVal = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int result = 0; switch (resType) { case 1: /* Exited */ result = resVal << 8; break; case 2: /* Signalled */ result = resVal; break; case 3: /* Stopped */ result = (resVal << 8) | 0177; } return Make_fixed_precision(taskData, result); } case 17: /* Run a new executable. */ { char *path = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); char **argl = stringListToVector(SAVE(DEREFHANDLE(args)->Get(1))); int err; restoreSignals(); execv(path, argl); err = errno; /* We only get here if there's been an error. */ free(path); freeStringVector(argl); raise_syscall(taskData, "execv failed", err); } case 18: /* Run a new executable with given environment. */ { char *path = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); char **argl = stringListToVector(SAVE(DEREFHANDLE(args)->Get(1))); char **envl = stringListToVector(SAVE(DEREFHANDLE(args)->Get(2))); int err; restoreSignals(); execve(path, argl, envl); err = errno; /* We only get here if there's been an error. */ free(path); freeStringVector(argl); freeStringVector(envl); raise_syscall(taskData, "execve failed", err); } case 19: /* Run a new executable using PATH environment variable. */ { char *path = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); char **argl = stringListToVector(SAVE(DEREFHANDLE(args)->Get(1))); int err; restoreSignals(); execvp(path, argl); err = errno; /* We only get here if there's been an error. */ free(path); freeStringVector(argl); raise_syscall(taskData, "execvp failed", err); } case 20: /* Sets an alarm and returns the current alarm time. A value of zero for the time cancels the timer. */ { /* We have a value in microseconds. We need to split it into seconds and microseconds. */ Handle hTime = args; Handle hMillion = Make_arbitrary_precision(taskData, 1000000); struct itimerval newTimer, oldTimer; newTimer.it_interval.tv_sec = 0; newTimer.it_interval.tv_usec = 0; newTimer.it_value.tv_sec = get_C_long(taskData, div_longc(taskData, hMillion, hTime)->Word()); newTimer.it_value.tv_usec = get_C_long(taskData, rem_longc(taskData, hMillion, hTime)->Word()); if (setitimer(ITIMER_REAL, &newTimer, &oldTimer) != 0) raise_syscall(taskData, "setitimer failed", errno); Handle result = /* Return the previous setting. */ Make_arb_from_pair_scaled(taskData, oldTimer.it_value.tv_sec, oldTimer.it_value.tv_usec, 1000000); return result; } - case 21: /* Pause until signal. */ - /* This never returns. When a signal is handled it will - be interrupted. */ - while (true) - { - processes->ThreadPause(taskData); - if (lastSigCount != receivedSignalCount) - raise_syscall(taskData, "Call interrupted by signal", EINTR); - } - - case 22: /* Sleep until given time or until a signal. Note: this is called - with an absolute time as an argument and returns a relative time as - result. This RTS call is tried repeatedly until either the time has - expired or a signal has occurred. */ - while (true) - { - struct timeval tv; - /* We have a value in microseconds. We need to split - it into seconds and microseconds. */ - Handle hSave = taskData->saveVec.mark(); - Handle hTime = args; - Handle hMillion = Make_arbitrary_precision(taskData, 1000000); - unsigned long secs = get_C_ulong(taskData, div_longc(taskData, hMillion, hTime)->Word()); - unsigned long usecs = get_C_ulong(taskData, rem_longc(taskData, hMillion, hTime)->Word()); - taskData->saveVec.reset(hSave); - /* Has the time expired? */ - if (gettimeofday(&tv, NULL) != 0) - raise_syscall(taskData, "gettimeofday failed", errno); - /* If the timeout time is earlier than the current time - we must return, otherwise we block. This can be interrupted - by a signal. */ - if ((unsigned long)tv.tv_sec < secs || - ((unsigned long)tv.tv_sec == secs && (unsigned long)tv.tv_usec < usecs)) - { - processes->ThreadPause(taskData); - if (lastSigCount != receivedSignalCount) - raise_syscall(taskData, "Call interrupted by signal", EINTR); - // And loop - } - else - { - processes->TestAnyEvents(taskData); // Check for interrupts anyway - return Make_fixed_precision(taskData, 0); - } - } - case 23: /* Set uid. */ { uid_t uid = get_C_long(taskData, args->Word()); if (setuid(uid) != 0) raise_syscall(taskData, "setuid failed", errno); return Make_fixed_precision(taskData, 0); } case 24: /* Set gid. */ { gid_t gid = get_C_long(taskData, args->Word()); if (setgid(gid) != 0) raise_syscall(taskData, "setgid failed", errno); return Make_fixed_precision(taskData, 0); } case 25: /* Get group list. */ { // This previously allocated gid_t[NGROUPS_MAX] on the stack but this // requires quite a bit of stack space. gid_t gid[1]; int ngroups = getgroups(0, gid); // Just get the number. if (ngroups < 0) raise_syscall(taskData, "getgroups failed", errno); if (ngroups == 0) return SAVE(ListNull); gid_t *groups = (gid_t*)calloc(sizeof(gid_t), ngroups); if (groups == 0) raise_syscall(taskData, "Unable to allocate memory", errno); if (getgroups(ngroups, groups) < 0) { int lasterr = errno; free(groups); raise_syscall(taskData, "getgroups failed", lasterr); } Handle saved = taskData->saveVec.mark(); Handle list = SAVE(ListNull); /* It's simplest to process the integers in reverse order */ while (--ngroups >= 0) { Handle value = Make_fixed_precision(taskData, groups[ngroups]); Handle next = ALLOC(SIZEOF(ML_Cons_Cell)); DEREFLISTHANDLE(next)->h = value->Word(); DEREFLISTHANDLE(next)->t = list->Word(); taskData->saveVec.reset(saved); list = SAVE(next->Word()); } free(groups); return list; } case 26: /* Get login name. */ { char *login = getlogin(); if (login == 0) raise_syscall(taskData, "getlogin failed", errno); return SAVE(C_string_to_Poly(taskData, login)); } case 27: /* Set sid */ { pid_t pid = setsid(); if (pid < 0) raise_syscall(taskData, "setsid failed", errno); return Make_fixed_precision(taskData, pid); } case 28: /* Set process group. */ { pid_t pid = get_C_long(taskData, DEREFHANDLE(args)->Get(0)); pid_t pgid = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (setpgid(pid, pgid) < 0 ) raise_syscall(taskData, "setpgid failed", errno); return Make_fixed_precision(taskData, 0); } case 29: /* uname */ return getUname(taskData); case 30: /* Get controlling terminal. */ #ifdef HAVE_CTERMID { char *term = ctermid(0); /* Can this generate an error? */ if (term == 0) raise_syscall(taskData, "ctermid failed", errno); return SAVE(C_string_to_Poly(taskData, term)); } #else raise_syscall(taskData, "ctermid is not implemented", 0); #endif case 31: /* Get terminal name for file descriptor. */ { char *term = ttyname(getStreamFileDescriptor(taskData, args->Word())); if (term == 0) raise_syscall(taskData, "ttyname failed", errno); return SAVE(C_string_to_Poly(taskData, term)); } case 32: /* Test if file descriptor is a terminal. Returns false if the stream is closed. */ { int descr = getStreamFileDescriptorWithoutCheck(args->Word()); if (descr != -1 && isatty(descr)) return Make_fixed_precision(taskData, 1); else return Make_fixed_precision(taskData, 0); } case 33: /* sysconf. */ return getSysConf(taskData, args); /* Filesys entries. */ case 50: /* Set the file creation mask and return the old one. */ { mode_t mode = get_C_ulong(taskData, args->Word()); return Make_fixed_precision(taskData, umask(mode)); } case 51: /* Create a hard link. */ { char *old = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); char *newp = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(1)); int err, res; res = link(old, newp); err = errno; /* Save the error result in case free changes it. */ free(old); free(newp); if (res < 0) raise_syscall(taskData, "link failed", err); return Make_fixed_precision(taskData, 0); } case 52: /* Create a directory. There is an OS-independent version in basicio which uses a default creation mode. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); mode_t mode = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int err, res; res = mkdir(name, mode); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "mkdir failed", err); return Make_fixed_precision(taskData, 0); } case 53: /* Create a fifo. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); mode_t mode = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int err, res; res = mkfifo(name, mode); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "mkfifo failed", err); return Make_fixed_precision(taskData, 0); } case 54: /* Create a symbolic link. */ { char *old = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); char *newp = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(1)); int err, res; res = symlink(old, newp); err = errno; /* Save the error result in case free changes it. */ free(old); free(newp); if (res < 0) raise_syscall(taskData, "link failed", err); return Make_fixed_precision(taskData, 0); } case 55: /* Get information about a file. */ { struct stat buf; int res, err; char *name = Poly_string_to_C_alloc(DEREFWORD(args)); res = stat(name, &buf); err = errno; free(name); if (res < 0) raise_syscall(taskData, "stat failed", err); return getStatInfo(taskData, &buf); } case 56: /* Get information about a symbolic link. */ { struct stat buf; int res, err; char *name = Poly_string_to_C_alloc(DEREFWORD(args)); res = lstat(name, &buf); err = errno; free(name); if (res < 0) raise_syscall(taskData, "lstat failed", err); return getStatInfo(taskData, &buf); } case 57: /* Get information about an open file. */ { struct stat buf; if (fstat(getStreamFileDescriptor(taskData, args->Word()), &buf) < 0) raise_syscall(taskData, "fstat failed", errno); return getStatInfo(taskData, &buf); } case 58: /* Test access rights to a file. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); int amode = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int res; res = access(name, amode); free(name); /* Return false if error, true if not. It's not clear that this is correct since there are several reasons why we might get -1 as the result. */ return Make_fixed_precision(taskData, res < 0 ? 0 : 1); } case 59: /* Change access rights. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); mode_t mode = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int err, res; res = chmod(name, mode); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "chmod failed", err); return Make_fixed_precision(taskData, 0); } case 60: /* Change access rights on open file. */ { mode_t mode = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (fchmod(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), mode) < 0) raise_syscall(taskData, "fchmod failed", errno); return Make_fixed_precision(taskData, 0); } case 61: /* Change owner and group. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); uid_t uid = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); gid_t gid = get_C_long(taskData, DEREFHANDLE(args)->Get(2)); int err, res; res = chown(name, uid, gid); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "chown failed", err); return Make_fixed_precision(taskData, 0); } case 62: /* Change owner and group on open file. */ { uid_t uid = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); gid_t gid = get_C_long(taskData, DEREFHANDLE(args)->Get(2)); if (fchown(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), uid, gid) < 0) raise_syscall(taskData, "fchown failed", errno); return Make_fixed_precision(taskData, 0); } case 63: /* Set access and modification times. We use utimes rather than utime since it allows us to be more accurate. There's a similar function in basicio which sets both the access and modification times to the same time. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); Handle hAccess = SAVE(DEREFHANDLE(args)->Get(1)); Handle hMod = SAVE(DEREFHANDLE(args)->Get(2)); struct timeval times[2]; /* We have a value in microseconds. We need to split it into seconds and microseconds. N.B. The arguments to div_longc and rem_longc are in reverse order. */ Handle hMillion = Make_arbitrary_precision(taskData, 1000000); unsigned secsAccess = get_C_ulong(taskData, div_longc(taskData, hMillion, hAccess)->Word()); unsigned usecsAccess = get_C_ulong(taskData, rem_longc(taskData, hMillion, hAccess)->Word()); unsigned secsMod = get_C_ulong(taskData, div_longc(taskData, hMillion, hMod)->Word()); unsigned usecsMod = get_C_ulong(taskData, rem_longc(taskData, hMillion, hMod)->Word()); int err, res; times[0].tv_sec = secsAccess; times[0].tv_usec = usecsAccess; times[1].tv_sec = secsMod; times[1].tv_usec = usecsMod; res = utimes(name, times); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "utimes failed", err); return Make_fixed_precision(taskData, 0); } case 64: /* Set access and modification times to the current time. This could be defined in terms of the previous call and Time.now but it could result in an error due to rounding. This is probably safer. */ { char *name = Poly_string_to_C_alloc(DEREFWORD(args)); int err, res; res = utimes(name, 0); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "utimes failed", err); return Make_fixed_precision(taskData, 0); } case 65: /* Truncate an open file. */ { int size = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (ftruncate(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), size) < 0) raise_syscall(taskData, "ftruncate failed", errno); return Make_fixed_precision(taskData, 0); } case 66: /* Get the configured limits for a file. */ { /* Look up the variable. May raise an exception. */ int nvar = findPathVar(taskData, DEREFHANDLE(args)->Get(1)); char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); int err, res; /* Set errno to zero. If there is no limit pathconf returns -1 but does not change errno. */ errno = 0; res = pathconf(name, nvar); err = errno; /* Save the error result in case free changes it. */ free(name); /* We return -1 as a valid result indicating no limit. */ if (res < 0 && err != 0) raise_syscall(taskData, "pathconf failed", err); return Make_fixed_precision(taskData, res); } case 67: /* Get the configured limits for an open file. */ { /* Look up the variable. May raise an exception. */ int nvar = findPathVar(taskData, DEREFHANDLE(args)->Get(1)); errno = 0; /* Unchanged if there is no limit. */ int res = fpathconf(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), nvar); if (res < 0 && errno != 0) raise_syscall(taskData, "fpathconf failed", errno); return Make_fixed_precision(taskData, res); } /* Password and group entries. */ case 100: /* Get Password entry by name. */ { char pwName[200]; int length; struct passwd *pw; length = Poly_string_to_C(DEREFWORD(args), pwName, 200); if (length > 200) raise_syscall(taskData, "Password name too long", ENAMETOOLONG); pw = getpwnam(pwName); if (pw == NULL) raise_syscall(taskData, "Password entry not found", ENOENT); return makePasswordEntry(taskData, pw); } case 101: /* Get password entry by uid. */ { int uid = get_C_long(taskData, DEREFWORD(args)); struct passwd *pw = getpwuid(uid); if (pw == NULL) raise_syscall(taskData, "Password entry not found", ENOENT); return makePasswordEntry(taskData, pw); } case 102: /* Get group entry by name. */ { struct group *grp; char grpName[200]; int length; length = Poly_string_to_C(DEREFWORD(args), grpName, 200); if (length > 200) raise_syscall(taskData, "Group name too long", ENAMETOOLONG); grp = getgrnam(grpName); if (grp == NULL) raise_syscall(taskData, "Group entry not found", ENOENT); return makeGroupEntry(taskData, grp); } case 103: /* Get group entry by gid. */ { int gid = get_C_long(taskData, DEREFWORD(args)); struct group *grp = getgrgid(gid); if (grp == NULL) raise_syscall(taskData, "Group entry not found", ENOENT); return makeGroupEntry(taskData, grp); } /* IO Entries. */ case 110: /* Create a pipe. */ { int filedes[2]; if (pipe(filedes) < 0) raise_syscall(taskData, "pipe failed", errno); Handle strRead = wrapFileDescriptor(taskData, filedes[0]); Handle strWrite = wrapFileDescriptor(taskData, filedes[1]); Handle result = ALLOC(2); DEREFHANDLE(result)->Set(0, strRead->Word()); DEREFHANDLE(result)->Set(1, strWrite->Word()); return result; } case 111: /* Duplicate a file descriptor. */ { int srcFd = getStreamFileDescriptor(taskData, args->WordP()); int fd = dup(srcFd); if (fd < 0) raise_syscall(taskData, "dup failed", errno); return wrapFileDescriptor(taskData, fd); } case 112: /* Duplicate a file descriptor to a given entry. */ { int oldFd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)); int newFd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(1)); if (dup2(oldFd, newFd) < 0) raise_syscall(taskData, "dup2 failed", errno); return Make_fixed_precision(taskData, 0); } case 113: /* Duplicate a file descriptor to an entry equal to or greater than the given value. */ { int oldFd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)); int baseFd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(1)); int newFd = fcntl(oldFd, F_DUPFD, baseFd); return wrapFileDescriptor(taskData, newFd); } case 114: /* Get the file descriptor flags. */ { int res = fcntl(getStreamFileDescriptor(taskData, args->Word()), F_GETFD); if (res < 0) raise_syscall(taskData, "fcntl failed", errno); return Make_fixed_precision(taskData, res); } case 115: /* Set the file descriptor flags. */ { int flags = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (fcntl(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), F_SETFD, flags) < 0) raise_syscall(taskData, "fcntl failed", errno); return Make_fixed_precision(taskData, 0); } case 116: /* Get the file status and access flags. */ { int res = fcntl(getStreamFileDescriptor(taskData, args->Word()), F_GETFL); if (res < 0) raise_syscall(taskData, "fcntl failed", errno); return Make_fixed_precision(taskData, res); } case 117: /* Set the file status and access flags. */ { int flags = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (fcntl(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), F_SETFL, flags) < 0) raise_syscall(taskData, "fcntl failed", errno); return Make_fixed_precision(taskData, 0); } case 118: /* Seek to a position on the stream. */ { long position = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int whence = get_C_long(taskData, DEREFHANDLE(args)->Get(2)); long newpos = lseek(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), position, whence); if (newpos < 0) raise_syscall(taskData, "lseek failed", errno); return Make_arbitrary_precision(taskData, (POLYSIGNED)newpos); // Position.int } case 119: /* Synchronise file contents. */ { if (fsync(getStreamFileDescriptor(taskData, args->Word())) < 0) raise_syscall(taskData, "fsync failed", errno); return Make_fixed_precision(taskData, 0); } case 120: /* get lock */ return lockCommand(taskData, F_GETLK, args); case 121: /* set lock */ return lockCommand(taskData, F_SETLK, args); case 122: /* wait for lock */ /* TODO: This may well block the whole process. We should look at the result and retry if need be. */ return lockCommand(taskData, F_SETLKW, args); /* TTY entries. */ case 150: /* Get attributes. */ return getTTYattrs(taskData, args); case 151: /* Set attributes. */ return setTTYattrs(taskData, args); case 152: /* Send a break. */ { int duration = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (tcsendbreak(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), duration) < 0) raise_syscall(taskData, "tcsendbreak failed", errno); return Make_fixed_precision(taskData, 0); } case 153: /* Wait for output to drain. */ { /* TODO: This will block the process. It really needs to check whether the stream has drained and run another process until it has. */ #ifdef HAVE_TCDRAIN if (tcdrain(getStreamFileDescriptor(taskData, args->Word())) < 0) raise_syscall(taskData, "tcdrain failed", errno); #else raise_syscall(taskData, "tcdrain is not implemented", 0); #endif return Make_fixed_precision(taskData, 0); } case 154: /* Flush terminal stream. */ { int qs = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (tcflush(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), qs) < 0) raise_syscall(taskData, "tcflush failed", errno); return Make_fixed_precision(taskData, 0); } case 155: /* Flow control. */ { int action = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (tcflow(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), action) < 0) raise_syscall(taskData, "tcflow failed", errno); return Make_fixed_precision(taskData, 0); } case 156: /* Get process group. */ { pid_t pid = tcgetpgrp(getStreamFileDescriptor(taskData, args->Word())); if (pid < 0) raise_syscall(taskData, "tcgetpgrp failed", errno); return Make_fixed_precision(taskData, pid); } case 157: /* Set process group. */ { pid_t pid = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (tcsetpgrp(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), pid) < 0) raise_syscall(taskData, "tcsetpgrp failed", errno); return Make_fixed_precision(taskData, 0); } default: { char msg[100]; sprintf(msg, "Unknown unix-specific function: %d", c); raise_exception_string(taskData, EXC_Fail, msg); } } } // General interface to Unix OS-specific. Ideally the various cases will be made into // separate functions. -POLYUNSIGNED PolyOSSpecificGeneral(PolyObject *threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyOSSpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCode = taskData->saveVec.push(code); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = OS_spec_dispatch_c(taskData, pushedArg, pushedCode); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } POLYUNSIGNED PolyGetOSType() { return TAGGED(0).AsUnsigned(); // Return 0 for Unix } +// Wait for the shorter of the times. +// TODO: This should really wait for some event from the signal thread. +class WaitUpto : public Waiter +{ +public: + WaitUpto(unsigned mSecs) : maxTime(mSecs), result(0), errcode(0) {} + virtual void Wait(unsigned maxMillisecs) + { + useconds_t usec; + if (maxTime < maxMillisecs) + usec = maxTime * 1000; + else usec = maxMillisecs * 1000; + result = usleep(usec); + if (result != 0) errcode = errno; + } + unsigned maxTime; + int result; + int errcode; +}; + +// This waits for a period of up to a second. The actual time calculations are +// done in ML. Takes the signal count as an argument and returns the last signal +// count. This ensures that it does not miss any signals that arrive while in ML. +POLYUNSIGNED PolyPosixSleep(FirstArgument threadId, PolyWord maxMillisecs, PolyWord sigCount) +{ + TaskData *taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + POLYUNSIGNED maxMilliseconds = maxMillisecs.UnTaggedUnsigned(); + + try { + if (UNTAGGED_UNSIGNED(sigCount) == receivedSignalCount) + { + WaitUpto waiter(maxMilliseconds); + processes->ThreadPauseForIO(taskData, &waiter); + if (waiter.result != 0) + { + if (waiter.errcode != EINTR) + raise_syscall(taskData, "sleep failed", waiter.errcode); + } + } + } catch (...) { } // If an ML exception is raised + + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + return TAGGED(receivedSignalCount).AsUnsigned(); +} + Handle waitForProcess(TaskData *taskData, Handle args) /* Get result status of a child process. */ { TryAgain: // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); int kind = get_C_long(taskData, DEREFHANDLE(args)->Get(0)); int pid = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int callFlags = get_C_long(taskData, DEREFHANDLE(args)->Get(2)); int flags = callFlags | WNOHANG; // Add in WNOHANG so we never block. pid_t pres = 0; int status = 0; switch (kind) { case 0: /* Wait for any child. */ pres = waitpid(-1, &status, flags); break; case 1: /* Wait for specific process. */ pres = waitpid(pid, &status, flags); break; case 2: /* Wait for any in current process group. */ pres = waitpid(0, &status, flags); break; case 3: /* Wait for child in given process group */ pres = waitpid(-pid, &status, flags); break; } if (pres < 0) { if (errno == EINTR) goto TryAgain; else raise_syscall(taskData, "wait failed", errno); } /* If the caller did not specify WNOHANG but there wasn't a child process waiting we have to block and come back here later. */ if (pres == 0 && !(callFlags & WNOHANG)) { processes->ThreadPause(taskData); goto TryAgain; } /* Construct the result tuple. */ { Handle result, pidHandle, resHandle; pidHandle = Make_fixed_precision(taskData, pres); // If the pid is zero status may not be a valid value and may overflow. resHandle = Make_fixed_precision(taskData, pres == 0 ? 0: status); result = ALLOC(2); DEREFHANDLE(result)->Set(0, DEREFWORD(pidHandle)); DEREFHANDLE(result)->Set(1, DEREFWORD(resHandle)); return result; } } static Handle makePasswordEntry(TaskData *taskData, struct passwd *pw) /* Return a password entry. */ { Handle nameHandle, uidHandle, gidHandle, homeHandle, shellHandle, result; nameHandle = SAVE(C_string_to_Poly(taskData, pw->pw_name)); uidHandle = Make_fixed_precision(taskData, pw->pw_uid); gidHandle = Make_fixed_precision(taskData, pw->pw_gid); homeHandle = SAVE(C_string_to_Poly(taskData, pw->pw_dir)); shellHandle = SAVE(C_string_to_Poly(taskData, pw->pw_shell)); result = ALLOC(5); DEREFHANDLE(result)->Set(0, nameHandle->Word()); DEREFHANDLE(result)->Set(1, uidHandle->Word()); DEREFHANDLE(result)->Set(2, gidHandle->Word()); DEREFHANDLE(result)->Set(3, homeHandle->Word()); DEREFHANDLE(result)->Set(4, shellHandle->Word()); return result; } static Handle makeGroupEntry(TaskData *taskData, struct group *grp) { Handle nameHandle, gidHandle, membersHandle, result; int i; char **p; nameHandle = SAVE(C_string_to_Poly(taskData, grp->gr_name)); gidHandle = Make_fixed_precision(taskData, grp->gr_gid); /* Group members. */ for (i=0, p = grp->gr_mem; *p != NULL; p++, i++); membersHandle = convert_string_list(taskData, i, grp->gr_mem); result = ALLOC(3); DEREFHANDLE(result)->Set(0, nameHandle->Word()); DEREFHANDLE(result)->Set(1, gidHandle->Word()); DEREFHANDLE(result)->Set(2, membersHandle->Word()); return result; } /* Make a cons cell for a pair of strings. */ // Doesn't currently reset the save vec so it's only safe for a small number // of cells. static void makeStringPairList(TaskData *taskData, Handle &list, const char *s1, const char *s2) { Handle nameHandle, valueHandle, pairHandle, next; /* This has to be done carefully to ensure we don't throw anything away if we garbage-collect and also to ensure that each object is fully initialised before the next object is created. */ /* Make the strings. */ nameHandle = SAVE(C_string_to_Poly(taskData, s1)); valueHandle = SAVE(C_string_to_Poly(taskData, s2)); /* Make the pair. */ pairHandle = ALLOC(2); DEREFHANDLE(pairHandle)->Set(0, nameHandle->Word()); DEREFHANDLE(pairHandle)->Set(1, valueHandle->Word()); /* Make the cons cell. */ next = ALLOC(SIZEOF(ML_Cons_Cell)); DEREFLISTHANDLE(next)->h = pairHandle->Word(); DEREFLISTHANDLE(next)->t = list->Word(); list = SAVE(next->Word()); } /* Return the uname information. */ static Handle getUname(TaskData *taskData) { #ifdef HAVE_SYS_UTSNAME_H struct utsname name; Handle list = SAVE(ListNull); if (uname(&name) < 0) raise_syscall(taskData, "uname failed", errno); makeStringPairList(taskData, list, "sysname", name.sysname); makeStringPairList(taskData, list, "nodename", name.nodename); makeStringPairList(taskData, list, "release", name.release); makeStringPairList(taskData, list, "version", name.version); makeStringPairList(taskData, list, "machine", name.machine); return list; #else raise_syscall(taskData, "uname not available on this machine", errno); #endif } /* Return the contents of a stat buffer. */ static Handle getStatInfo(TaskData *taskData, struct stat *buf) { int kind; /* Get the protection mode, masking off the file type info. */ Handle modeHandle = Make_fixed_precision(taskData, buf->st_mode & (S_IRWXU|S_IRWXG|S_IRWXO|S_ISUID|S_ISGID)); if (S_ISDIR(buf->st_mode)) kind = 1; else if (S_ISCHR(buf->st_mode)) kind = 2; else if (S_ISBLK(buf->st_mode)) kind = 3; else if (S_ISFIFO(buf->st_mode)) kind = 4; else if ((buf->st_mode & S_IFMT) == S_IFLNK) kind = 5; else if ((buf->st_mode & S_IFMT) == S_IFSOCK) kind = 6; else /* Regular. */ kind = 0; Handle kindHandle = Make_fixed_precision(taskData, kind); Handle inoHandle = Make_arbitrary_precision(taskData, buf->st_ino); Handle devHandle = Make_arbitrary_precision(taskData, buf->st_dev); Handle linkHandle = Make_fixed_precision(taskData, buf->st_nlink); Handle uidHandle = Make_fixed_precision(taskData, buf->st_uid); Handle gidHandle = Make_fixed_precision(taskData, buf->st_gid); Handle sizeHandle = Make_arbitrary_precision(taskData, buf->st_size); // Position.int Handle atimeHandle = Make_arb_from_pair_scaled(taskData, STAT_SECS(buf,a), STAT_USECS(buf,a), 1000000); Handle mtimeHandle = Make_arb_from_pair_scaled(taskData, STAT_SECS(buf,m), STAT_USECS(buf,m), 1000000); Handle ctimeHandle = Make_arb_from_pair_scaled(taskData, STAT_SECS(buf,c), STAT_USECS(buf,c), 1000000); Handle result = ALLOC(11); DEREFHANDLE(result)->Set(0, modeHandle->Word()); DEREFHANDLE(result)->Set(1, kindHandle->Word()); DEREFHANDLE(result)->Set(2, inoHandle->Word()); DEREFHANDLE(result)->Set(3, devHandle->Word()); DEREFHANDLE(result)->Set(4, linkHandle->Word()); DEREFHANDLE(result)->Set(5, uidHandle->Word()); DEREFHANDLE(result)->Set(6, gidHandle->Word()); DEREFHANDLE(result)->Set(7, sizeHandle->Word()); DEREFHANDLE(result)->Set(8, atimeHandle->Word()); DEREFHANDLE(result)->Set(9, mtimeHandle->Word()); DEREFHANDLE(result)->Set(10, ctimeHandle->Word()); return result; } static Handle getTTYattrs(TaskData *taskData, Handle args) { int fd = getStreamFileDescriptor(taskData, args->Word()); struct termios tios; speed_t ispeed, ospeed; Handle ifHandle, ofHandle, cfHandle, lfHandle, ccHandle; Handle isHandle, osHandle, result; if (tcgetattr(fd, &tios) < 0) raise_syscall(taskData, "tcgetattr failed", errno); /* Extract the speed entries. */ ospeed = cfgetospeed(&tios); ispeed = cfgetispeed(&tios); /* Set the speed entries to zero. In Solaris, at least, the speed is encoded in the flags and we don't want any confusion. The order of these functions is significant. */ cfsetospeed(&tios, B0); cfsetispeed(&tios, B0); /* Convert the values to ML representation. */ ifHandle = Make_fixed_precision(taskData, tios.c_iflag); ofHandle = Make_fixed_precision(taskData, tios.c_oflag); cfHandle = Make_fixed_precision(taskData, tios.c_cflag); lfHandle = Make_fixed_precision(taskData, tios.c_lflag); /* The cc vector is treated as a string. */ ccHandle = SAVE(C_string_to_Poly(taskData, (const char *)tios.c_cc, NCCS)); isHandle = Make_fixed_precision(taskData, ispeed); osHandle = Make_fixed_precision(taskData, ospeed); /* We can now create the result tuple. */ result = ALLOC(7); DEREFHANDLE(result)->Set(0, ifHandle->Word()); DEREFHANDLE(result)->Set(1, ofHandle->Word()); DEREFHANDLE(result)->Set(2, cfHandle->Word()); DEREFHANDLE(result)->Set(3, lfHandle->Word()); DEREFHANDLE(result)->Set(4, ccHandle->Word()); DEREFHANDLE(result)->Set(5, isHandle->Word()); DEREFHANDLE(result)->Set(6, osHandle->Word()); return result; } /* Assemble the tios structure from the arguments and set the TTY attributes. */ static Handle setTTYattrs(TaskData *taskData, Handle args) { int fd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)); int actions = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); struct termios tios; speed_t ispeed, ospeed; /* Make sure anything unset is zero. It might be better to call tcgetattr instead. */ memset(&tios, 0, sizeof(tios)); tios.c_iflag = get_C_ulong(taskData, DEREFHANDLE(args)->Get(2)); tios.c_oflag = get_C_ulong(taskData, DEREFHANDLE(args)->Get(3)); tios.c_cflag = get_C_ulong(taskData, DEREFHANDLE(args)->Get(4)); tios.c_lflag = get_C_ulong(taskData, DEREFHANDLE(args)->Get(5)); /* The cc vector should be a string of exactly NCCS characters. It may well contain nulls so we can't use Poly_string_to_C to copy it. */ PolyWord ccv = DEREFHANDLE(args)->Get(6); if (ccv.IsTagged()) // Just to check. raise_syscall(taskData, "Incorrect cc vector", EINVAL); PolyStringObject * ccvs = (PolyStringObject *)ccv.AsObjPtr(); if (ccvs->length != NCCS) // Just to check. */ raise_syscall(taskData, "Incorrect cc vector", EINVAL); memcpy(tios.c_cc, ccvs->chars, NCCS); ispeed = get_C_ulong(taskData, DEREFHANDLE(args)->Get(7)); ospeed = get_C_ulong(taskData, DEREFHANDLE(args)->Get(8)); if (cfsetispeed(&tios, ispeed) < 0) raise_syscall(taskData, "cfsetispeed failed", errno); if (cfsetospeed(&tios, ospeed) < 0) raise_syscall(taskData, "cfsetospeed failed", errno); /* Now it's all set we can call tcsetattr to do the work. */ if (tcsetattr(fd, actions, &tios) < 0) raise_syscall(taskData, "tcsetattr failed", errno); return Make_fixed_precision(taskData, 0); } /* Lock/unlock/test file locks. Returns the, possibly modified, argument structure. */ static Handle lockCommand(TaskData *taskData, int cmd, Handle args) { int fd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)); struct flock lock; memset(&lock, 0, sizeof(lock)); /* Make sure unused fields are zero. */ lock.l_type = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); lock.l_whence = get_C_long(taskData, DEREFHANDLE(args)->Get(2)); lock.l_start = get_C_long(taskData, DEREFHANDLE(args)->Get(3)); lock.l_len = get_C_long(taskData, DEREFHANDLE(args)->Get(4)); lock.l_pid = get_C_long(taskData, DEREFHANDLE(args)->Get(5)); if (fcntl(fd, cmd, &lock) < 0) raise_syscall(taskData, "fcntl failed", errno); /* Construct the result. */ Handle typeHandle = Make_fixed_precision(taskData, lock.l_type); Handle whenceHandle = Make_fixed_precision(taskData, lock.l_whence); Handle startHandle = Make_arbitrary_precision(taskData, (POLYUNSIGNED)lock.l_start); // Position.int Handle lenHandle = Make_arbitrary_precision(taskData, (POLYUNSIGNED)lock.l_len); // Position.int Handle pidHandle = Make_fixed_precision(taskData, lock.l_pid); Handle result = ALLOC(5); DEREFHANDLE(result)->Set(0, typeHandle->Word()); DEREFHANDLE(result)->Set(1, whenceHandle->Word()); DEREFHANDLE(result)->Set(2, startHandle->Word()); DEREFHANDLE(result)->Set(3, lenHandle->Word()); DEREFHANDLE(result)->Set(4, pidHandle->Word()); return result; } /* This table maps string arguments for sysconf into the corresponding constants. */ /* These are highly OS dependent. It has been configured on Solaris 2.8, Linux Redhat 5.2 and FreeBSD 3.4. */ static struct { const char *saName; int saVal; } sysArgTable[] = { { "_SC_ARG_MAX", _SC_ARG_MAX }, { "_SC_CHILD_MAX", _SC_CHILD_MAX }, { "_SC_CLK_TCK", _SC_CLK_TCK }, { "_SC_NGROUPS_MAX", _SC_NGROUPS_MAX }, { "_SC_OPEN_MAX", _SC_OPEN_MAX }, { "_SC_JOB_CONTROL", _SC_JOB_CONTROL }, { "_SC_SAVED_IDS", _SC_SAVED_IDS }, { "_SC_VERSION", _SC_VERSION }, #ifdef _SC_PASS_MAX { "_SC_PASS_MAX", _SC_PASS_MAX }, #endif #ifdef _SC_LOGNAME_MAX { "_SC_LOGNAME_MAX", _SC_LOGNAME_MAX }, #endif #ifdef _SC_PAGESIZE { "_SC_PAGESIZE", _SC_PAGESIZE }, #endif #ifdef _SC_XOPEN_VERSION { "_SC_XOPEN_VERSION", _SC_XOPEN_VERSION }, #endif #ifdef _SC_NPROCESSORS_CONF { "_SC_NPROCESSORS_CONF", _SC_NPROCESSORS_CONF }, #endif #ifdef _SC_NPROCESSORS_ONLN { "_SC_NPROCESSORS_ONLN", _SC_NPROCESSORS_ONLN }, #endif #ifdef _SC_STREAM_MAX { "_SC_STREAM_MAX", _SC_STREAM_MAX }, #endif #ifdef _SC_TZNAME_MAX { "_SC_TZNAME_MAX", _SC_TZNAME_MAX }, #endif #ifdef _SC_AIO_LISTIO_MAX { "_SC_AIO_LISTIO_MAX", _SC_AIO_LISTIO_MAX }, #endif #ifdef _SC_AIO_MAX { "_SC_AIO_MAX", _SC_AIO_MAX }, #endif #ifdef _SC_AIO_PRIO_DELTA_MAX { "_SC_AIO_PRIO_DELTA_MAX", _SC_AIO_PRIO_DELTA_MAX }, #endif #ifdef _SC_ASYNCHRONOUS_IO { "_SC_ASYNCHRONOUS_IO", _SC_ASYNCHRONOUS_IO }, #endif #ifdef _SC_DELAYTIMER_MAX { "_SC_DELAYTIMER_MAX", _SC_DELAYTIMER_MAX }, #endif #ifdef _SC_FSYNC { "_SC_FSYNC", _SC_FSYNC }, #endif #ifdef _SC_MAPPED_FILES { "_SC_MAPPED_FILES", _SC_MAPPED_FILES }, #endif #ifdef _SC_MEMLOCK { "_SC_MEMLOCK", _SC_MEMLOCK }, #endif #ifdef _SC_MEMLOCK_RANGE { "_SC_MEMLOCK_RANGE", _SC_MEMLOCK_RANGE }, #endif #ifdef _SC_MEMORY_PROTECTION { "_SC_MEMORY_PROTECTION", _SC_MEMORY_PROTECTION }, #endif #ifdef _SC_MESSAGE_PASSING { "_SC_MESSAGE_PASSING", _SC_MESSAGE_PASSING }, #endif #ifdef _SC_MQ_OPEN_MAX { "_SC_MQ_OPEN_MAX", _SC_MQ_OPEN_MAX }, #endif #ifdef _SC_MQ_PRIO_MAX { "_SC_MQ_PRIO_MAX", _SC_MQ_PRIO_MAX }, #endif #ifdef _SC_PRIORITIZED_IO { "_SC_PRIORITIZED_IO", _SC_PRIORITIZED_IO }, #endif #ifdef _SC_PRIORITY_SCHEDULING { "_SC_PRIORITY_SCHEDULING", _SC_PRIORITY_SCHEDULING }, #endif #ifdef _SC_REALTIME_SIGNALS { "_SC_REALTIME_SIGNALS", _SC_REALTIME_SIGNALS }, #endif #ifdef _SC_RTSIG_MAX { "_SC_RTSIG_MAX", _SC_RTSIG_MAX }, #endif #ifdef _SC_SEMAPHORES { "_SC_SEMAPHORES", _SC_SEMAPHORES }, #endif #ifdef _SC_SEM_NSEMS_MAX { "_SC_SEM_NSEMS_MAX", _SC_SEM_NSEMS_MAX }, #endif #ifdef _SC_SEM_VALUE_MAX { "_SC_SEM_VALUE_MAX", _SC_SEM_VALUE_MAX }, #endif #ifdef _SC_SHARED_MEMORY_OBJECTS { "_SC_SHARED_MEMORY_OBJECTS", _SC_SHARED_MEMORY_OBJECTS }, #endif #ifdef _SC_SIGQUEUE_MAX { "_SC_SIGQUEUE_MAX", _SC_SIGQUEUE_MAX }, #endif #ifdef _SC_SIGRT_MIN { "_SC_SIGRT_MIN", _SC_SIGRT_MIN }, #endif #ifdef _SC_SIGRT_MAX { "_SC_SIGRT_MAX", _SC_SIGRT_MAX }, #endif #ifdef _SC_SYNCHRONIZED_IO { "_SC_SYNCHRONIZED_IO", _SC_SYNCHRONIZED_IO }, #endif #ifdef _SC_TIMERS { "_SC_TIMERS", _SC_TIMERS }, #endif #ifdef _SC_TIMER_MAX { "_SC_TIMER_MAX", _SC_TIMER_MAX }, #endif #ifdef _SC_2_C_BIND { "_SC_2_C_BIND", _SC_2_C_BIND }, #endif #ifdef _SC_2_C_DEV { "_SC_2_C_DEV", _SC_2_C_DEV }, #endif #ifdef _SC_2_C_VERSION { "_SC_2_C_VERSION", _SC_2_C_VERSION }, #endif #ifdef _SC_2_FORT_DEV { "_SC_2_FORT_DEV", _SC_2_FORT_DEV }, #endif #ifdef _SC_2_FORT_RUN { "_SC_2_FORT_RUN", _SC_2_FORT_RUN }, #endif #ifdef _SC_2_LOCALEDEF { "_SC_2_LOCALEDEF", _SC_2_LOCALEDEF }, #endif #ifdef _SC_2_SW_DEV { "_SC_2_SW_DEV", _SC_2_SW_DEV }, #endif #ifdef _SC_2_UPE { "_SC_2_UPE", _SC_2_UPE }, #endif #ifdef _SC_2_VERSION { "_SC_2_VERSION", _SC_2_VERSION }, #endif #ifdef _SC_BC_BASE_MAX { "_SC_BC_BASE_MAX", _SC_BC_BASE_MAX }, #endif #ifdef _SC_BC_DIM_MAX { "_SC_BC_DIM_MAX", _SC_BC_DIM_MAX }, #endif #ifdef _SC_BC_SCALE_MAX { "_SC_BC_SCALE_MAX", _SC_BC_SCALE_MAX }, #endif #ifdef _SC_BC_STRING_MAX { "_SC_BC_STRING_MAX", _SC_BC_STRING_MAX }, #endif #ifdef _SC_COLL_WEIGHTS_MAX { "_SC_COLL_WEIGHTS_MAX", _SC_COLL_WEIGHTS_MAX }, #endif #ifdef _SC_EXPR_NEST_MAX { "_SC_EXPR_NEST_MAX", _SC_EXPR_NEST_MAX }, #endif #ifdef _SC_LINE_MAX { "_SC_LINE_MAX", _SC_LINE_MAX }, #endif #ifdef _SC_RE_DUP_MAX { "_SC_RE_DUP_MAX", _SC_RE_DUP_MAX }, #endif #ifdef _SC_XOPEN_CRYPT { "_SC_XOPEN_CRYPT", _SC_XOPEN_CRYPT }, #endif #ifdef _SC_XOPEN_ENH_I18N { "_SC_XOPEN_ENH_I18N", _SC_XOPEN_ENH_I18N }, #endif #ifdef _SC_XOPEN_SHM { "_SC_XOPEN_SHM", _SC_XOPEN_SHM }, #endif #ifdef _SC_2_CHAR_TERM { "_SC_2_CHAR_TERM", _SC_2_CHAR_TERM }, #endif #ifdef _SC_XOPEN_XCU_VERSION { "_SC_XOPEN_XCU_VERSION", _SC_XOPEN_XCU_VERSION }, #endif #ifdef _SC_ATEXIT_MAX { "_SC_ATEXIT_MAX", _SC_ATEXIT_MAX }, #endif #ifdef _SC_IOV_MAX { "_SC_IOV_MAX", _SC_IOV_MAX }, #endif #ifdef _SC_XOPEN_UNIX { "_SC_XOPEN_UNIX", _SC_XOPEN_UNIX }, #endif #ifdef _SC_PAGE_SIZE { "_SC_PAGE_SIZE", _SC_PAGE_SIZE }, #endif #ifdef _SC_T_IOV_MAX { "_SC_T_IOV_MAX", _SC_T_IOV_MAX }, #endif #ifdef _SC_PHYS_PAGES { "_SC_PHYS_PAGES", _SC_PHYS_PAGES }, #endif #ifdef _SC_AVPHYS_PAGES { "_SC_AVPHYS_PAGES", _SC_AVPHYS_PAGES }, #endif #ifdef _SC_COHER_BLKSZ { "_SC_COHER_BLKSZ", _SC_COHER_BLKSZ }, #endif #ifdef _SC_SPLIT_CACHE { "_SC_SPLIT_CACHE", _SC_SPLIT_CACHE }, #endif #ifdef _SC_ICACHE_SZ { "_SC_ICACHE_SZ", _SC_ICACHE_SZ }, #endif #ifdef _SC_DCACHE_SZ { "_SC_DCACHE_SZ", _SC_DCACHE_SZ }, #endif #ifdef _SC_ICACHE_LINESZ { "_SC_ICACHE_LINESZ", _SC_ICACHE_LINESZ }, #endif #ifdef _SC_DCACHE_LINESZ { "_SC_DCACHE_LINESZ", _SC_DCACHE_LINESZ }, #endif #ifdef _SC_ICACHE_BLKSZ { "_SC_ICACHE_BLKSZ", _SC_ICACHE_BLKSZ }, #endif #ifdef _SC_DCACHE_BLKSZ { "_SC_DCACHE_BLKSZ", _SC_DCACHE_BLKSZ }, #endif #ifdef _SC_DCACHE_TBLKSZ { "_SC_DCACHE_TBLKSZ", _SC_DCACHE_TBLKSZ }, #endif #ifdef _SC_ICACHE_ASSOC { "_SC_ICACHE_ASSOC", _SC_ICACHE_ASSOC }, #endif #ifdef _SC_DCACHE_ASSOC { "_SC_DCACHE_ASSOC", _SC_DCACHE_ASSOC }, #endif #ifdef _SC_MAXPID { "_SC_MAXPID", _SC_MAXPID }, #endif #ifdef _SC_STACK_PROT { "_SC_STACK_PROT", _SC_STACK_PROT }, #endif #ifdef _SC_THREAD_DESTRUCTOR_ITERATIONS { "_SC_THREAD_DESTRUCTOR_ITERATIONS", _SC_THREAD_DESTRUCTOR_ITERATIONS }, #endif #ifdef _SC_GETGR_R_SIZE_MAX { "_SC_GETGR_R_SIZE_MAX", _SC_GETGR_R_SIZE_MAX }, #endif #ifdef _SC_GETPW_R_SIZE_MAX { "_SC_GETPW_R_SIZE_MAX", _SC_GETPW_R_SIZE_MAX }, #endif #ifdef _SC_LOGIN_NAME_MAX { "_SC_LOGIN_NAME_MAX", _SC_LOGIN_NAME_MAX }, #endif #ifdef _SC_THREAD_KEYS_MAX { "_SC_THREAD_KEYS_MAX", _SC_THREAD_KEYS_MAX }, #endif #ifdef _SC_THREAD_STACK_MI { "_SC_THREAD_STACK_MIN", _SC_THREAD_STACK_MIN }, #endif #ifdef _SC_THREAD_THREADS_MAX { "_SC_THREAD_THREADS_MAX", _SC_THREAD_THREADS_MAX }, #endif #ifdef _SC_THREAD_ATTR_STACKADDR { "_SC_THREAD_ATTR_STACKADDR", _SC_THREAD_ATTR_STACKADDR }, #endif #ifdef _SC_THREAD_ATTR_STACKSIZE { "_SC_THREAD_ATTR_STACKSIZE", _SC_THREAD_ATTR_STACKSIZE }, #endif #ifdef _SC_THREAD_PRIORITY_SCHEDULING { "_SC_THREAD_PRIORITY_SCHEDULING", _SC_THREAD_PRIORITY_SCHEDULING }, #endif #ifdef _SC_THREAD_PRIO_INHERIT { "_SC_THREAD_PRIO_INHERIT", _SC_THREAD_PRIO_INHERIT }, #endif #ifdef _SC_THREAD_PRIO_PROTECT { "_SC_THREAD_PRIO_PROTECT", _SC_THREAD_PRIO_PROTECT }, #endif #ifdef _SC_THREAD_PROCESS_SHARED { "_SC_THREAD_PROCESS_SHARED", _SC_THREAD_PROCESS_SHARED }, #endif #ifdef _SC_XOPEN_LEGACY { "_SC_XOPEN_LEGACY", _SC_XOPEN_LEGACY }, #endif #ifdef _SC_XOPEN_REALTIME { "_SC_XOPEN_REALTIME", _SC_XOPEN_REALTIME }, #endif #ifdef _SC_XOPEN_REALTIME_THREADS { "_SC_XOPEN_REALTIME_THREADS", _SC_XOPEN_REALTIME_THREADS }, #endif #ifdef _SC_XBS5_ILP32_OFF32 { "_SC_XBS5_ILP32_OFF32", _SC_XBS5_ILP32_OFF32 }, #endif #ifdef _SC_XBS5_ILP32_OFFBIG { "_SC_XBS5_ILP32_OFFBIG", _SC_XBS5_ILP32_OFFBIG }, #endif #ifdef _SC_XBS5_LP64_OFF64 { "_SC_XBS5_LP64_OFF64", _SC_XBS5_LP64_OFF64 }, #endif #ifdef _SC_XBS5_LPBIG_OFFBIG { "_SC_XBS5_LPBIG_OFFBIG", _SC_XBS5_LPBIG_OFFBIG }, #endif #ifdef _SC_EQUIV_CLASS_MAX { "_SC_EQUIV_CLASS_MAX", _SC_EQUIV_CLASS_MAX }, #endif #ifdef _SC_CHARCLASS_NAME_MAX { "_SC_CHARCLASS_NAME_MAX", _SC_CHARCLASS_NAME_MAX }, #endif #ifdef _SC_PII { "_SC_PII", _SC_PII }, #endif #ifdef _SC_PII_XTI { "_SC_PII_XTI", _SC_PII_XTI }, #endif #ifdef _SC_PII_SOCKET { "_SC_PII_SOCKET", _SC_PII_SOCKET }, #endif #ifdef _SC_PII_INTERNET { "_SC_PII_INTERNET", _SC_PII_INTERNET }, #endif #ifdef _SC_PII_OSI { "_SC_PII_OSI", _SC_PII_OSI }, #endif #ifdef _SC_POLL { "_SC_POLL", _SC_POLL }, #endif #ifdef _SC_SELECT { "_SC_SELECT", _SC_SELECT }, #endif #ifdef _SC_UIO_MAXIOV { "_SC_UIO_MAXIOV", _SC_UIO_MAXIOV }, #endif #ifdef _SC_PII_INTERNET_STREAM { "_SC_PII_INTERNET_STREAM", _SC_PII_INTERNET_STREAM }, #endif #ifdef _SC_PII_INTERNET_DGRAM { "_SC_PII_INTERNET_DGRAM", _SC_PII_INTERNET_DGRAM }, #endif #ifdef _SC_PII_OSI_COTS { "_SC_PII_OSI_COTS", _SC_PII_OSI_COTS }, #endif #ifdef _SC_PII_OSI_CLTS { "_SC_PII_OSI_CLTS", _SC_PII_OSI_CLTS }, #endif #ifdef _SC_PII_OSI_M { "_SC_PII_OSI_M", _SC_PII_OSI_M }, #endif #ifdef _SC_T_IOV_MAX { "_SC_T_IOV_MAX", _SC_T_IOV_MAX }, #endif #ifdef _SC_THREADS { "_SC_THREADS", _SC_THREADS }, #endif #ifdef _SC_THREAD_SAFE_FUNCTIONS { "_SC_THREAD_SAFE_FUNCTIONS", _SC_THREAD_SAFE_FUNCTIONS }, #endif #ifdef _SC_TTY_NAME_MAX { "_SC_TTY_NAME_MAX", _SC_TTY_NAME_MAX }, #endif #ifdef _SC_XOPEN_XPG2 { "_SC_XOPEN_XPG2", _SC_XOPEN_XPG2 }, #endif #ifdef _SC_XOPEN_XPG3 { "_SC_XOPEN_XPG3", _SC_XOPEN_XPG3 }, #endif #ifdef _SC_XOPEN_XPG4 { "_SC_XOPEN_XPG4", _SC_XOPEN_XPG4 }, #endif #ifdef _SC_CHAR_BIT { "_SC_CHAR_BIT", _SC_CHAR_BIT }, #endif #ifdef _SC_CHAR_MAX { "_SC_CHAR_MAX", _SC_CHAR_MAX }, #endif #ifdef _SC_CHAR_MIN { "_SC_CHAR_MIN", _SC_CHAR_MIN }, #endif #ifdef _SC_INT_MAX { "_SC_INT_MAX", _SC_INT_MAX }, #endif #ifdef _SC_INT_MIN { "_SC_INT_MIN", _SC_INT_MIN }, #endif #ifdef _SC_LONG_BIT { "_SC_LONG_BIT", _SC_LONG_BIT }, #endif #ifdef _SC_WORD_BIT { "_SC_WORD_BIT", _SC_WORD_BIT }, #endif #ifdef _SC_MB_LEN_MAX { "_SC_MB_LEN_MAX", _SC_MB_LEN_MAX }, #endif #ifdef _SC_NZERO { "_SC_NZERO", _SC_NZERO }, #endif #ifdef _SC_SSIZE_MAX { "_SC_SSIZE_MAX", _SC_SSIZE_MAX }, #endif #ifdef _SC_SCHAR_MAX { "_SC_SCHAR_MAX", _SC_SCHAR_MAX }, #endif #ifdef _SC_SCHAR_MIN { "_SC_SCHAR_MIN", _SC_SCHAR_MIN }, #endif #ifdef _SC_SHRT_MAX { "_SC_SHRT_MAX", _SC_SHRT_MAX }, #endif #ifdef _SC_SHRT_MIN { "_SC_SHRT_MIN", _SC_SHRT_MIN }, #endif #ifdef _SC_UCHAR_MAX { "_SC_UCHAR_MAX", _SC_UCHAR_MAX }, #endif #ifdef _SC_UINT_MAX { "_SC_UINT_MAX", _SC_UINT_MAX }, #endif #ifdef _SC_ULONG_MAX { "_SC_ULONG_MAX", _SC_ULONG_MAX }, #endif #ifdef _SC_USHRT_MAX { "_SC_USHRT_MAX", _SC_USHRT_MAX }, #endif #ifdef _SC_NL_ARGMAX { "_SC_NL_ARGMAX", _SC_NL_ARGMAX }, #endif #ifdef _SC_NL_LANGMAX { "_SC_NL_LANGMAX", _SC_NL_LANGMAX }, #endif #ifdef _SC_NL_MSGMAX { "_SC_NL_MSGMAX", _SC_NL_MSGMAX }, #endif #ifdef _SC_NL_NMAX { "_SC_NL_NMAX", _SC_NL_NMAX }, #endif #ifdef _SC_NL_SETMAX { "_SC_NL_SETMAX", _SC_NL_SETMAX }, #endif }; static Handle getSysConf(TaskData *taskData, Handle args) { char argName[200]; int length; unsigned i; long res; length = Poly_string_to_C(DEREFWORD(args), argName, 200); if (length > 200) raise_syscall(taskData, "Argument name too long", ENAMETOOLONG); for (i = 0; i < sizeof(sysArgTable)/sizeof(sysArgTable[0]); i++) { if (strcmp(argName, sysArgTable[i].saName) == 0) break; /* See if it matches without the _SC_ at the beginning. */ if (strcmp(argName, sysArgTable[i].saName+4) == 0) break; } if (i == sizeof(sysArgTable)/sizeof(sysArgTable[0])) raise_syscall(taskData, "sysconf argument not found", EINVAL); errno = 0; /* Sysconf may return -1 without updating errno. */ res = sysconf(sysArgTable[i].saVal); if (res < 0) raise_syscall(taskData, "sysconf failed", errno); return Make_fixed_precision(taskData, (POLYUNSIGNED)res); } static struct { const char *pcName; int pcVal; } pathConfTable[] = { { "_PC_LINK_MAX", _PC_LINK_MAX }, { "_PC_MAX_CANON", _PC_MAX_CANON }, { "_PC_MAX_INPUT", _PC_MAX_INPUT }, { "_PC_NAME_MAX", _PC_NAME_MAX }, { "_PC_PATH_MAX", _PC_PATH_MAX }, { "_PC_PIPE_BUF", _PC_PIPE_BUF }, { "_PC_NO_TRUNC", _PC_NO_TRUNC }, { "_PC_VDISABLE", _PC_VDISABLE }, { "_PC_CHOWN_RESTRICTED", _PC_CHOWN_RESTRICTED }, #ifdef _PC_ASYNC_IO { "_PC_ASYNC_IO", _PC_ASYNC_IO }, #endif #ifdef _PC_PRIO_IO { "_PC_PRIO_IO", _PC_PRIO_IO }, #endif #ifdef _PC_SYNC_IO { "_PC_SYNC_IO", _PC_SYNC_IO }, #endif #ifdef _PC_FILESIZEBITS { "_PC_FILESIZEBITS", _PC_FILESIZEBITS }, #endif #ifdef _PC_SOCK_MAXBUF { "_PC_SOCK_MAXBUF", _PC_SOCK_MAXBUF }, #endif }; /* Look up a path variable in the table. */ static int findPathVar(TaskData *taskData, PolyWord ps) { char argName[200]; int length; unsigned i; length = Poly_string_to_C(ps, argName, 200); if (length > 200) raise_syscall(taskData, "Argument name too long", ENAMETOOLONG); for (i = 0; i < sizeof(pathConfTable)/sizeof(pathConfTable[0]); i++) { if (strcmp(argName, pathConfTable[i].pcName) == 0) return pathConfTable[i].pcVal; /* See if it matches without the _PC_ at the beginning. */ if (strcmp(argName, pathConfTable[i].pcName+4) == 0) return pathConfTable[i].pcVal; } raise_syscall(taskData, "pathconf argument not found", EINVAL); } struct _entrypts osSpecificEPT[] = { { "PolyGetOSType", (polyRTSFunction)&PolyGetOSType}, { "PolyOSSpecificGeneral", (polyRTSFunction)&PolyOSSpecificGeneral}, - + { "PolyPosixSleep", (polyRTSFunction)&PolyPosixSleep}, + { NULL, NULL} // End of list. }; class UnixSpecific: public RtsModule { public: virtual void Init(void); }; // Declare this. It will be automatically added to the table. static UnixSpecific unixModule; void UnixSpecific::Init(void) { struct sigaction sigcatch; /* Ignore SIGPIPE - return any errors as failure to write. */ memset(&sigcatch, 0, sizeof(sigcatch)); sigcatch.sa_handler = SIG_IGN; sigaction(SIGPIPE, &sigcatch, NULL); } diff --git a/libpolyml/winbasicio.cpp b/libpolyml/winbasicio.cpp index 8c87b4b3..d3617fd9 100644 --- a/libpolyml/winbasicio.cpp +++ b/libpolyml/winbasicio.cpp @@ -1,1399 +1,1439 @@ /* Title: Basic IO for Windows. Copyright (c) 2000, 2015-2019 David C. J. Matthews This was split from the common code for Unix and Windows. Portions of this code are derived from the original stream io package copyright CUTS 1983-2000. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_STAT_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_SIGNAL_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_ALLOCA_H #include #endif #ifdef HAVE_IO_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_SYS_IOCTL_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_POLL_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_SYS_SELECT_H #include #endif #ifdef HAVE_MALLOC_H #include #endif #ifdef HAVE_DIRECT_H #include #endif #ifdef HAVE_STDIO_H #include #endif #include #include #include #ifndef INFTIM #define INFTIM (-1) #endif #include #include "globals.h" #include "basicio.h" #include "sys.h" #include "gc.h" #include "run_time.h" #include "machine_dep.h" #include "arb.h" #include "processes.h" #include "diagnostics.h" #include "io_internal.h" #include "scanaddrs.h" #include "polystring.h" #include "mpoly.h" #include "save_vec.h" #include "rts_module.h" #include "locking.h" #include "rtsentry.h" #include "timing.h" #include "winstartup.h" #define NOMEMORY ERROR_NOT_ENOUGH_MEMORY #define STREAMCLOSED ERROR_INVALID_HANDLE #define FILEDOESNOTEXIST ERROR_FILE_NOT_FOUND #define ERRORNUMBER _doserrno #ifndef O_ACCMODE #define O_ACCMODE (O_RDONLY|O_RDWR|O_WRONLY) #endif #define SAVE(x) taskData->saveVec.push(x) #ifdef _MSC_VER // Don't tell me about ISO C++ changes. #pragma warning(disable:4996) #endif extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyChDir(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyBasicIOGeneral(PolyObject *threadId, PolyWord code, PolyWord strm, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyChDir(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyBasicIOGeneral(FirstArgument threadId, PolyWord code, PolyWord strm, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(FirstArgument threadId, PolyWord streamVec, PolyWord bitVec, PolyWord maxMillisecs); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTestForInput(FirstArgument threadId, PolyWord strm, PolyWord waitMillisecs); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTestForOutput(FirstArgument threadId, PolyWord strm, PolyWord waitMillisecs); } // References to the standard streams. They are only needed if we are compiling // the basis library and make a second call to get the standard streams. static PolyObject *standardInputValue, *standardOutputValue, *standardErrorValue; // Creates a new unique pipename in the appropriate format. // Utility function provided for winguiconsole and windows_specific void newPipeName(TCHAR *pipeName) { static LONG pipenum = 0; wsprintf(pipeName, _T("\\\\.\\Pipe\\PolyPipe.%08x.%08x"), GetCurrentProcessId(), InterlockedIncrement(&pipenum)); } int WinStream::fileTypeOfHandle(HANDLE hStream) { switch (GetFileType(hStream)) { case FILE_TYPE_PIPE: return FILEKIND_PIPE; case FILE_TYPE_CHAR: return FILEKIND_TTY;// Or a device? case FILE_TYPE_DISK: return FILEKIND_FILE; default: if (GetLastError() == 0) return FILEKIND_UNKNOWN; // Error or unknown. else return FILEKIND_ERROR; } } +void WinStream::unimplemented(TaskData *taskData) +{ + // Called on the random access functions + raise_syscall(taskData, "Position error", ERROR_NOT_SUPPORTED); +} + +// Backwards compatibility. This should now be done in ML. void WinStream::waitUntilAvailable(TaskData *taskData) { - while (!isAvailable(taskData)) + while (!testForInput(taskData, 1000)) { - WaitHandle waiter(NULL); - processes->ThreadPauseForIO(taskData, &waiter); } } void WinStream::waitUntilOutputPossible(TaskData *taskData) { - while (!canOutput(taskData)) + while (!testForOutput(taskData, 1000)) { - // Use the default waiter for the moment since we don't have - // one to test for output. - processes->ThreadPauseForIO(taskData, Waiter::defaultWaiter); } } -void WinStream::unimplemented(TaskData *taskData) -{ - // Called on the random access functions - raise_syscall(taskData, "Position error", ERROR_NOT_SUPPORTED); -} WinInOutStream::WinInOutStream() { hStream = hEvent = INVALID_HANDLE_VALUE; buffer = 0; currentInBuffer = currentPtr = 0; endOfStream = false; buffSize = 4096; // Seems like a good number ZeroMemory(&overlap, sizeof(overlap)); isText = false; isRead = true; } WinInOutStream::~WinInOutStream() { free(buffer); } void WinInOutStream::openFile(TaskData * taskData, TCHAR *name, openMode mode, bool isT) { isRead = mode == OPENREAD; isText = isT; ASSERT(hStream == INVALID_HANDLE_VALUE); // We should never reuse an object. buffer = (byte*)malloc(buffSize); if (buffer == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); // Create a manual reset event with state=signalled. This means // that no operation is in progress. hEvent = CreateEvent(NULL, TRUE, TRUE, NULL); overlap.hEvent = hEvent; switch (mode) { case OPENREAD: hStream = CreateFile(name, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, NULL); break; case OPENWRITE: hStream = CreateFile(name, GENERIC_WRITE, FILE_SHARE_READ, NULL, CREATE_ALWAYS, FILE_FLAG_OVERLAPPED, NULL); break; case OPENAPPEND: hStream = CreateFile(name, GENERIC_WRITE, FILE_SHARE_READ, NULL, OPEN_ALWAYS, FILE_FLAG_OVERLAPPED, NULL); break; } if (hStream == INVALID_HANDLE_VALUE) raise_syscall(taskData, "CreateFile failed", GetLastError()); // Start a read immediately so that there is something in the buffer. switch (mode) { case OPENREAD: if(!beginReading()) raise_syscall(taskData, "Read failure", GetLastError()); break; case OPENWRITE: break; case OPENAPPEND: { // We could use the special 0xfff... value in the overlapped structure for this // but that would mess up getPos/endPos. LARGE_INTEGER fileSize; if (!GetFileSizeEx(hStream, &fileSize)) raise_syscall(taskData, "Stream is not a file", GetLastError()); setOverlappedPos(fileSize.QuadPart); } break; } } // This is only used to set up standard output. // Now also used for Windows.execute. bool WinInOutStream::openHandle(HANDLE hndl, openMode mode, bool isT) { // Need to check the handle. It seems DuplicateHandle actually allows an invalid handle if (hndl == INVALID_HANDLE_VALUE) { SetLastError(ERROR_INVALID_HANDLE); return false; } isRead = mode == OPENREAD; isText = isT; ASSERT(hStream == INVALID_HANDLE_VALUE); // We should never reuse an object. buffer = (byte*)malloc(buffSize); if (buffer == 0) { SetLastError(NOMEMORY); return false; } hEvent = CreateEvent(NULL, TRUE, TRUE, NULL); overlap.hEvent = hEvent; // Duplicate the handle so we can safely close it. if (!DuplicateHandle(GetCurrentProcess(), hndl, GetCurrentProcess(), &hStream, 0, FALSE, DUPLICATE_SAME_ACCESS)) return false; if (isRead) return beginReading(); return true; } // Start reading. This may complete immediately. bool WinInOutStream::beginReading() { if (!ReadFile(hStream, buffer, buffSize, NULL, &overlap)) { switch (GetLastError()) { case ERROR_HANDLE_EOF: // We get ERROR_BROKEN_PIPE as EOF on a pipe. case ERROR_BROKEN_PIPE: endOfStream = true; case ERROR_IO_PENDING: return true; default: return false; } } return true; } void WinInOutStream::closeEntry(TaskData *taskData) { if (isRead) { if (WaitForSingleObject(hEvent, 0) == WAIT_TIMEOUT) // Something is in progress. CancelIoEx(hStream, &overlap); } else flushOut(taskData); PLocker locker(&lock); if (!CloseHandle(hStream)) raise_syscall(taskData, "CloseHandle failed", GetLastError()); hStream = INVALID_HANDLE_VALUE; CloseHandle(hEvent); hEvent = INVALID_HANDLE_VALUE; } // Make sure that everything has been written. void WinInOutStream::flushOut(TaskData *taskData) { while (currentInBuffer != 0) { // If currentInBuffer is not zero we have an operation in progress. waitUntilOutputPossible(taskData); // canOutput will test the result and may update currentInBuffer. // We may not have written everything so check and repeat if necessary. if (currentInBuffer != 0) writeStream(taskData, NULL, 0); } } size_t WinInOutStream::readStream(TaskData *taskData, byte *base, size_t length) { PLocker locker(&lock); if (endOfStream) return 0; size_t copied = 0; // Copy as much as we can from the buffer. while (currentPtr < currentInBuffer && copied < length) { byte b = buffer[currentPtr++]; // In text mode we want to return NL for CRNL. Assume that this is // properly formatted and simply skip CRs. It's not clear what to return // if it isn't properly formatted and the user can always open it as binary // and do the conversion. if (!isText || b != '\r') base[copied++] = b; } // If we have exhausted the buffer we start a new read. while (isText && currentPtr < currentInBuffer && buffer[currentPtr] == '\r') currentPtr++; if (currentInBuffer == currentPtr) { // We need to start a new read currentInBuffer = currentPtr = 0; if (!beginReading()) raise_syscall(taskData, "Read failure", GetLastError()); } return copied; } // This actually does most of the work. In particular for text streams we may have a // block that consists only of CRs. bool WinInOutStream::isAvailable(TaskData *taskData) { while (1) { { PLocker locker(&lock); // It is available if we have something in the buffer or we're at EOF if (currentInBuffer < currentPtr || endOfStream) return true; // We should have had a read in progress. DWORD bytesRead = 0; if (!GetOverlappedResult(hStream, &overlap, &bytesRead, FALSE)) { DWORD err = GetLastError(); switch (err) { case ERROR_HANDLE_EOF: case ERROR_BROKEN_PIPE: // We've had EOF - That result is available endOfStream = true; return true; case ERROR_IO_INCOMPLETE: // It's still in progress. return false; default: raise_syscall(taskData, "GetOverlappedResult failed", err); } } // The next read must be after this. setOverlappedPos(getOverlappedPos() + bytesRead); currentInBuffer = bytesRead; // If this is a text stream skip CRs. while (isText && currentPtr < currentInBuffer && buffer[currentPtr] == '\r') currentPtr++; // If we have some real data it can be read now if (currentPtr < currentInBuffer) return true; } // Try again. if (!beginReading()) // And loop raise_syscall(taskData, "Read failure", GetLastError()); } } -void WinInOutStream::waitUntilAvailable(TaskData *taskData) +bool WinInOutStream::testForInput(TaskData *taskData, unsigned waitMilliSecs) { - while (!isAvailable(taskData)) + if (isAvailable(taskData)) return true; + if (waitMilliSecs != 0) { - WaitHandle waiter(hEvent); + WaitHandle waiter(hEvent, waitMilliSecs); processes->ThreadPauseForIO(taskData, &waiter); } + return false; } int WinInOutStream::poll(TaskData *taskData, int test) { if (test & POLL_BIT_IN) { - if (isAvailable(taskData)) + if (testForInput(taskData, 0)) return POLL_BIT_IN; } if (test & POLL_BIT_OUT) { - if (canOutput(taskData)) + if (testForOutput(taskData, 0)) return POLL_BIT_OUT; } return 0; } // Random access functions uint64_t WinInOutStream::getPos(TaskData *taskData) { if (GetFileType(hStream) != FILE_TYPE_DISK) raise_syscall(taskData, "Stream is not a file", ERROR_SEEK_ON_DEVICE); PLocker locker(&lock); if (isRead) return getOverlappedPos() - currentInBuffer + currentPtr; else return getOverlappedPos() + currentInBuffer; } void WinInOutStream::setPos(TaskData *taskData, uint64_t pos) { if (GetFileType(hStream) != FILE_TYPE_DISK) raise_syscall(taskData, "Stream is not a file", ERROR_SEEK_ON_DEVICE); // Need to wait until any pending operation is complete. If this is a write // we need to flush anything before changing the position. if (isRead) { - while (WaitForSingleObject(hEvent, 0) == WAIT_TIMEOUT) { - WaitHandle waiter(hEvent); + WaitHandle waiter(hEvent, 1000); processes->ThreadPauseForIO(taskData, &waiter); } } else flushOut(taskData); PLocker locker(&lock); setOverlappedPos(pos); // Discard any unread data and start reading at the new position. currentInBuffer = currentPtr = 0; endOfStream = false; if (isRead && !beginReading()) raise_syscall(taskData, "Read failure", GetLastError()); } uint64_t WinInOutStream::fileSize(TaskData *taskData) { LARGE_INTEGER fileSize; if (!GetFileSizeEx(hStream, &fileSize)) raise_syscall(taskData, "Stream is not a file", GetLastError()); return fileSize.QuadPart; } - bool WinInOutStream::canOutput(TaskData *taskData) { if (isRead) unimplemented(taskData); PLocker locker(&lock); // If the buffer is empty we're fine. if (currentInBuffer == 0) return true; // Otherwise there is an operation in progress. Has it finished? DWORD bytesWritten = 0; if (!GetOverlappedResult(hStream, &overlap, &bytesWritten, FALSE)) { DWORD err = GetLastError(); if (err == ERROR_IO_INCOMPLETE) return false; else raise_syscall(taskData, "GetOverlappedResult failed", err); } setOverlappedPos(getOverlappedPos() + bytesWritten); // If we haven't written everything copy down what we have left. if (bytesWritten < currentInBuffer) memmove(buffer, buffer + bytesWritten, currentInBuffer - bytesWritten); currentInBuffer -= bytesWritten; // This will then be written before anything else. return true; } -void WinInOutStream::waitUntilOutputPossible(TaskData *taskData) +bool WinInOutStream::testForOutput(TaskData *taskData, unsigned waitMilliSecs) { - if (isRead) - unimplemented(taskData); - - while (!canOutput(taskData)) + if (canOutput(taskData)) return true; + if (waitMilliSecs != 0) { - WaitHandle waiter(hEvent); + WaitHandle waiter(hEvent, waitMilliSecs); processes->ThreadPauseForIO(taskData, &waiter); } + return false; } // Write data. N.B. This is also used with zero data from closeEntry. size_t WinInOutStream::writeStream(TaskData *taskData, byte *base, size_t length) { if (isRead) unimplemented(taskData); PLocker locker(&lock); // Copy as much as we can into the buffer. size_t copied = 0; while (currentInBuffer < buffSize && copied < length) { if (isText && base[copied] == '\n') { // Put in a CR but make sure we've space for both. if (currentInBuffer == buffSize - 1) break; // Exit the loop with what we've done. buffer[currentInBuffer++] = '\r'; } buffer[currentInBuffer++] = base[copied++]; } // Write what's in the buffer. if (!WriteFile(hStream, buffer, currentInBuffer, NULL, &overlap)) { DWORD dwErr = GetLastError(); if (dwErr != ERROR_IO_PENDING) raise_syscall(taskData, "WriteFile failed", dwErr); } // Even if it actually succeeded we still pick up the result in canOutput. return copied; // Return what we copied. } /* Open a file in the required mode. */ static Handle openWinFile(TaskData *taskData, Handle filename, openMode mode, bool isAppend, bool isBinary) { TempString cFileName(filename->Word()); // Get file name if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); try { WinInOutStream *stream = new WinInOutStream(); stream->openFile(taskData, cFileName, mode, !isBinary); return MakeVolatileWord(taskData, stream); } catch (std::bad_alloc&) { raise_syscall(taskData, "Insufficient memory", NOMEMORY); } } /* Read into an array. */ // We can't combine readArray and readString because we mustn't compute the // destination of the data in readArray until after any GC. static Handle readArray(TaskData *taskData, Handle stream, Handle args, bool/*isText*/) { WinStream *strm = *(WinStream**)(stream->WordP()); if (strm == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); /* The isText argument is ignored in both Unix and Windows but is provided for future use. Windows remembers the mode used when the file was opened to determine whether to translate CRLF into LF. */ // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); // First test to see if we have input available. // These tests may result in a GC if another thread is running. strm->waitUntilAvailable(taskData); // We can now try to read without blocking. // Actually there's a race here in the unlikely situation that there // are multiple threads sharing the same low-level reader. They could // both detect that input is available but only one may succeed in // reading without blocking. This doesn't apply where the threads use // the higher-level IO interfaces in ML which have their own mutexes. byte *base = DEREFHANDLE(args)->Get(0).AsObjPtr()->AsBytePtr(); POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(1)); size_t length = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(2)); size_t haveRead = strm->readStream(taskData, base + offset, length); return Make_fixed_precision(taskData, haveRead); // Success. } /* Return input as a string. We don't actually need both readArray and readString but it's useful to have both to reduce unnecessary garbage. The IO library will construct one from the other but the higher levels choose the appropriate function depending on need. */ static Handle readString(TaskData *taskData, Handle stream, Handle args, bool/*isText*/) { size_t length = getPolyUnsigned(taskData, DEREFWORD(args)); WinStream *strm = *(WinStream**)(stream->WordP()); if (strm == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); // First test to see if we have input available. // These tests may result in a GC if another thread is running. strm->waitUntilAvailable(taskData); // We can now try to read without blocking. // We previously allocated the buffer on the stack but that caused // problems with multi-threading at least on Mac OS X because of // stack exhaustion. We limit the space to 100k. */ if (length > 102400) length = 102400; byte *buff = (byte*)malloc(length); if (buff == 0) raise_syscall(taskData, "Unable to allocate buffer", NOMEMORY); try { size_t haveRead = strm->readStream(taskData, buff, length); Handle result = SAVE(C_string_to_Poly(taskData, (char*)buff, haveRead)); free(buff); return result; } catch (...) { free(buff); throw; } } static Handle writeArray(TaskData *taskData, Handle stream, Handle args, bool/*isText*/) { // The isText argument is ignored in both Unix and Windows but // is provided for future use. Windows remembers the mode used // when the file was opened to determine whether to translate // LF into CRLF. WinStream *strm = *(WinStream**)(stream->WordP()); if (strm == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); strm->waitUntilOutputPossible(taskData); PolyWord base = DEREFWORDHANDLE(args)->Get(0); POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(1)); size_t length = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(2)); /* We don't actually handle cases of blocking on output. */ byte *toWrite = base.AsObjPtr()->AsBytePtr(); size_t haveWritten = strm->writeStream(taskData, toWrite + offset, length); return Make_fixed_precision(taskData, haveWritten); } Handle pollTest(TaskData *taskData, Handle stream) { WinStream *strm = *(WinStream**)(stream->WordP()); return Make_fixed_precision(taskData, strm->pollTest()); } -// Do the polling. Takes a vector of io descriptors, a vector of bits to test +// Poll file descriptors. Also used with empty descriptors as OS.Process.sleep. +// Takes a vector of io descriptors, a vector of bits to test // and a time to wait and returns a vector of results. - // Windows: This is messy because "select" only works on sockets. // Do the best we can. -static Handle pollDescriptors(TaskData *taskData, Handle args, int blockType) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(FirstArgument threadId, PolyWord streamVector, PolyWord bitVector, PolyWord maxMillisecs) { - Handle hSave = taskData->saveVec.mark(); -TryAgain: - PolyObject *strmVec = DEREFHANDLE(args)->Get(0).AsObjPtr(); - PolyObject *bitVec = DEREFHANDLE(args)->Get(1).AsObjPtr(); - POLYUNSIGNED nDesc = strmVec->Length(); - ASSERT(nDesc == bitVec->Length()); - // We should check for interrupts even if we're not going to block. - processes->TestAnyEvents(taskData); + TaskData *taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + unsigned maxMilliseconds = (unsigned)maxMillisecs.UnTaggedUnsigned(); + Handle result = 0; - /* Simply do a non-blocking poll. */ - /* Record the results in this vector. */ - char *results = 0; - bool haveResult = false; - Handle resVec; - if (nDesc > 0) - { - results = (char*)alloca(nDesc); - memset(results, 0, nDesc); - } + try { + PolyObject *strmVec = streamVector.AsObjPtr(); + PolyObject *bitVec = bitVector.AsObjPtr(); + POLYUNSIGNED nDesc = strmVec->Length(); + ASSERT(nDesc == bitVec->Length()); + // We should check for interrupts even if we're not going to block. + processes->TestAnyEvents(taskData); - for (POLYUNSIGNED i = 0; i < nDesc; i++) - { - WinStream *strm = *(WinStream**)(strmVec->Get(i).AsObjPtr()); - if (strm == NULL) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); - int bits = get_C_int(taskData, bitVec->Get(i)); - results[i] = strm->poll(taskData, bits); - if (results[i] != 0) - haveResult = true; - } - if (haveResult == 0) - { - /* Poll failed - treat as time out. */ - switch (blockType) + /* Simply do a non-blocking poll. */ + /* Record the results in this vector. */ + char *results = 0; + bool haveResult = false; + if (nDesc > 0) { - case 0: /* Check the time out. */ + results = (char*)alloca(nDesc); + memset(results, 0, nDesc); + } + + for (POLYUNSIGNED i = 0; i < nDesc; i++) { - Handle hSave = taskData->saveVec.mark(); - /* The time argument is an absolute time. */ - FILETIME ftTime, ftNow; - /* Get the file time. */ - getFileTimeFromArb(taskData, taskData->saveVec.push(DEREFHANDLE(args)->Get(2)), &ftTime); - GetSystemTimeAsFileTime(&ftNow); - taskData->saveVec.reset(hSave); - /* If the timeout time is earlier than the current time - we must return, otherwise we block. */ - if (CompareFileTime(&ftTime, &ftNow) <= 0) - break; /* Return the empty set. */ - /* else drop through and block. */ + WinStream *strm = *(WinStream**)(strmVec->Get(i).AsObjPtr()); + if (strm == NULL) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); + int bits = get_C_int(taskData, bitVec->Get(i)); + results[i] = strm->poll(taskData, bits); + if (results[i] != 0) + haveResult = true; } - case 1: /* Block until one of the descriptors is ready. */ - processes->ThreadPause(taskData); - taskData->saveVec.reset(hSave); - goto TryAgain; - /*NOTREACHED*/ - case 2: /* Just a simple poll - drop through. */ - break; + if (haveResult == 0 && maxMilliseconds != 0) + { + /* Poll failed - treat as time out. */ + WaitHandle waiter(NULL, maxMilliseconds); + processes->ThreadPauseForIO(taskData, &waiter); } + /* Copy the results to a result vector. */ + result = alloc_and_save(taskData, nDesc); + for (POLYUNSIGNED j = 0; j < nDesc; j++) + (DEREFWORDHANDLE(result))->Set(j, TAGGED(results[j])); } - /* Copy the results to a result vector. */ - resVec = alloc_and_save(taskData, nDesc); - for (POLYUNSIGNED j = 0; j < nDesc; j++) - (DEREFWORDHANDLE(resVec))->Set(j, TAGGED(results[j])); - return resVec; + catch (KillException &) { + processes->ThreadExit(taskData); // TestAnyEvents may test for kill + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); } // Directory functions. class WinDirData { public: HANDLE hFind; /* FindFirstFile handle */ WIN32_FIND_DATA lastFind; int fFindSucceeded; }; static Handle openDirectory(TaskData *taskData, Handle dirname) { // Get the directory name but add on two characters for the \* plus one for the NULL. POLYUNSIGNED length = PolyStringLength(dirname->Word()); TempString dirName((TCHAR*)malloc((length + 3) * sizeof(TCHAR))); if (dirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); Poly_string_to_C(dirname->Word(), dirName, length + 2); // Tack on \* to the end so that we find all files in the directory. lstrcat(dirName, _T("\\*")); WinDirData *pData = new WinDirData; // TODO: Handle failue HANDLE hFind = FindFirstFile(dirName, &pData->lastFind); if (hFind == INVALID_HANDLE_VALUE) raise_syscall(taskData, "FindFirstFile failed", GetLastError()); pData->hFind = hFind; /* There must be at least one file which matched. */ pData->fFindSucceeded = 1; return MakeVolatileWord(taskData, pData); } /* Return the next entry from the directory, ignoring current and parent arcs ("." and ".." in Windows and Unix) */ Handle readDirectory(TaskData *taskData, Handle stream) { WinDirData *pData = *(WinDirData**)(stream->WordP()); // In a Volatile if (pData == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); Handle result = NULL; // The next entry to read is already in the buffer. FindFirstFile // both opens the directory and returns the first entry. If // fFindSucceeded is false we have already reached the end. if (!pData->fFindSucceeded) return SAVE(EmptyString(taskData)); while (result == NULL) { WIN32_FIND_DATA *pFind = &(pData->lastFind); if (!((pFind->dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) && (lstrcmp(pFind->cFileName, _T(".")) == 0 || lstrcmp(pFind->cFileName, _T("..")) == 0))) { result = SAVE(C_string_to_Poly(taskData, pFind->cFileName)); } /* Get the next entry. */ if (!FindNextFile(pData->hFind, pFind)) { DWORD dwErr = GetLastError(); if (dwErr == ERROR_NO_MORE_FILES) { pData->fFindSucceeded = 0; if (result == NULL) return SAVE(EmptyString(taskData)); } } } return result; } Handle rewindDirectory(TaskData *taskData, Handle stream, Handle dirname) { WinDirData *pData = *(WinDirData**)(stream->WordP()); // In a SysWord if (pData == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); // There's no rewind - close and reopen. FindClose(pData->hFind); POLYUNSIGNED length = PolyStringLength(dirname->Word()); TempString dirName((TCHAR*)malloc((length + 3) * sizeof(TCHAR))); if (dirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); Poly_string_to_C(dirname->Word(), dirName, length + 2); // Tack on \* to the end so that we find all files in the directory. lstrcat(dirName, _T("\\*")); HANDLE hFind = FindFirstFile(dirName, &(pData->lastFind)); if (hFind == INVALID_HANDLE_VALUE) raise_syscall(taskData, "FindFirstFile failed", GetLastError()); pData->hFind = hFind; /* There must be at least one file which matched. */ pData->fFindSucceeded = 1; return Make_fixed_precision(taskData, 0); } static Handle closeDirectory(TaskData *taskData, Handle stream) { WinDirData *pData = *(WinDirData**)(stream->WordP()); // In a SysWord if (pData != 0) { FindClose(pData->hFind); delete(pData); *((WinDirData**)stream->WordP()) = 0; // Clear this - no longer valid } return Make_fixed_precision(taskData, 0); } /* change_dirc - this is called directly and not via the dispatch function. */ static Handle change_dirc(TaskData *taskData, Handle name) /* Change working directory. */ { TempString cDirName(name->Word()); if (cDirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (SetCurrentDirectory(cDirName) == FALSE) raise_syscall(taskData, "SetCurrentDirectory failed", GetLastError()); return SAVE(TAGGED(0)); } // External call -POLYUNSIGNED PolyChDir(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyChDir(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); try { (void)change_dirc(taskData, pushedArg); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); // Result is unit } /* Test for a directory. */ Handle isDir(TaskData *taskData, Handle name) { TempString cDirName(name->Word()); if (cDirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); DWORD dwRes = GetFileAttributes(cDirName); if (dwRes == 0xFFFFFFFF) raise_syscall(taskData, "GetFileAttributes failed", GetLastError()); if (dwRes & FILE_ATTRIBUTE_DIRECTORY) return Make_fixed_precision(taskData, 1); else return Make_fixed_precision(taskData, 0); } /* Get absolute canonical path name. */ Handle fullPath(TaskData *taskData, Handle filename) { TempString cFileName; /* Special case of an empty string. */ if (PolyStringLength(filename->Word()) == 0) cFileName = _tcsdup(_T(".")); else cFileName = Poly_string_to_T_alloc(filename->Word()); if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); // Get the length DWORD dwRes = GetFullPathName(cFileName, 0, NULL, NULL); if (dwRes == 0) raise_syscall(taskData, "GetFullPathName failed", GetLastError()); TempString resBuf((TCHAR*)malloc(dwRes * sizeof(TCHAR))); if (resBuf == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); // When the length is enough the result is the length excluding the null DWORD dwRes1 = GetFullPathName(cFileName, dwRes, resBuf, NULL); if (dwRes1 == 0 || dwRes1 >= dwRes) raise_syscall(taskData, "GetFullPathName failed", GetLastError()); /* Check that the file exists. GetFullPathName doesn't do that. */ dwRes = GetFileAttributes(resBuf); if (dwRes == 0xffffffff) raise_syscall(taskData, "File does not exist", FILEDOESNOTEXIST); return(SAVE(C_string_to_Poly(taskData, resBuf))); } /* Get file modification time. This returns the value in the time units and from the base date used by timing.c. c.f. filedatec */ Handle modTime(TaskData *taskData, Handle filename) { TempString cFileName(filename->Word()); if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); /* There are two ways to get this information. We can either use GetFileTime if we are able to open the file for reading but if it is locked we won't be able to. FindFirstFile is the other alternative. We have to check that the file name does not contain '*' or '?' otherwise it will try to "glob" this, which isn't what we want here. */ WIN32_FIND_DATA wFind; HANDLE hFind; const TCHAR *p; for(p = cFileName; *p; p++) if (*p == '*' || *p == '?') raise_syscall(taskData, "Invalid filename", STREAMCLOSED); hFind = FindFirstFile(cFileName, &wFind); if (hFind == INVALID_HANDLE_VALUE) raise_syscall(taskData, "FindFirstFile failed", GetLastError()); FindClose(hFind); return Make_arb_from_Filetime(taskData, wFind.ftLastWriteTime); } /* Get file size. */ Handle fileSize(TaskData *taskData, Handle filename) { TempString cFileName(filename->Word()); if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); /* Similar to modTime*/ WIN32_FIND_DATA wFind; HANDLE hFind; const TCHAR *p; for(p = cFileName; *p; p++) if (*p == '*' || *p == '?') raise_syscall(taskData, "Invalid filename", STREAMCLOSED); hFind = FindFirstFile(cFileName, &wFind); if (hFind == INVALID_HANDLE_VALUE) raise_syscall(taskData, "FindFirstFile failed", GetLastError()); FindClose(hFind); return Make_arb_from_32bit_pair(taskData, wFind.nFileSizeHigh, wFind.nFileSizeLow); } /* Set file modification and access times. */ Handle setTime(TaskData *taskData, Handle fileName, Handle fileTime) { TempString cFileName(fileName->Word()); if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); // The only way to set the time is to open the file and use SetFileTime. FILETIME ft; /* Get the file time. */ getFileTimeFromArb(taskData, fileTime, &ft); /* Open an existing file with write access. We need that for SetFileTime. */ HANDLE hFile = CreateFile(cFileName, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (hFile == INVALID_HANDLE_VALUE) raise_syscall(taskData, "CreateFile failed", GetLastError()); /* Set the file time. */ if (!SetFileTime(hFile, NULL, &ft, &ft)) { int nErr = GetLastError(); CloseHandle(hFile); raise_syscall(taskData, "SetFileTime failed", nErr); } CloseHandle(hFile); return Make_fixed_precision(taskData, 0); } /* Rename a file. */ Handle renameFile(TaskData *taskData, Handle oldFileName, Handle newFileName) { TempString oldName(oldFileName->Word()), newName(newFileName->Word()); if (oldName == 0 || newName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (! MoveFileEx(oldName, newName, MOVEFILE_REPLACE_EXISTING)) raise_syscall(taskData, "MoveFileEx failed", GetLastError()); return Make_fixed_precision(taskData, 0); } /* Access right requests passed in from ML. */ #define FILE_ACCESS_READ 1 #define FILE_ACCESS_WRITE 2 #define FILE_ACCESS_EXECUTE 4 /* Get access rights to a file. */ Handle fileAccess(TaskData *taskData, Handle name, Handle rights) { TempString fileName(name->Word()); if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); int rts = get_C_int(taskData, DEREFWORD(rights)); /* Test whether the file is read-only. This is, of course, not what was asked but getting anything more is really quite complicated. I don't see how we can find out if a file is executable (maybe check if the extension is .exe, .com or .bat?). It would be possible, in NT, to examine the access structures but that seems far too complicated. Leave it for the moment. */ DWORD dwRes = GetFileAttributes(fileName); if (dwRes == 0xffffffff) return Make_fixed_precision(taskData, 0); /* If we asked for write access but it is read-only we return false. */ if ((dwRes & FILE_ATTRIBUTE_READONLY) && (rts & FILE_ACCESS_WRITE)) return Make_fixed_precision(taskData, 0); else return Make_fixed_precision(taskData, 1); } /* IO_dispatchc. Called from assembly code module. */ static Handle IO_dispatch_c(TaskData *taskData, Handle args, Handle strm, Handle code) { unsigned c = get_C_unsigned(taskData, DEREFWORD(code)); switch (c) { case 0: // Return standard input. // This and the next two are normally only called once during start-up. // The exception is when we build the basis library during bootstrap. // We need to maintain the invariant that each WinStream object is referenced // by precisely one volatile word in order to be able to delete it when we close it. { if (standardInputValue != 0) return taskData->saveVec.push(standardInputValue); Handle stdStrm = MakeVolatileWord(taskData, standardInput); standardInputValue = stdStrm->WordP(); return stdStrm; } case 1: // Return standard output { if (standardOutputValue != 0) return taskData->saveVec.push(standardOutputValue); Handle stdStrm = MakeVolatileWord(taskData, standardOutput); standardOutputValue = stdStrm->WordP(); return stdStrm; } case 2: // Return standard error { if (standardErrorValue != 0) return taskData->saveVec.push(standardErrorValue); Handle stdStrm = MakeVolatileWord(taskData, standardError); standardErrorValue = stdStrm->WordP(); return stdStrm; } case 3: /* Open file for text input. */ return openWinFile(taskData, args, OPENREAD, false, false); case 4: /* Open file for binary input. */ return openWinFile(taskData, args, OPENREAD, false, true); case 5: /* Open file for text output. */ return openWinFile(taskData, args, OPENWRITE, false, false); case 6: /* Open file for binary output. */ return openWinFile(taskData, args, OPENWRITE, false, true); case 13: /* Open text file for appending. */ /* The IO library definition leaves it open whether this should use "append mode" or not. */ return openWinFile(taskData, args, OPENWRITE, true, false); case 14: /* Open binary file for appending. */ return openWinFile(taskData, args, OPENWRITE, true, true); case 7: /* Close file */ { // During the bootstrap we will have old format references. if (strm->Word().IsTagged()) return Make_fixed_precision(taskData, 0); WinStream *stream = *(WinStream **)(strm->WordP()); // May already have been closed. if (stream != 0) { try { stream->closeEntry(taskData); delete(stream); *(WinStream **)(strm->WordP()) = 0; } catch (...) { // If there was an error and we've raised an exception. delete(stream); *(WinStream **)(strm->WordP()) = 0; throw; } } return Make_fixed_precision(taskData, 0); } case 8: /* Read text into an array. */ return readArray(taskData, strm, args, true); case 9: /* Read binary into an array. */ return readArray(taskData, strm, args, false); case 10: /* Get text as a string. */ return readString(taskData, strm, args, true); case 11: /* Write from memory into a text file. */ return writeArray(taskData, strm, args, true); case 12: /* Write from memory into a binary file. */ return writeArray(taskData, strm, args, false); case 15: /* Return recommended buffer size. */ // This is a guess but 4k seems reasonable. return Make_fixed_precision(taskData, 4096); case 16: /* See if we can get some input. */ { WinStream *stream = *(WinStream **)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); - return Make_fixed_precision(taskData, stream->isAvailable(taskData) ? 1 : 0); + return Make_fixed_precision(taskData, stream->testForInput(taskData, 0) ? 1 : 0); } case 17: // Return the number of bytes available. PrimIO.avail. { WinStream *stream = *(WinStream**)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); uint64_t endOfStream = stream->fileSize(taskData); // May raise an exception if this isn't a file. uint64_t current = stream->getPos(taskData); return Make_fixed_precision(taskData, endOfStream - current); } case 18: // Get position on stream. PrimIO.getPos { WinStream *stream = *(WinStream**)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); // Get the current position in the stream. This is used to test // for the availability of random access so it should raise an // exception if setFilePos or endFilePos would fail. return Make_arbitrary_precision(taskData, stream->getPos(taskData)); } case 19: // Seek to position on stream. PrimIO.setPos { WinStream *stream = *(WinStream**)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); // TODO: This doesn't necessarily return a 64-bit value. uint64_t position = (uint64_t)getPolyUnsigned(taskData, DEREFWORD(args)); stream->setPos(taskData, position); return Make_arbitrary_precision(taskData, 0); } case 20: // Return position at end of stream. PrimIO.endPos. { WinStream *stream = *(WinStream**)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); return Make_arbitrary_precision(taskData, stream->fileSize(taskData)); } case 21: /* Get the kind of device underlying the stream. */ { WinStream *stream = *(WinStream**)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); return Make_fixed_precision(taskData, stream->fileKind()); } case 22: /* Return the polling options allowed on this descriptor. */ return pollTest(taskData, strm); - case 23: /* Poll the descriptor, waiting forever. */ - return pollDescriptors(taskData, args, 1); - case 24: /* Poll the descriptor, waiting for the time requested. */ - return pollDescriptors(taskData, args, 0); - case 25: /* Poll the descriptor, returning immediately.*/ - return pollDescriptors(taskData, args, 2); +// case 23: /* Poll the descriptor, waiting forever. */ +// return pollDescriptors(taskData, args, 1); +// case 24: /* Poll the descriptor, waiting for the time requested. */ +// return pollDescriptors(taskData, args, 0); +// case 25: /* Poll the descriptor, returning immediately.*/ +// return pollDescriptors(taskData, args, 2); + case 26: /* Get binary as a vector. */ return readString(taskData, strm, args, false); case 27: /* Block until input is available. */ { WinStream *stream = *(WinStream **)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); stream->waitUntilAvailable(taskData); return Make_fixed_precision(taskData, 0); } case 28: /* Test whether output is possible. */ { WinStream *stream = *(WinStream **)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); - return Make_fixed_precision(taskData, stream->canOutput(taskData) ? 1 : 0); + return Make_fixed_precision(taskData, stream->testForOutput(taskData, 0) ? 1 : 0); } case 29: /* Block until output is possible. */ { WinStream *stream = *(WinStream **)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); stream->waitUntilOutputPossible(taskData); return Make_fixed_precision(taskData, 0); } /* Directory functions. */ case 50: /* Open a directory. */ return openDirectory(taskData, args); case 51: /* Read a directory entry. */ return readDirectory(taskData, strm); case 52: /* Close the directory */ return closeDirectory(taskData, strm); case 53: /* Rewind the directory. */ return rewindDirectory(taskData, strm, args); case 54: /* Get current working directory. */ { DWORD space = GetCurrentDirectory(0, NULL); if (space == 0) raise_syscall(taskData, "GetCurrentDirectory failed", GetLastError()); TempString buff((TCHAR*)malloc(space * sizeof(TCHAR))); if (buff == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (GetCurrentDirectory(space, buff) == 0) raise_syscall(taskData, "GetCurrentDirectory failed", GetLastError()); return SAVE(C_string_to_Poly(taskData, buff)); } case 55: /* Create a new directory. */ { TempString dirName(args->Word()); if (dirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (!CreateDirectory(dirName, NULL)) raise_syscall(taskData, "CreateDirectory failed", GetLastError()); return Make_fixed_precision(taskData, 0); } case 56: /* Delete a directory. */ { TempString dirName(args->Word()); if (dirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (!RemoveDirectory(dirName)) raise_syscall(taskData, "RemoveDirectory failed", GetLastError()); return Make_fixed_precision(taskData, 0); } case 57: /* Test for directory. */ return isDir(taskData, args); case 58: /* Test for symbolic link. */ { TempString fileName(args->Word()); if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); DWORD dwRes = GetFileAttributes(fileName); if (dwRes == 0xFFFFFFFF) raise_syscall(taskData, "GetFileAttributes failed", GetLastError()); return Make_fixed_precision(taskData, (dwRes & FILE_ATTRIBUTE_REPARSE_POINT) ? 1 : 0); } case 59: /* Read a symbolic link. */ { // Windows has added symbolic links but reading the target is far from // straightforward. It's probably not worth trying to implement this. raise_syscall(taskData, "Symbolic links are not implemented", 0); return taskData->saveVec.push(TAGGED(0)); /* To keep compiler happy. */ } case 60: /* Return the full absolute path name. */ return fullPath(taskData, args); case 61: /* Modification time. */ return modTime(taskData, args); case 62: /* File size. */ return fileSize(taskData, args); case 63: /* Set file time. */ return setTime(taskData, strm, args); case 64: /* Delete a file. */ { TempString fileName(args->Word()); if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (!DeleteFile(fileName)) raise_syscall(taskData, "DeleteFile failed", GetLastError()); return Make_fixed_precision(taskData, 0); } case 65: /* rename a file. */ return renameFile(taskData, strm, args); case 66: /* Get access rights. */ return fileAccess(taskData, strm, args); case 67: /* Return a temporary file name. */ { DWORD dwSpace = GetTempPath(0, NULL); if (dwSpace == 0) raise_syscall(taskData, "GetTempPath failed", GetLastError()); TempString buff((TCHAR*)malloc((dwSpace + 12) * sizeof(TCHAR))); if (buff == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (GetTempPath(dwSpace, buff) == 0) raise_syscall(taskData, "GetTempPath failed", GetLastError()); lstrcat(buff, _T("MLTEMPXXXXXX")); #if (defined(HAVE_MKSTEMP) && ! defined(UNICODE)) // mkstemp is present in the Mingw64 headers but only as ANSI not Unicode. // Set the umask to mask out access by anyone else. // mkstemp generally does this anyway. mode_t oldMask = umask(0077); int fd = mkstemp(buff); int wasError = ERRORNUMBER; (void)umask(oldMask); if (fd != -1) close(fd); else raise_syscall(taskData, "mkstemp failed", wasError); #else if (_tmktemp(buff) == 0) raise_syscall(taskData, "mktemp failed", ERRORNUMBER); int fd = _topen(buff, O_RDWR | O_CREAT | O_EXCL, 00600); if (fd != -1) close(fd); else raise_syscall(taskData, "Temporary file creation failed", ERRORNUMBER); #endif Handle res = SAVE(C_string_to_Poly(taskData, buff)); return res; } case 68: /* Get the file id. */ { /* This concept does not exist in Windows. */ /* Return a negative number. This is interpreted as "not implemented". */ return Make_fixed_precision(taskData, -1); } case 69: { // Return an index for a token. It is used in OS.IO.hash. // This is supposed to be well distributed for any 2^n but simply return // the low order part of the object address. WinStream *stream = *(WinStream **)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); return Make_fixed_precision(taskData, (POLYUNSIGNED)((uintptr_t)(stream)) & 0xfffffff); } default: { char msg[100]; sprintf(msg, "Unknown io function: %d", c); raise_exception_string(taskData, EXC_Fail, msg); return 0; } } } // General interface to IO. Ideally the various cases will be made into // separate functions. -POLYUNSIGNED PolyBasicIOGeneral(PolyObject *threadId, PolyWord code, PolyWord strm, PolyWord arg) +POLYUNSIGNED PolyBasicIOGeneral(FirstArgument threadId, PolyWord code, PolyWord strm, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCode = taskData->saveVec.push(code); Handle pushedStrm = taskData->saveVec.push(strm); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = IO_dispatch_c(taskData, pushedArg, pushedStrm, pushedCode); } catch (KillException &) { processes->ThreadExit(taskData); // TestAnyEvents may test for kill } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } +POLYEXTERNALSYMBOL POLYUNSIGNED PolyTestForInput(FirstArgument threadId, PolyWord strm, PolyWord waitMillisecs) +{ + TaskData *taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + bool result = false; + + try { + WinStream *stream = *(WinStream **)(strm.AsObjPtr()); + if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); + result = stream->testForInput(taskData, (unsigned)waitMillisecs.UnTaggedUnsigned()); + } + catch (KillException &) { + processes->ThreadExit(taskData); // TestAnyEvents may test for kill + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + return TAGGED(result? 1: 0).AsUnsigned(); +} + +POLYEXTERNALSYMBOL POLYUNSIGNED PolyTestForOutput(FirstArgument threadId, PolyWord strm, PolyWord waitMillisecs) +{ + TaskData *taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + bool result = false; + + try { + WinStream *stream = *(WinStream **)(strm.AsObjPtr()); + if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); + result = stream->testForOutput(taskData, (unsigned)waitMillisecs.UnTaggedUnsigned()); + } + catch (KillException &) { + processes->ThreadExit(taskData); // TestAnyEvents may test for kill + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); + taskData->PostRTSCall(); + return TAGGED(result ? 1 : 0).AsUnsigned(); +} + struct _entrypts basicIOEPT[] = { { "PolyChDir", (polyRTSFunction)&PolyChDir }, { "PolyBasicIOGeneral", (polyRTSFunction)&PolyBasicIOGeneral }, + { "PolyPollIODescriptors", (polyRTSFunction)&PolyPollIODescriptors }, + { "PolyTestForInput", (polyRTSFunction)&PolyTestForInput }, + { "PolyTestForOutput", (polyRTSFunction)&PolyTestForOutput }, { NULL, NULL } // End of list. }; class WinBasicIO : public RtsModule { public: virtual void Start(void); virtual void GarbageCollect(ScanAddress * /*process*/); }; // Declare this. It will be automatically added to the table. static WinBasicIO basicIOModule; void WinBasicIO::Start(void) { } void WinBasicIO::GarbageCollect(ScanAddress *process) { if (standardInputValue != 0) process->ScanRuntimeAddress(&standardInputValue, ScanAddress::STRENGTH_STRONG); if (standardOutputValue != 0) process->ScanRuntimeAddress(&standardOutputValue, ScanAddress::STRENGTH_STRONG); if (standardErrorValue != 0) process->ScanRuntimeAddress(&standardErrorValue, ScanAddress::STRENGTH_STRONG); } \ No newline at end of file diff --git a/libpolyml/windows_specific.cpp b/libpolyml/windows_specific.cpp index 73b898ac..9bf6e2fa 100644 --- a/libpolyml/windows_specific.cpp +++ b/libpolyml/windows_specific.cpp @@ -1,1119 +1,538 @@ /* Title: Operating Specific functions: Windows version. Copyright (c) 2000, 2015, 2018, 2019 David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #include #include #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_TCHAR_H #include #endif #ifdef HAVE_IO_H #include #endif #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #include #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #include #include "globals.h" #include "arb.h" #include "gc.h" #include "run_time.h" #include "io_internal.h" #include "os_specific.h" #include "sys.h" #include "processes.h" #include "winguiconsole.h" #include "mpoly.h" #include "diagnostics.h" #include "scanaddrs.h" #include "polystring.h" #include "save_vec.h" #include "rts_module.h" #include "machine_dep.h" #include "rtsentry.h" #include "winstartup.h" #define SAVE(x) taskData->saveVec.push(x) #define SIZEOF(x) (sizeof(x)/sizeof(word)) extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyOSSpecificGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsExecute(FirstArgument threadId, PolyWord command, PolyWord argument); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsOpenProcessHandle(FirstArgument threadId, PolyWord arg, PolyWord isRead, PolyWord isText); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsGetProcessResult(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsSimpleExecute(FirstArgument threadId, PolyWord command, PolyWord argument); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsDDEStartDialogue(FirstArgument threadId, PolyWord service, PolyWord topic); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsDDEExecute(FirstArgument threadId, PolyWord info, PolyWord commd); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsDDEClose(FirstArgument threadId, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetOSType(); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsGetCodePage(); } -typedef enum -{ - HE_UNUSED, - HE_PROCESS -} HANDENTRYTYPE; - typedef struct { HANDLE hProcess, hInput, hOutput; } PROCESSDATA; -static Handle execute(TaskData *taskData, Handle pname); -static Handle simpleExecute(TaskData *taskData, Handle args); -static Handle openProcessHandle(TaskData *taskData, Handle args, bool fIsRead, bool fIsText); -static Handle openRegistryKey(TaskData *taskData, Handle args, HKEY hkParent); -static Handle createRegistryKey(TaskData *taskData, Handle args, HKEY hkParent); -static Handle queryRegistryKey(TaskData *taskData, Handle args, HKEY hkParent); -static Handle setRegistryKey(TaskData *taskData, Handle args, HKEY hkParent); -static Handle deleteRegistryKey(TaskData *taskData, Handle args, HKEY hkParent); -static Handle deleteRegistryValue(TaskData *taskData, Handle args, HKEY hkParent); -static Handle enumerateRegistry(TaskData *taskData, Handle args, HKEY hkey, BOOL isKey); - -// Vector of constants returned by call1006 -static POLYUNSIGNED winConstVec[] = -{ - KEY_ALL_ACCESS, // 0 - KEY_CREATE_LINK, - KEY_CREATE_SUB_KEY, - KEY_ENUMERATE_SUB_KEYS, - KEY_EXECUTE, - KEY_NOTIFY, - KEY_QUERY_VALUE, - KEY_READ, - KEY_SET_VALUE, - KEY_WRITE, // 9 - - STATUS_ACCESS_VIOLATION, // 10 - STATUS_ARRAY_BOUNDS_EXCEEDED, - STATUS_BREAKPOINT, - STATUS_CONTROL_C_EXIT, - STATUS_DATATYPE_MISALIGNMENT, - STATUS_FLOAT_DENORMAL_OPERAND, - STATUS_FLOAT_DIVIDE_BY_ZERO, - STATUS_FLOAT_INEXACT_RESULT, - STATUS_FLOAT_INVALID_OPERATION, - STATUS_FLOAT_OVERFLOW, - STATUS_FLOAT_STACK_CHECK, - STATUS_FLOAT_UNDERFLOW, - STATUS_GUARD_PAGE_VIOLATION, - STATUS_INTEGER_DIVIDE_BY_ZERO, - STATUS_INTEGER_OVERFLOW, - STATUS_ILLEGAL_INSTRUCTION, - STATUS_INVALID_DISPOSITION, -#ifdef STATUS_INVALID_HANDLE - STATUS_INVALID_HANDLE, -#else - 0, // Not defined in Win CE -#endif - STATUS_IN_PAGE_ERROR, - STATUS_NONCONTINUABLE_EXCEPTION, - STATUS_PENDING, - STATUS_PRIVILEGED_INSTRUCTION, - STATUS_SINGLE_STEP, - STATUS_STACK_OVERFLOW, - STATUS_TIMEOUT, - STATUS_USER_APC, // 35 - - VER_PLATFORM_WIN32s, // 36 - VER_PLATFORM_WIN32_WINDOWS, - VER_PLATFORM_WIN32_NT, // 38 - // VER_PLATFORM_WIN32_CE is only defined in the Windows CE headers -#ifdef VER_PLATFORM_WIN32_CE - VER_PLATFORM_WIN32_CE, // 39 -#else - 3, // 39 -#endif -}; - -HKEY hkPredefinedKeyTab[] = -{ - HKEY_CLASSES_ROOT, - HKEY_CURRENT_USER, - HKEY_LOCAL_MACHINE, - HKEY_USERS, -#ifdef HKEY_PERFORMANCE_DATA - HKEY_PERFORMANCE_DATA, -#else - 0, // Not defined in Win CE -#endif -#ifdef HKEY_CURRENT_CONFIG - HKEY_CURRENT_CONFIG, -#else - 0, -#endif -#ifdef HKEY_DYN_DATA - HKEY_DYN_DATA -#else - 0 -#endif -}; - - -Handle OS_spec_dispatch_c(TaskData *taskData, Handle args, Handle code) +// Start DDE dialogue. +POLYUNSIGNED PolyWindowsDDEStartDialogue(FirstArgument threadId, PolyWord service, PolyWord topic) { - unsigned c = get_C_unsigned(taskData, DEREFWORD(code)); - switch (c) - { - case 0: /* Return our OS type. Not in any structure. */ - return Make_fixed_precision(taskData, 1); /* 1 for Windows. */ - - /* Windows-specific functions. */ - case 1000: /* execute */ - return execute(taskData, args); - - case 1001: /* Get input stream as text. */ - return openProcessHandle(taskData, args, true, true); - - case 1002: /* Get output stream as text. */ - return openProcessHandle(taskData, args, false, true); - - case 1003: /* Get input stream as binary. */ - return openProcessHandle(taskData, args, true, false); - - case 1004: /* Get output stream as binary. */ - return openProcessHandle(taskData, args, false, false); - - case 1005: /* Get result of process. */ - { - PROCESSDATA *hnd = *(PROCESSDATA**)(args->WordP()); - *(PROCESSDATA**)(args->WordP()) = 0; // Mark as inaccessible. - if (hnd == 0) - raise_syscall(taskData, "Process is closed", ERROR_INVALID_HANDLE); - // Close the streams. Either of them may have been - // passed to the stream package. - if (hnd->hInput != INVALID_HANDLE_VALUE) - CloseHandle(hnd->hInput); - hnd->hInput = INVALID_HANDLE_VALUE; - if (hnd->hOutput != INVALID_HANDLE_VALUE) - CloseHandle(hnd->hOutput); - hnd->hOutput = INVALID_HANDLE_VALUE; - - // See if it's finished. - while (true) { - DWORD dwResult; - if (GetExitCodeProcess(hnd->hProcess, &dwResult) == 0) - raise_syscall(taskData, "GetExitCodeProcess failed", GetLastError()); - if (dwResult != STILL_ACTIVE) { - // Finished - return the result. - // Remove the process object. The result is cached in ML. - free(hnd); - return Make_fixed_precision(taskData, dwResult); - } - // Block and try again. - WaitHandle waiter(hnd->hProcess); - processes->ThreadPauseForIO(taskData, &waiter); - } - } - - case 1006: /* Return a constant. */ - { - unsigned i = get_C_unsigned(taskData, DEREFWORD(args)); - if (i >= sizeof(winConstVec)/sizeof(winConstVec[0])) - raise_syscall(taskData, "Invalid index", 0); - return Make_arbitrary_precision(taskData, winConstVec[i]); - } - - /* Registry functions. */ - case 1007: // Open a key within one of the roots. - { - unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0)); - // This should only ever happen as a result of a fault in - // the Windows structure. - if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0])) - raise_syscall(taskData, "Invalid index", 0); - return openRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]); - } - - case 1008: // Open a subkey of an opened key. - { - HKEY hKey = *(HKEY*)(args->WordP()->Get(0).AsObjPtr()); - if (hKey == 0) - raise_syscall(taskData, "Handle is closed", ERROR_INVALID_HANDLE); - return openRegistryKey(taskData, args, hKey); - } - - case 1009: // Create a subkey within one of the roots. - { - unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0)); - // This should only ever happen as a result of a fault in - // the Windows structure. - if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0])) - raise_syscall(taskData, "Invalid index", 0); - return createRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]); - } - - case 1010: // Create a subkey within an opened key. - { - HKEY hKey = *(HKEY*)(args->WordP()->Get(0).AsObjPtr()); - if (hKey == 0) - raise_syscall(taskData, "Handle is closed", ERROR_INVALID_HANDLE); - return createRegistryKey(taskData, args, hKey); - } - - case 1011: // Close a registry handle. - { - HKEY hKey = *(HKEY*)(args->WordP()); - if (hKey != 0) - { - RegCloseKey(hKey); - *(void**)(args->WordP()) = 0; - } - return Make_fixed_precision(taskData, 0); - } - - case 1012: // Get a value - { - unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0)); - // This should only ever happen as a result of a fault in - // the Windows structure. - if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0])) - raise_syscall(taskData, "Invalid index", 0); - return queryRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]); - } - - case 1013: // Get a value - { - HKEY hKey = *(HKEY*)(args->WordP()->Get(0).AsObjPtr()); - if (hKey == 0) - raise_syscall(taskData, "Handle is closed", ERROR_INVALID_HANDLE); - return queryRegistryKey(taskData, args, hKey); - } - - case 1014: // Delete a subkey - { - unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0)); - // This should only ever happen as a result of a fault in - // the Windows structure. - if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0])) - raise_syscall(taskData, "Invalid index", 0); - return deleteRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]); - } - - case 1015: // Delete a subkey - { - HKEY hKey = *(HKEY*)(args->WordP()->Get(0).AsObjPtr()); - if (hKey == 0) - raise_syscall(taskData, "Handle is closed", ERROR_INVALID_HANDLE); - return deleteRegistryKey(taskData, args, hKey); - } - - case 1016: // Set a value - { - unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0)); - // This should only ever happen as a result of a fault in - // the Windows structure. - if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0])) - raise_syscall(taskData, "Invalid index", 0); - return setRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]); - } - - case 1017: // Set a value - { - HKEY hKey = *(HKEY*)(args->WordP()->Get(0).AsObjPtr()); - if (hKey == 0) - raise_syscall(taskData, "Handle is closed", ERROR_INVALID_HANDLE); - return setRegistryKey(taskData, args, hKey); - } - - case 1018: // Enumerate a key in the predefined keys - { - unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0)); - if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0])) - raise_syscall(taskData, "Invalid index", 0); - return enumerateRegistry(taskData, args, hkPredefinedKeyTab[keyIndex], TRUE); - } - - case 1019: // Enumerate a key in an opened key - { - HKEY hKey = *(HKEY*)(args->WordP()->Get(0).AsObjPtr()); - if (hKey == 0) - raise_syscall(taskData, "Handle is closed", ERROR_INVALID_HANDLE); - return enumerateRegistry(taskData, args, hKey, TRUE); - } - - case 1020: // Enumerate a value in the predefined keys - { - unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0)); - if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0])) - raise_syscall(taskData, "Invalid index", 0); - return enumerateRegistry(taskData, args, hkPredefinedKeyTab[keyIndex], FALSE); - } - - case 1021: // Enumerate a value in an opened key - { - HKEY hKey = *(HKEY*)(args->WordP()->Get(0).AsObjPtr()); - if (hKey == 0) - raise_syscall(taskData, "Handle is closed", ERROR_INVALID_HANDLE); - return enumerateRegistry(taskData, args, hKey, FALSE); - } - - case 1022: // Delete a value - { - unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0)); - // This should only ever happen as a result of a fault in - // the Windows structure. - if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0])) - raise_syscall(taskData, "Invalid index", 0); - return deleteRegistryValue(taskData, args, hkPredefinedKeyTab[keyIndex]); - } - - case 1023: // Delete a value - { - HKEY hKey = *(HKEY*)(args->WordP()->Get(0).AsObjPtr()); - if (hKey == 0) - raise_syscall(taskData, "Handle is closed", ERROR_INVALID_HANDLE); - return deleteRegistryValue(taskData, args, hKey); - } - - - case 1030: // Convert UTC time values to local time. -- No longer used?? - { - FILETIME ftUTC, ftLocal; - /* Get the file time. */ - getFileTimeFromArb(taskData, args, &ftUTC); - if (! FileTimeToLocalFileTime(&ftUTC, &ftLocal)) - raise_syscall(taskData, "FileTimeToLocalFileTime failed", GetLastError()); - return Make_arb_from_Filetime(taskData, ftLocal); - } - - case 1031: // Convert local time values to UTC. -- No longer used?? - { - FILETIME ftUTC, ftLocal; - /* Get the file time. */ - getFileTimeFromArb(taskData, args, &ftLocal); - if (! LocalFileTimeToFileTime(&ftLocal, &ftUTC)) - raise_syscall(taskData, "LocalFileTimeToFileTime failed", GetLastError()); - return Make_arb_from_Filetime(taskData, ftUTC); - } - - case 1032: // Get volume information. - { - TCHAR rootName[MAX_PATH], volName[MAX_PATH], sysName[MAX_PATH]; - DWORD dwVolSerial, dwMaxComponentLen, dwFlags; - Handle volHandle, sysHandle, serialHandle, maxCompHandle; - Handle resultHandle; - POLYUNSIGNED length = Poly_string_to_C(DEREFWORD(args), rootName, MAX_PATH); - if (length > MAX_PATH) - raise_syscall(taskData, "Root name too long", ERROR_BAD_LENGTH); - - if (!GetVolumeInformation(rootName, volName, MAX_PATH, - &dwVolSerial, &dwMaxComponentLen, &dwFlags, - sysName, MAX_PATH)) - raise_syscall(taskData, "GetVolumeInformation failed", GetLastError()); - volHandle = SAVE(C_string_to_Poly(taskData, volName)); - sysHandle = SAVE(C_string_to_Poly(taskData, sysName)); - serialHandle = Make_arbitrary_precision(taskData, dwVolSerial); - maxCompHandle = Make_arbitrary_precision(taskData, dwMaxComponentLen); - resultHandle = alloc_and_save(taskData, 4); - DEREFHANDLE(resultHandle)->Set(0, volHandle->Word()); - DEREFHANDLE(resultHandle)->Set(1, sysHandle->Word()); - DEREFHANDLE(resultHandle)->Set(2, serialHandle->Word()); - DEREFHANDLE(resultHandle)->Set(3, maxCompHandle->Word()); - return resultHandle; - } - - case 1033: - { - TCHAR fileName[MAX_PATH], execName[MAX_PATH]; - POLYUNSIGNED length = Poly_string_to_C(DEREFWORD(args), fileName, MAX_PATH); - HINSTANCE hInst; - if (length > MAX_PATH) - raise_syscall(taskData, "File name too long", ERROR_BAD_LENGTH); - hInst = FindExecutable(fileName, NULL, execName); - if ((uintptr_t)hInst <= 32) - { - int error = 0; - switch ((uintptr_t)hInst) { - case SE_ERR_FNF: error = ERROR_FILE_NOT_FOUND; break; - case SE_ERR_PNF: error = ERROR_PATH_NOT_FOUND; break; - case SE_ERR_ACCESSDENIED: error = ERROR_ACCESS_DENIED; break; - case SE_ERR_OOM: error = ERROR_NOT_ENOUGH_MEMORY; break; - case SE_ERR_NOASSOC: error = ERROR_NO_ASSOCIATION; break; - } - raise_syscall(taskData, "FindExecutable failed", error); - } - return SAVE(C_string_to_Poly(taskData, execName)); - } - - case 1034: // Open a document - { - SHELLEXECUTEINFO shellEx; - memset(&shellEx, 0, sizeof(shellEx)); - shellEx.cbSize = sizeof(shellEx); - shellEx.lpVerb = _T("open"); - shellEx.lpFile = Poly_string_to_T_alloc(DEREFWORD(args)); - shellEx.hwnd = hMainWindow; - shellEx.nShow = SW_SHOWNORMAL; - BOOL fRes = ShellExecuteEx(&shellEx); - free((void*)shellEx.lpFile); - if (! fRes) - raise_syscall(taskData, "ShellExecuteEx failed", GetLastError()); - return Make_fixed_precision(taskData, 0); - } - - case 1035: // Launch an application. - { - SHELLEXECUTEINFO shellEx; - memset(&shellEx, 0, sizeof(shellEx)); - shellEx.cbSize = sizeof(shellEx); - shellEx.lpVerb = _T("open"); - shellEx.lpFile = Poly_string_to_T_alloc(args->WordP()->Get(0)); - shellEx.lpParameters = Poly_string_to_T_alloc(args->WordP()->Get(1)); - shellEx.nShow = SW_SHOWNORMAL; - BOOL fRes = ShellExecuteEx(&shellEx); - free((void*)shellEx.lpFile); - free((void*)shellEx.lpParameters); - if (! fRes) - raise_syscall(taskData, "ShellExecuteEx failed", GetLastError()); - return Make_fixed_precision(taskData, 0); - } - - case 1036: // Does the process have its own console? - return Make_fixed_precision(taskData, hMainWindow != NULL ? 1: 0); - - case 1037: // Simple execute. - return simpleExecute(taskData, args); - - - // DDE - case 1038: // Start DDE dialogue. - { - TCHAR *serviceName = Poly_string_to_T_alloc(args->WordP()->Get(0)); - TCHAR *topicName = Poly_string_to_T_alloc(args->WordP()->Get(1)); - /* Send a request to the main thread to do the work. */ - HCONV hcDDEConv = StartDDEConversation(serviceName, topicName); - free(serviceName); free(topicName); - if (hcDDEConv == 0) raise_syscall(taskData, "DdeConnect failed", 0); - // Create an entry to return the conversation. - return MakeVolatileWord(taskData, hcDDEConv); - } - - case 1039: // Send DDE execute request. - { - HCONV hcDDEConv = *(HCONV*)(args->WordP()->Get(0).AsObjPtr()); - if (hcDDEConv == 0) raise_syscall(taskData, "DDE Conversation is closed", 0); - char *command = Poly_string_to_C_alloc(args->WordP()->Get(1)); - /* Send a request to the main thread to do the work. */ - LRESULT res = ExecuteDDE(command, hcDDEConv); - free(command); - if (res == -1) raise_syscall(taskData, "DdeClientTransaction failed", 0); - else return Make_arbitrary_precision(taskData, res); - } - - case 1040: // Close a DDE conversation. - { - HCONV hcDDEConv = *(HCONV*)(args->WordP()->Get(0).AsObjPtr()); - if (hcDDEConv != 0) - { - CloseDDEConversation(hcDDEConv); - *(void**)(args->WordP()->Get(0).AsObjPtr()) = 0; - } - return Make_fixed_precision(taskData, 0); - } - - // Configuration functions. - case 1050: // Get version data - { - - OSVERSIONINFO osver; - ZeroMemory(&osver, sizeof(OSVERSIONINFO)); - osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); - // GetVersionEx is deprecated in Windows 8.1 -#ifdef _MSC_VER -#pragma warning(disable: 4996) -#endif - if (! GetVersionEx(&osver)) - raise_syscall(taskData, "GetVersionEx failed", GetLastError()); -#ifdef _MSC_VER -#pragma warning(default: 4996) -#endif - Handle major = Make_fixed_precision(taskData, osver.dwMajorVersion); - Handle minor = Make_fixed_precision(taskData, osver.dwMinorVersion); - Handle build = Make_fixed_precision(taskData, osver.dwBuildNumber); - Handle platform = Make_fixed_precision(taskData, osver.dwPlatformId); - Handle version = SAVE(C_string_to_Poly(taskData, osver.szCSDVersion)); - Handle resVal = alloc_and_save(taskData, 5); - DEREFHANDLE(resVal)->Set(0, major->Word()); - DEREFHANDLE(resVal)->Set(1, minor->Word()); - DEREFHANDLE(resVal)->Set(2, build->Word()); - DEREFHANDLE(resVal)->Set(3, platform->Word()); - DEREFHANDLE(resVal)->Set(4, version->Word()); - return resVal; - } - - case 1051: // Get windows directory - { - TCHAR path[MAX_PATH+1]; - if (GetWindowsDirectory(path, sizeof(path)/sizeof(TCHAR)) == 0) - raise_syscall(taskData, "GetWindowsDirectory failed", GetLastError()); - return SAVE(C_string_to_Poly(taskData, path)); - } - - case 1052: // Get system directory - { - TCHAR path[MAX_PATH+1]; - if (GetSystemDirectory(path, sizeof(path)/sizeof(TCHAR)) == 0) - raise_syscall(taskData, "GetSystemDirectory failed", GetLastError()); - return SAVE(C_string_to_Poly(taskData, path)); - } - - case 1053: // Get computer name - { - TCHAR name[MAX_COMPUTERNAME_LENGTH +1]; - DWORD dwSize = MAX_COMPUTERNAME_LENGTH +1; - if (GetComputerName(name, &dwSize) == 0) - raise_syscall(taskData, "GetComputerName failed", GetLastError()); - return SAVE(C_string_to_Poly(taskData, name)); - } - - case 1054: // Get user name - { - TCHAR name[UNLEN +1]; - DWORD dwSize = UNLEN +1; - if (GetUserName(name, &dwSize) == 0) - raise_syscall(taskData, "GetUserName failed", GetLastError()); - return SAVE(C_string_to_Poly(taskData, name)); - } - - case 1100: // Get the error result from the last call. - // This is saved when we make a call to a foreign function. - { - return(SAVE(TAGGED(taskData->lastError))); - } + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; - case 1101: // Wait for a message. - { - HWND hwnd = *(HWND*)(DEREFWORDHANDLE(args)->Get(0).AsCodePtr()); - UINT wMsgFilterMin = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(1)); - UINT wMsgFilterMax = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(2)); - while (1) - { - MSG msg; - processes->ThreadReleaseMLMemory(taskData); - // N.B. PeekMessage may directly call the window proc resulting in a - // callback to ML. For this to work a callback must not overwrite "args". - BOOL result = PeekMessage(&msg, hwnd, wMsgFilterMin, wMsgFilterMax, PM_NOREMOVE); - processes->ThreadUseMLMemory(taskData); - if (result) return Make_fixed_precision(taskData, 0); - // Pause until a message arrives. - processes->ThreadPause(taskData); - } - } + try { + TCHAR* serviceName = Poly_string_to_T_alloc(service); + TCHAR* topicName = Poly_string_to_T_alloc(topic); + /* Send a request to the main thread to do the work. */ + HCONV hcDDEConv = StartDDEConversation(serviceName, topicName); + free(serviceName); free(topicName); + if (hcDDEConv == 0) raise_syscall(taskData, "DdeConnect failed", 0); + // Create an entry to return the conversation. + result = MakeVolatileWord(taskData, hcDDEConv); - // case 1102: // Return the address of the window callback function. + } + catch (KillException&) { + processes->ThreadExit(taskData); // Call 1005 may test for kill + } + catch (...) {} // If an ML exception is raised - case 1103: // Return the application instance. - { - Handle result = alloc_and_save(taskData, 1, F_BYTE_OBJ); - *(HINSTANCE*)(result->Word().AsCodePtr()) = hApplicationInstance; - return result; - } + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} - case 1104: // Return the main window handle - { - Handle result = alloc_and_save(taskData, 1, F_BYTE_OBJ); - *(HWND*)(result->Word().AsCodePtr()) = hMainWindow; - return result; - } +// Send DDE execute request. +POLYUNSIGNED PolyWindowsDDEExecute(FirstArgument threadId, PolyWord info, PolyWord commd) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + LRESULT res = 0; -// case 1105: // Set the callback function + try { + HCONV hcDDEConv = *(HCONV*)(info.AsObjPtr()); + if (hcDDEConv == 0) raise_syscall(taskData, "DDE Conversation is closed", 0); + char* command = Poly_string_to_C_alloc(commd); + // Send a request to the main thread to do the work. + // The result is -1 if an error, 0 if busy, 1 if success + res = ExecuteDDE(command, hcDDEConv); + free(command); + if (res == -1) raise_syscall(taskData, "DdeClientTransaction failed", 0); - default: - { - char msg[100]; - sprintf(msg, "Unknown windows-specific function: %d", c); - raise_exception_string(taskData, EXC_Fail, msg); - return 0; - } } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + return TAGGED(res == 1 ? 1 : 0).AsUnsigned(); } -// General interface to Windows OS-specific. Ideally the various cases will be made into -// separate functions. -POLYUNSIGNED PolyOSSpecificGeneral(PolyObject *threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyWindowsDDEClose(FirstArgument threadId, PolyWord arg) { - TaskData *taskData = TaskData::FindTaskForId(threadId); + TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); - Handle pushedCode = taskData->saveVec.push(code); - Handle pushedArg = taskData->saveVec.push(arg); - Handle result = 0; try { - result = OS_spec_dispatch_c(taskData, pushedArg, pushedCode); - } - catch (KillException &) { - processes->ThreadExit(taskData); // Call 1005 may test for kill + HCONV hcDDEConv = *(HCONV*)(arg.AsObjPtr()); + if (hcDDEConv != 0) + { + CloseDDEConversation(hcDDEConv); + *(void**)(arg.AsObjPtr()) = 0; + } } - catch (...) { } // If an ML exception is raised + catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); - if (result == 0) return TAGGED(0).AsUnsigned(); - else return result->Word().AsUnsigned(); + return TAGGED(0).AsUnsigned(); } POLYUNSIGNED PolyGetOSType() { return TAGGED(1).AsUnsigned(); // Return 1 for Windows } +// Return the current code page set by the --codepage argument. +// This allows Unicode conversions to use same conversions as everything else. +POLYUNSIGNED PolyWindowsGetCodePage() +{ +#if defined(UNICODE) + return TAGGED(codePage).AsUnsigned(); +#else + return TAGGED(CP_ACP).AsUnsigned(); +#endif +} + + /* The Windows version of this is more complicated than the Unix version because we can't manipulate the pipe handles in the child process. Everything has to be set up in the parent. As with Unix we create two pipes and pass one end of each pipe to the child. The end we pass to the child is "inheritable" (i.e. duplicated in the child as with Unix file descriptors) while the ends we keep in the parent are non-inheritable (i.e. not duplicated in the child). DCJM: December 1999. This now uses overlapped IO for the streams. */ -static Handle execute(TaskData *taskData, Handle args) +static Handle execute(TaskData *taskData, PolyWord command, PolyWord argument) { LPCSTR lpszError = ""; HANDLE hWriteToChild = INVALID_HANDLE_VALUE, hReadFromParent = INVALID_HANDLE_VALUE, hWriteToParent = INVALID_HANDLE_VALUE, hReadFromChild = INVALID_HANDLE_VALUE; STARTUPINFO startupInfo; PROCESS_INFORMATION processInfo; PROCESSDATA *pProcData = 0; - LPTSTR commandName = Poly_string_to_T_alloc(args->WordP()->Get(0)); - LPTSTR arguments = Poly_string_to_T_alloc(args->WordP()->Get(1)); + LPTSTR commandName = Poly_string_to_T_alloc(command); + LPTSTR arguments = Poly_string_to_T_alloc(argument); TCHAR toChildPipeName[MAX_PATH], fromChildPipeName[MAX_PATH]; newPipeName(toChildPipeName); newPipeName(fromChildPipeName); // Create the pipes as inheritable handles. These will be passed to the child. SECURITY_ATTRIBUTES secure; secure.nLength = sizeof(SECURITY_ATTRIBUTES); secure.lpSecurityDescriptor = NULL; secure.bInheritHandle = TRUE; hReadFromParent = CreateNamedPipe(toChildPipeName, PIPE_ACCESS_INBOUND | FILE_FLAG_FIRST_PIPE_INSTANCE, PIPE_READMODE_BYTE | PIPE_WAIT | PIPE_REJECT_REMOTE_CLIENTS, 1, 4096, 4096, 0, &secure); if (hReadFromParent == INVALID_HANDLE_VALUE) { lpszError = "CreateNamedPipe failed"; goto error; } hWriteToChild = CreateFile(toChildPipeName, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL | FILE_FLAG_OVERLAPPED, NULL); if (hWriteToChild == INVALID_HANDLE_VALUE) { lpszError = "CreateFile failed"; goto error; } hWriteToParent = CreateNamedPipe(fromChildPipeName, PIPE_ACCESS_OUTBOUND | FILE_FLAG_FIRST_PIPE_INSTANCE, PIPE_READMODE_BYTE | PIPE_WAIT | PIPE_REJECT_REMOTE_CLIENTS, 1, 4096, 4096, 0, &secure); if (hWriteToParent == INVALID_HANDLE_VALUE) { lpszError = "CreateNamedPipe failed"; goto error; } hReadFromChild = CreateFile(fromChildPipeName, GENERIC_READ, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL | FILE_FLAG_OVERLAPPED, NULL); if (hReadFromChild == INVALID_HANDLE_VALUE) { lpszError = "CreateFile failed"; goto error; } // Create a STARTUPINFO structure in which to pass the pipes as stdin // and stdout to the new process. memset(&startupInfo, 0, sizeof(startupInfo)); startupInfo.cb = sizeof(startupInfo); startupInfo.dwFlags = STARTF_USESTDHANDLES; startupInfo.hStdInput = hReadFromParent; startupInfo.hStdOutput = hWriteToParent; // What should we do about the stderr? For the moment, inherit the original. startupInfo.hStdError = GetStdHandle(STD_ERROR_HANDLE); // Treat the empty string as NULL. This is non-standard. if (!CreateProcess(commandName[0] == 0 ? NULL: commandName, arguments[0] == 0 ? NULL: arguments, // Command line NULL, NULL, TRUE, // Security attributes. Inherit handles CREATE_NO_WINDOW, // creation flags NULL, NULL, // Inherit our environment and directory &startupInfo, &processInfo)) { lpszError = "Could not create process"; goto error; } pProcData = (PROCESSDATA *)malloc(sizeof(PROCESSDATA)); if (pProcData == 0) { lpszError = "Insufficient memory"; SetLastError(ERROR_NOT_ENOUGH_MEMORY); goto error; } pProcData->hProcess = processInfo.hProcess; pProcData->hInput = hReadFromChild; pProcData->hOutput = hWriteToChild; // Everything has gone well - remove what we don't want free(commandName); free(arguments); /* Close thread handle since we don't need it. */ CloseHandle(processInfo.hThread); /* Close the sides of the pipes we don't use in the parent. */ CloseHandle(hReadFromParent); CloseHandle(hWriteToParent); return(MakeVolatileWord(taskData, pProcData)); error: { int err = GetLastError(); free(commandName); free(arguments); free(pProcData); // Close all the pipe handles. if (hWriteToChild != INVALID_HANDLE_VALUE) CloseHandle(hWriteToChild); if (hReadFromParent != INVALID_HANDLE_VALUE) CloseHandle(hReadFromParent); if (hWriteToParent != INVALID_HANDLE_VALUE) CloseHandle(hWriteToParent); if (hReadFromChild != INVALID_HANDLE_VALUE) CloseHandle(hReadFromChild); raise_syscall(taskData, lpszError, err); return NULL; // Never reached. } } -static Handle simpleExecute(TaskData *taskData, Handle args) +// Execute a command. +POLYUNSIGNED PolyWindowsExecute(FirstArgument threadId, PolyWord command, PolyWord argument) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + result = execute(taskData, command, argument); + } + catch (KillException&) { + processes->ThreadExit(taskData); // Call 1005 may test for kill + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +static Handle simpleExecute(TaskData *taskData, PolyWord command, PolyWord argument) { HANDLE hNull = INVALID_HANDLE_VALUE; PROCESS_INFORMATION processInfo; - TCHAR *commandName = Poly_string_to_T_alloc(args->WordP()->Get(0)); - TCHAR *arguments = Poly_string_to_T_alloc(args->WordP()->Get(1)); + TCHAR *commandName = Poly_string_to_T_alloc(command); + TCHAR *arguments = Poly_string_to_T_alloc(argument); STARTUPINFO startupInfo; // Open a handle to NUL for input and output. hNull = CreateFile(_T("NUL"), GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); // Create a STARTUPINFO structure in which to pass hNULL as stdin // and stdout to the new process. // TODO: The handles should really be open on "NUL". memset(&startupInfo, 0, sizeof(startupInfo)); startupInfo.cb = sizeof(startupInfo); startupInfo.dwFlags = STARTF_USESTDHANDLES; startupInfo.hStdInput = hNull; startupInfo.hStdOutput = hNull; startupInfo.hStdError = hNull; STARTUPINFO *start = &startupInfo; // Treat the empty string as NULL. This is non-standard. if (!CreateProcess(commandName[0] == 0 ? NULL : commandName, arguments[0] == 0 ? NULL : arguments, // Command line NULL, NULL, // Security attributes TRUE, CREATE_NO_WINDOW, // Inherit handles, creation flags NULL, NULL, // Inherit our environment and directory start, &processInfo)) { int nErr = GetLastError(); // Clean up free(commandName); free(arguments); CloseHandle(hNull); raise_syscall(taskData, "CreateProcess failed", nErr); } free(commandName); free(arguments); /* Close thread handle since we don't need it. */ CloseHandle(processInfo.hThread); #ifndef _WIN32_WCE CloseHandle(hNull); // We no longer need this #endif PROCESSDATA *pProcData = (PROCESSDATA *)malloc(sizeof(PROCESSDATA)); if (pProcData == 0) raise_syscall(taskData, "Insufficient memory", ERROR_NOT_ENOUGH_MEMORY); pProcData->hProcess = processInfo.hProcess; // We only use the process handle entry. pProcData->hInput = INVALID_HANDLE_VALUE; pProcData->hOutput = INVALID_HANDLE_VALUE; return(MakeVolatileWord(taskData, pProcData)); } -/* Return a stream, either text or binary, connected to an open process. */ -static Handle openProcessHandle(TaskData *taskData, Handle args, bool fIsRead, bool fIsText) +POLYUNSIGNED PolyWindowsSimpleExecute(FirstArgument threadId, PolyWord command, PolyWord argument) { - PROCESSDATA *hnd = *(PROCESSDATA**)(args->WordP()); - if (hnd == 0) - raise_syscall(taskData, "Process is closed", ERROR_INVALID_HANDLE); - // We allow multiple streams on the handles. Since they are duplicated by openHandle that's safe. - // A consequence is that closing the stream does not close the pipe as far as the child is - // concerned. That only happens when we close the final handle in reap. - try - { - WinInOutStream *stream = new WinInOutStream; - bool result; - if (fIsRead) result = stream->openHandle(hnd->hInput, OPENREAD, fIsText); - else result = stream->openHandle(hnd->hOutput, OPENWRITE, fIsText); - if (!result) - { - delete(stream); - raise_syscall(taskData, "openHandle failed", GetLastError()); - } + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; - return MakeVolatileWord(taskData, stream); - } - catch (std::bad_alloc&) - { - raise_syscall(taskData, "Insufficient memory", ERROR_NOT_ENOUGH_MEMORY); + try { + result = simpleExecute(taskData, command, argument); } -} - -// Open a registry key and make an entry in the table for it. -static Handle openRegistryKey(TaskData *taskData, Handle args, HKEY hkParent) -{ - TCHAR keyName[MAX_PATH]; - REGSAM sam = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(2)); - POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), keyName, MAX_PATH); - if (length > MAX_PATH) - raise_syscall(taskData, "Key name too long", ERROR_BAD_LENGTH); - // Try opening the key. - HKEY hkey; - LONG lRes = RegOpenKeyEx(hkParent, keyName, 0, sam, &hkey); - if (lRes != ERROR_SUCCESS) - raise_syscall(taskData, "RegOpenKeyEx failed", lRes); - - return MakeVolatileWord(taskData, hkey); -} + catch (...) {} // If an ML exception is raised -// Create a registry key and make an entry in the table for it. -static Handle createRegistryKey(TaskData *taskData, Handle args, HKEY hkParent) -{ - TCHAR keyName[MAX_PATH]; - HKEY hkey; - DWORD dwDisp; - REGSAM sam = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(3)); - unsigned opt = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(2)); - POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), keyName, MAX_PATH); - if (length > MAX_PATH) - raise_syscall(taskData, "Key name too long", ERROR_BAD_LENGTH); - - // Try opening the key. - LONG lRes = RegCreateKeyEx(hkParent, keyName, 0, NULL, - opt ? REG_OPTION_NON_VOLATILE : REG_OPTION_VOLATILE, - sam, NULL, &hkey, &dwDisp); - if (lRes != ERROR_SUCCESS) - raise_syscall(taskData, "RegCreateKeyEx failed", lRes); - - // Make an entry in the table. - Handle keyResult = MakeVolatileWord(taskData, hkey); - // Record whether this was new or old. - Handle dispRes = Make_fixed_precision(taskData, dwDisp == REG_CREATED_NEW_KEY ? 0: 1); - /* Return a pair of the disposition and the token. */ - Handle pair = alloc_and_save(taskData, 2); - DEREFHANDLE(pair)->Set(0, dispRes->Word()); - DEREFHANDLE(pair)->Set(1, keyResult->Word()); - return pair; -} - -// Delete a key. Note that in Windows NT (but not 95) this will fail if -// the key has subkeys. -static Handle deleteRegistryKey(TaskData *taskData, Handle args, HKEY hkParent) -{ - TCHAR keyName[MAX_PATH]; - LONG lRes; - POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), keyName, MAX_PATH); - if (length > MAX_PATH) - raise_syscall(taskData, "Key name too long", ERROR_BAD_LENGTH); - - // Try deleting the key. - lRes = RegDeleteKey(hkParent, keyName); - if (lRes != ERROR_SUCCESS) - /* Return the error. */ - raise_syscall(taskData, "RegDeleteKey failed", lRes); - return Make_fixed_precision(taskData, 0); + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); } -static Handle deleteRegistryValue(TaskData *taskData, Handle args, HKEY hkParent) +/* Return a stream, either text or binary, connected to an open process. */ +POLYUNSIGNED PolyWindowsOpenProcessHandle(FirstArgument threadId, PolyWord arg, PolyWord isRead, PolyWord isText) { - TCHAR keyName[MAX_PATH]; - LONG lRes; - POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), keyName, MAX_PATH); - if (length > MAX_PATH) - raise_syscall(taskData, "Key name too long", ERROR_BAD_LENGTH); - - // Try deleting the value. - lRes = RegDeleteValue(hkParent, keyName); - if (lRes != ERROR_SUCCESS) - /* Return the original error. */ - raise_syscall(taskData, "RegDeleteValue failed", lRes); - return Make_fixed_precision(taskData, 0); -} + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle pushedCode = taskData->saveVec.push(TAGGED(1001)); + Handle pushedArg = taskData->saveVec.push(arg); + Handle result = 0; -static Handle queryRegistryKey(TaskData *taskData, Handle args, HKEY hkey) -{ - TCHAR valName[MAX_PATH]; - byte *keyValue = 0; - LONG lRes; - DWORD valSize; - Handle result, resVal, resType; - DWORD dwType; - POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), valName, MAX_PATH); - if (length > MAX_PATH) - raise_syscall(taskData, "Value name too long", ERROR_BAD_LENGTH); - - // How long is the entry? - lRes = RegQueryValueEx(hkey, valName, 0, NULL, NULL, &valSize); - // When opening HKEY_PERFORMANCE_DATA we don't get a sensible - // answer here. - if (lRes == ERROR_MORE_DATA) valSize = 1024; // Guess - else if (lRes != ERROR_SUCCESS) - raise_syscall(taskData, "RegQueryValueEx failed", lRes); - // Allocate that much store and get the value. We could - // try reading directly into ML store to save copying but - // it hardly seems worthwhile. - // Note: It seems that valSize can be zero for some items. - if (valSize == 0) resVal = SAVE(C_string_to_Poly(taskData, "", 0)); - else - { - do { - byte *newAlloc = (byte*)realloc(keyValue, valSize); - if (newAlloc == 0) + try { + PROCESSDATA* hnd = *(PROCESSDATA * *)(arg.AsObjPtr()); + if (hnd == 0) + raise_syscall(taskData, "Process is closed", ERROR_INVALID_HANDLE); + // We allow multiple streams on the handles. Since they are duplicated by openHandle that's safe. + // A consequence is that closing the stream does not close the pipe as far as the child is + // concerned. That only happens when we close the final handle in reap. + try + { + WinInOutStream* stream = new WinInOutStream; + bool fResult; + if (isRead.UnTagged()) fResult = stream->openHandle(hnd->hInput, OPENREAD, isText.UnTagged()); + else fResult = stream->openHandle(hnd->hOutput, OPENWRITE, isText.UnTagged()); + if (!fResult) { - free(keyValue); - raise_syscall(taskData, "Insufficient memory", ERROR_NOT_ENOUGH_MEMORY); + delete(stream); + raise_syscall(taskData, "openHandle failed", GetLastError()); } - keyValue = newAlloc; - lRes = RegQueryValueEx(hkey, valName, 0, &dwType, keyValue, &valSize); - // In the special case of HKEY_PERFORMANCE_DATA we may need to keep - // growing the buffer. - if (lRes == ERROR_MORE_DATA) valSize = valSize + 1024; - } while (lRes == ERROR_MORE_DATA); - - if (lRes != ERROR_SUCCESS) + + result = MakeVolatileWord(taskData, stream); + } + catch (std::bad_alloc&) { - free(keyValue); - raise_syscall(taskData, "RegQueryValue failed", lRes); + raise_syscall(taskData, "Insufficient memory", ERROR_NOT_ENOUGH_MEMORY); } - // If we have a string we have to convert this to ANSI/utf-8. - if (dwType == REG_SZ || dwType == REG_MULTI_SZ || dwType == REG_EXPAND_SZ) - resVal = SAVE(C_string_to_Poly(taskData, (TCHAR*)keyValue, valSize / sizeof(TCHAR))); - else resVal = SAVE(C_string_to_Poly(taskData, (char*)keyValue, valSize)); - free(keyValue); - } - /* Create a pair containing the type and the value. */ - resType = Make_fixed_precision(taskData, dwType); - result = alloc_and_save(taskData, 2); - DEREFHANDLE(result)->Set(0, resType->Word()); - DEREFHANDLE(result)->Set(1, resVal->Word()); - return result; -} - -static Handle setRegistryKey(TaskData *taskData, Handle args, HKEY hkey) -{ - TCHAR valName[MAX_PATH]; - LONG lRes; - PolyWord str = args->WordP()->Get(3); - POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), valName, MAX_PATH); - DWORD dwType = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(2)); - if (length > MAX_PATH) - raise_syscall(taskData, "Value name too long", ERROR_BAD_LENGTH); - - // The value is binary. Strings will already have had a null added. - if (IS_INT(str)) - { - byte b = (byte)UNTAGGED(str); - // Single byte value. - lRes = RegSetValueEx(hkey, valName, 0, dwType, &b, 1); } - else - { - PolyStringObject *ps = (PolyStringObject*)str.AsObjPtr(); - lRes = RegSetValueEx(hkey, valName, 0, dwType, - (CONST BYTE *)ps->chars, (DWORD)ps->length); + catch (KillException&) { + processes->ThreadExit(taskData); // Call 1005 may test for kill } + catch (...) {} // If an ML exception is raised - if (lRes != ERROR_SUCCESS) - raise_syscall(taskData, "RegSetValue failed", lRes); - - return Make_fixed_precision(taskData, 0); + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); } -// Enumerate a key or a value. Returns a string option containing NONE if -// no key/value could be found or SOME s where s is the name of the key/value. -static Handle enumerateRegistry(TaskData *taskData, Handle args, HKEY hkey, BOOL isKey) +/* Get result of process. */ +POLYUNSIGNED PolyWindowsGetProcessResult(FirstArgument threadId, PolyWord arg) { - DWORD num = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(1)); - LONG lRes; - TCHAR keyName[MAX_PATH]; - DWORD dwLength = sizeof(keyName)/sizeof(keyName[0]); - Handle result, resVal; - if (isKey) - { - FILETIME ftMod; - lRes = RegEnumKeyEx(hkey, num, keyName, &dwLength, NULL, NULL, NULL, &ftMod); - if (lRes != ERROR_SUCCESS && lRes != ERROR_NO_MORE_ITEMS) - raise_syscall(taskData, "RegEnumKeyEx failed", lRes); + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle pushedCode = taskData->saveVec.push(TAGGED(1005)); + Handle pushedArg = taskData->saveVec.push(arg); + Handle result = 0; + + try { + PROCESSDATA* hnd = *(PROCESSDATA * *)(arg.AsObjPtr()); + *(PROCESSDATA * *)(arg.AsObjPtr()) = 0; // Mark as inaccessible. + if (hnd == 0) + raise_syscall(taskData, "Process is closed", ERROR_INVALID_HANDLE); + // Close the streams. Either of them may have been + // passed to the stream package. + if (hnd->hInput != INVALID_HANDLE_VALUE) + CloseHandle(hnd->hInput); + hnd->hInput = INVALID_HANDLE_VALUE; + if (hnd->hOutput != INVALID_HANDLE_VALUE) + CloseHandle(hnd->hOutput); + hnd->hOutput = INVALID_HANDLE_VALUE; + + // See if it's finished. + while (true) { + DWORD dwResult; + if (GetExitCodeProcess(hnd->hProcess, &dwResult) == 0) + raise_syscall(taskData, "GetExitCodeProcess failed", GetLastError()); + if (dwResult != STILL_ACTIVE) { + // Finished - return the result. + // Remove the process object. The result is cached in ML. + free(hnd); + result = Make_fixed_precision(taskData, dwResult); + break; + } + // Block and try again. + WaitHandle waiter(hnd->hProcess, 1000); + processes->ThreadPauseForIO(taskData, &waiter); + } + } - else - { - lRes = RegEnumValue(hkey, num, keyName, &dwLength, NULL, NULL, NULL, NULL); - if (lRes != ERROR_SUCCESS && lRes != ERROR_NO_MORE_ITEMS) - raise_syscall(taskData, "RegEnumValue failed", lRes); + catch (KillException&) { + processes->ThreadExit(taskData); // May test for kill } - if (lRes == ERROR_NO_MORE_ITEMS) - return SAVE(NONE_VALUE); /* NONE. */ - resVal = SAVE(C_string_to_Poly(taskData, keyName)); - result = alloc_and_save(taskData, 1); - DEREFHANDLE(result)->Set(0, resVal->Word()); - return result; + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); } struct _entrypts osSpecificEPT[] = { { "PolyGetOSType", (polyRTSFunction)&PolyGetOSType}, - { "PolyOSSpecificGeneral", (polyRTSFunction)&PolyOSSpecificGeneral}, + { "PolyWindowsExecute", (polyRTSFunction)& PolyWindowsExecute}, + { "PolyWindowsOpenProcessHandle", (polyRTSFunction)& PolyWindowsOpenProcessHandle}, + { "PolyWindowsGetProcessResult", (polyRTSFunction)& PolyWindowsGetProcessResult}, + { "PolyWindowsSimpleExecute", (polyRTSFunction)& PolyWindowsSimpleExecute}, + { "PolyWindowsDDEStartDialogue", (polyRTSFunction)& PolyWindowsDDEStartDialogue}, + { "PolyWindowsDDEExecute", (polyRTSFunction)& PolyWindowsDDEExecute}, + { "PolyWindowsDDEClose", (polyRTSFunction)& PolyWindowsDDEClose}, + { "PolyWindowsGetCodePage", (polyRTSFunction)& PolyWindowsGetCodePage}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/winguiconsole.cpp b/libpolyml/winguiconsole.cpp index 2b89c6d9..90bbe809 100644 --- a/libpolyml/winguiconsole.cpp +++ b/libpolyml/winguiconsole.cpp @@ -1,703 +1,706 @@ /* Title: Poly/ML Console Window. Copyright (c) 2000, 2015, 2018, 2019 David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_WINDOWS_H #include // Include first to avoid conflicts #include #include #endif #ifdef HAVE_TCHAR_H #include #endif #ifdef HAVE_IO_H #include #endif #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #include "../resource.h" #include "sighandler.h" // For RequestConsoleInterrupt #include "processes.h" #include "polystring.h" // For codepage #include "io_internal.h" #include "locking.h" #include "winguiconsole.h" /* This module takes the place of the Windows console which has a number of problems, apart from not being a pleasant user interface. It creates a main window containing an edit control, which it has to sub-class so that we can receive all the characters as they are typed. I've written this in C using the direct Windows calls to make it fairly independent of the compiler. It would definitely be simpler and cleaner written in C++ using MFC. DCJM 30/5/2000. */ HWND hMainWindow = NULL; // Main window - exported. extern HINSTANCE hApplicationInstance; // Application instance (exported) static HANDLE hReadFromML; // Handles to pipe from ML thread static WNDPROC wpOrigEditProc; // Saved window proc. static BOOL fAtEnd; // True if we are at the end of the window static HWND hEditWnd; // Edit sub-window static CHAR *pchInputBuffer; // Buffer to text read. static int nBuffLen; // Length of input buffer. static int nNextPosn; // Position to add input. (<= nBuffLen) static int nAvailable; // Position of "committed" input (<= nNextPosn) static int nReadPosn; // Position of last read (<= nAvailable) static PLock iOInterlock; static HANDLE hInputEvent; // Signalled when input is available. static int nInitialShow; // Value of nCmdShow passed in. static bool isActive = false; #ifdef UNICODE #define DDECODEPAGE CP_WINUNICODE #else #define DDECODEPAGE CP_WINANSI #endif /* All addition is made at the end of the text so this function is called to find out if we're there. */ static void MoveToEnd(void) { if (! fAtEnd) { // Make sure any text we add goes at the end. LRESULT dwEnd = SendMessage(hEditWnd, WM_GETTEXTLENGTH, 0, 0); SendMessage(hEditWnd, EM_SETSEL, dwEnd, dwEnd); fAtEnd = TRUE; } } // Remove lines at the beginning until we have enough space. // If nChars is bigger than the limit we'll delete everything and // return. Returns the space removed. static DWORD CheckForScreenSpace(LRESULT nChars) { DWORD dwRemoved = 0; // TODO: We could avoid these calls by remembering this information. LRESULT limit = SendMessage(hEditWnd, EM_GETLIMITTEXT, 0, 0); LRESULT size = SendMessage(hEditWnd, WM_GETTEXTLENGTH, 0, 0); while (nChars+size >= limit) { int i; if (size == 0) return dwRemoved; for (i = 0; i < size; i++) { if (SendMessage(hEditWnd, EM_LINEFROMCHAR, i, 0) != 0) break; } SendMessage(hEditWnd, EM_SETSEL, 0, i); SendMessage(hEditWnd, WM_CLEAR, 0, 0); fAtEnd = FALSE; MoveToEnd(); size -= i; dwRemoved += i; } return dwRemoved; } // Expand the buffer if necessary to allow room for // additional characters. static void CheckForBufferSpace(int nChars) { BOOL fOverflow; if (nNextPosn >= nReadPosn) fOverflow = nNextPosn+nChars >= nReadPosn+nBuffLen; else fOverflow = nNextPosn+nChars >= nReadPosn; if (fOverflow) { int nOldLen = nBuffLen; // Need more space. nBuffLen = nBuffLen + nChars + nBuffLen/2; pchInputBuffer = (char*)realloc(pchInputBuffer, nBuffLen); // Have to copy any data that has wrapped round to the // new area. if (nNextPosn < nReadPosn) { int nExtra = nBuffLen-nOldLen; if (nExtra >= nNextPosn) { // All the space before will fit in the new area. memcpy(pchInputBuffer+nOldLen, pchInputBuffer, nNextPosn); } else { // Some of the space before will fit but not all. memcpy(pchInputBuffer+nOldLen, pchInputBuffer, nExtra); memmove(pchInputBuffer, pchInputBuffer+nExtra, nNextPosn-nExtra); } // Adjust these pointers modulo the old and new lengths. if (nAvailable < nNextPosn) nAvailable += nOldLen; if (nAvailable >= nBuffLen) nAvailable -= nBuffLen; nNextPosn += nOldLen; if (nNextPosn >= nBuffLen) nNextPosn -= nBuffLen; } } ASSERT(nBuffLen >= 0 && nAvailable >= 0 && nNextPosn >= 0 && nReadPosn >= 0 && nAvailable < nBuffLen && nReadPosn < nBuffLen && nReadPosn < nBuffLen); if (nNextPosn > nReadPosn) ASSERT(nAvailable >= nReadPosn && nAvailable <= nNextPosn); else ASSERT((nNextPosn != nReadPosn && nAvailable <= nNextPosn) || nAvailable >= nReadPosn); } /* In order to be able to handle all the keys we need to sub-class the edit control. */ static LRESULT APIENTRY EditSubclassProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam) { switch (uMsg) { case WM_GETDLGCODE: return DLGC_WANTALLKEYS | DLGC_WANTCHARS; case WM_KEYDOWN: switch(wParam) { case VK_DELETE: // Ignore the delete key. Beep perhaps? return 0; case VK_LEFT: // If we move the cursor we are probably not case VK_RIGHT: // at the end. case VK_UP: case VK_DOWN: fAtEnd = FALSE; default: return CallWindowProc(wpOrigEditProc, hwnd, uMsg, wParam, lParam); } case WM_CHAR: { LPARAM nRpt = lParam & 0xffff; PLocker locker(&iOInterlock); if (wParam == '\b') { // Delete the previous character(s). if (nNextPosn != nAvailable) { int nCanRemove = 0; while (nRpt-- > 0 && nNextPosn != nAvailable) { nCanRemove++; if (nNextPosn == 0) nNextPosn = nBuffLen; nNextPosn--; } lParam = (lParam & 0xffff0000) | nCanRemove; return CallWindowProc(wpOrigEditProc, hwnd, uMsg, wParam, lParam); } } else if (wParam == 22) // Control-V { // Generate a Paste command. SendMessage(hMainWindow, WM_COMMAND, ID_EDIT_PASTE, 0); } else if (wParam == 3) // Control-C { // In Windows this has the effect of Copy but we also // want it to generate an interrupt. I've chosen to // make it copy if there is any selection, otherwise to // generate an interrupt. We'll have to see how this works. DWORD dwStart, dwEnd; SendMessage(hwnd, EM_GETSEL, (WPARAM)&dwStart, (LPARAM)&dwEnd); if (dwStart != dwEnd) { SendMessage(hwnd, WM_COPY, 0, 0); } else { // Discard any type-ahead. nNextPosn = nAvailable = nReadPosn = 0; RequestConsoleInterrupt(); } } else if (wParam >= ' ' || wParam == '\r' || wParam == '\t' || wParam == 4 /* ctrl-D */ || wParam == 26 /* ctrl-Z */) { CheckForBufferSpace((int)nRpt); CheckForScreenSpace(nRpt); // Make sure we have space on the screen. // Add the character(s) to the buffer. while (nRpt-- > 0) { if (wParam == '\r') { pchInputBuffer[nNextPosn++] = '\n'; nAvailable = nNextPosn; SetEvent(hInputEvent); } else if (wParam == 4 || wParam == 26) { // Treat either of these as EOF chars. pchInputBuffer[nNextPosn++] = (CHAR)wParam; nAvailable = nNextPosn; SetEvent(hInputEvent); wParam = 4; } else pchInputBuffer[nNextPosn++] = (CHAR)wParam; if (nNextPosn == nBuffLen) nNextPosn = 0; if (nAvailable == nBuffLen) nAvailable = 0; } MoveToEnd(); // Add this to the window except if it's ctrl-Z or ctrl-D. if (wParam == 4 || wParam == 26) return 0; return CallWindowProc(wpOrigEditProc, hwnd, uMsg, wParam, lParam); } return 0; } case WM_DESTROY: { HFONT hFount; // Switch back to the old window proc just in case. #ifdef _M_AMD64 SetWindowLongPtr(hwnd, GWLP_WNDPROC, (INT_PTR)wpOrigEditProc); SetWindowLongPtr(hwnd, GWLP_USERDATA, 0); #else SetWindowLong(hwnd, GWL_WNDPROC, (LONG)wpOrigEditProc); SetWindowLong(hwnd, GWL_USERDATA, 0); #endif // Get the fount and delete it if it's not the default. hFount = (HFONT)SendMessage(hwnd, WM_GETFONT, 0, 0); if (hFount != NULL) { SendMessage(hwnd, WM_SETFONT, (WPARAM)NULL, FALSE); DeleteObject(hFount); } // Call the original to finish off. return CallWindowProc(wpOrigEditProc, hwnd, uMsg, wParam, lParam); } case WM_LBUTTONDOWN: case WM_RBUTTONDOWN: case WM_LBUTTONUP: case WM_RBUTTONUP: case EM_SETSEL: // Need to record that we may no longer be at the end of the text. fAtEnd = FALSE; // Drop through to default. default: return CallWindowProc(wpOrigEditProc, hwnd, uMsg, wParam, lParam); } } /* This function is only used when the "About Poly/ML" dialogue box is being displayed. */ static BOOL CALLBACK AboutProc(HWND hwndDlg, UINT uMsg, WPARAM wParam, LPARAM lParam) { switch (uMsg) { case WM_INITDIALOG: return 1; case WM_COMMAND: if (wParam == IDOK) { EndDialog(hwndDlg, IDOK); return 1; } case WM_CLOSE: EndDialog(hwndDlg, IDOK); return 1; default: return 0; } } #ifdef UNICODE #define CF_TEXTFORMAT CF_UNICODETEXT #else #define CF_TEXTFORMAT CF_TEXT #endif /* Messages interpreted by the main window thread. */ #define WM_ADDTEXT WM_APP /* This is the main window procedure. */ LRESULT CALLBACK WndProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam) { switch (uMsg) { case WM_CREATE: { LoadLibrary(TEXT("Riched20.dll")); hEditWnd = CreateWindow(RICHEDIT_CLASS, TEXT(""), WS_CHILD | WS_VISIBLE | WS_VSCROLL | WS_HSCROLL | ES_LEFT | ES_MULTILINE | ES_AUTOVSCROLL | ES_AUTOHSCROLL, 0, 0, 0, 0, hwnd, 0, hApplicationInstance, NULL); if (hEditWnd == NULL) return -1; /* Failed */ // Sub-class this so that we get the keys that are pressed. // Save the old window proc. #ifdef _M_AMD64 wpOrigEditProc = (WNDPROC)GetWindowLongPtr(hEditWnd, GWLP_WNDPROC); // Set our new window proc. SetWindowLongPtr(hEditWnd, GWLP_WNDPROC, (INT_PTR)EditSubclassProc); #else wpOrigEditProc = (WNDPROC)GetWindowLong(hEditWnd, GWL_WNDPROC); // Set our new window proc. SetWindowLong(hEditWnd, GWL_WNDPROC, (LONG)EditSubclassProc); #endif fAtEnd = TRUE; // Get a 10 point Courier fount. HDC hDC = GetDC(hEditWnd); int nHeight = -MulDiv(10, GetDeviceCaps(hDC, LOGPIXELSY), 72); ReleaseDC(hEditWnd, hDC); HFONT hFont = CreateFont(nHeight, 0, 0, 0, FW_DONTCARE, FALSE, FALSE, FALSE, ANSI_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, FIXED_PITCH | FF_MODERN, _T("Courier")); if (hFont) SendMessage(hEditWnd, WM_SETFONT, (WPARAM)hFont, 0); SetWindowText(hEditWnd, _T("")); return 0; /* Succeeded */ } case WM_SETFOCUS: /* When the focus arrives at the parent set the focus on the edit window. */ SetFocus(hEditWnd); return 0; case WM_SIZE: { LONG offset = 0; // Make the edit control the size of the window's client area. MoveWindow(hEditWnd, 0, offset, LOWORD(lParam), HIWORD(lParam)-offset, TRUE); } return 0; case WM_DESTROY: PostQuitMessage(0); return 0; case WM_COMMAND: switch(wParam) { case ID_EDIT_COPY: SendMessage(hEditWnd, WM_COPY, 0, 0); return 0; case ID_EDIT_PASTE: if (IsClipboardFormatAvailable(CF_TEXTFORMAT)) { // We need to check that we have enough space // BEFORE we try pasting. HANDLE hClip; LPCTSTR lpszText; OpenClipboard(hEditWnd); hClip = GetClipboardData(CF_TEXTFORMAT); lpszText = (LPCTSTR)GlobalLock(hClip); CheckForScreenSpace(lstrlen(lpszText)); MoveToEnd(); // Add it to the screen. // SendMessage(hEditWnd, EM_REPLACESEL, FALSE, (LPARAM)lpszText); // Add to the type-ahead. PLocker locker(&iOInterlock); // Check there's enough space. This may be an // over-estimate since we replace CRNL by NL. CheckForBufferSpace(lstrlen(lpszText)); while (*lpszText) { // The data we're pasting contains CRNL as // line separators. if (lpszText[0] == '\r' && lpszText[1] == '\n') { pchInputBuffer[nNextPosn++] = '\n'; if (nNextPosn == nBuffLen) nNextPosn = 0; nAvailable = nNextPosn; lpszText += 2; } else { pchInputBuffer[nNextPosn++] = (char)*lpszText++; if (nNextPosn == nBuffLen) nNextPosn = 0; if (lpszText[0] == 4 || lpszText[0] == 26) nAvailable = nNextPosn; // EOF characters. } } if (nAvailable != nReadPosn) SetEvent(hInputEvent); GlobalUnlock(hClip); CloseClipboard(); } return 0; case ID_HELP_ABOUT: DialogBox(hApplicationInstance, MAKEINTRESOURCE(IDD_ABOUT_POLYML), hwnd, (DLGPROC)AboutProc); return 0; case ID_FILE_QUIT: if (MessageBox(hwnd, _T("Are you sure you want to quit?"), _T("Confirm Quit"), MB_OKCANCEL) == IDOK) processes->RequestProcessExit(0); return 0; case ID_RUN_INTERRUPT: // Discard any type-ahead. nNextPosn = nAvailable = nReadPosn = 0; RequestConsoleInterrupt(); return 0; default: return DefWindowProc(hwnd, uMsg, wParam, lParam); } case WM_CLOSE: if (MessageBox(hwnd, _T("Are you sure you want to quit?"), _T("Confirm Quit"), MB_OKCANCEL) == IDOK) processes->RequestProcessExit(0); return 0; case WM_ADDTEXT: // Request from the input thread to add some text. { // Remember the old selection and the original length. LRESULT lrStart, lrEnd; SendMessage(hEditWnd, EM_GETSEL, (WPARAM)&lrStart, (LPARAM)&lrEnd); LRESULT lrLength = SendMessage(hEditWnd, WM_GETTEXTLENGTH, 0, 0); LRESULT lrRemoved = CheckForScreenSpace(lrLength); MoveToEnd(); SendMessage(hEditWnd, EM_REPLACESEL, 0, lParam); // If the old selection was at the end (i.e. the pointer // was at the end) we don't reinstate the old selection. if (lrStart != lrLength && lrEnd > lrRemoved) { if (lrStart > lrRemoved) lrStart -= lrRemoved; else lrStart = 0; fAtEnd = FALSE; SendMessage(hEditWnd, EM_SETSEL, lrStart, lrEnd-lrRemoved); } return 0; } default: return DefWindowProc(hwnd, uMsg, wParam, lParam); } } static DWORD WINAPI InThrdProc(LPVOID lpParameter) // This thread deals with input from the ML process. { while (1) { CHAR buff[4096]; DWORD dwRead; if (!ReadFile(hReadFromML, buff, sizeof(buff) - 1, &dwRead, NULL)) return 0; buff[dwRead] = 0; if (! isActive) { ShowWindow(hMainWindow, nInitialShow); isActive = true; } #ifdef UNICODE // We need to write Unicode here. Convert it using the current code-page. int wlen = MultiByteToWideChar(codePage, 0, buff, -1, NULL, 0); if (wlen == 0) continue; WCHAR *wBuff = new WCHAR[wlen]; wlen = MultiByteToWideChar(codePage, 0, buff, -1, wBuff, wlen); SendMessage(hMainWindow, WM_ADDTEXT, 0, (LPARAM)wBuff); delete[] wBuff; #else SendMessage(hMainWindow, WM_ADDTEXT, 0, (LPARAM)buff); #endif } } class WinGuiConsoleStream : public WinStream { public: WinGuiConsoleStream() {} - virtual bool isAvailable(TaskData *taskData); - virtual void waitUntilAvailable(TaskData *taskData); + virtual bool testForInput(TaskData *taskData, unsigned waitMilliSecs); + + virtual bool testForOutput(TaskData *taskData, unsigned waitMilliSecs) { + unimplemented(taskData); + return false; + } virtual size_t readStream(TaskData *taskData, byte *base, size_t length); virtual int fileKind() { return FILEKIND_TTY; // Treat it as a TTY i.e. an interactive input } virtual void closeEntry(TaskData *taskData) { } // Not closed virtual bool canOutput(TaskData *taskData) { return false; } virtual size_t writeStream(TaskData *taskData, byte *base, size_t length) { unimplemented(taskData); return 0; } }; -bool WinGuiConsoleStream::isAvailable(TaskData *taskData) +bool WinGuiConsoleStream::testForInput(TaskData *taskData, unsigned waitMilliSecs) { if (!isActive) { ShowWindow(hMainWindow, nInitialShow); isActive = true; } - PLocker locker(&iOInterlock); - return nAvailable != nReadPosn; + { + PLocker locker(&iOInterlock); + if (nAvailable != nReadPosn) return true; + } + if (waitMilliSecs != 0) + { + WaitHandle waiter(hInputEvent, waitMilliSecs); // Global event + processes->ThreadPauseForIO(taskData, &waiter); + } + return false; // It may actually be ready now. } size_t WinGuiConsoleStream::readStream(TaskData *taskData, byte *base, size_t length) /* Read characters from the input. Only returns zero on EOF. */ { unsigned nRes = 0; if (!isActive) { ShowWindow(hMainWindow, nInitialShow); isActive = true; } PLocker locker(&iOInterlock); // Copy the available characters into the buffer. while (nReadPosn != nAvailable && length-- > 0) { char ch; ch = pchInputBuffer[nReadPosn]; if (ch == 4 || ch == 26) { // EOF character. We have to return this as // a separate buffer of size zero so if we've // already returned some characters we leave it till // next time. if (nRes == 0) if (++nReadPosn == nBuffLen) nReadPosn = 0; break; } base[nRes++] = ch; if (++nReadPosn == nBuffLen) nReadPosn = 0; } if (nAvailable == nReadPosn) ResetEvent(hInputEvent); return nRes; } -void WinGuiConsoleStream::waitUntilAvailable(TaskData *taskData) -{ - while (!isAvailable(taskData)) - { - WaitHandle waiter(hInputEvent); // Global event - processes->ThreadPauseForIO(taskData, &waiter); - } -} - HANDLE createConsoleWindow(int nCmdShow) { WNDCLASSEX wndClass; ATOM atClass; // Allocate initial buffer space to maintain the invariants. hInputEvent = CreateEvent(NULL, TRUE, FALSE, NULL); nBuffLen = 80; pchInputBuffer = (char*)malloc(nBuffLen); TCHAR pipeName[MAX_PATH]; newPipeName(pipeName); hReadFromML = CreateNamedPipe(pipeName, PIPE_ACCESS_INBOUND | FILE_FLAG_FIRST_PIPE_INSTANCE, PIPE_READMODE_BYTE | PIPE_WAIT | PIPE_REJECT_REMOTE_CLIENTS, 1, 4096, 4096, 0, NULL); if (hReadFromML == INVALID_HANDLE_VALUE) return INVALID_HANDLE_VALUE; // We want to be able to inherit this handle. SECURITY_ATTRIBUTES secure; secure.nLength = sizeof(SECURITY_ATTRIBUTES); secure.lpSecurityDescriptor = NULL; secure.bInheritHandle = TRUE; HANDLE hWriteToScreen = CreateFile(pipeName, GENERIC_WRITE, 0, &secure, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL | FILE_FLAG_OVERLAPPED, NULL); if (hWriteToScreen == INVALID_HANDLE_VALUE) return INVALID_HANDLE_VALUE; // Create a thread to manage the output from ML. DWORD dwInId; HANDLE hInThread = CreateThread(NULL, 0, InThrdProc, 0, 0, &dwInId); if (hInThread == NULL) return INVALID_HANDLE_VALUE; CloseHandle(hInThread); wndClass.cbSize = sizeof(wndClass); wndClass.style = 0; wndClass.lpfnWndProc = WndProc; wndClass.cbClsExtra = 0; wndClass.cbWndExtra = 0; wndClass.hInstance = hApplicationInstance; wndClass.hIcon = LoadIcon(hApplicationInstance, MAKEINTRESOURCE(IDI_ICON)); wndClass.hCursor = NULL; // For the moment wndClass.hbrBackground = NULL; // For the moment wndClass.lpszClassName = _T("PolyMLWindowClass"); wndClass.lpszMenuName = MAKEINTRESOURCE(IDR_MENU); wndClass.hIconSm = NULL; // For the moment DWORD dwStyle = WS_OVERLAPPEDWINDOW; if ((atClass = RegisterClassEx(&wndClass)) == 0) return INVALID_HANDLE_VALUE; // Initially created invisible. hMainWindow = CreateWindow( (LPTSTR)(intptr_t)atClass, _T("Poly/ML"), dwStyle, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, NULL, NULL, // handle to menu or child-window identifier hApplicationInstance, NULL // pointer to window-creation data ); if (hMainWindow == NULL) return INVALID_HANDLE_VALUE; // Save this setting and only apply it when we actually // read from or write to the main window. That way if we are // actually using another window this will never get displayed. nInitialShow = nCmdShow; return hWriteToScreen; } WinStream *createConsoleStream() { return new WinGuiConsoleStream(); } void closeConsole() { if (hInputEvent) CloseHandle(hInputEvent); } diff --git a/libpolyml/x86_dep.cpp b/libpolyml/x86_dep.cpp index d98c7edb..ab038aec 100644 --- a/libpolyml/x86_dep.cpp +++ b/libpolyml/x86_dep.cpp @@ -1,1464 +1,1467 @@ /* Title: Machine dependent code for i386 and X64 under Windows and Unix Copyright (c) 2000-7 Cambridge University Technical Services Limited Further work copyright David C. J. Matthews 2011-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 */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDLIB_H #include #endif #include #ifdef HAVE_SIGNAL_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #if (defined(_WIN32)) #include #include #endif #include "globals.h" #include "run_time.h" #include "diagnostics.h" #include "processes.h" #include "profiling.h" #include "machine_dep.h" #include "scanaddrs.h" #include "memmgr.h" #include "rtsentry.h" #include "sys.h" // Temporary /********************************************************************** * * Register usage: * * %Reax: First argument to function. Result of function call. * %Rebx: Second argument to function. * %Recx: General register * %Redx: Closure pointer in call. * %Rebp: Points to memory used for extra registers * %Resi: General register. * %Redi: General register. * %Resp: Stack pointer. * The following apply only on the X64 * %R8: Third argument to function * %R9: Fourth argument to function * %R10: Fifth argument to function * %R11: General register * %R12: General register * %R13: General register * %R14: General register * %R15: Memory allocation pointer * **********************************************************************/ #ifdef HOSTARCHITECTURE_X86_64 struct fpSaveArea { double fpregister[7]; // Save area for xmm0-6 }; #else // Structure of floating point save area. // This is dictated by the hardware. typedef byte fpregister[10]; struct fpSaveArea { unsigned short cw; unsigned short _unused0; unsigned short sw; unsigned short _unused1; unsigned short tw; unsigned short _unused2; unsigned fip; unsigned short fcs0; unsigned short _unused3; unsigned foo; unsigned short fcs1; unsigned short _unused4; fpregister registers[8]; }; #endif /* the amount of ML stack space to reserve for registers, C exception handling etc. The compiler requires us to reserve 2 stack-frames worth (2 * 20 words). We actually reserve slightly more than this. */ #if (!defined(_WIN32) && !defined(HAVE_SIGALTSTACK)) // If we can't handle signals on a separate stack make sure there's space // on the Poly stack. #define OVERFLOW_STACK_SIZE (50+1024) #else #define OVERFLOW_STACK_SIZE 50 #endif union stackItem { /* #ifndef POLYML32IN64 stackItem(PolyWord v) { words[0] = v.AsUnsigned(); }; stackItem() { words[0] = TAGGED(0).AsUnsigned(); } POLYUNSIGNED words[1]; #else // In 32-in-64 we need to clear the second PolyWord. This assumes little-endian. stackItem(PolyWord v) { words[0] = v.AsUnsigned(); words[1] = 0; }; stackItem() { words[0] = TAGGED(0).AsUnsigned(); words[1] = 0; } POLYUNSIGNED words[2]; #endif */ stackItem(PolyWord v) { argValue = v.AsUnsigned(); } stackItem() { argValue = TAGGED(0).AsUnsigned(); } // These return the low order word. PolyWord w()const { return PolyWord::FromUnsigned((POLYUNSIGNED)argValue); } operator PolyWord () { return PolyWord::FromUnsigned((POLYUNSIGNED)argValue); } POLYCODEPTR codeAddr; // Return addresses stackItem *stackAddr; // Stack addresses uintptr_t argValue; // Treat an address as an int }; class X86TaskData; // This is passed as the argument vector to X86AsmSwitchToPoly. // The offsets are built into the assembly code and the code-generator. // localMpointer and stackPtr are updated before control returns to C. typedef struct _AssemblyArgs { public: PolyWord *localMpointer; // Allocation ptr + 1 word stackItem *handlerRegister; // Current exception handler PolyWord *localMbottom; // Base of memory + 1 word stackItem *stackLimit; // Lower limit of stack stackItem exceptionPacket; // Set if there is an exception byte unusedRequestCode; // No longer used. byte unusedFlag; // No longer used byte returnReason; // Reason for returning from ML. byte unusedRestore; // No longer used. uintptr_t saveCStack; // Saved C stack frame. PolyWord threadId; // My thread id. Saves having to call into RTS for it. stackItem *stackPtr; // Current stack pointer byte *noLongerUsed; // Now removed byte *heapOverFlowCall; // These are filled in with the functions. byte *stackOverFlowCall; byte *stackOverFlowCallEx; // Saved registers, where applicable. stackItem p_rax; stackItem p_rbx; stackItem p_rcx; stackItem p_rdx; stackItem p_rsi; stackItem p_rdi; #ifdef HOSTARCHITECTURE_X86_64 stackItem p_r8; stackItem p_r9; stackItem p_r10; stackItem p_r11; stackItem p_r12; stackItem p_r13; stackItem p_r14; #endif struct fpSaveArea p_fp; } AssemblyArgs; // These next few are temporarily added for the interpreter // This duplicates some code in reals.cpp but is now updated. #define DOUBLESIZE (sizeof(double)/sizeof(POLYUNSIGNED)) union realdb { double dble; POLYUNSIGNED puns[DOUBLESIZE]; }; #define LGWORDSIZE (sizeof(uintptr_t) / sizeof(PolyWord)) class X86TaskData: public TaskData { public: X86TaskData(); unsigned allocReg; // The register to take the allocated space. POLYUNSIGNED allocWords; // The words to allocate. Handle callBackResult; AssemblyArgs assemblyInterface; int saveRegisterMask; // Registers that need to be updated by a GC. virtual void GarbageCollect(ScanAddress *process); void ScanStackAddress(ScanAddress *process, stackItem &val, StackSpace *stack); virtual Handle EnterPolyCode(); // Start running ML virtual void InterruptCode(); virtual bool AddTimeProfileCount(SIGNALCONTEXT *context); virtual void InitStackFrame(TaskData *parentTask, Handle proc, Handle arg); virtual void SetException(poly_exn *exc); // Release a mutex in exactly the same way as compiler code virtual Handle AtomicIncrement(Handle mutexp); virtual void AtomicReset(Handle mutexp); // Return the minimum space occupied by the stack. Used when setting a limit. // N.B. This is PolyWords not native words. virtual uintptr_t currentStackSpace(void) const { return (this->stack->top - (PolyWord*)assemblyInterface.stackPtr) + OVERFLOW_STACK_SIZE*sizeof(uintptr_t)/sizeof(PolyWord); } // Increment the profile count for an allocation. Also now used for mutex contention. virtual void addProfileCount(POLYUNSIGNED words) { add_count(this, assemblyInterface.stackPtr[0].codeAddr, words); } // PreRTSCall: After calling from ML to the RTS we need to save the current heap pointer virtual void PreRTSCall(void) { TaskData::PreRTSCall(); SaveMemRegisters(); } // PostRTSCall: Before returning we need to restore the heap pointer. // If there has been a GC in the RTS call we need to create a new heap area. virtual void PostRTSCall(void) { SetMemRegisters(); TaskData::PostRTSCall(); } virtual void CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length); virtual Handle EnterCallbackFunction(Handle func, Handle args); int SwitchToPoly(); void HeapOverflowTrap(byte *pcPtr); void SetMemRegisters(); void SaveMemRegisters(); void SetRegisterMask(); void MakeTrampoline(byte **pointer, byte*entryPt); PLock interruptLock; stackItem *get_reg(int n); stackItem *®SP() { return assemblyInterface.stackPtr; } stackItem ®AX() { return assemblyInterface.p_rax; } stackItem ®BX() { return assemblyInterface.p_rbx; } stackItem ®CX() { return assemblyInterface.p_rcx; } stackItem ®DX() { return assemblyInterface.p_rdx; } stackItem ®SI() { return assemblyInterface.p_rsi; } stackItem ®DI() { return assemblyInterface.p_rdi; } #ifdef HOSTARCHITECTURE_X86_64 stackItem ®8() { return assemblyInterface.p_r8; } stackItem ®9() { return assemblyInterface.p_r9; } stackItem ®10() { return assemblyInterface.p_r10; } stackItem ®11() { return assemblyInterface.p_r11; } stackItem ®12() { return assemblyInterface.p_r12; } stackItem ®13() { return assemblyInterface.p_r13; } stackItem ®14() { return assemblyInterface.p_r14; } #endif #if (defined(_WIN32)) DWORD savedErrno; #else int savedErrno; #endif }; class X86Dependent: public MachineDependent { public: X86Dependent() {} // Create a task data object. virtual TaskData *CreateTaskData(void) { return new X86TaskData(); } // Initial size of stack in PolyWords virtual unsigned InitialStackSize(void) { return (128+OVERFLOW_STACK_SIZE) * sizeof(uintptr_t) / sizeof(PolyWord); } virtual void ScanConstantsWithinCode(PolyObject *addr, PolyObject *oldAddr, POLYUNSIGNED length, ScanAddress *process); virtual Architectures MachineArchitecture(void) #ifndef HOSTARCHITECTURE_X86_64 { return MA_I386; } #elif defined(POLYML32IN64) { return MA_X86_64_32; } #else { return MA_X86_64; } #endif }; // Values for the returnReason byte enum RETURN_REASON { RETURN_IO_CALL_NOW_UNUSED = 0, RETURN_HEAP_OVERFLOW = 1, RETURN_STACK_OVERFLOW = 2, RETURN_STACK_OVERFLOWEX = 3, RETURN_CALLBACK_RETURN = 6, RETURN_CALLBACK_EXCEPTION = 7, RETURN_KILL_SELF = 9 }; extern "C" { // These are declared in the assembly code segment. void X86AsmSwitchToPoly(void *); extern int X86AsmKillSelf(void); extern int X86AsmCallbackReturn(void); extern int X86AsmCallbackException(void); extern int X86AsmPopArgAndClosure(void); extern int X86AsmRaiseException(void); extern int X86AsmCallExtraRETURN_HEAP_OVERFLOW(void); extern int X86AsmCallExtraRETURN_STACK_OVERFLOW(void); extern int X86AsmCallExtraRETURN_STACK_OVERFLOWEX(void); POLYUNSIGNED X86AsmAtomicIncrement(PolyObject*); POLYUNSIGNED X86AsmAtomicDecrement(PolyObject*); }; // Pointers to assembly code or trampolines to assembly code. static byte *popArgAndClosure, *killSelf, *raiseException, *callbackException, *callbackReturn; X86TaskData::X86TaskData(): allocReg(0), allocWords(0), saveRegisterMask(0) { assemblyInterface.heapOverFlowCall = (byte*)X86AsmCallExtraRETURN_HEAP_OVERFLOW; assemblyInterface.stackOverFlowCall = (byte*)X86AsmCallExtraRETURN_STACK_OVERFLOW; assemblyInterface.stackOverFlowCallEx = (byte*)X86AsmCallExtraRETURN_STACK_OVERFLOWEX; savedErrno = 0; } void X86TaskData::GarbageCollect(ScanAddress *process) { TaskData::GarbageCollect(process); // Process the parent first assemblyInterface.threadId = threadObject; if (stack != 0) { // Now the values on the stack. for (stackItem *q = assemblyInterface.stackPtr; q < (stackItem*)stack->top; q++) ScanStackAddress(process, *q, stack); } // Register mask for (int i = 0; i < 16; i++) { if (saveRegisterMask & (1 << i)) ScanStackAddress(process, *get_reg(i), stack); } } // Process a value within the stack. void X86TaskData::ScanStackAddress(ScanAddress *process, stackItem &stackItem, StackSpace *stack) { // We may have return addresses on the stack which could look like // tagged values. Check whether the value is in the code area before // checking whether it is untagged. #ifdef POLYML32IN64 // In 32-in-64 return addresses always have the top 32 bits non-zero. if (stackItem.argValue < ((uintptr_t)1 << 32)) { // It's either a tagged integer or an object pointer. if (stackItem.w().IsDataPtr()) { PolyWord val = process->ScanObjectAddress(stackItem.w().AsObjPtr()); stackItem = val; } } else { // Could be a code address or a stack address. MemSpace *space = gMem.SpaceForAddress(stackItem.codeAddr - 1); if (space == 0 || space->spaceType != ST_CODE) return; PolyObject *obj = gMem.FindCodeObject(stackItem.codeAddr); ASSERT(obj != 0); // Process the address of the start. Don't update anything. process->ScanObjectAddress(obj); } #else // The -1 here is because we may have a zero-sized cell in the last // word of a space. MemSpace *space = gMem.SpaceForAddress(stackItem.codeAddr-1); if (space == 0) return; // In particular we may have one of the assembly code addresses. if (space->spaceType == ST_CODE) { PolyObject *obj = gMem.FindCodeObject(stackItem.codeAddr); // If it is actually an integer it might be outside a valid code object. if (obj == 0) { ASSERT(stackItem.w().IsTagged()); // It must be an integer } else // Process the address of the start. Don't update anything. process->ScanObjectAddress(obj); } else if (space->spaceType == ST_LOCAL && stackItem.w().IsDataPtr()) // Local values must be word addresses. { PolyWord val = process->ScanObjectAddress(stackItem.w().AsObjPtr()); stackItem = val; } #endif } // Copy a stack void X86TaskData::CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length) { /* Moves a stack, updating all references within the stack */ #ifdef POLYML32IN64 old_length = old_length / 2; new_length = new_length / 2; #endif stackItem *old_base = (stackItem *)old_stack; stackItem *new_base = (stackItem*)new_stack; stackItem *old_top = old_base + old_length; /* Calculate the offset of the new stack from the old. If the frame is being extended objects in the new frame will be further up the stack than in the old one. */ uintptr_t offset = new_base - old_base + new_length - old_length; stackItem *oldStackPtr = assemblyInterface.stackPtr; // Adjust the stack pointer and handler pointer since these point into the stack. assemblyInterface.stackPtr = assemblyInterface.stackPtr + offset; assemblyInterface.handlerRegister = assemblyInterface.handlerRegister + offset; // We need to adjust any values on the stack that are pointers within the stack. // Skip the unused part of the stack. size_t i = oldStackPtr - old_base; ASSERT (i <= old_length); i = old_length - i; stackItem *old = oldStackPtr; stackItem *newp = assemblyInterface.stackPtr; while (i--) { stackItem old_word = *old++; if (old_word.w().IsDataPtr() && old_word.stackAddr >= old_base && old_word.stackAddr <= old_top) old_word.stackAddr = old_word.stackAddr + offset; else if (old_word.w().IsDataPtr() && IsHeapAddress(old_word.stackAddr)) { stackItem *addr = (stackItem*)old_word.w().AsStackAddr(); if (addr >= old_base && addr <= old_top) { addr += offset; old_word = PolyWord::FromStackAddr((PolyWord*)addr); } } *newp++ = old_word; } ASSERT(old == ((stackItem*)old_stack)+old_length); ASSERT(newp == ((stackItem*)new_stack)+new_length); // And change any registers that pointed into the old stack for (int j = 0; j < 16; j++) { if (saveRegisterMask & (1 << j)) { stackItem *regAddr = get_reg(j); stackItem old_word = *regAddr; if (old_word.w().IsDataPtr() && old_word.stackAddr >= old_base && old_word.stackAddr <= old_top) old_word.stackAddr = old_word.stackAddr + offset; else if (old_word.w().IsDataPtr() && IsHeapAddress(old_word.stackAddr)) { stackItem *addr = (stackItem*)old_word.w().AsStackAddr(); if (addr >= old_base && addr <= old_top) { addr += offset; old_word = PolyWord::FromStackAddr((PolyWord*)addr); } } *regAddr = old_word; } } } Handle X86TaskData::EnterPolyCode() /* Called from "main" to enter the code. */ { Handle hOriginal = this->saveVec.mark(); // Set this up for the IO calls. while (1) { this->saveVec.reset(hOriginal); // Remove old RTS arguments and results. // Run the ML code and return with the function to call. this->inML = true; int ioFunction = SwitchToPoly(); this->inML = false; try { switch (ioFunction) { case -1: // We've been interrupted. This usually involves simulating a // stack overflow so we could come here because of a genuine // stack overflow. // Previously this code was executed on every RTS call but there // were problems on Mac OS X at least with contention on schedLock. // Process any asynchronous events i.e. interrupts or kill processes->ProcessAsynchRequests(this); // Release and re-acquire use of the ML memory to allow another thread // to GC. processes->ThreadReleaseMLMemory(this); processes->ThreadUseMLMemory(this); break; case -2: // A callback has returned. return callBackResult; // Return the saved value. Not used in the new interface. default: Crash("Unknown io operation %d\n", ioFunction); } } catch (IOException &) { } } } // Run the current ML process. X86AsmSwitchToPoly saves the C state so that // whenever the ML requires assistance from the rest of the RTS it simply // returns to C with the appropriate values set in assemblyInterface.requestCode and // int X86TaskData::SwitchToPoly() // (Re)-enter the Poly code from C. Returns with the io function to call or // -1 if we are responding to an interrupt. { Handle mark = this->saveVec.mark(); do { this->saveVec.reset(mark); // Remove old data e.g. from arbitrary precision. SetMemRegisters(); // We need to save the C stack entry across this call in case // we're making a callback and the previous C stack entry is // for the original call. uintptr_t savedCStack = this->assemblyInterface.saveCStack; // Restore the saved error state. #if (defined(_WIN32)) SetLastError(savedErrno); #else errno = savedErrno; #endif + if (assemblyInterface.exceptionPacket.argValue != TAGGED(0).AsUnsigned()) + { + (--assemblyInterface.stackPtr)->codeAddr = (byte*)X86AsmRaiseException; + regAX() = (PolyWord)assemblyInterface.exceptionPacket; /* put exception data into eax */ + } // Enter the ML code. X86AsmSwitchToPoly(&this->assemblyInterface); this->assemblyInterface.saveCStack = savedCStack; // Save the error codes. We may have made an RTS/FFI call that // has set these and we don't want to do anything to change them. #if (defined(_WIN32)) savedErrno = GetLastError(); #else savedErrno = errno; #endif SaveMemRegisters(); // Update globals from the memory registers. // Handle any heap/stack overflows or arbitrary precision traps. switch (this->assemblyInterface.returnReason) { case RETURN_HEAP_OVERFLOW: // The heap has overflowed. SetRegisterMask(); this->HeapOverflowTrap(assemblyInterface.stackPtr[0].codeAddr); // Computes a value for allocWords only break; case RETURN_STACK_OVERFLOW: case RETURN_STACK_OVERFLOWEX: { SetRegisterMask(); uintptr_t min_size; // Size in PolyWords if (assemblyInterface.returnReason == RETURN_STACK_OVERFLOW) { min_size = (this->stack->top - (PolyWord*)assemblyInterface.stackPtr) + OVERFLOW_STACK_SIZE * sizeof(uintptr_t) / sizeof(PolyWord); } else { // Stack limit overflow. If the required stack space is larger than // the fixed overflow size the code will calculate the limit in %EDI. stackItem *stackP = regDI().stackAddr; min_size = (this->stack->top - (PolyWord*)stackP) + OVERFLOW_STACK_SIZE * sizeof(uintptr_t) / sizeof(PolyWord); } try { // The stack check has failed. This may either be because we really have // overflowed the stack or because the stack limit value has been adjusted // to result in a call here. CheckAndGrowStack(this, min_size); } catch (IOException &) { // We may get an exception while handling this if we run out of store } { PLocker l(&interruptLock); // Set the stack limit. This clears any interrupt and also sets the // correct value if we've grown the stack. this->assemblyInterface.stackLimit = (stackItem*)this->stack->bottom + OVERFLOW_STACK_SIZE; } return -1; // We're in a safe state to handle any interrupts. } case RETURN_CALLBACK_RETURN: // regSP has been set by the assembly code. N.B. This may not be the same value as when // EnterCallbackFunction was called because the callback may have grown and moved the stack. // Remove the extra exception handler we created in EnterCallbackFunction ASSERT(assemblyInterface.handlerRegister == regSP()); regSP() += 1; assemblyInterface.handlerRegister = (*(regSP()++)).stackAddr; // Restore the previous handler. this->callBackResult = this->saveVec.push(regAX()); // Argument to return is in RAX. return -2; case RETURN_CALLBACK_EXCEPTION: // An ML callback has raised an exception. // It isn't possible to do anything here except abort. Crash("An ML function called from foreign code raised an exception. Unable to continue."); case RETURN_KILL_SELF: exitThread(this); default: Crash("Unknown return reason code %u", this->assemblyInterface.returnReason); } } while (1); } void X86TaskData::MakeTrampoline(byte **pointer, byte *entryPt) { #ifdef POLYML32IN64 // In the native address versions we can store the address directly onto the stack. // We can't do that in 32-in-64 because it's likely that the address will be in the // bottom 32-bits and we can't distinguish it from an object ID. Instead we have to // build a small code segment which jumps to the code. unsigned requiredSize = 8; // 8 words i.e. 32 bytes PolyObject *result = gMem.AllocCodeSpace(requiredSize); byte *p = (byte*)result; *p++ = 0x48; // rex.w *p++ = 0x8b; // Movl *p++ = 0x0d; // rcx, pc relative *p++ = 0x09; // +2 bytes *p++ = 0x00; *p++ = 0x00; *p++ = 0x00; *p++ = 0xff; // jmp *p++ = 0xe1; // rcx *p++ = 0xf4; // hlt - needed to stop scan of constants for (unsigned i = 0; i < 6; i++) *p++ = 0; uintptr_t ep = (uintptr_t)entryPt; for (unsigned i = 0; i < 8; i++) { *p++ = ep & 0xff; ep >>= 8; } // Clear the remainder. In particular this sets the number // of address constants to zero. for (unsigned i = 0; i < 8; i++) *p++ = 0; result->SetLengthWord(requiredSize, F_CODE_OBJ); *pointer = (byte*)result; #else *pointer = entryPt; // Can go there directly #endif } void X86TaskData::InitStackFrame(TaskData *parentTaskData, Handle proc, Handle arg) /* Initialise stack frame. */ { // Set the assembly code addresses. if (popArgAndClosure == 0) MakeTrampoline(&popArgAndClosure, (byte*)&X86AsmPopArgAndClosure); if (killSelf == 0) MakeTrampoline(&killSelf, (byte*)&X86AsmKillSelf); if (raiseException == 0) MakeTrampoline(&raiseException, (byte*)&X86AsmRaiseException); if (callbackException == 0) MakeTrampoline(&callbackException, (byte*)&X86AsmCallbackException); if (callbackReturn == 0) MakeTrampoline(&callbackReturn, (byte*)&X86AsmCallbackReturn); StackSpace *space = this->stack; StackObject * newStack = space->stack(); uintptr_t stack_size = space->spaceSize() * sizeof(PolyWord) / sizeof(stackItem); uintptr_t topStack = stack_size-6; stackItem *stackTop = (stackItem*)newStack + topStack; assemblyInterface.stackPtr = stackTop; assemblyInterface.stackLimit = (stackItem*)space->bottom + OVERFLOW_STACK_SIZE; assemblyInterface.handlerRegister = (stackItem*)newStack+topStack+4; // Floating point save area. memset(&assemblyInterface.p_fp, 0, sizeof(struct fpSaveArea)); #ifndef HOSTARCHITECTURE_X86_64 // Set the control word for 64-bit precision otherwise we get inconsistent results. assemblyInterface.p_fp.cw = 0x027f ; // Control word assemblyInterface.p_fp.tw = 0xffff; // Tag registers - all unused #endif // Initial entry point - on the stack. stackTop[0].codeAddr = popArgAndClosure; // Push the argument and the closure on the stack. We can't put them into the registers // yet because we might get a GC before we actually start the code. stackTop[1] = proc->Word(); // Closure stackTop[2] = (arg == 0) ? TAGGED(0) : DEREFWORD(arg); // Argument /* We initialise the end of the stack with a sequence that will jump to kill_self whether the process ends with a normal return or by raising an exception. A bit of this was added to fix a bug when stacks were objects on the heap and could be scanned by the GC. */ stackTop[5] = TAGGED(0); // Probably no longer needed // Set the default handler and return address to point to this code. // PolyWord killJump(PolyWord::FromCodePtr((byte*)&X86AsmKillSelf)); // Exception handler. stackTop[4].codeAddr = killSelf; // Normal return address. We need a separate entry on the stack from // the exception handler because it is possible that the code we are entering // may replace this entry with an argument. The code-generator optimises tail-recursive // calls to functions with more args than the called function. stackTop[3].codeAddr = killSelf; #ifdef POLYML32IN64 // In 32-in-64 RBX always contains the heap base address. assemblyInterface.p_rbx.stackAddr = (stackItem*)globalHeapBase; #endif } // In Solaris-x86 the registers are named EIP and ESP. #if (!defined(REG_EIP) && defined(EIP)) #define REG_EIP EIP #endif #if (!defined(REG_ESP) && defined(ESP)) #define REG_ESP ESP #endif // Get the PC and SP(stack) from a signal context. This is needed for profiling. // This version gets the actual sp and pc if we are in ML. bool X86TaskData::AddTimeProfileCount(SIGNALCONTEXT *context) { stackItem * sp = 0; POLYCODEPTR pc = 0; if (context != 0) { // The tests for HAVE_UCONTEXT_T, HAVE_STRUCT_SIGCONTEXT and HAVE_WINDOWS_H need // to follow the tests in processes.h. #if defined(HAVE_WINDOWS_H) #ifdef _WIN64 sp = (stackItem *)context->Rsp; pc = (POLYCODEPTR)context->Rip; #else // Windows 32 including cygwin. sp = (stackItem *)context->Esp; pc = (POLYCODEPTR)context->Eip; #endif #elif defined(HAVE_UCONTEXT_T) #ifdef HAVE_MCONTEXT_T_GREGS // Linux #ifndef HOSTARCHITECTURE_X86_64 pc = (byte*)context->uc_mcontext.gregs[REG_EIP]; sp = (stackItem*)context->uc_mcontext.gregs[REG_ESP]; #else /* HOSTARCHITECTURE_X86_64 */ pc = (byte*)context->uc_mcontext.gregs[REG_RIP]; sp = (stackItem*)context->uc_mcontext.gregs[REG_RSP]; #endif /* HOSTARCHITECTURE_X86_64 */ #elif defined(HAVE_MCONTEXT_T_MC_ESP) // FreeBSD #ifndef HOSTARCHITECTURE_X86_64 pc = (byte*)context->uc_mcontext.mc_eip; sp = (stackItem*)context->uc_mcontext.mc_esp; #else /* HOSTARCHITECTURE_X86_64 */ pc = (byte*)context->uc_mcontext.mc_rip; sp = (stackItem*)context->uc_mcontext.mc_rsp; #endif /* HOSTARCHITECTURE_X86_64 */ #else // Mac OS X #ifndef HOSTARCHITECTURE_X86_64 #if(defined(HAVE_STRUCT_MCONTEXT_SS)||defined(HAVE_STRUCT___DARWIN_MCONTEXT32_SS)) pc = (byte*)context->uc_mcontext->ss.eip; sp = (PolyWord*)context->uc_mcontext->ss.esp; #elif(defined(HAVE_STRUCT___DARWIN_MCONTEXT32___SS)) pc = (byte*)context->uc_mcontext->__ss.__eip; sp = (PolyWord*)context->uc_mcontext->__ss.__esp; #endif #else /* HOSTARCHITECTURE_X86_64 */ #if(defined(HAVE_STRUCT_MCONTEXT_SS)||defined(HAVE_STRUCT___DARWIN_MCONTEXT64_SS)) pc = (byte*)context->uc_mcontext->ss.rip; sp = (PolyWord*)context->uc_mcontext->ss.rsp; #elif(defined(HAVE_STRUCT___DARWIN_MCONTEXT64___SS)) pc = (byte*)context->uc_mcontext->__ss.__rip; sp = (PolyWord*)context->uc_mcontext->__ss.__rsp; #endif #endif /* HOSTARCHITECTURE_X86_64 */ #endif #elif defined(HAVE_STRUCT_SIGCONTEXT) #if defined(HOSTARCHITECTURE_X86_64) && defined(__OpenBSD__) // CPP defines missing in amd64/signal.h in OpenBSD pc = (byte*)context->sc_rip; sp = (PolyWord*)context->sc_rsp; #else // !HOSTARCHITEXTURE_X86_64 || !defined(__OpenBSD__) pc = (byte*)context->sc_pc; sp = (PolyWord*)context->sc_sp; #endif #endif } if (pc != 0) { // See if the PC we've got is an ML code address. MemSpace *space = gMem.SpaceForAddress(pc); if (space != 0 && (space->spaceType == ST_CODE || space->spaceType == ST_PERMANENT)) { add_count(this, pc, 1); return true; } } // See if the sp value is in the current stack. if (sp >= (stackItem*)this->stack->bottom && sp < (stackItem*)this->stack->top) { // We may be in the assembly code. The top of the stack will be a return address. pc = sp[0].w().AsCodePtr(); MemSpace *space = gMem.SpaceForAddress(pc); if (space != 0 && (space->spaceType == ST_CODE || space->spaceType == ST_PERMANENT)) { add_count(this, pc, 1); return true; } } // See if the value of regSP is a valid stack pointer. // This works if we happen to be in an RTS call using a "Full" call. // It doesn't work if we've used a "Fast" call because that doesn't save the SP. sp = assemblyInterface.stackPtr; if (sp >= (stackItem*)this->stack->bottom && sp < (stackItem*)this->stack->top) { // We may be in the run-time system. pc = sp[0].w().AsCodePtr(); MemSpace *space = gMem.SpaceForAddress(pc); if (space != 0 && (space->spaceType == ST_CODE || space->spaceType == ST_PERMANENT)) { add_count(this, pc, 1); return true; } } // None of those worked return false; } // This is called from a different thread so we have to be careful. void X86TaskData::InterruptCode() { PLocker l(&interruptLock); // Set the stack limit pointer to the top of the stack to cause // a trap when we next check for stack overflow. // We use a lock here to ensure that we always use the current value of the // stack. The thread we're interrupting could be growing the stack at this point. if (this->stack != 0) this->assemblyInterface.stackLimit = (stackItem*)(this->stack->top-1); } // This is called from SwitchToPoly before we enter the ML code. void X86TaskData::SetMemRegisters() { // Copy the current store limits into variables before we go into the assembly code. // If we haven't yet set the allocation area or we don't have enough we need // to create one (or a new one). if (this->allocPointer <= this->allocLimit + this->allocWords) { if (this->allocPointer < this->allocLimit) Crash ("Bad length in heap overflow trap"); // Find some space to allocate in. Updates taskData->allocPointer and // returns a pointer to the newly allocated space (if allocWords != 0) PolyWord *space = processes->FindAllocationSpace(this, this->allocWords, true); if (space == 0) { // We will now raise an exception instead of returning. // Set allocWords to zero so we don't set the allocation register // since that could be holding the exception packet. this->allocWords = 0; } // Undo the allocation just now. this->allocPointer += this->allocWords; } if (this->allocWords != 0) { // If we have had a heap trap we actually do the allocation here. // We will have already garbage collected and recovered sufficient space. // This also happens if we have just trapped because of store profiling. this->allocPointer -= this->allocWords; // Now allocate // Set the allocation register to this area. N.B. This is an absolute address. if (this->allocReg < 15) get_reg(this->allocReg)[0].codeAddr = (POLYCODEPTR)(this->allocPointer + 1); /* remember: it's off-by-one */ this->allocWords = 0; } // If we have run out of store, either just above or while allocating in the RTS, // allocPointer and allocLimit will have been set to zero as part of the GC. We will // now be raising an exception which may free some store but we need to come back here // before we allocate anything. The compiled code uses unsigned arithmetic to check for // heap overflow but only after subtracting the space required. We need to make sure // that the values are still non-negative after substracting any object size. if (this->allocPointer == 0) this->allocPointer += MAX_OBJECT_SIZE; if (this->allocLimit == 0) this->allocLimit += MAX_OBJECT_SIZE; this->assemblyInterface.localMbottom = this->allocLimit + 1; this->assemblyInterface.localMpointer = this->allocPointer + 1; // If we are profiling store allocation we set mem_hl so that a trap // will be generated. if (profileMode == kProfileStoreAllocation) this->assemblyInterface.localMbottom = this->assemblyInterface.localMpointer; this->assemblyInterface.returnReason = RETURN_IO_CALL_NOW_UNUSED; this->assemblyInterface.threadId = this->threadObject; } // This is called whenever we have returned from ML to C. void X86TaskData::SaveMemRegisters() { this->allocPointer = this->assemblyInterface.localMpointer - 1; this->allocWords = 0; this->assemblyInterface.exceptionPacket = TAGGED(0); this->saveRegisterMask = 0; } // Called on a GC or stack overflow trap. The register mask // is in the bytes after the trap call. void X86TaskData::SetRegisterMask() { byte *pc = assemblyInterface.stackPtr[0].codeAddr; if (*pc == 0xcd) // CD - INT n is used for a single byte { pc++; saveRegisterMask = *pc++; } else if (*pc == 0xca) // CA - FAR RETURN is used for a two byte mask { pc++; saveRegisterMask = pc[0] | (pc[1] << 8); pc += 2; } assemblyInterface.stackPtr[0].codeAddr = pc; } stackItem *X86TaskData::get_reg(int n) /* Returns a pointer to the register given by n. */ { switch (n) { case 0: return &assemblyInterface.p_rax; case 1: return &assemblyInterface.p_rcx; case 2: return &assemblyInterface.p_rdx; case 3: return &assemblyInterface.p_rbx; // Should not have rsp or rbp. case 6: return &assemblyInterface.p_rsi; case 7: return &assemblyInterface.p_rdi; #ifdef HOSTARCHITECTURE_X86_64 case 8: return &assemblyInterface.p_r8; case 9: return &assemblyInterface.p_r9; case 10: return &assemblyInterface.p_r10; case 11: return &assemblyInterface.p_r11; case 12: return &assemblyInterface.p_r12; case 13: return &assemblyInterface.p_r13; case 14: return &assemblyInterface.p_r14; // R15 is the heap pointer so shouldn't occur here. #endif /* HOSTARCHITECTURE_X86_64 */ default: Crash("Unknown register %d\n", n); } } // Called as a result of a heap overflow trap void X86TaskData::HeapOverflowTrap(byte *pcPtr) { X86TaskData *mdTask = this; POLYUNSIGNED wordsNeeded = 0; // The next instruction, after any branches round forwarding pointers or pop // instructions, will be a store of register containing the adjusted heap pointer. // We need to find that register and the value in it in order to find out how big // the area we actually wanted is. N.B. The code-generator and assembly code // must generate the correct instruction sequence. // byte *pcPtr = assemblyInterface.programCtr; while (true) { if (pcPtr[0] == 0xeb) { // Forwarding pointer if (pcPtr[1] >= 128) pcPtr += 256 - pcPtr[1] + 2; else pcPtr += pcPtr[1] + 2; } else if ((pcPtr[0] & 0xf8) == 0x58) // Pop instruction. pcPtr++; else if (pcPtr[0] == 0x41 && ((pcPtr[1] & 0xf8) == 0x58)) // Pop with Rex prefix pcPtr += 2; else break; } #ifndef HOSTARCHITECTURE_X86_64 // This should be movl REG,0[%ebp]. ASSERT(pcPtr[0] == 0x89); mdTask->allocReg = (pcPtr[1] >> 3) & 7; // Remember this until we allocate the memory stackItem *reg = get_reg(mdTask->allocReg); stackItem reg_val = *reg; // The space we need is the difference between this register // and the current value of newptr. // The +1 here is because assemblyInterface.localMpointer is A.M.pointer +1. The reason // is that after the allocation we have the register pointing at the address we will // actually use. wordsNeeded = (this->allocPointer - (PolyWord*)reg_val.stackAddr) + 1; *reg = TAGGED(0); // Clear this - it's not a valid address. /* length in words, including length word */ ASSERT (wordsNeeded <= (1<<24)); /* Max object size including length/flag word is 2^24 words. */ #else /* HOSTARCHITECTURE_X86_64 */ ASSERT(pcPtr[1] == 0x89 || pcPtr[1] == 0x8b); if (pcPtr[1] == 0x89) { // New (5.4) format. This should be movq REG,%r15 ASSERT(pcPtr[0] == 0x49 || pcPtr[0] == 0x4d); mdTask->allocReg = (pcPtr[2] >> 3) & 7; // Remember this until we allocate the memory if (pcPtr[0] & 0x4) mdTask->allocReg += 8; } else { // Alternative form of movq REG,%r15 ASSERT(pcPtr[0] == 0x4c || pcPtr[0] == 0x4d); mdTask->allocReg = pcPtr[2] & 7; // Remember this until we allocate the memory if (pcPtr[0] & 0x1) mdTask->allocReg += 8; } stackItem *reg = get_reg(this->allocReg); stackItem reg_val = *reg; wordsNeeded = (POLYUNSIGNED)((this->allocPointer - (PolyWord*)reg_val.stackAddr) + 1); *reg = TAGGED(0); // Clear this - it's not a valid address. #endif /* HOSTARCHITECTURE_X86_64 */ if (profileMode == kProfileStoreAllocation) addProfileCount(wordsNeeded); mdTask->allocWords = wordsNeeded; // The actual allocation is done in SetMemRegisters. } void X86TaskData::SetException(poly_exn *exc) -// Set up the stack to raise an exception. +// The RTS wants to raise an exception packet. Normally this is as the +// result of an RTS call in which case the caller will check this. It can +// also happen in a trap. { - // Do we need to set the PC value any longer? It may be necessary if - // we have taken a trap because another thread has sent a broadcast interrupt. - (--assemblyInterface.stackPtr)->codeAddr = raiseException; - regAX() = (PolyWord)exc; /* put exception data into eax */ assemblyInterface.exceptionPacket = (PolyWord)exc; // Set for direct calls. } // Sets up a callback function on the current stack. The present state is that // the ML code has made a call in to foreign_dispatch. We need to set the stack // up so that we will enter the callback (as with CallCodeTupled) but when we return // the result we enter callback_return. Handle X86TaskData::EnterCallbackFunction(Handle func, Handle args) { // If we ever implement a light version of the FFI that allows a call to C // code without saving enough to allow allocation in C code we need to ensure // that this code doesn't do any allocation. Essentially we need the values // in localMpointer and localMbottom to be valid across a call to C. If we do // a callback the ML callback function would pick up the values saved in the // originating call. // However, it is essential that the light version still saves the stack pointer // and reloads it afterwards. // Set up an exception handler so we will enter callBackException if there is an exception. (--regSP())->stackAddr = assemblyInterface.handlerRegister; // Create a special handler entry (--regSP())->codeAddr = callbackException; assemblyInterface.handlerRegister = regSP(); // Push the call to callBackReturn onto the stack as the return address. (--regSP())->codeAddr = callbackReturn; // Set up the entry point of the callback. PolyObject *functToCall = func->WordP(); regDX() = (PolyWord)functToCall; // Closure address regAX() = args->Word(); // Push entry point address (--regSP())->codeAddr = *(POLYCODEPTR*)functToCall; // First word of closure is entry pt. return EnterPolyCode(); } // Decode and process an effective address. There may // be a constant address in here but in any case we need // to decode it to work out where the next instruction starts. // If this is an lea instruction any addresses are just constants // so must not be treated as addresses. static void skipea(PolyObject *base, byte **pt, ScanAddress *process, bool lea) { unsigned int modrm = *((*pt)++); unsigned int md = modrm >> 6; unsigned int rm = modrm & 7; if (md == 3) { } /* Register. */ else if (rm == 4) { /* s-i-b present. */ unsigned int sib = *((*pt)++); if (md == 0) { if ((sib & 7) == 5) { if (! lea) { #ifndef HOSTARCHITECTURE_X86_64 process->ScanConstant(base, *pt, PROCESS_RELOC_DIRECT); #endif /* HOSTARCHITECTURE_X86_64 */ } (*pt) += 4; } } else if (md == 1) (*pt)++; else if (md == 2) (*pt) += 4; } else if (md == 0 && rm == 5) { if (!lea) { #ifndef HOSTARCHITECTURE_X86_64 /* Absolute address. */ process->ScanConstant(base, *pt, PROCESS_RELOC_DIRECT); #endif /* HOSTARCHITECTURE_X86_64 */ } *pt += 4; } else { if (md == 1) *pt += 1; else if (md == 2) *pt += 4; } } /* Added to deal with constants within the code rather than in the constant area. The constant area is still needed for the function name. DCJM 2/1/2001 */ void X86Dependent::ScanConstantsWithinCode(PolyObject *addr, PolyObject *old, POLYUNSIGNED length, ScanAddress *process) { byte *pt = (byte*)addr; PolyWord *end = addr->Offset(length - 1); #ifdef POLYML32IN64 // If this begins with enter-int it's interpreted code - ignore if (pt[0] == 0xff && pt[1] == 0x55 && pt[2] == 0x48) return; #endif while (true) { // Escape prefixes come before any Rex byte if (*pt == 0xf2 || *pt == 0xf3 || *pt == 0x66) pt++; #ifdef HOSTARCHITECTURE_X86_64 // REX prefixes. Set this first. byte lastRex; if (*pt >= 0x40 && *pt <= 0x4f) lastRex = *pt++; else lastRex = 0; //printf("pt=%p *pt=%x\n", pt, *pt); #endif /* HOSTARCHITECTURE_X86_64 */ switch (*pt) { case 0x00: return; // This is actually the first byte of the old "marker" word. case 0xf4: return; // Halt - now used as a marker. case 0x50: case 0x51: case 0x52: case 0x53: case 0x54: case 0x55: case 0x56: case 0x57: /* Push */ case 0x58: case 0x59: case 0x5a: case 0x5b: case 0x5c: case 0x5d: case 0x5e: case 0x5f: /* Pop */ case 0x90: /* nop */ case 0xc3: /* ret */ case 0xf9: /* stc */ case 0xce: /* into */ case 0xf0: /* lock. */ case 0xf3: /* rep/repe */ case 0xa4: case 0xa5: case 0xaa: case 0xab: /* movs/stos */ case 0xa6: /* cmpsb */ case 0x9e: /* sahf */ case 0x99: /* cqo/cdq */ pt++; break; case 0x70: case 0x71: case 0x72: case 0x73: case 0x74: case 0x75: case 0x76: case 0x77: case 0x78: case 0x79: case 0x7a: case 0x7b: case 0x7c: case 0x7d: case 0x7e: case 0x7f: case 0xeb: /* short jumps. */ case 0xcd: /* INT - now used for a register mask */ case 0xa8: /* TEST_ACC8 */ case 0x6a: /* PUSH_8 */ pt += 2; break; case 0xc2: /* RET_16 */ case 0xca: /* FAR RET 16 - used for a register mask */ pt += 3; break; case 0x8d: /* leal. */ pt++; skipea(addr, &pt, process, true); break; case 0x03: case 0x0b: case 0x13: case 0x1b: case 0x23: case 0x2b: case 0x33: case 0x3b: /* Add r,ea etc. */ case 0x88: /* MOVB_R_A */ case 0x89: /* MOVL_R_A */ case 0x8b: /* MOVL_A_R */ case 0x62: /* BOUNDL */ case 0xff: /* Group5 */ case 0xd1: /* Group2_1_A */ case 0x8f: /* POP_A */ case 0xd3: /* Group2_CL_A */ case 0x87: // XCHNG case 0x63: // MOVSXD pt++; skipea(addr, &pt, process, false); break; case 0xf6: /* Group3_a */ { int isTest = 0; pt++; /* The test instruction has an immediate operand. */ if ((*pt & 0x38) == 0) isTest = 1; skipea(addr, &pt, process, false); if (isTest) pt++; break; } case 0xf7: /* Group3_A */ { int isTest = 0; pt++; /* The test instruction has an immediate operand. */ if ((*pt & 0x38) == 0) isTest = 1; skipea(addr, &pt, process, false); if (isTest) pt += 4; break; } case 0xc1: /* Group2_8_A */ case 0xc6: /* MOVB_8_A */ case 0x83: /* Group1_8_A */ case 0x80: /* Group1_8_a */ case 0x6b: // IMUL Ev,Ib pt++; skipea(addr, &pt, process, false); pt++; break; case 0x69: // IMUL Ev,Iv pt++; skipea(addr, &pt, process, false); pt += 4; break; case 0x81: /* Group1_32_A */ { pt ++; #ifndef HOSTARCHITECTURE_X86_64 unsigned opCode = *pt; #endif skipea(addr, &pt, process, false); // Only check the 32 bit constant if this is a comparison. // For other operations this may be untagged and shouldn't be an address. #ifndef HOSTARCHITECTURE_X86_64 if ((opCode & 0x38) == 0x38) process->ScanConstant(addr, pt, PROCESS_RELOC_DIRECT); #endif pt += 4; break; } case 0xe8: case 0xe9: // Long jump and call. These are used to call constant (known) functions // and also long jumps within the function. { pt++; POLYSIGNED disp = (pt[3] & 0x80) ? -1 : 0; // Set the sign just in case. for(unsigned i = 4; i > 0; i--) disp = (disp << 8) | pt[i-1]; byte *absAddr = pt + disp + 4; // The address is relative to AFTER the constant // If the new address is within the current piece of code we don't do anything if (absAddr >= (byte*)addr && absAddr < (byte*)end) {} else { #ifdef HOSTARCHITECTURE_X86_64 ASSERT(sizeof(PolyWord) == 4); // Should only be used internally on x64 #endif /* HOSTARCHITECTURE_X86_64 */ if (addr != old) { // The old value of the displacement was relative to the old address before // we copied this code segment. // We have to correct it back to the original address. absAddr = absAddr - (byte*)addr + (byte*)old; // We have to correct the displacement for the new location and store // that away before we call ScanConstant. size_t newDisp = absAddr - pt - 4; for (unsigned i = 0; i < 4; i++) { pt[i] = (byte)(newDisp & 0xff); newDisp >>= 8; } } process->ScanConstant(addr, pt, PROCESS_RELOC_I386RELATIVE); } pt += 4; break; } case 0xc7:/* MOVL_32_A */ { pt++; if ((*pt & 0xc0) == 0x40 /* Byte offset or sib present */ && ((*pt & 7) != 4) /* But not sib present */ && pt[1] == 256-sizeof(PolyWord)) { /* We may use a move instruction to set the length word on a new segment. We mustn't try to treat this as a constant. */ pt += 6; /* Skip the modrm byte, the offset and the constant. */ } else { skipea(addr, &pt, process, false); #ifndef HOSTARCHITECTURE_X86_64 // This isn't used for addresses even in 32-in-64 process->ScanConstant(addr, pt, PROCESS_RELOC_DIRECT); #endif /* HOSTARCHITECTURE_X86_64 */ pt += 4; } break; } case 0xb8: case 0xb9: case 0xba: case 0xbb: case 0xbc: case 0xbd: case 0xbe: case 0xbf: /* MOVL_32_64_R */ pt ++; #ifdef HOSTARCHITECTURE_X86_64 if ((lastRex & 8) == 0) pt += 4; // 32-bit mode on 64-bits else #endif /* HOSTARCHITECTURE_X86_64 */ { // This is no longer generated in 64-bit mode but needs to // be retained in native 64-bit for backwards compatibility. #ifndef POLYML32IN64 // 32 bits in 32-bit mode, 64-bits in 64-bit mode. process->ScanConstant(addr, pt, PROCESS_RELOC_DIRECT); #endif pt += sizeof(PolyWord); } break; case 0x68: /* PUSH_32 */ pt ++; #if (!defined(HOSTARCHITECTURE_X86_64) || defined(POLYML32IN64)) // Currently the only inline constant in 32-in-64. process->ScanConstant(addr, pt, PROCESS_RELOC_DIRECT); #endif pt += 4; break; case 0x0f: /* ESCAPE */ { pt++; switch (*pt) { case 0xb6: /* movzl */ case 0xb7: // movzw case 0xbe: // movsx case 0xbf: // movsx case 0xc1: /* xaddl */ case 0xae: // ldmxcsr/stmxcsr case 0xaf: // imul case 0x40: case 0x41: case 0x42: case 0x43: case 0x44: case 0x45: case 0x46: case 0x47: case 0x48: case 0x49: case 0x4a: case 0x4b: case 0x4c: case 0x4d: case 0x4e: case 0x4f: // cmov pt++; skipea(addr, &pt, process, false); break; case 0x80: case 0x81: case 0x82: case 0x83: case 0x84: case 0x85: case 0x86: case 0x87: case 0x88: case 0x89: case 0x8a: case 0x8b: case 0x8c: case 0x8d: case 0x8e: case 0x8f: /* Conditional branches with 32-bit displacement. */ pt += 5; break; case 0x90: case 0x91: case 0x92: case 0x93: case 0x94: case 0x95: case 0x96: case 0x97: case 0x98: case 0x99: case 0x9a: case 0x9b: case 0x9c: case 0x9d: case 0x9e: case 0x9f: /* SetCC. */ pt++; skipea(addr, &pt, process, false); break; // These are SSE2 instructions case 0x10: case 0x11: case 0x58: case 0x5c: case 0x59: case 0x5e: case 0x2e: case 0x2a: case 0x54: case 0x57: case 0x5a: case 0x6e: case 0x7e: case 0x2c: case 0x2d: pt++; skipea(addr, &pt, process, false); break; case 0x73: // PSRLDQ - EA,imm pt++; skipea(addr, &pt, process, false); pt++; break; default: Crash("Unknown opcode %d at %p\n", *pt, pt); } break; } case 0xd8: case 0xd9: case 0xda: case 0xdb: case 0xdc: case 0xdd: case 0xde: case 0xdf: // Floating point escape instructions { pt++; if ((*pt & 0xe0) == 0xe0) pt++; else skipea(addr, &pt, process, false); break; } default: Crash("Unknown opcode %d at %p\n", *pt, pt); } } } // Increment the value contained in the first word of the mutex. Handle X86TaskData::AtomicIncrement(Handle mutexp) { PolyObject *p = DEREFHANDLE(mutexp); POLYUNSIGNED result = X86AsmAtomicIncrement(p); return this->saveVec.push(PolyWord::FromUnsigned(result)); } // Release a mutex. Because the atomic increment and decrement // use the hardware LOCK prefix we can simply set this to one. void X86TaskData::AtomicReset(Handle mutexp) { DEREFHANDLE(mutexp)->Set(0, TAGGED(1)); } static X86Dependent x86Dependent; MachineDependent *machineDependent = &x86Dependent; class X86Module : public RtsModule { public: virtual void GarbageCollect(ScanAddress * /*process*/); }; // Declare this. It will be automatically added to the table. static X86Module x86Module; void X86Module::GarbageCollect(ScanAddress *process) { #ifdef POLYML32IN64 // These are trampolines in the code area rather than direct calls. if (popArgAndClosure != 0) process->ScanRuntimeAddress((PolyObject**)&popArgAndClosure, ScanAddress::STRENGTH_STRONG); if (killSelf != 0) process->ScanRuntimeAddress((PolyObject**)&killSelf, ScanAddress::STRENGTH_STRONG); if (raiseException != 0) process->ScanRuntimeAddress((PolyObject**)&raiseException, ScanAddress::STRENGTH_STRONG); if (callbackException != 0) process->ScanRuntimeAddress((PolyObject**)&callbackException, ScanAddress::STRENGTH_STRONG); if (callbackReturn != 0) process->ScanRuntimeAddress((PolyObject**)&callbackReturn, ScanAddress::STRENGTH_STRONG); #endif } \ No newline at end of file diff --git a/libpolyml/xwindows.cpp b/libpolyml/xwindows.cpp index e931033f..f36eb408 100644 --- a/libpolyml/xwindows.cpp +++ b/libpolyml/xwindows.cpp @@ -1,9634 +1,9634 @@ /* Title: X-Windows/Motif Interface. Copyright (c) 2000 Cambridge University Technical Services Limited 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 */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #if (defined(WITH_XWINDOWS)) // X-Windows is required. /* xwindows.c */ /* Removed indirection from get_C_* functions SPF 31/10/93 */ /* Added Handle type 2/11/93 */ /* Fixed "GetString can only be used once" bug 17/11/93 */ /* Dealing with gcc warning messages SPF 6/1/94 */ /* Retrofit to old Sun cc SPF 7/1/94 */ /* 25/1/94 SPF Fixed bug in EmptyVisual (core-dump when v==NULL) */ /* Comment added 4/11/93 SPF Global Invariants: (1) Get functions promise not to allocate on the Poly/ML heap (2) The Poly/ML heap contains pointers into the C heap! As these are only valid for one session, the run-time system records which Poly/ML objects have been created in the current session. Only these objects contain valid C pointers, and so may be dereferenced. The "bad" Poly/ML objects are: Flags Object Bad Field Access Function ----- ------ --------- --------------- M X_GC_Object GC *gc GetGC X_Font_Object Font *font GetFont ditto XFontStruct **fs GetFS X_Cursor_Object Cursor *cursor GetCursor BM X_Window_Object Drawable *drawable GetDrawable, GetPixmap X_Pixmap_Object Pixmap *pixmap GetDrawable, GetPixmap X_Colormap_Object Colormap *cmap GetColormap X_Visual_Object Visual **visual GetVisual (* FISHY *) B X_Display_Object Display *display (?) GetDisplay (?) ditto XtAppContext app_context NONE(?) M X_Widget_Object Widget *widget GetWidget, GetNWidget B X_Trans_Object XtTranslations table GetTrans B X_Acc_Object XtAccelerators acc GetAcc WARNING: the above list of unsafe fields was created by SPF and may be incomplete. The function CheckExists should be called on these objects before it is safe to use any of the above fields. That's because the object may have been created in a previous ML session, so the pointers that it contains may no longer be valid. Using the appropriate access function listed above guarantees that CheckExists is called. Exception: the fields can safely be tested against C's zero (None, Null) even if CheckExists hasn't been called. Note that this is only database-safe because this value is used for uninitialised fields, so it doesn't confuse the garbage-collector. For all the above fields EXCEPT display, app_context, table, acc the run-time system creates an indirection object in the Poly heap. These fields don't need an indirection object because the object which contains them is itself a BYTE object. This indirection is a byte-object. The indirection is necessary because the garbage collector would object to finding a C pointer in a standard ML labelled record. The alternative would be to store the C pointer as an ML integer, but then we would have to convert back to a C pointer befor we could dereference it. For similar reasons, eventMask is also stored as a boxed PolyWord. abstype Colormap = Colormap with end; (* X_Colormap_Object *) abstype Cursor = Cursor with end; (* X_Cursor_Object *) abstype Drawable = Drawable with end; (* X_Window_Object, XPixmap_Object *) abstype Font = Font with end; (* X_Font_Object *) abstype GC = GC with end; (* X_GC_Object *) abstype Visual = Visual with end; (* X_Visual_Object *) abstype Display = Display with end; (* X_Display_Object *) abstype Widget = Widget of int with end; abstype XtAccelerators = XtAccelerators of int with end; abstype XtTranslations = XtTranslations of int with end; */ /* MLXPoint, MLXRectangle, MLXArc, MLPair, MLTriple added 31/10/93 SPF */ #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_SIGNAL_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_CTYPE_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_ASSERT_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_ALLOCA_H #include #endif #ifdef HAVE_ERRNO_H #include #endif /* what goes wrong? ... gid, fd, private15 inaccessible */ /* THIS NEEDS TO BE FIXED!!!! */ #define XLIB_ILLEGAL_ACCESS 1 /* We need access to some opaque structures */ /* use prototypes, but make sure we get Booleans, not ints */ #define NeedWidePrototypes 0 #include #include /* IsCursorKey, IsFunctionKey, et cetera */ #include /* needed for protocol names such as X_CreateWindow */ #include /* XA_ATOM, et cetera */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include /* Motif 1.2 */ #include /* for XmIsDesktopObject */ #include /* for XmIsExtObject */ #include /* for XmIsShellExt */ #include /* for XmIsVendorShellExt */ #include #if(0) /* for XmIsWorldObject */ /* This is not supported in FreeBSD or Solaris 8. */ #include #endif #include "globals.h" #include "sys.h" #include "xwindows.h" #include "run_time.h" #include "arb.h" #include "mpoly.h" #include "gc.h" #include "xcall_numbers.h" #include "diagnostics.h" #include "processes.h" #include "save_vec.h" #include "polystring.h" #include "scanaddrs.h" #include "memmgr.h" #include "machine_dep.h" #include "processes.h" #include "rts_module.h" #include "rtsentry.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyXWindowsGeneral(PolyObject *threadId, PolyWord params); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyXWindowsGeneral(FirstArgument threadId, PolyWord params); } /* The following are only forward so we can declare attributes */ static void RaiseXWindows(TaskData *taskData, const char *s) __attribute__((noreturn)); #define ButtonClickMask (((unsigned)1 << 29)) #define XMASK(m) ((m) &~ButtonClickMask) #undef SIZEOF #define debug1(fmt,p1) { /*EMPTY*/ } #undef debug1 #define debug1(fmt,p1) {if (debugOptions & DEBUG_X) printf(fmt,p1);} #define debug3(fmt,p1,p2,p3) {if (debugOptions & DEBUG_X) printf(fmt,p1,p2,p3);} #define debugCreate(type,value) debug1("%lx " #type " created\n",(unsigned long)(value)) #define debugReclaim(type,value) debug1("%lx " #type " reclaimed\n",(unsigned long)(value)) #define debugReclaimRef(type,value) debug1("%lx " #type " reference reclaimed\n",(unsigned long)(value)) #define debugRefer(type,value) debug1("%lx " #type " referenced\n",(unsigned long)(value)) #define debugCreateCallback(MLValue,CValue,CListCell) debug3("%p Widget callback reference created (%p,%p)\n",CValue,CListCell,MLValue) #define debugReclaimCallback(MLValue,CValue,CListCell) debug3("%p Widget callback reference removed (%p,%p)\n",CValue,CListCell,MLValue) /* forward declarations */ static Atom WM_DELETE_WINDOW(Display *d); /* was int SPF 6/1/94 */ #define DEREFDISPLAYHANDLE(h) ((X_Display_Object *)DEREFHANDLE(h)) #define DEREFWINDOWHANDLE(h) ((X_Window_Object *)DEREFHANDLE(h)) #define DEREFXOBJECTHANDLE(h) ((X_Object *)DEREFHANDLE(h)) #define SAVE(x) taskData->saveVec.push(x) #define Make_int(x) Make_arbitrary_precision(taskData, x) #define Make_string(s) SAVE(C_string_to_Poly(taskData, s)) #define Make_bool(b) Make_arbitrary_precision(taskData, (b) != 0) #define SIZEOF(x) (sizeof(x)/sizeof(PolyWord)) #define min(a,b) (a < b ? a : b) #define max(a,b) (a > b ? a : b) #define ISNIL(p) (ML_Cons_Cell::IsNull(p)) #define NONNIL(p) (!ISNIL(p)) typedef Handle EventHandle; /********************************************************************************/ /* Objects are created MUTABLE and are FINISHED when all their fields have been */ /* filled in (assuming they are immutable objects). This is so that we can */ /* consider the possibility of storing immutable objects in read-only memory */ /* segments (not currently implemented). SPF 7/12/93 */ /********************************************************************************/ static Handle FINISHED(TaskData *taskData, Handle P) { PolyObject *pt = DEREFHANDLE(P); assert(taskData->saveVec.isValidHandle(P)); assert(pt->IsMutable()); POLYUNSIGNED lengthW = pt->LengthWord(); pt->SetLengthWord(lengthW & ~_OBJ_MUTABLE_BIT); return P; } static void RaiseXWindows(TaskData *taskData, const char *s) { if (mainThreadPhase == MTP_USER_CODE) { raise_exception_string(taskData, EXC_XWindows,s); } else { /* Crash added 7/7/94 SPF */ Crash("Tried to raise exception (XWindows \"%s\") during garbage collection\n",s); } /*NOTREACHED*/ } /* bugfixed 6/12/94 SPF */ #define RaiseXWindows2(varmessage,constmessage) \ { \ const char message[] = constmessage; \ int n1 = strlen(varmessage); \ int n2 = strlen(message); \ char *mess = (char *)alloca(n1 + n2 + 1); \ strcat(strncpy(mess,varmessage,n1),message); \ RaiseXWindows(taskData, mess); \ /*NOTREACHED*/ \ } static void RaiseRange(TaskData *taskData) { raise_exception0(taskData, EXC_size); } typedef unsigned char uchar; static uchar get_C_uchar(TaskData *taskData, PolyWord a) { unsigned u = get_C_ushort(taskData, a); if (u >= 256) RaiseRange(taskData); return u; } /******************************************************************************/ /* */ /* String */ /* */ /******************************************************************************/ //#define String PolyStringObject //#define GetString(s) _GetString((PolyWord *)(s)) /* can only be called TABLESIZE times per X opcode */ static PolyStringObject *GetString(PolyWord s) { #define TABLESIZE 5 static PolyStringObject string[TABLESIZE]; static int index = 0; if (! s.IsTagged()) return (PolyStringObject *) s.AsObjPtr(); index = (index + 1) % TABLESIZE; string[index].length = 1; string[index].chars[0] = UNTAGGED(s); return &string[index]; #undef TABLESIZE } /******************************************************************************/ /* */ /* XObjects (Type definitions) */ /* */ /******************************************************************************/ /* We keep a list of all objects created by calls to X. */ /* When an object is created we add an entry to the list and */ /* return the entry. If the entry becomes inaccessible */ /* by the garbage collector then we free the object. */ /* The list is created by malloc so that it is not in the heap. */ // Types of objects. These are tagged when they are stored // in objects because some objects are not byte objects. typedef enum { X_GC = 111, X_Font = 222, X_Cursor = 333, X_Window = 444, X_Pixmap = 555, X_Colormap = 666, X_Visual = 777, X_Display = 888, X_Widget = 999, X_Trans = 1111, X_Acc = 2222 } X_types; class X_Object: public PolyObject { public: X_Object(): type(TAGGED(1)) {} // Just to keep gcc happy PolyWord type; }; class X_Trans_Object: public X_Object /* BYTE object */ { public: XtTranslations table; /* C value */ }; class X_Acc_Object: public X_Object /* BYTE object */ { public: XtAccelerators acc; /* C value */ }; class X_Display_Object: public X_Object /* BYTE object */ { public: Display *display; /* C value */ unsigned screen; /* C value */ XtAppContext app_context; /* C value */ } ; class X_Font_Object: public X_Object { public: Font *font; /* Token for C value */ XFontStruct **fs; /* Token for C value */ X_Display_Object *ds; /* Token */ } ; class X_Cursor_Object: public X_Object { public: Cursor *cursor; /* Token for C value */ X_Display_Object *ds; /* Token */ } ; class X_Pixmap_Object: public X_Object { public: Pixmap *pixmap; /* Token for C value */ X_Display_Object *ds; /* Token */ } ; class X_Colormap_Object: public X_Object { public: Colormap *cmap; /* Token for C value */ X_Display_Object *ds; /* Token */ } ; class X_Widget_Object: public X_Object /* MUTABLE */ { public: Widget *widget; /* Token for C value */ PolyWord callbackList; /* mutable */ PolyWord state; /* mutable */ X_Display_Object *ds; /* Token */ } ; class X_Visual_Object: public X_Object { public: Visual **visual; /* Token for C value */ X_Display_Object *ds; /* Token */ } ; class X_GC_Object: public X_Object /* MUTABLE */ { public: GC *gc; /* Token for C value */ X_Font_Object *font_object; /* mutable; may be 0 */ X_Pixmap_Object *tile; /* mutable; may be 0 */ X_Pixmap_Object *stipple; /* mutable; may be 0 */ X_Pixmap_Object *clipMask; /* mutable; may be 0 */ X_Display_Object *ds; /* Token */ } ; class X_Window_Struct: public X_Object /* MUTABLE */ { public: Drawable *drawable; /* Token for C value */ PolyWord handler; /* mutable? */ PolyWord state; /* mutable? */ PolyObject *eventMask; /* Token for C value; token itself is mutable */ X_Colormap_Object *colormap_object; /* mutable; may be 0 */ X_Cursor_Object *cursor_object; /* mutable; may be 0 */ X_Pixmap_Object *backgroundPixmap; /* mutable; may be 0 */ X_Pixmap_Object *borderPixmap; /* mutable; may be 0 */ X_Window_Struct *parent; /* may be 0 */ X_Display_Object *ds; /* Token */ }; typedef X_Window_Struct X_Window_Object; /******************************************************************************/ /* */ /* Forward declarations */ /* */ /******************************************************************************/ static Font GetFont(TaskData *taskData, X_Object *P); static Cursor GetCursor(TaskData *taskData,X_Object *P); static Colormap GetColormap(TaskData *taskData,X_Object *P); static Visual *GetVisual(TaskData *taskData,X_Object *P); static XtTranslations GetTrans(TaskData *taskData,X_Object *P); static XtAccelerators GetAcc(TaskData *taskData,X_Object *P); static Pixmap GetPixmap(TaskData *, X_Object *P); static Widget GetNWidget(TaskData *, X_Object *P); static Window GetWindow(TaskData *, X_Object *P); static Display *GetDisplay(TaskData *, X_Object *P); static void DestroyWindow(X_Object *W); static void DestroySubwindows(X_Object *W); static X_GC_Object *GCObject(X_Object *P); static X_Pixmap_Object *PixmapObject(X_Object *P); static X_Widget_Object *WidgetObject(TaskData *, X_Object *P); static X_Window_Object *WindowObject(X_Object *P); /******************************************************************************/ /* */ /* C lists (Type definitions) */ /* */ /******************************************************************************/ typedef struct X_List_struct X_List; struct X_List_struct { X_List *next; /* pointer into C heap */ X_Object *object; /* pointer into Poly heap; weak */ }; typedef struct timeval TimeVal; /* In C heap */ typedef struct T_List_struct T_List; struct T_List_struct { T_List *next; /* pointer into C heap */ TimeVal timeout; /* here */ X_Window_Object *window_object; /* pointer into Poly heap, or 0; weak */ X_Widget_Object *widget_object; /* pointer into Poly heap, or 0; strong */ PolyObject *alpha; /* pointer into Poly heap; strong */ PolyObject *handler; /* pointer into Poly heap; strong */ int expired; /* here */ }; /* NB precisely one of window_object and widget_object should be non-zero */ /* In C heap */ typedef struct C_List_struct C_List; struct C_List_struct { PolyObject *function; /* pointer into Poly heap; strong */ X_Widget_Object *widget_object; /* pointer into Poly heap; strong */ C_List *next; /* pointer into C heap */ }; /* lists of X objects currently in Poly heap i.e. those created in this session */ #define XLISTSIZE 1001 /* must be coprime to 4 ('cos pointers are PolyWord-aligned) */ static X_List *XList[XLISTSIZE] = {0}; static T_List *TList = 0; /* C pending messages list, ordered by arrival time */ static C_List *CList = 0; /* Acts as root for objects "owned" by C callbacks */ static PolyWord FList = TAGGED(0); /* ML Callback list - acts as a Root for the Heap */ static PolyWord GList = TAGGED(0); /* ML Event list - acts as a Root for the Heap */ static Bool callbacks_enabled = False; /******************************************************************************/ /* */ /* High-speed XList routines */ /* */ /******************************************************************************/ /* maps an (X_Object *) to an (unsigned); this mapping from must give the same */ /* (unsigned) for each (X_Object) for an entire Poly/ML session, even though its */ /* address may change at every garbage collection. */ /* The way we achieve this is by returning the address of the corresponding C */ /* object. Note that since the ML object doesn't necessarily correspond to a real*/ /* C object, this value may be neither valid nor sensible (but it WILL be a */ /* constant). */ /* Unfortunately, we can't do this for GCs or VISUALS, since the actual C object */ /* contains the id we want, and we can't access the id if we haven't got the */ /* object. For these, we return a constant instead. */ static unsigned long hashId(X_Object *P) { #define HASH_GC 0 #define HASH_VISUAL 1 switch(UNTAGGED(P->type)) { case X_GC: return HASH_GC; case X_Font: return (unsigned long)(*(((X_Font_Object*)P)->font)); case X_Cursor: return (unsigned long)(*(((X_Cursor_Object*)P)->cursor)); case X_Window: return (unsigned long)(*(((X_Window_Struct*)P)->drawable)); case X_Pixmap: return (unsigned long)(*(((X_Pixmap_Object*)P)->pixmap)); case X_Colormap: return (unsigned long)(*(((X_Colormap_Object*)P)->cmap)); case X_Visual: return HASH_VISUAL; case X_Display: return (unsigned long)(((X_Display_Object*)P)->display); case X_Widget: return (unsigned long)(*(((X_Widget_Object*)P)->widget)); case X_Trans: return (unsigned long)(((X_Trans_Object*)P)->table); case X_Acc: return (unsigned long)(((X_Acc_Object*)P)->acc); default: Crash ("Bad X_Object type (%d) in hashId",UNTAGGED(P->type)); } /*NOTREACHED*/ } static void initXList(void) { int i; for (i = 0; i < XLISTSIZE; i++) { XList[i] = NULL; } } static X_List **hashXList(X_Object *P) { unsigned long id = hashId(P); unsigned n = (id % XLISTSIZE); /* a poor hash function, but good enough for now */ return &(XList[n]); } static X_List *findXList(unsigned long id) { unsigned n = (id % XLISTSIZE); /* a poor hash function, but good enough for now */ return XList[n]; } /******************************************************************************/ /* */ /* C lists (Polymorphic functions) */ /* */ /******************************************************************************/ // Creates a list from a vector of items. static Handle CreateList4(TaskData *taskData, unsigned n, void *p, unsigned objSize, Handle (*f)(TaskData *, void *)) { Handle saved = taskData->saveVec.mark(); Handle list = SAVE(ListNull); // Process the vector in reverse order. That way we can make the // cells as immutable objects rather than having to create them as // mutable and then lock them. while (n) { n--; byte *objP = (byte*)p + objSize*n; Handle value = (* f)(taskData, objP); Handle next = alloc_and_save(taskData, SIZEOF(ML_Cons_Cell)); DEREFLISTHANDLE(next)->h = DEREFWORDHANDLE(value); DEREFLISTHANDLE(next)->t = DEREFLISTHANDLE(list); /* reset save vector to stop it overflowing */ taskData->saveVec.reset(saved); list = SAVE(DEREFHANDLE(next)); } return list; } static Handle CreateList4I(TaskData *taskData, unsigned n, void *p, unsigned objSize, Handle (*f)(TaskData *, void *, unsigned i)) { Handle saved = taskData->saveVec.mark(); Handle list = SAVE(ListNull); while (n) { n--; byte *objP = (byte*)p + objSize*n; Handle value = (* f)(taskData, objP, n); Handle next = alloc_and_save(taskData, SIZEOF(ML_Cons_Cell)); DEREFLISTHANDLE(next)->h = DEREFWORDHANDLE(value); DEREFLISTHANDLE(next)->t = DEREFLISTHANDLE(list); /* reset save vector to stop it overflowing */ taskData->saveVec.reset(saved); list = SAVE(DEREFHANDLE(next)); } return list; } static Handle CreateList5(TaskData *taskData, POLYUNSIGNED n, void *p, POLYUNSIGNED objSize, Handle (*f)(TaskData *, void *, Handle), Handle a1) { Handle saved = taskData->saveVec.mark(); Handle list = SAVE(ListNull); // Process the vector in reverse order. That way we can make the // cells as immutable objects rather than having to create them as // mutable and then lock them. while (n) { n--; byte *objP = (byte*)p + objSize*n; Handle value = (* f)(taskData, objP, a1); Handle next = alloc_and_save(taskData, SIZEOF(ML_Cons_Cell)); DEREFLISTHANDLE(next)->h = DEREFWORDHANDLE(value); DEREFLISTHANDLE(next)->t = DEREFLISTHANDLE(list); /* reset save vector to stop it overflowing */ taskData->saveVec.reset(saved); list = SAVE(DEREFHANDLE(next)); } return list; } static void GetList4(TaskData *taskData, PolyWord list, void *v, unsigned bytes, void (*get)(TaskData *, PolyWord, void*, unsigned)) { unsigned i = 0; byte *s = (byte*)v; for(PolyWord p = list; NONNIL(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { (* get)(taskData, ((ML_Cons_Cell*)p.AsObjPtr())->h, s, i); s += bytes; i++; } } /* ListLength no longer requires indirection via handle SPF 4/11/93 */ static unsigned ListLength(PolyWord list) { unsigned n = 0; for(PolyWord p = list; NONNIL(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) n++; return n; } /******************************************************************************/ /* */ /* TList Purge Functions (SPF 29/11/93) */ /* */ /******************************************************************************/ static void PurgePendingWidgetMessages(X_Widget_Object *P) { T_List **T = &TList; while(*T) { T_List *t = *T; if (t->widget_object == P) /* clear out pending messages for this widget */ { *T = t->next; free(t); } else T = &t->next; } } static void PurgePendingWindowMessages(X_Window_Object *P) { T_List **T = &TList; while(*T) { T_List *t = *T; if (t->window_object == P) /* clear out pending messages for this window */ { *T = t->next; free(t); } else T = &t->next; } } /******************************************************************************/ /* */ /* CList Purge Functions (SPF 29/2/96) */ /* */ /******************************************************************************/ static void PurgeCCallbacks(X_Widget_Object *P, Widget w) { C_List **C = &CList; while(*C) { C_List *c = *C; if (c->widget_object == P) /* clear out callback info for this widget */ { debugReclaimCallback(P,w,c); *C = c->next; free(c); } else C = &c->next; } } /******************************************************************************/ /* */ /* XObjects (Polymorphic functions 1) */ /* */ /******************************************************************************/ static int ResourceExists(X_Object *P) { X_List *L; for(L = *hashXList(P); L; L = L->next) { if (L->object == P) return 1; } return 0; } /* SafeResourceExists is like ResourceExists but doesn't assume that we actually have a valid X object, so it doesn't use hashing. SPF 6/4/95 */ static int SafeResourceExists(X_Object *P) { unsigned n; for (n = 0; n < XLISTSIZE; n++) { X_List *L; for(L = XList[n]; L; L = L->next) { if (L->object == P) return 1; } } return 0; } static void DestroyXObject(X_Object *P) { TaskData *taskData = processes->GetTaskDataForThread(); X_List **X = hashXList(P); switch(UNTAGGED(P->type)) { case X_GC: { X_GC_Object *G = GCObject(P); GC gc = *G->gc; Display *d = G->ds->display; if (gc == DefaultGC(d,G->ds->screen)) { debugReclaimRef(GC,gc->gid); } else { debugReclaim(GC,gc->gid); XFreeGC(d,gc); /* SAFE(?) */ } break; } case X_Font: { Font f = GetFont(taskData, P); if (f == None) { debugReclaimRef(Font,f); } else { debugReclaim(Font,f); #if NEVER XUnloadFont(GetDisplay(taskData, P),f); #endif } break; } case X_Cursor: { Cursor cursor = GetCursor(taskData, P); if (cursor == None) { debugReclaimRef(Cursor,cursor); } else { debugReclaim(Cursor,cursor); #if NEVER XFreeCursor(GetDisplay(taskData, P),cursor); #endif } break; } case X_Window: { /* added 29/11/93 SPF */ PurgePendingWindowMessages(WindowObject(P)); if (((X_Window_Object *)P)->parent != 0) /* this clients window */ { debugReclaim(Window,GetWindow(taskData, P)); DestroyWindow(P); } else /* None, ParentRelative, and other clients windows */ { debugReclaimRef(Window,GetWindow(taskData, P)); } break; } case X_Pixmap: { Pixmap pixmap = GetPixmap(taskData, P); if (pixmap == None) { debugReclaimRef(Pixmap,pixmap); } else { debugReclaim(Pixmap,pixmap); #if NEVER XFreePixmap(GetDisplay(taskData, P),pixmap); #endif } break; } case X_Colormap: { Colormap cmap = GetColormap(taskData, P); if (cmap == None) { debugReclaimRef(Colormap,cmap); } else { debugReclaim(Colormap,cmap); #if NEVER XFreeColormap(GetDisplay(taskData, P),cmap); #endif } break; } case X_Visual: { Visual *visual = GetVisual(taskData, P); debugReclaimRef(Visual,visual->visualid); break; } case X_Widget: { Widget widget = GetNWidget(taskData, P); PurgePendingWidgetMessages(WidgetObject(taskData, P)); debugReclaimRef(Widget,widget); break; } case X_Trans: { XtTranslations table = GetTrans(taskData, P); debugReclaimRef(Trans,table); break; } case X_Acc: { XtAccelerators acc = GetAcc(taskData, (X_Object *)P); debugReclaimRef(Acc,acc); break; } default: Crash ("Unknown X_Object type %d",UNTAGGED(P->type)); } while(*X) { X_List *L = *X; if (L->object == P) { *X = L->next; free(L); return; } else X = &L->next; } printf("DestroyXObject: destroy failed\n"); } #define CheckExists(P,resource) \ {\ if (! ResourceExists(P)) RaiseXWindows(taskData, (char*) "Non-existent " #resource); \ } static X_Font_Object *FontObject(X_Object *P) { assert(UNTAGGED(P->type) == X_Font); return (X_Font_Object *)P; } static X_Object *FindResource ( Handle dsHandle, /* Handle to (X_Display_Object *) */ X_types type, unsigned long id, unsigned long hashid ) { X_List *L; X_Display_Object *d = (type == X_Widget) ? NULL : DEREFDISPLAYHANDLE(dsHandle); for(L = findXList(hashid); L; L = L->next) { X_Object *P = L->object; if (UNTAGGED(P->type) == type) { switch(type) { case X_GC: if (((X_GC_Object*)P)->ds == d && (*((X_GC_Object*)P)->gc)->gid == id) return P; break; case X_Font: if (((X_Font_Object*)P)->ds == d && (*((X_Font_Object*)P)->font) == id) return P; break; case X_Cursor: if (((X_Cursor_Object*)P)->ds == d && (*((X_Cursor_Object*)P)->cursor) == id) return P; break; case X_Window: if (((X_Window_Object*)P)->ds == d && (*((X_Window_Object*)P)->drawable) == id) return P; break; case X_Pixmap: if (((X_Pixmap_Object*)P)->ds == d && (*((X_Pixmap_Object*)P)->pixmap) == id) return P; break; case X_Colormap: if (((X_Colormap_Object*)P)->ds == d && (*((X_Colormap_Object*)P)->cmap) == id) return P; break; case X_Visual: if (((X_Visual_Object*)P)->ds == d && (*((X_Visual_Object*)P)->visual)->visualid == id) return P; break; case X_Widget: if (*(((X_Widget_Object*)P)->widget) == (Widget) id) return P; break; case X_Display: break; case X_Trans: break; case X_Acc: break; default: Crash ("Bad X_Object type (%d) in FindResource", type); } } } return 0; } // Why are there these casts to unsigned here???? #define FindWindow(d,id) ((X_Window_Object *) FindResource(d,X_Window,(unsigned long)id,(unsigned long)id)) #define FindPixmap(d,id) ((X_Pixmap_Object *) FindResource(d,X_Pixmap,(unsigned long)id,(unsigned long)id)) #define FindCursor(d,id) ((X_Cursor_Object *) FindResource(d,X_Cursor,(unsigned long)id,(unsigned long)id)) #define FindFont(d,id) ((X_Font_Object *) FindResource(d,X_Font,(unsigned long)id,(unsigned long)id)) #define FindColormap(d,id) ((X_Colormap_Object *) FindResource(d,X_Colormap,(unsigned long)id,(unsigned long)id)) #define FindWidget(id) ((X_Widget_Object *) FindResource((Handle)NULL,X_Widget,(unsigned long)id,(unsigned long)id)) /* can't use id for hashing in the following, so use arbitrary values instead */ #define FindGC(d,id) ((X_GC_Object *) FindResource(d,X_GC,(unsigned long)id,HASH_GC)) #define FindVisual(d,id) ((X_Visual_Object *) FindResource(d,X_Visual,(unsigned long)id,HASH_VISUAL)) static Handle AddXObject(Handle objectHandle) { X_List **X = hashXList(DEREFXOBJECTHANDLE(objectHandle)); X_List *L = (X_List *) malloc(sizeof(X_List)); L->next = *X; L->object = (X_Object *)DEREFHANDLE(objectHandle); *X = L; return objectHandle; } /******************************************************************************/ /* */ /* MLXPoint - implements ML XPoint datatype */ /* */ /******************************************************************************/ typedef struct /* depends on XPoint datatype + ML compiler hash function */ { PolyWord x; /* ML int */ PolyWord y; /* ML int */ } MLXPoint; inline MLXPoint * Point(PolyWord p) { return (MLXPoint *) p.AsObjPtr(); } /* shouldn't these be long values? */ inline short GetPointX(TaskData *taskData, PolyWord p) { return get_C_short(taskData, Point(p)->x); } inline short GetPointY(TaskData *taskData, PolyWord p) { return get_C_short(taskData, Point(p)->y); } inline short GetOffsetX(TaskData *taskData, PolyWord p) { return get_C_ushort(taskData, Point(p)->x); } inline short GetOffsetY(TaskData *taskData, PolyWord p) { return get_C_ushort(taskData, Point(p)->y); } static Handle CreatePoint(TaskData *taskData, int x, int y) { Handle pointHandle = alloc_and_save(taskData, SIZEOF(MLXPoint), F_MUTABLE_BIT); /* Still allocating, so must use explicit DEREF for each element */ #define point ((MLXPoint *)DEREFHANDLE(pointHandle)) point->x = DEREFWORD(Make_int(x)); point->y = DEREFWORD(Make_int(y)); #undef point return FINISHED(taskData, pointHandle); } static void GetPoints(TaskData *taskData, PolyWord p, void *v, unsigned) { XPoint *A = (XPoint *)v; A->x = GetPointX(taskData, p); A->y = GetPointY(taskData, p); } /******************************************************************************/ /* */ /* MLXRectangle - implements ML XRectangle datatype */ /* */ /******************************************************************************/ typedef struct /* depends on XRectangle datatype + ML compiler hash function */ { PolyWord top; /* ML int */ PolyWord left; /* ML int */ PolyWord right; /* ML int */ PolyWord bottom; /* ML int */ } MLXRectangle; inline MLXRectangle *Rect(PolyWord R) { return (MLXRectangle *) R.AsObjPtr(); } inline short GetRectTop(TaskData *taskData, PolyWord R) { return get_C_short(taskData, Rect(R)->top); } inline short GetRectLeft(TaskData *taskData, PolyWord R) { return get_C_short(taskData, Rect(R)->left); } inline short GetRectRight(TaskData *taskData, PolyWord R) { return get_C_short(taskData, Rect(R)->right); } inline short GetRectBottom(TaskData *taskData, PolyWord R) { return get_C_short(taskData, Rect(R)->bottom); } #define GetRectX(taskData, R) GetRectLeft(taskData, R) #define GetRectY(taskData, R) GetRectTop(taskData, R) /* functions added 29/10/93 SPF */ static unsigned GetRectW(TaskData *taskData, PolyWord R) { long result = GetRectRight(taskData, R) - GetRectLeft(taskData, R); if (result < 0) RaiseRange(taskData); return (unsigned)result; } static unsigned GetRectH(TaskData *taskData, PolyWord R) { long result = GetRectBottom(taskData, R) - GetRectTop(taskData, R); if (result < 0) RaiseRange(taskData); return (unsigned)result; } /* static MLXRectangle **CreateRect(top,left,bottom,right) */ static Handle CreateRect(TaskData *taskData, int top, int left, int bottom, int right) { Handle rectHandle = alloc_and_save(taskData, SIZEOF(MLXRectangle), F_MUTABLE_BIT); /* Still allocating, so must use explicit DEREF for each element */ #define rect ((MLXRectangle *)DEREFHANDLE(rectHandle)) rect->top = DEREFWORD(Make_int(top)); rect->left = DEREFWORD(Make_int(left)); rect->right = DEREFWORD(Make_int(right)); rect->bottom = DEREFWORD(Make_int(bottom)); #undef rect return FINISHED(taskData, rectHandle); } #define CreateArea(w,h) CreateRect(taskData, 0,0,(int)h,(int)w) static void GetRects(TaskData *taskData, PolyWord p, void *v, unsigned) { XRectangle *A = (XRectangle *)v; A->x = GetRectX(taskData, p); A->y = GetRectY(taskData, p); A->width = GetRectW(taskData, p); A->height = GetRectH(taskData, p); } static void CheckZeroRect(TaskData *taskData, PolyWord R) { unsigned x = GetRectX(taskData, R); unsigned y = GetRectY(taskData, R); unsigned w = GetRectW(taskData, R); unsigned h = GetRectH(taskData, R); if (x != 0 || y != 0 || /* w <= 0 || h <= 0 || w,h now unsigned SPF 29/10/93 */ w == 0 || h == 0 || w > 65535 || h > 65535) RaiseRange(taskData); } /******************************************************************************/ /* */ /* MLXArc - implements ML XArc datatype */ /* */ /******************************************************************************/ /* MLXArc added 31/10/93 SPF; depends on ML XArc datatype */ typedef struct { PolyWord r; /* MMLXRectangle* */ PolyWord a1; /* ML int */ PolyWord a2; /* ML int */ } MLXArc; inline MLXArc *Arc(PolyWord A) { return (MLXArc *) A.AsObjPtr(); } inline PolyWord GetArcR(PolyWord A) { return Arc(A)->r; } inline short GetArcA1(TaskData *taskData, PolyWord A) { return get_C_short(taskData, Arc(A)->a1); } inline short GetArcA2(TaskData *taskData, PolyWord A) { return get_C_short(taskData, Arc(A)->a2); } static void GetArcs(TaskData *taskData, PolyWord p, void *v, unsigned) { XArc *A = (XArc *)v; A->x = GetRectX(taskData, GetArcR(p)); A->y = GetRectY(taskData, GetArcR(p)); A->width = GetRectW(taskData, GetArcR(p)); A->height = GetRectH(taskData, GetArcR(p)); A->angle1 = GetArcA1(taskData, p); A->angle2 = GetArcA2(taskData, p); } /******************************************************************************/ /* */ /* Colormap */ /* */ /******************************************************************************/ static X_Colormap_Object *ColormapObject(X_Object *P) { assert(UNTAGGED(P->type) == X_Colormap); return (X_Colormap_Object *)P; } static Colormap GetColormap(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Colormap); /* val NoColormap = xcall (23,0) : Colormap; */ /* special case for NoColormap - correct(?) */ if ( *(((X_Colormap_Object *)P)->cmap) == None) return None; CheckExists(P,colormap); return *(((X_Colormap_Object *)P)->cmap); } static Handle EmptyColormap ( TaskData *taskData, Handle dsHandle /* Handle to (X_Display_Object *) */, Colormap id ) { X_Colormap_Object *E = FindColormap(dsHandle,id); if (E) { return SAVE(E); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Colormap_Object), F_MUTABLE_BIT); Handle cmapHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT | F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Colormap_Object *object = (X_Colormap_Object *)DEREFHANDLE(objectHandle); Colormap *cmap = (Colormap *)DEREFHANDLE(cmapHandle); *cmap = id; FINISHED(taskData, cmapHandle); object->type = TAGGED(X_Colormap); object->cmap = cmap; object->ds = DEREFDISPLAYHANDLE(dsHandle); debugRefer(Colormap,id); return AddXObject(FINISHED(taskData, objectHandle)); } } /******************************************************************************/ /* */ /* Visual */ /* */ /******************************************************************************/ static Visual *GetVisual(TaskData *taskData, X_Object *P) { static Visual EMPTYVISUAL = { 0 }; assert(UNTAGGED(P->type) == X_Visual); /* val NoVisual = xcall (24,0) : Visual; */ /* special case for NoVisual */ if (*(((X_Visual_Object *)P)->visual) == None) return &EMPTYVISUAL; /* FISHY (?) */ CheckExists(P,visual); return *(((X_Visual_Object *)P)->visual); } static Handle EmptyVisual ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Visual *v ) { if (v != None) { X_Visual_Object *E = FindVisual(dsHandle,v->visualid); if (E) return SAVE(E); } /* else */ { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Visual_Object), F_MUTABLE_BIT); Handle visualHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Visual_Object *object = (X_Visual_Object *)DEREFHANDLE(objectHandle); Visual **visual = (Visual **)DEREFHANDLE(visualHandle); *visual = v; FINISHED(taskData, visualHandle); object->type = TAGGED(X_Visual); object->visual = visual; object->ds = DEREFDISPLAYHANDLE(dsHandle); debugRefer(Visual,(v == None) ? None : v->visualid); return AddXObject(FINISHED(taskData, objectHandle)); } } /******************************************************************************/ /* */ /* GC */ /* */ /******************************************************************************/ static X_GC_Object *GCObject(X_Object *P) { assert(UNTAGGED(P->type) == X_GC); return (X_GC_Object *)P; } static GC GetGC(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_GC); CheckExists(P,gc); return *(((X_GC_Object *)P)->gc); } static Handle GetDefaultGC(TaskData *taskData, Handle dsHandle /* Handle to (X_Display_Object *) */) { GC defaultGC = DefaultGC(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen); X_GC_Object *G = FindGC(dsHandle,defaultGC->gid); if (G) { return SAVE(G); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_GC_Object), F_MUTABLE_BIT); Handle GCHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_GC_Object *object = (X_GC_Object *)DEREFHANDLE(objectHandle); GC *gc = (GC *)DEREFHANDLE(GCHandle); *gc = defaultGC; FINISHED(taskData, GCHandle); debugRefer(GC,defaultGC->gid); object->type = TAGGED(X_GC); object->gc = gc; object->ds = DEREFDISPLAYHANDLE(dsHandle); /* object->font_object = 0; object->tile = 0; object->stipple = 0; object->clipMask = 0; */ return AddXObject(objectHandle); /* must stay MUTABLE */ } } static void ChangeGC(TaskData *taskData, X_GC_Object *G, unsigned n, PolyWord P) { XGCValues v; unsigned mask = 1 << n; switch(mask) { case GCFunction: v.function = get_C_ushort(taskData, P); break; case GCPlaneMask: v.plane_mask = get_C_ulong (taskData, P); break; case GCForeground: v.foreground = get_C_ulong (taskData, P); break; case GCBackground: v.background = get_C_ulong (taskData, P); break; case GCLineWidth: v.line_width = get_C_short (taskData, P); break; case GCLineStyle: v.line_style = get_C_ushort(taskData, P); break; case GCCapStyle: v.cap_style = get_C_ushort(taskData, P); break; case GCJoinStyle: v.join_style = get_C_ushort(taskData, P); break; case GCFillStyle: v.fill_style = get_C_ushort(taskData, P); break; case GCFillRule: v.fill_rule = get_C_ushort(taskData, P); break; case GCTileStipXOrigin: v.ts_x_origin = get_C_short (taskData, P); break; case GCTileStipYOrigin: v.ts_y_origin = get_C_short (taskData, P); break; case GCSubwindowMode: v.subwindow_mode = get_C_ushort(taskData, P); break; case GCGraphicsExposures: v.graphics_exposures = get_C_ushort(taskData, P); break; case GCClipXOrigin: v.clip_x_origin = get_C_short (taskData, P); break; case GCClipYOrigin: v.clip_y_origin = get_C_short (taskData, P); break; case GCDashOffset: v.dash_offset = get_C_ushort(taskData, P); break; case GCDashList: v.dashes = get_C_uchar (taskData, P); break; case GCArcMode: v.arc_mode = get_C_ushort(taskData, P); break; case GCFont: v.font = GetFont(taskData, (X_Object *)P.AsObjPtr()); G->font_object = FontObject((X_Object *)P.AsObjPtr()); break; case GCTile: v.tile = GetPixmap(taskData, (X_Object *)P.AsObjPtr()); G->tile = PixmapObject((X_Object *)P.AsObjPtr()); break; case GCStipple: v.stipple = GetPixmap(taskData, (X_Object *)P.AsObjPtr()); G->stipple = PixmapObject((X_Object *)P.AsObjPtr()); break; case GCClipMask: v.clip_mask = GetPixmap(taskData, (X_Object *)P.AsObjPtr()); G->clipMask = PixmapObject((X_Object *)P.AsObjPtr()); break; default: Crash ("Bad gc mask %u",mask); } XChangeGC(GetDisplay(taskData, (X_Object *)G),GetGC(taskData, (X_Object *)G),mask,&v); } static Handle CreateGC ( TaskData *taskData, Handle dsHandle /* Handle to (X_Display_Object *) */, Drawable w ) { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_GC_Object), F_MUTABLE_BIT); Handle GCHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_GC_Object *object = (X_GC_Object *)DEREFHANDLE(objectHandle); GC *gc = (GC *)DEREFHANDLE(GCHandle); *gc = XCreateGC(DEREFDISPLAYHANDLE(dsHandle)->display,w,0,0); FINISHED(taskData, GCHandle); debugCreate(GC,(*gc)->gid); object->type = TAGGED(X_GC); object->gc = gc; object->ds = DEREFDISPLAYHANDLE(dsHandle); /* object->font_object = 0; object->tile = 0; object->stipple = 0; object->clipMask = 0; */ return AddXObject(objectHandle); /* must remain MUTABLE */ } /******************************************************************************/ /* */ /* Window */ /* */ /******************************************************************************/ static X_Window_Object *WindowObject(X_Object *P) { assert(UNTAGGED(P->type) == X_Window); return (X_Window_Object *)P; } static Window GetWindow(TaskData *taskData, X_Object *P) { if (UNTAGGED(P->type) == X_Pixmap) { if (*((X_Pixmap_Object*)P)->pixmap == None) return None; RaiseXWindows(taskData, "Not a window"); } assert(UNTAGGED(P->type) == X_Window); CheckExists(P,window); return *(((X_Window_Object*)P)->drawable); } static Handle EmptyWindow ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w ) { X_Window_Object *W = FindWindow(dsHandle,w); if (W) { return SAVE(W); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Window_Object), F_MUTABLE_BIT); Handle eventMaskHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); Handle drawableHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Window_Object *object = DEREFWINDOWHANDLE(objectHandle); Drawable *drawable = (Drawable *)DEREFHANDLE(drawableHandle); PolyObject *eventMask = DEREFHANDLE(eventMaskHandle); *drawable = w; FINISHED(taskData, drawableHandle); #ifdef nodef /* DCJM: This gets in the way of trying to handle ButtonPress events - get rid of it. */ /* so that Motif windows get ButtonClick XEvent structures */ eventMask->Set(0, PolyWord::FromUnsigned(ButtonClickMask)); /* eventMask must remain MUTABLE */ #else eventMask->Set(0, PolyWord::FromUnsigned(0)); #endif object->type = TAGGED(X_Window); object->drawable = drawable; object->handler = TAGGED(0); object->state = TAGGED(0); object->eventMask = eventMask; /* object->colormap_object = 0; object->cursor_object = 0; object->backgroundPixmap = 0; object->borderPixmap = 0; object->parent = 0; */ object->ds = DEREFDISPLAYHANDLE(dsHandle); debugRefer(Window,w); return AddXObject(objectHandle); /* must remain MUTABLE */ } } /******************************************************************************/ /* */ /* Pixmap */ /* */ /******************************************************************************/ static X_Pixmap_Object *PixmapObject(X_Object *P) { assert(UNTAGGED(P->type) == X_Pixmap); return (X_Pixmap_Object *)P; } static Pixmap GetPixmap(TaskData *taskData, X_Object *P) { if (UNTAGGED(P->type) == X_Window) { if (! ResourceExists(P)) { debug1("Non-existent window %lx\n",(long)P); } if (*(((X_Window_Object*)P)->drawable) == None) return None; RaiseXWindows(taskData, "Not a pixmap"); } assert(UNTAGGED(P->type) == X_Pixmap); /* val NoDrawable = xcall (20,0) : Drawable; */ /* val ParentRelative = xcall (20,1) : Drawable; */ /* special case for NoDrawable */ if (*((X_Pixmap_Object*)P)->pixmap == 0) return None; /* special case for ParentRelative */ if (*((X_Pixmap_Object*)P)->pixmap == 1) return None; CheckExists(P,pixmap); return *(((X_Pixmap_Object*)P)->pixmap); } static Handle EmptyPixmap ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Pixmap id ) { X_Pixmap_Object *E = FindPixmap(dsHandle,id); if (E) { return SAVE(E); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Pixmap_Object), F_MUTABLE_BIT); Handle pixmapHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Pixmap_Object *object = (X_Pixmap_Object *)DEREFHANDLE(objectHandle); Pixmap *pixmap = (Pixmap *)DEREFHANDLE(pixmapHandle); *pixmap = id; FINISHED(taskData, pixmapHandle); object->type = TAGGED(X_Pixmap); object->pixmap = pixmap; object->ds = DEREFDISPLAYHANDLE(dsHandle); debugCreate(Pixmap,id); return AddXObject(FINISHED(taskData, objectHandle)); } } /******************************************************************************/ /* */ /* Drawable */ /* */ /******************************************************************************/ static Drawable GetDrawable(TaskData *taskData, X_Object *P) { CheckExists(P,drawable); switch(UNTAGGED(P->type)) { case X_Window: return *(((X_Window_Object*)P)->drawable); case X_Pixmap: return *(((X_Pixmap_Object*)P)->pixmap); default: Crash ("Bad X_Object type (%d) in GetDrawable",UNTAGGED(P->type)); } /*NOTREACHED*/ } /******************************************************************************/ /* */ /* DS / Display */ /* */ /******************************************************************************/ static Handle GetDS(TaskData *taskData, X_Object *P) { X_Display_Object *ds; CheckExists(P,resource); switch(UNTAGGED(P->type)) { case X_GC: ds = ((X_GC_Object*)P)->ds; break; case X_Font: ds = ((X_Font_Object*)P)->ds; break; case X_Cursor: ds = ((X_Cursor_Object*)P)->ds; break; case X_Window: ds = ((X_Window_Object*)P)->ds; break; case X_Pixmap: ds = ((X_Pixmap_Object*)P)->ds; break; case X_Colormap: ds = ((X_Colormap_Object*)P)->ds; break; case X_Visual: ds = ((X_Visual_Object*)P)->ds; break; case X_Widget: ds = ((X_Widget_Object*)P)->ds; break; case X_Display: ds = (X_Display_Object*)P; break; /* i.e. P cast to the right type */ default: Crash ("Bad X_Object type (%d) in GetDS",UNTAGGED(P->type)); } assert((PolyWord)ds != TAGGED(0)); return SAVE(ds); } static Display *GetDisplay(TaskData *taskData, X_Object *P) { CheckExists(P,resource); switch(UNTAGGED(P->type)) { case X_GC: return ((X_GC_Object*)P)->ds->display; case X_Font: return ((X_Font_Object*)P)->ds->display; case X_Cursor: return ((X_Cursor_Object*)P)->ds->display; case X_Window: return ((X_Window_Object*)P)->ds->display; case X_Pixmap: return ((X_Pixmap_Object*)P)->ds->display; case X_Colormap: return ((X_Colormap_Object*)P)->ds->display; case X_Visual: return ((X_Visual_Object*)P)->ds->display; case X_Widget: return ((X_Widget_Object*)P)->ds->display; case X_Display: return ((X_Display_Object*)P)->display; default: Crash ("Bad X_Object type (%d) in GetDisplay",UNTAGGED(P->type)); } /*NOTREACHED*/ } /******************************************************************************/ /* */ /* FS / Font */ /* */ /******************************************************************************/ static Font GetFont(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Font); /* val NoFont = xcall (22,0) : Font; */ /* special case for NoFont - valid(?) */ if (*(((X_Font_Object *)P)->font) == None) return None; CheckExists(P,font); return *(((X_Font_Object *)P)->font); } static Handle EmptyFont ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Font id, XFontStruct *fs ) { X_Font_Object *E = FindFont(dsHandle,id); if (E && (fs == NULL || *(E->fs) == fs)) { return SAVE(E); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Font_Object), F_MUTABLE_BIT); Handle fontHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); Handle FSHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Font_Object *object = (X_Font_Object *)DEREFHANDLE(objectHandle); Font *font = (Font *)DEREFHANDLE(fontHandle); XFontStruct **xfstr = (XFontStruct **)DEREFHANDLE(FSHandle); *font = id; FINISHED(taskData, fontHandle); *xfstr = fs; FINISHED(taskData, FSHandle); object->type = TAGGED(X_Font); object->font = font; object->fs = xfstr; object->ds = DEREFDISPLAYHANDLE(dsHandle); debugCreate(Font,id); return AddXObject(FINISHED(taskData, objectHandle)); } } /******************************************************************************/ /* */ /* Cursor */ /* */ /******************************************************************************/ static X_Cursor_Object *CursorObject(X_Object *P) { assert(UNTAGGED(P->type) == X_Cursor); return (X_Cursor_Object *)P; } static Cursor GetCursor(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Cursor); /* val NoCursor = xcall (21,0) : Cursor; */ /* special case for NoCursor */ if (*(((X_Cursor_Object *)P)->cursor) == None) return None; CheckExists(P,cursor); return *(((X_Cursor_Object *)P)->cursor); } static Handle EmptyCursor ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Cursor id ) { X_Cursor_Object *E = FindCursor(dsHandle,id); if (E) { return SAVE(E); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Cursor_Object), F_MUTABLE_BIT); Handle cursorHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Cursor_Object *object = (X_Cursor_Object *)DEREFHANDLE(objectHandle); Cursor *cursor = (Cursor *)DEREFHANDLE(cursorHandle); *cursor = id; FINISHED(taskData, cursorHandle); object->type = TAGGED(X_Cursor); object->cursor = cursor; object->ds = DEREFDISPLAYHANDLE(dsHandle); debugRefer(Cursor,id); return AddXObject(FINISHED(taskData, objectHandle)); } } static Handle CreateFontCursor ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ unsigned shape ) { return EmptyCursor(taskData, dsHandle,XCreateFontCursor(DEREFDISPLAYHANDLE(dsHandle)->display,shape)); } static Handle CreateGlyphCursor ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Font sf, Font mf, unsigned sc, unsigned mc, XColor *foreground, XColor *background ) { return EmptyCursor(taskData, dsHandle,XCreateGlyphCursor(DEREFDISPLAYHANDLE(dsHandle)->display,sf,mf,sc,mc,foreground,background)); } static Handle CreatePixmapCursor ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Pixmap source, Pixmap mask, XColor *foreground, XColor *background, unsigned x, unsigned y ) { return EmptyCursor(taskData, dsHandle,XCreatePixmapCursor(DEREFDISPLAYHANDLE(dsHandle)->display,source,mask,foreground,background,x,y)); } /******************************************************************************/ /* */ /* Widget */ /* */ /******************************************************************************/ static Widget GetNWidget(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Widget); if (*(((X_Widget_Object *)P)->widget) == NULL) return NULL; CheckExists(P,widget); return *(((X_Widget_Object *)P)->widget); } static Widget GetWidget(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Widget); if (*(((X_Widget_Object *)P)->widget) == NULL) { RaiseXWindows(taskData, "Not a real widget"); } CheckExists(P,widget); return *(((X_Widget_Object *)P)->widget); } /* added 6/11/94 SPF */ static Widget GetRealizedWidget(TaskData *taskData, char *where, X_Object *P) { Widget w; assert(UNTAGGED(P->type) == X_Widget); w = *(((X_Widget_Object *)P)->widget); if (w == NULL) { RaiseXWindows2(where,": not a real widget"); } CheckExists(P,widget); if (XtIsRealized(w) == False) { RaiseXWindows2(where,": widget is not realized"); } return w; } /* P is a pointer to an X_Widget_Object */ static X_Widget_Object *WidgetObjectToken(X_Object *P) { assert(UNTAGGED(P->type) == X_Widget); return (X_Widget_Object *)P; } /* P is a pointer to an X_Widget_Object, which is bound to a C widget */ static X_Widget_Object *WidgetObject(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Widget); CheckExists(P,widget); return (X_Widget_Object *)P; } static Handle EmptyWidget ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget id ) { X_Widget_Object *E = FindWidget(id); if (E) { return SAVE(E); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Widget_Object), F_MUTABLE_BIT); Handle widgetHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Widget_Object *object = (X_Widget_Object *)DEREFHANDLE(objectHandle); Widget *widget = (Widget *)DEREFHANDLE(widgetHandle); *widget = id; FINISHED(taskData, widgetHandle); object->type = TAGGED(X_Widget); object->widget = widget; object->callbackList = ListNull; object->state = TAGGED(0); object->ds = DEREFDISPLAYHANDLE(dsHandle); debugRefer(Widget,id); return AddXObject(objectHandle); /* Must stay MUTABLE */ } } static Handle NewWidget ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget id ) { X_Widget_Object *E = FindWidget(id); if (E) DestroyXObject((X_Object *)E); return EmptyWidget(taskData, dsHandle,id); } /******************************************************************************/ /* */ /* Text Widgets */ /* */ /******************************************************************************/ static Widget GetTextWidget(TaskData *taskData, char *funcname, X_Object *P) { Widget w = GetWidget(taskData, P); if (XmIsText(w)) return w; /* Text operations are also legal on TextField widgets */ if (XmIsTextField(w)) return w; RaiseXWindows2(funcname,": not a Text or TextField widget"); /*NOTREACHED*/ } /******************************************************************************/ /* */ /* TextField Widgets */ /* */ /******************************************************************************/ static Widget GetTextFieldWidget(TaskData *taskData, char *funcname, X_Object *P) { Widget w = GetWidget(taskData, P); if (XmIsTextField(w)) return w; RaiseXWindows2(funcname,": not a TextField widget"); /*NOTREACHED*/ } /******************************************************************************/ /* */ /* List Widgets */ /* */ /******************************************************************************/ static Widget GetListWidget(TaskData *taskData, char *funcname, X_Object *P) { Widget w = GetWidget(taskData, P); if (XmIsList(w)) return w; RaiseXWindows2(funcname,": not a List widget"); /*NOTREACHED*/ } /******************************************************************************/ /* */ /* Window */ /* */ /******************************************************************************/ static void RemoveWindowEvents(Display *d, Window w) { XEvent event; XSync(d,False); while(XCheckWindowEvent(d,w,~0,&event)) { /* do nothing */ } } static Handle AddWindow ( TaskData *taskData, Window W, Handle handlerHandle, /* Handle to (PolyWord *) (?) */ Handle stateHandle, /* Handle to (PolyWord *) (?) */ Handle parentHandle /* Handle to (X_Window_Object *) */ ) { XWMHints hints; Atom deleteWindow; /* was int SPF 6/1/94 */ Display *d = GetDisplay(taskData, DEREFXOBJECTHANDLE(parentHandle)); Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Window_Object), F_MUTABLE_BIT); Handle eventMaskHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); Handle drawableHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Window_Object *object = DEREFWINDOWHANDLE(objectHandle); Drawable *drawable = (Drawable *)DEREFHANDLE(drawableHandle); PolyObject *eventMask = DEREFHANDLE(eventMaskHandle); eventMask->Set(0, PolyWord::FromUnsigned(0)); /* eventMask must remain MUTABLE */ *drawable = W; FINISHED(taskData, drawableHandle); hints.flags = InputHint; hints.input = True; XSetWMHints(d,W,&hints); deleteWindow = WM_DELETE_WINDOW(d); if (deleteWindow != None) XSetWMProtocols(d,W,&deleteWindow,1); debugCreate(Window,W); object->type = TAGGED(X_Window); object->drawable = drawable; object->eventMask = eventMask; object->handler = DEREFHANDLE(handlerHandle); object->state = DEREFHANDLE(stateHandle); object->parent = DEREFWINDOWHANDLE(parentHandle); object->ds = DEREFWINDOWHANDLE(parentHandle)->ds; /* Tidy up (?) */ /* object->colormap_object = 0; object->cursor_object = 0; object->backgroundPixmap = 0; object->borderPixmap = 0; */ if (ISNIL(DEREFHANDLE(handlerHandle))) Crash ("No handler set"); return AddXObject(objectHandle); /* object must remain MUTABLE */ } static void DestroyWindow(X_Object *W /* Should be a Window Object! */) { TaskData *taskData = processes->GetTaskDataForThread(); Window w = GetWindow(taskData, W); Display *d = GetDisplay(taskData, W); debugReclaim(Window,w); XUnmapWindow(d,w); DestroySubwindows(W); XDestroyWindow(d,w); RemoveWindowEvents(d,w); } static Handle CreateSimpleWindow ( TaskData *taskData, Handle parent, /* Handle to (X_Window_Object *) */ int x, int y, unsigned w, unsigned h, unsigned borderWidth, unsigned border, unsigned background, Handle handler, /* Handle to (PolyWord *) (?) */ Handle state /* Handle to (PolyWord *) (?) */ ) { Window W = XCreateSimpleWindow(GetDisplay(taskData, DEREFXOBJECTHANDLE(parent)), GetWindow(taskData, DEREFXOBJECTHANDLE(parent)), x,y,w,h, borderWidth,border,background); if (W == 0) RaiseXWindows(taskData, "XCreateSimpleWindow failed"); return AddWindow(taskData,W,handler,state,parent); } static Handle CreateWindow ( TaskData *taskData, Handle parent, /* Handle to (X_Window_Object *) */ int x, int y, unsigned w, unsigned h, unsigned borderWidth, unsigned depth, unsigned clas, Visual *visual, Handle handler, /* Handle to (PolyWord *) (?) */ Handle state /* Handle to (PolyWord *) (?) */ ) { Window W; W = XCreateWindow(GetDisplay(taskData, DEREFXOBJECTHANDLE(parent)), GetWindow(taskData, DEREFXOBJECTHANDLE(parent)), x,y,w,h, borderWidth,depth,clas,visual,0,0); if (W == 0) RaiseXWindows(taskData, "XCreateWindow failed"); return AddWindow(taskData,W,handler,state,parent); } static void DestroySubwindows(X_Object *W /* should be a Window object! */) { TaskData *taskData = processes->GetTaskDataForThread(); Window root,parent,*children; unsigned n; int s; Window w = GetWindow(taskData, W); Display *d = GetDisplay(taskData, W); s = XQueryTree(d,w,&root,&parent,&children,&n); if (s == 0) { RaiseXWindows(taskData, "XDestroySubwindows failed"); return; } XUnmapSubwindows(d,w); if (n) { Handle dsHandle = GetDS(taskData, W); while(n--) { X_Window_Object *child = FindWindow(dsHandle,children[n]); if (child) DestroyXObject((X_Object *)child); } XFree((char *)children); } XDestroySubwindows(d,w); } /******************************************************************************/ /* */ /* Translations / Accelerators */ /* */ /******************************************************************************/ static Handle EmptyTrans(TaskData *taskData, XtTranslations table) { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Trans_Object), F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Trans_Object *object = (X_Trans_Object *)DEREFHANDLE(objectHandle); /* OK to store C values because this is a byte object */ object->type = TAGGED(X_Trans); object->table = table; debugRefer(Trans,table); return AddXObject(FINISHED(taskData, objectHandle)); } static XtTranslations GetTrans(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Trans); CheckExists(P,trans); return ((X_Trans_Object *)P)->table; } static Handle EmptyAcc(TaskData *taskData, XtTranslations acc) { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Acc_Object), F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Acc_Object *object = (X_Acc_Object *)DEREFHANDLE(objectHandle); /* OK to store C values because this is a byte object */ object->type = TAGGED(X_Acc); object->acc = acc; debugRefer(Acc,acc); return AddXObject(FINISHED(taskData, objectHandle)); } static XtAccelerators GetAcc(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Acc); CheckExists(P,acc); return ((X_Acc_Object *)P)->acc; } /******************************************************************************/ /* */ /* Utility functions */ /* */ /******************************************************************************/ static XtGrabKind GetXtGrabKind(TaskData *taskData, PolyWord P) { int i = get_C_long(taskData, P); /* This encoding must be the same as that used in Motif/ml_bind.ML */ switch (i) { case 0: return XtGrabNone; case 1: return XtGrabNonexclusive; case 2: return XtGrabExclusive; default: Crash ("Bad XtGrabKind index (%d) in GetXtGrabKind",i); } return XtGrabNone; /* to keep lint/gcc happy */ } /******************************************************************************/ /* */ /* MLXStandardColormap - implements ML XStandardColormap datatype */ /* */ /******************************************************************************/ typedef struct { X_Colormap_Object *Colormap; PolyWord redMax; /* ML int */ PolyWord redMult; /* ML int */ PolyWord greenMax; /* ML int */ PolyWord greenMult; /* ML int */ PolyWord blueMax; /* ML int */ PolyWord blueMult; /* ML int */ PolyWord basePixel; /* ML int */ X_Visual_Object *visual; } MLXStandardColormap; static void GetStandardColormap(TaskData *taskData, PolyWord p, void *v, unsigned) { MLXStandardColormap *P = (MLXStandardColormap *)p.AsObjPtr(); XStandardColormap *s = (XStandardColormap *)v; s->colormap = GetColormap(taskData, (X_Object *)P->Colormap); s->red_max = get_C_ulong(taskData, P->redMax); s->red_mult = get_C_ulong(taskData, P->redMult); s->green_max = get_C_ulong(taskData, P->greenMax); s->green_mult = get_C_ulong(taskData, P->greenMult); s->blue_max = get_C_ulong(taskData, P->blueMax); s->blue_mult = get_C_ulong(taskData, P->blueMult); s->base_pixel = get_C_ulong(taskData, P->basePixel); s->visualid = GetVisual(taskData, (X_Object *)P->visual)->visualid; /* UNSAFE(?) */ s->killid = None; } static Handle CreateStandardColormap ( TaskData *taskData, void *v, Handle dsHandle /* Handle to (X_Display_Object *) */ ) { XStandardColormap *s = (XStandardColormap *)v; XVisualInfo T; XVisualInfo *info; int count; Handle tupleHandle = alloc_and_save(taskData, SIZEOF(MLXStandardColormap), F_MUTABLE_BIT); T.visualid = s->visualid; T.visual = None; info = XGetVisualInfo(DEREFDISPLAYHANDLE(dsHandle)->display,VisualIDMask,&T,&count); if (info) { T.visual = info->visual; XFree((char *)info); } /* Still allocating, so must use explicit DEREF for each element */ #define tuple /* hack */((MLXStandardColormap *)DEREFHANDLE(tupleHandle)) tuple->Colormap = (X_Colormap_Object *)DEREFHANDLE(EmptyColormap(taskData, dsHandle,s->colormap)); tuple->redMax = DEREFWORD(Make_arbitrary_precision(taskData, s->red_max)); tuple->redMult = DEREFWORD(Make_arbitrary_precision(taskData, s->red_mult)); tuple->greenMax = DEREFWORD(Make_arbitrary_precision(taskData, s->green_max)); tuple->greenMult = DEREFWORD(Make_arbitrary_precision(taskData, s->green_mult)); tuple->blueMax = DEREFWORD(Make_arbitrary_precision(taskData, s->blue_max)); tuple->blueMult = DEREFWORD(Make_arbitrary_precision(taskData, s->blue_mult)); tuple->basePixel = DEREFWORD(Make_arbitrary_precision(taskData, s->base_pixel)); tuple->visual = (X_Visual_Object *)DEREFHANDLE(EmptyVisual(taskData, dsHandle,T.visual)); #undef tuple return FINISHED(taskData, tupleHandle); } /******************************************************************************/ /* */ /* Polymorphic pairs */ /* */ /******************************************************************************/ class MLPair: public PolyObject { public: PolyWord x0; /* first value */ PolyWord x1; /* second value */ }; /* Polymorphic pair creation */ static Handle CreatePair(TaskData *taskData, Handle p1, Handle p2) { Handle pairHandle = alloc_and_save(taskData, SIZEOF(MLPair), F_MUTABLE_BIT); /* Still allocating, so must use explicit DEREF for each element */ #define pair ((MLPair *)DEREFHANDLE(pairHandle)) pair->x0 = DEREFWORD(p1); pair->x1 = DEREFWORD(p2); #undef pair return FINISHED(taskData, pairHandle); } /******************************************************************************/ /* */ /* Polymorphic triples */ /* */ /******************************************************************************/ class MLTriple: public PolyObject { public: PolyWord x0; /* first value */ PolyWord x1; /* second value */ PolyWord x2; /* third value */ }; inline PolyWord FST(PolyWord P) { return ((MLTriple*)P.AsObjPtr())->x0; } inline PolyWord SND(PolyWord P) { return ((MLTriple*)P.AsObjPtr())->x1; } inline PolyWord THIRD(PolyWord P) { return ((MLTriple*)P.AsObjPtr())->x2; } static Handle CreateTriple(TaskData *taskData, Handle p1, Handle p2, Handle p3) { Handle tripleHandle = alloc_and_save(taskData, SIZEOF(MLTriple), F_MUTABLE_BIT); /* Still allocating, so must use explicit DEREF for each element */ #define triple ((MLTriple *)DEREFHANDLE(tripleHandle)) triple->x0 = DEREFWORD(p1); triple->x1 = DEREFWORD(p2); triple->x2 = DEREFWORD(p3); #undef triple return FINISHED(taskData, tripleHandle); } /******************************************************************************/ /* */ /* MLXImage - Implements ML XImage datatype */ /* */ /******************************************************************************/ typedef struct { PolyWord data; /* ML (abstype containing) string */ PolyWord size; /* MLXRectangle * */ PolyWord depth; /* ML int */ PolyWord format; /* (short ML int) XYBitmap | XYPixmap | ZPixmap */ PolyWord xoffset; /* ML int */ PolyWord bitmapPad; /* ML int */ PolyWord byteOrder; /* (short ML int) LSBFirst | MSBFirst */ PolyWord bitmapUnit; /* ML int */ PolyWord bitsPerPixel; /* ML int */ PolyWord bytesPerLine; /* ML int */ PolyWord visualRedMask; /* ML int */ PolyWord bitmapBitOrder; /* (short ML int) LSBFirst | MSBFirst */ PolyWord visualBlueMask; /* ML int */ PolyWord visualGreenMask; /* ML int */ } MLXImage; #define MLImageFormat(n) (n+1) #define MLImageOrder(n) (n+1) #define CImageFormat(n) (n-1) #define CImageOrder(n) (n-1) static unsigned ImageBytes(XImage *image) { unsigned dsize = image->bytes_per_line * image->height; if (image->format == XYPixmap) dsize = dsize * image->depth; return dsize; } static XImage *GetXImage(TaskData *taskData, Display *d, PolyWord p) /* can only be called once per X opcode */ { MLXImage *I = (MLXImage *)p.AsObjPtr(); static XImage image = { 0 }; PolyStringObject *data = GetString(I->data); unsigned width = GetRectW(taskData, I->size); unsigned height = GetRectH(taskData, I->size); unsigned depth = get_C_ulong(taskData, I->depth); unsigned format = get_C_ulong(taskData, I->format); int xoffset = get_C_short(taskData, I->xoffset); int bitmapPad = get_C_short(taskData, I->bitmapPad); int bytesPerLine = get_C_long (taskData, I->bytesPerLine); unsigned byteOrder = get_C_ulong(taskData, I->byteOrder); unsigned bitmapUnit = get_C_ulong(taskData, I->bitmapUnit); unsigned bitsPerPixel = get_C_ulong(taskData, I->bitsPerPixel); unsigned bitmapBitOrder = get_C_ulong(taskData, I->bitmapBitOrder); format = CImageFormat(format); byteOrder = CImageOrder(byteOrder); bitmapBitOrder = CImageOrder(bitmapBitOrder); image.width = width; image.height = height; image.xoffset = xoffset; image.format = format; image.data = data->chars; image.byte_order = byteOrder; image.bitmap_unit = bitmapUnit; image.bitmap_bit_order = bitmapBitOrder; image.bitmap_pad = bitmapPad; image.depth = depth; image.bytes_per_line = bytesPerLine; image.bits_per_pixel = bitsPerPixel; image.red_mask = get_C_ulong(taskData, I->visualRedMask); image.green_mask = get_C_ulong(taskData, I->visualGreenMask); image.blue_mask = get_C_ulong(taskData, I->visualBlueMask); if (ImageBytes(&image) != data->length) RaiseXWindows(taskData, "Bad image string length"); return ℑ } static Handle CreateImage(TaskData *taskData, XImage *image) { Handle XHandle = alloc_and_save(taskData, SIZEOF(MLXImage), F_MUTABLE_BIT); int dsize = ImageBytes(image); /* Still allocating, so must use explicit DEREF for each element */ #define X ((MLXImage *)DEREFHANDLE(XHandle)) X->data = C_string_to_Poly(taskData, image->data,dsize); X->size = DEREFWORD(CreateArea(image->width,image->height)); X->depth = DEREFWORD(Make_arbitrary_precision(taskData, image->depth)); X->format = DEREFWORD(Make_arbitrary_precision(taskData, MLImageFormat(image->format))); X->xoffset = DEREFWORD(Make_int(image->xoffset)); X->bitmapPad = DEREFWORD(Make_int(image->bitmap_pad)); X->byteOrder = DEREFWORD(Make_arbitrary_precision(taskData, MLImageOrder(image->byte_order))); X->bitmapUnit = DEREFWORD(Make_arbitrary_precision(taskData, image->bitmap_unit)); X->bitsPerPixel = DEREFWORD(Make_arbitrary_precision(taskData, image->bits_per_pixel)); X->bytesPerLine = DEREFWORD(Make_int(image->bytes_per_line)); X->visualRedMask = DEREFWORD(Make_arbitrary_precision(taskData, image->red_mask)); X->bitmapBitOrder = DEREFWORD(Make_arbitrary_precision(taskData, MLImageOrder(image->bitmap_bit_order))); X->visualBlueMask = DEREFWORD(Make_arbitrary_precision(taskData, image->blue_mask)); X->visualGreenMask = DEREFWORD(Make_arbitrary_precision(taskData, image->green_mask)); #undef X XDestroyImage(image); return FINISHED(taskData, XHandle); } static Handle GetImage ( TaskData *taskData, Display *d, Drawable drawable, int x, int y, unsigned w, unsigned h, unsigned /* long */ mask, int format ) { XImage *image = XGetImage(d,drawable,x,y,w,h,mask,CImageFormat(format)); if (image == 0) RaiseXWindows(taskData, "XGetImage failed"); return CreateImage(taskData, image); } static Handle SubImage ( TaskData *taskData, XImage *image, int x, int y, unsigned w, unsigned h ) { XImage *subimage = XSubImage(image,x,y,w,h); if (subimage == 0) RaiseXWindows(taskData, "XSubImage failed"); return CreateImage(taskData, subimage); } /******************************************************************************/ /* */ /* XImage */ /* */ /******************************************************************************/ static void GetSubImage ( Display *d, Drawable drawable, int sx, int sy, unsigned sw, unsigned sh, unsigned /* long */ mask, int format, XImage *image, int dx, int dy ) { XGetSubImage(d,drawable,sx,sy,sw,sh,mask,CImageFormat(format),image,dx,dy); /* XFree((char *)image); */ } static void PutImage ( Display *d, Drawable drawable, GC gc, XImage *image, int sx, int sy, int dx, int dy, unsigned dw, unsigned dh ) { XPutImage(d,drawable,gc,image,sx,sy,dx,dy,dw,dh); /* XFree((char *)image); */ } static Handle GetPixel(TaskData *taskData, XImage *image, int x, int y) { unsigned pixel = XGetPixel(image,x,y); /* XFree((char *)image); */ return Make_arbitrary_precision(taskData, pixel); } static void PutPixel(XImage *image, int x, int y, unsigned pixel) { XPutPixel(image,x,y,pixel); /* XFree((char *)image); */ } static void AddPixel(XImage *image, unsigned value) { XAddPixel(image,value); /* XFree((char *)image); */ } /******************************************************************************/ /* */ /* TimeVal */ /* */ /******************************************************************************/ static int DoubleClickTime = 250; /* Double click time in milliseconds */ static int MouseDrift = 5; /* Mouse movement allowed in button events */ static void NormaliseTime(TimeVal *t) { while(t->tv_usec >= 1000000) { t->tv_usec -= 1000000; t->tv_sec++; } while(t->tv_usec < 0) { t->tv_usec += 1000000; t->tv_sec--; } } static void TimeAdd(TimeVal *a, TimeVal *b, TimeVal *t) { t->tv_sec = a->tv_sec + b->tv_sec; t->tv_usec = a->tv_usec + b->tv_usec; NormaliseTime(t); } static int TimeLt(TimeVal *a, TimeVal *b) { return ((a->tv_sec < b->tv_sec) || ((a->tv_sec == b->tv_sec) && (a->tv_usec < b->tv_usec))); } static int TimeLeq(TimeVal *a, TimeVal *b) { return ((a->tv_sec < b->tv_sec) || ((a->tv_sec == b->tv_sec) && (a->tv_usec <= b->tv_usec))); } /******************************************************************************/ /* */ /* (?) */ /* */ /******************************************************************************/ typedef struct { XButtonEvent *button; /* initial button press event */ int up,down; /* count of button transitions */ } PredicateArgs; static Bool SameClickEvent(Display *dpy, XEvent *ev, XPointer arg) { PredicateArgs *A = (PredicateArgs *)arg; switch(ev->type) { case MotionNotify: { int dx = ev->xmotion.x - A->button->x; int dy = ev->xmotion.y - A->button->y; if (ev->xmotion.window != A->button->window) return False; if (abs(dx) > MouseDrift) return False; if (abs(dy) > MouseDrift) return False; return True; } case ButtonPress: case ButtonRelease: { int dx = ev->xbutton.x - A->button->x; int dy = ev->xbutton.y - A->button->y; if (ev->xbutton.window != A->button->window) return False; if (ev->xbutton.button != A->button->button) return False; if (abs(dx) > MouseDrift) return False; if (abs(dy) > MouseDrift) return False; if (ev->type == ButtonPress) A->down++; else A->up++; return True; } } return False; } static void WaitDoubleClickTime(Handle dsHandle, PredicateArgs *A) { XEvent N; TimeVal start_time,end_time,dt; Display *d = DEREFDISPLAYHANDLE(dsHandle)->display; /* AIX doesn't document support for NULL pointers in the select call, so we have to initialise empty fd_sets instead. SPF 30/10/95 */ fd_set read_fds, write_fds, except_fds; FD_ZERO(&read_fds); FD_ZERO(&write_fds); FD_ZERO(&except_fds); { int fd = d->fd; assert (0 <= fd && fd < FD_SETSIZE); FD_SET(fd,&read_fds); } gettimeofday(&start_time, NULL); dt.tv_sec = 0; dt.tv_usec = DoubleClickTime * 1000; TimeAdd(&start_time,&dt,&end_time); for (;;) { int extended = 0; while(XCheckIfEvent(d,&N,SameClickEvent,(char *) A)) { if (DEREFDISPLAYHANDLE(dsHandle)->app_context) XtDispatchEvent(&N); extended = 1; } if (QLength(d)) break; /* some other event to be processed next */ if (extended) /* button event extended, so extend time period */ { dt.tv_sec = 0; dt.tv_usec = DoubleClickTime * 1000; TimeAdd(&end_time,&dt,&end_time); } if (TimeLeq(&end_time,&start_time)) break; /* the time period has elapsed */ select(FD_SETSIZE,&read_fds,&write_fds,&except_fds,&dt); gettimeofday(&start_time, NULL); } } static Handle GetKeyVector(TaskData *taskData, void *k, unsigned i) { uchar *keys = (uchar*)k; unsigned index = i / 8; unsigned mask = 1 << (i % 8); return Make_bool(keys[index] & mask); } static Handle QueryKeymap(TaskData *taskData, Display *d) { char keys[32]; XQueryKeymap(d, keys); return CreateList4I(taskData, 256,keys,0,GetKeyVector); } /******************************************************************************/ /* */ /* EventName */ /* */ /******************************************************************************/ typedef struct { const char *name; int type; } EventName; static EventName EventNames[] = { { "KeyPress",KeyPress }, { "KeyRelease",KeyRelease }, { "ButtonPress",ButtonPress }, { "ButtonRelease",ButtonRelease }, { "MotionNotify",MotionNotify }, { "EnterNotify",EnterNotify }, { "LeaveNotify",LeaveNotify }, { "FocusIn",FocusIn }, { "FocusOut",FocusOut }, { "KeymapNotify",KeymapNotify }, { "Expose",Expose }, { "GraphicsExpose",GraphicsExpose }, { "NoExpose",NoExpose }, { "VisibilityNotify",VisibilityNotify }, { "CreateNotify",CreateNotify }, { "DestroyNotify",DestroyNotify }, { "UnmapNotify",UnmapNotify }, { "MapNotify",MapNotify }, { "MapRequest",MapRequest }, { "ReparentNotify",ReparentNotify }, { "ConfigureNotify",ConfigureNotify }, { "ConfigureRequest",ConfigureRequest }, { "GravityNotify",GravityNotify }, { "ResizeRequest",ResizeRequest }, { "CirculateNotify",CirculateNotify }, { "CirculateRequest",CirculateRequest }, { "PropertyNotify",PropertyNotify }, { "SelectionClear",SelectionClear }, { "SelectionRequest",SelectionRequest }, { "SelectionNotify",SelectionNotify }, { "ColormapNotify",ColormapNotify }, { "ClientMessage",ClientMessage }, { "MappingNotify",MappingNotify }, }; #define NEVENTS (sizeof(EventNames)/sizeof(EventName)) static const char *DebugEventName(int type) { for(unsigned i = 0; i < NEVENTS; i++) { if (EventNames[i].type == type) return EventNames[i].name; } return "** BAD EVENT **"; } static int WM_PROTOCOLS(Display *d) { static int protocols = None; if (protocols == None) protocols = XInternAtom(d,"WM_PROTOCOLS",True); return protocols; } static Atom WM_DELETE_WINDOW(Display *d) { static Atom deleteWindow = None; if (deleteWindow == None) deleteWindow = XInternAtom(d,"WM_DELETE_WINDOW",True); return deleteWindow; } /******************************************************************************/ /* */ /* Structures used by CreateEvent function. */ /* */ /* These typedefs should correspond with the tuples used by MakeXKeyEvent etc */ /* */ /******************************************************************************/ typedef struct { X_Window_Object *root; X_Window_Object *subwindow; PolyWord time; /* ML int */ MLXPoint *pointer; MLXPoint *rootPointer; PolyWord modifiers; /* ML modifier (int) */ PolyWord keycode; /* ML int */ } ML_KeyEvent_Data; typedef struct { X_Window_Object *root; X_Window_Object *subwindow; PolyWord time; /* ML int */ MLXPoint *pointer; MLXPoint *rootPointer; PolyWord modifiers; /* ML modifier (int) */ PolyWord button; /* ML int */ } ML_ButtonEvent_Data; typedef struct { X_Window_Object *root; X_Window_Object *subwindow; PolyWord time; /* ML int */ MLXPoint *pointer; MLXPoint *rootPointer; PolyWord modifiers; /* ML modifier (int) */ PolyWord button; /* ML int */ PolyWord up; /* ML int */ PolyWord down; /* ML int */ } ML_ButtonClick_Data; typedef struct { X_Window_Object *root; X_Window_Object *subwindow; PolyWord time; /* ML int */ MLXPoint *pointer; MLXPoint *rootPointer; PolyWord modifiers; /* ML modifier (int) */ PolyWord isHint; /* ML bool */ } ML_MotionEvent_Data; typedef struct { X_Window_Object *root; X_Window_Object *subwindow; PolyWord time; /* ML int */ MLXPoint *pointer; MLXPoint *rootPointer; PolyWord mode; /* ? */ PolyWord detail; /* ? */ PolyWord focus; /* ? */ PolyWord modifiers; /* ML modifier (int) */ } ML_CrossingEvent_Data; typedef struct { MLXRectangle *region; PolyWord count; /* ML int */ } ML_ExposeEvent_Data; typedef struct { X_Window_Object *window; MLXPoint *position; MLXRectangle *size; PolyWord borderWidth; /* ML int */ X_Window_Object *above; PolyWord overrideRedirect; /* ML bool */ } ML_ConfigureNotify_Data; typedef struct { X_Window_Object *window; MLXPoint *position; MLXRectangle *size; PolyWord borderWidth; X_Window_Object *above; PolyWord detail; /* ? */ } ML_ConfigureRequest_Data; typedef struct { MLXRectangle *region; PolyWord count; /* ML int */ PolyWord code; /* ML int */ } ML_GraphicsExposeEvent_Data; typedef struct { PolyWord mode; /* ML int ? */ PolyWord detail; /* ML int ? */ } ML_FocusChangeEvent_Data; typedef struct { X_Window_Object *window; MLXPoint *position; MLXRectangle *size; PolyWord borderWidth; /* ML int */ PolyWord overrideRedirect; /* ML bool */ } ML_CreateEvent_Data; typedef struct { X_Window_Object *window; PolyWord fromConfigure; /* ML bool */ } ML_UnmapEvent_Data; typedef struct { X_Window_Object *window; PolyWord overrideRedirect; /* ML bool */ } ML_MapEvent_Data; typedef struct { X_Window_Object *window; X_Window_Object *parent; MLXPoint *position; PolyWord overrideRedirect; /* ML bool */ } ML_ReparentEvent_Data; typedef struct { X_Window_Object *window; MLXPoint *position; } ML_GravityEvent_Data; typedef struct { X_Window_Object *window; PolyWord place; } ML_CirculateEvent_Data; typedef struct { X_Colormap_Object *colormap_object; PolyWord c_new; /* ML bool */ PolyWord installed; /* ML bool */ } ML_ColormapEvent_Data; typedef struct { PolyWord selection; /* ML int */ PolyWord time; /* ML int */ } ML_SelectionClear_Data; typedef struct { X_Window_Object *requestor; PolyWord selection; /* ML int */ PolyWord target; /* ML int */ PolyWord property; /* ML int */ PolyWord time; /* ML int */ } ML_SelectionRequest_Data; typedef struct { PolyWord selection; /* ML int */ PolyWord target; /* ML int */ PolyWord property; /* ML int */ PolyWord time; /* ML int */ } ML_Selection_Data; class ML_Event: public PolyObject { public: PolyWord type; /* ML (?) */ PolyWord sendEvent; /* ML bool */ PolyWord window; /* X_Window_Object* */ PolyWord data; /* pointer to event-specific data, in ML_XXX_Data format */ PolyWord callbacks; /* ML list of something */ PolyWord events; /* ML list */ }; /******************************************************************************/ /* */ /* CreateEvent function */ /* */ /******************************************************************************/ static Handle CreateEvent ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ XEvent *ev, Handle W /* Handle to (X_Window_Object *) */ ) { Handle eventHandle = alloc_and_save(taskData, SIZEOF(ML_Event), F_MUTABLE_BIT); Display *d = DEREFDISPLAYHANDLE(dsHandle)->display; int type = ev->xany.type; int send_event = ev->xany.send_event; assert(d == ev->xany.display); if (debugOptions & DEBUG_X) { printf("CreateEvent called, type=%s,", DebugEventName(type)); printf(" window=%lx\n", ev->xany.window); } #define event ((ML_Event *)DEREFHANDLE(eventHandle)) event->type = DEREFWORD(Make_arbitrary_precision(taskData, type)); event->sendEvent = DEREFWORD(Make_bool(send_event)); event->window = DEREFWINDOWHANDLE(W); switch(type) { case KeyPress: case KeyRelease: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_KeyEvent_Data), F_MUTABLE_BIT); #define data ((ML_KeyEvent_Data *)DEREFHANDLE(dataHandle)) data->root = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xkey.root)); data->subwindow = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xkey.subwindow)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xkey.time)); data->pointer = (MLXPoint *)DEREFHANDLE(CreatePoint(taskData, ev->xkey.x,ev->xkey.y)); data->rootPointer = (MLXPoint *)DEREFHANDLE(CreatePoint(taskData, ev->xkey.x_root,ev->xkey.y_root)); data->modifiers = DEREFWORD(Make_arbitrary_precision(taskData, ev->xkey.state)); data->keycode = DEREFWORD(Make_arbitrary_precision(taskData, ev->xkey.keycode)); #undef data event->data = DEREFHANDLE(FINISHED(taskData, dataHandle)); break; } case ButtonPress: case ButtonRelease: { if (DEREFWINDOWHANDLE(W)->eventMask->Get(0).AsUnsigned() & ButtonClickMask) { Handle dataHandle; PredicateArgs A; A.button = &ev->xbutton; A.up = (ev->type == ButtonRelease); A.down = (ev->type == ButtonPress); WaitDoubleClickTime(dsHandle,&A); dataHandle = alloc_and_save(taskData, SIZEOF(ML_ButtonClick_Data), F_MUTABLE_BIT); #define data ((ML_ButtonClick_Data *)DEREFHANDLE(dataHandle)) data->root = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xbutton.root)); data->subwindow = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xbutton.subwindow)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.time)); data->pointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xbutton.x,ev->xbutton.y)); data->rootPointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xbutton.x_root,ev->xbutton.y_root)); data->modifiers = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.state)); data->button = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.button)); data->up = DEREFWORD(Make_arbitrary_precision(taskData, A.up)); data->down = DEREFWORD(Make_arbitrary_precision(taskData, A.down)); #undef data event->type = DEREFWORD(Make_arbitrary_precision(taskData, 42)); /* What's this for? */ event->data = DEREFWORD(FINISHED(taskData, dataHandle)); } else { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_ButtonEvent_Data), F_MUTABLE_BIT); #define data ((ML_ButtonEvent_Data *)DEREFHANDLE(dataHandle)) data->root = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xbutton.root)); data->subwindow = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xbutton.subwindow)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.time)); data->pointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xbutton.x,ev->xbutton.y)); data->rootPointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xbutton.x_root,ev->xbutton.y_root)); data->modifiers = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.state)); data->button = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.button)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); } break; } case MotionNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_MotionEvent_Data), F_MUTABLE_BIT); #define data ((ML_MotionEvent_Data *)DEREFHANDLE(dataHandle)) data->root = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xmotion.root)); data->subwindow = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xmotion.subwindow)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xmotion.time)); data->pointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xmotion.x,ev->xmotion.y)); data->rootPointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xmotion.x_root,ev->xmotion.y_root)); data->modifiers = DEREFWORD(Make_arbitrary_precision(taskData, ev->xmotion.state)); data->isHint = DEREFWORD(Make_arbitrary_precision(taskData, ev->xmotion.is_hint)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case EnterNotify: case LeaveNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_CrossingEvent_Data), F_MUTABLE_BIT); #define data ((ML_CrossingEvent_Data *)DEREFHANDLE(dataHandle)) data->root = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xcrossing.root)); data->subwindow = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xcrossing.subwindow)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xcrossing.time)); data->pointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xcrossing.x,ev->xcrossing.y)); data->rootPointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xcrossing.x_root,ev->xcrossing.y_root)); data->mode = DEREFWORD(Make_arbitrary_precision(taskData, ev->xcrossing.mode)); data->detail = DEREFWORD(Make_arbitrary_precision(taskData, ev->xcrossing.detail)); data->focus = DEREFWORD(Make_bool(ev->xcrossing.focus)); data->modifiers = DEREFWORD(Make_arbitrary_precision(taskData, ev->xcrossing.state)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case Expose: { int left = ev->xexpose.x; int top = ev->xexpose.y; int right = left + ev->xexpose.width; int bottom = top + ev->xexpose.height; Handle dataHandle; while(XCheckTypedWindowEvent(d,ev->xexpose.window,Expose,ev)) { int L = ev->xexpose.x; int T = ev->xexpose.y; int R = L + ev->xexpose.width; int B = T + ev->xexpose.height; assert(ev->type == Expose); left = min(left,L); top = min(top,T); right = max(right,R); bottom = max(bottom,B); } dataHandle = alloc_and_save(taskData, SIZEOF(ML_ExposeEvent_Data), F_MUTABLE_BIT); #define data ((ML_ExposeEvent_Data *)DEREFHANDLE(dataHandle)) data->region = (MLXRectangle *)DEREFHANDLE(CreateRect(taskData, top,left,bottom,right)); data->count = DEREFWORD(Make_arbitrary_precision(taskData, 0)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case GraphicsExpose: { int left = ev->xgraphicsexpose.x; int top = ev->xgraphicsexpose.y; int right = left + ev->xgraphicsexpose.width; int bottom = top + ev->xgraphicsexpose.height; Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_GraphicsExposeEvent_Data), F_MUTABLE_BIT); #define data ((ML_GraphicsExposeEvent_Data *)DEREFHANDLE(dataHandle)) data->region = (MLXRectangle *)DEREFHANDLE(CreateRect(taskData, top,left,bottom,right)); data->count = DEREFWORD(Make_arbitrary_precision(taskData, ev->xgraphicsexpose.count)); data->code = DEREFWORD(Make_arbitrary_precision(taskData, ev->xgraphicsexpose.major_code)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case NoExpose: { event->data = DEREFWORD(Make_arbitrary_precision(taskData, ev->xnoexpose.major_code)); break; } case ConfigureNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_ConfigureNotify_Data), F_MUTABLE_BIT); #define data ((ML_ConfigureNotify_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xconfigure.window)); data->position = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xconfigure.x,ev->xconfigure.y)); data->size = (MLXRectangle *) DEREFHANDLE(CreateArea(ev->xconfigure.width,ev->xconfigure.height)); data->borderWidth = DEREFWORD(Make_int(ev->xconfigure.border_width)); data->above = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xconfigure.above)); data->overrideRedirect = DEREFWORD(Make_bool(ev->xconfigure.override_redirect)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case FocusIn: case FocusOut: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_FocusChangeEvent_Data), F_MUTABLE_BIT); #define data ((ML_FocusChangeEvent_Data *)DEREFHANDLE(dataHandle)) data->mode = DEREFWORD(Make_int(ev->xfocus.mode)); data->detail = DEREFWORD(Make_int(ev->xfocus.detail)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case VisibilityNotify: { event->data = DEREFWORD(Make_int(ev->xvisibility.state)); break; } case CreateNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_CreateEvent_Data), F_MUTABLE_BIT); #define data ((ML_CreateEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xcreatewindow.window)); data->position = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xcreatewindow.x,ev->xcreatewindow.y)); data->size = (MLXRectangle *) DEREFHANDLE(CreateArea(ev->xcreatewindow.width,ev->xcreatewindow.height)); data->borderWidth = DEREFWORD(Make_int(ev->xcreatewindow.border_width)); data->overrideRedirect = DEREFWORD(Make_bool(ev->xcreatewindow.override_redirect)); #undef data event->data = DEREFHANDLE(FINISHED(taskData, dataHandle)); break; } case DestroyNotify: { debugReclaim(Window,ev->xdestroywindow.window); event->data = DEREFWORD(EmptyWindow(taskData, dsHandle,ev->xdestroywindow.window)); break; } case UnmapNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_UnmapEvent_Data), F_MUTABLE_BIT); #define data ((ML_UnmapEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xunmap.window)); data->fromConfigure = DEREFWORD(Make_bool(ev->xunmap.from_configure)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case MapNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_MapEvent_Data), F_MUTABLE_BIT); #define data ((ML_MapEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xmap.window)); data->overrideRedirect = DEREFWORD(Make_bool(ev->xmap.override_redirect)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case MapRequest: { event->data = DEREFWORD(EmptyWindow(taskData, dsHandle,ev->xmaprequest.window)); break; } case ReparentNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_ReparentEvent_Data), F_MUTABLE_BIT); #define data ((ML_ReparentEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xreparent.window)); data->parent = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xreparent.parent)); data->position = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xreparent.x,ev->xreparent.y)); data->overrideRedirect = DEREFWORD(Make_bool(ev->xreparent.override_redirect)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case ConfigureRequest: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_ConfigureRequest_Data), F_MUTABLE_BIT); #define data ((ML_ConfigureRequest_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xconfigurerequest.window)); data->position = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xconfigurerequest.x,ev->xconfigurerequest.y)); data->size = (MLXRectangle *) DEREFHANDLE(CreateArea(ev->xconfigurerequest.width,ev->xconfigurerequest.height)); data->borderWidth = DEREFWORD(Make_int(ev->xconfigurerequest.border_width)); data->above = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xconfigurerequest.above)); data->detail = DEREFWORD(Make_int(ev->xconfigurerequest.detail)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case GravityNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_GravityEvent_Data), F_MUTABLE_BIT); #define data ((ML_GravityEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xgravity.window)); data->position = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xgravity.x,ev->xgravity.y)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case ResizeRequest: { event->data = DEREFWORD(CreateArea(ev->xresizerequest.width,ev->xresizerequest.height)); break; } case CirculateNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_CirculateEvent_Data), F_MUTABLE_BIT); #define data ((ML_CirculateEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xcirculate.window)); data->place = DEREFWORD(Make_int(ev->xcirculate.place)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case CirculateRequest: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_CirculateEvent_Data), F_MUTABLE_BIT); #define data ((ML_CirculateEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xcirculaterequest.window)); data->place = DEREFWORD(Make_int(ev->xcirculaterequest.place)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case ColormapNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_ColormapEvent_Data), F_MUTABLE_BIT); #define data ((ML_ColormapEvent_Data *)DEREFHANDLE(dataHandle)) data->colormap_object = (X_Colormap_Object *)DEREFHANDLE(EmptyColormap(taskData, dsHandle,ev->xcolormap.colormap)); data->c_new = DEREFWORD(Make_bool(ev->xcolormap.c_new)); data->installed = DEREFWORD(Make_bool(ev->xcolormap.state == ColormapInstalled)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case MappingNotify: { XRefreshKeyboardMapping((XMappingEvent *)ev); /* cast added SPF 6/1/94 */ return 0; /* HACK !!!! */ } case SelectionClear: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_SelectionClear_Data), F_MUTABLE_BIT); #define data ((ML_SelectionClear_Data *)DEREFHANDLE(dataHandle)) data->selection = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionclear.selection)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionclear.time)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case SelectionNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_Selection_Data), F_MUTABLE_BIT); #define data ((ML_Selection_Data *)DEREFHANDLE(dataHandle)) data->selection = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselection.selection)); data->target = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselection.target)); data->property = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselection.property)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselection.time)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case SelectionRequest: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_SelectionRequest_Data), F_MUTABLE_BIT); #define data ((ML_SelectionRequest_Data *)DEREFHANDLE(dataHandle)) data->requestor = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xselectionrequest.requestor)); data->selection = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionrequest.selection)); data->target = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionrequest.target)); data->property = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionrequest.property)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionrequest.time)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case ClientMessage: { unsigned protocols = WM_PROTOCOLS(d); int deleteWindow = WM_DELETE_WINDOW(d); if (protocols != None && deleteWindow != None && ev->xclient.message_type == protocols && ev->xclient.format == 32 && ev->xclient.data.l[0] == deleteWindow) { event->type = DEREFWORD(Make_arbitrary_precision(taskData, 43)); /* (?) */ break; } else return 0; } case PropertyNotify: return 0; case KeymapNotify: return 0; /* Broken: the window field does not tell me the window requesting this event */ default: Crash ("Bad event type %x",ev->type); } event->callbacks = FList; /* Safe, since FList is a Root */ FList = TAGGED(0); event->events = GList; /* Safe, since GList is a Root */ GList = TAGGED(0); return FINISHED(taskData, eventHandle); #undef event } /******************************************************************************/ /* */ /* HERE */ /* */ /******************************************************************************/ static Handle LookupString(TaskData *taskData, Display *d, unsigned keycode, unsigned modifiers) { XKeyEvent ev; int n; KeySym keysym; /* was int SPF 6/1/94 */ char buffer[500]; ev.display = d; ev.keycode = keycode; ev.state = modifiers; n = XLookupString(&ev,buffer,sizeof(buffer)-1,&keysym,NULL); buffer[n] = '\0'; return CreatePair(taskData, Make_string(buffer),Make_arbitrary_precision(taskData, keysym)); } static Handle GetScreenSaver(TaskData *taskData, Display *d) { int timeout,interval,blanking,exposures; Handle tuple; XGetScreenSaver(d,&timeout,&interval,&blanking,&exposures); tuple = alloc_and_save(taskData, 4, F_MUTABLE_BIT); #define data DEREFHANDLE(tuple) data->Set(0, DEREFWORD(Make_int(timeout))); data->Set(1, DEREFWORD(Make_int(interval))); data->Set(2, DEREFWORD(Make_arbitrary_precision(taskData, blanking))); data->Set(3, DEREFWORD(Make_arbitrary_precision(taskData, exposures))); #undef data return FINISHED(taskData, tuple); } static Handle TranslateCoordinates ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window src, Window dst, int x, int y ) { Window child; int dx,dy,s; s = XTranslateCoordinates(DEREFDISPLAYHANDLE(dsHandle)->display,src,dst,x,y,&dx,&dy,&child); if (s == 0) RaiseXWindows(taskData, "XTranslateCoordinates failed"); return CreatePair(taskData, CreatePoint(taskData, dx,dy),EmptyWindow(taskData, dsHandle,child)); } static Handle QueryBest ( TaskData *taskData, int (*f)(Display*, Drawable, unsigned, unsigned, unsigned *, unsigned *), Display *d, Drawable drawable, unsigned width, unsigned height ) { unsigned W,H; int s = (* f)(d,drawable,width,height,&W,&H); if (s == 0) RaiseXWindows(taskData, "XQueryBest failed"); return CreateArea(W,H); } static Handle QueryPointer ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w ) { Window root,child; int rootX,rootY; int winX,winY; unsigned mask; int s; Handle tuple; s = XQueryPointer(DEREFDISPLAYHANDLE(dsHandle)->display,w,&root,&child,&rootX,&rootY,&winX,&winY,&mask); tuple = alloc_and_save(taskData, 6, F_MUTABLE_BIT); #define data DEREFHANDLE(tuple) data->Set(0, DEREFWORD(Make_arbitrary_precision(taskData, s))); data->Set(1, DEREFWORD(EmptyWindow(taskData, dsHandle,root))); data->Set(2, DEREFWORD(EmptyWindow(taskData, dsHandle,child))); data->Set(3, DEREFWORD(CreatePoint(taskData, rootX,rootY))); data->Set(4, DEREFWORD(CreatePoint(taskData, winX,winY))); data->Set(5, DEREFWORD(Make_arbitrary_precision(taskData, mask))); #undef data return FINISHED(taskData, tuple); } static Handle ReadBitmap ( TaskData *taskData, Handle dsHandle, /* handle to (X_Display_Object *) */ Drawable w, PolyStringObject *string ) { unsigned width,height; char name[500]; int s,xhot,yhot; Pixmap pixmap; Handle tuple; Poly_string_to_C(string,name,sizeof(name)); s = XReadBitmapFile(DEREFDISPLAYHANDLE(dsHandle)->display,w,name,&width,&height,&pixmap,&xhot,&yhot); tuple = alloc_and_save(taskData, 4, F_MUTABLE_BIT); #define data DEREFHANDLE(tuple) data->Set(0,DEREFWORD(Make_arbitrary_precision(taskData, s))); if (s == BitmapSuccess) { data->Set(1, DEREFWORD(EmptyPixmap(taskData, dsHandle,pixmap))); data->Set(2, DEREFWORD(CreateArea(width,height))); data->Set(3, DEREFWORD(CreatePoint(taskData, xhot,yhot))); } /******************** What if we don't succeed? Badly-formed tuple !!!! */ #undef data return FINISHED(taskData, tuple); } static Handle WriteBitmapFile ( TaskData *taskData, PolyStringObject *string, Display *d, Pixmap bitmap, unsigned w, unsigned h, int x, int y ) { char name[500]; int s; Poly_string_to_C(string,name,sizeof(name)); s = XWriteBitmapFile(d,name,bitmap,w,h,x,y); return Make_arbitrary_precision(taskData, s); } static Handle GetDefault(TaskData *taskData, Display *d, PolyStringObject *s1, PolyStringObject *s2) { char program[500]; char option[500]; char *s; Poly_string_to_C(s1,program,sizeof(program)); Poly_string_to_C(s2,option ,sizeof(option)); s = XGetDefault(d,program,option); if (s == NULL) RaiseXWindows(taskData, "XGetDefault failed"); return Make_string(s); } static void GetWindows(TaskData *taskData, PolyWord p, void *w, unsigned) { *(Window *)w = GetWindow(taskData, (X_Object *)p.AsObjPtr()); } static void GetSegments(TaskData *taskData, PolyWord pp, void *w, unsigned) { XSegment *A = (XSegment *)w; PolyObject *p = pp.AsObjPtr(); A->x1 = GetPointX(taskData, p->Get(0)); A->y1 = GetPointY(taskData, p->Get(0)); A->x2 = GetPointX(taskData, p->Get(1)); A->y2 = GetPointY(taskData, p->Get(1)); } static void GetChar2(TaskData *taskData, PolyWord p, void *v, unsigned) { XChar2b *A = (XChar2b *)v; unsigned short u = get_C_ushort(taskData, p); A->byte1 = u >> 8; A->byte2 = u &0xFF; } static void CopyString(TaskData *, PolyWord w, void *v, unsigned) { char **p = (char**)v; PolyStringObject *s = GetString(w); POLYUNSIGNED n = s->length+1; *p = (char*)malloc(n); Poly_string_to_C(s,*p,n); } static void GetText(TaskData *taskData, PolyWord p, void *w, unsigned) { XTextItem *A = (XTextItem *)w; PolyObject *obj = p.AsObjPtr(); CopyString(taskData, obj->Get(0), &A->chars, 0); A->nchars = strlen(A->chars); A->delta = get_C_short(taskData, obj->Get(1)); A->font = GetFont(taskData, (X_Object *)obj->Get(2).AsObjPtr()); } static void GetText16(TaskData *taskData, PolyWord p, void *v, unsigned) { XTextItem16 *A = (XTextItem16 *)v; PolyObject *obj = p.AsObjPtr(); unsigned N = ListLength(obj->Get(0)); XChar2b *L = (XChar2b *) malloc(N * sizeof(XChar2b)); GetList4(taskData,obj->Get(0),L,sizeof(XChar2b),GetChar2); A->chars = L; A->nchars = N; A->delta = get_C_short(taskData, obj->Get(1)); A->font = GetFont(taskData, (X_Object *)obj->Get(2).AsObjPtr()); } typedef void (*GetFunc)(TaskData *taskData, PolyWord, void*, unsigned); static void SetClipRectangles ( TaskData *taskData, Display *d, GC gc, int x, int y, Handle list, unsigned order ) { if (ISNIL(DEREFWORD(list))) { XSetClipRectangles(d,gc,x,y,NULL,0,order); } else { unsigned N = ListLength(DEREFWORD(list)); XRectangle *L = (XRectangle *) alloca(N * sizeof(XRectangle)); GetList4(taskData, DEREFWORD(list),L,sizeof(XRectangle),GetRects); XSetClipRectangles(d,gc,x,y,L,N,order); } } static void GetUChars(TaskData *taskData, PolyWord p, void *u, unsigned) { *(uchar*)u = get_C_uchar(taskData, p); } static void SetDashes ( TaskData *taskData, Display *d, GC gc, unsigned offset, Handle list ) { if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); char *D = (char *) alloca(N); GetList4(taskData,DEREFWORD(list),D,sizeof(uchar),GetUChars); XSetDashes(d,gc,offset,D,N); } } static Handle CreateDrawable ( TaskData *taskData, void *p, Handle dsHandle /* Handle to (X_Display_Object *) */ ) { return EmptyWindow(taskData, dsHandle,*(Window*)p); } static Handle QueryTree ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w ) { Window root,parent,*children; unsigned n; Handle data; int s = XQueryTree(DEREFDISPLAYHANDLE(dsHandle)->display,w,&root,&parent,&children,&n); if (s == 0) RaiseXWindows(taskData, "XQueryTree failed"); data = CreateTriple(taskData, EmptyWindow(taskData, dsHandle,root), EmptyWindow(taskData, dsHandle,parent), CreateList5(taskData, n,children,sizeof(Window),CreateDrawable,dsHandle)); if (n) XFree((char *)children); return data; } static void RestackWindows(TaskData *taskData, Handle list /* handle to list of X_Window_Objects (?) */) { if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); Window *W = (Window *) alloca(N * sizeof(Window)); Display *d = GetDisplay(taskData, (X_Object *)DEREFLISTHANDLE(list)->h.AsObjPtr()); GetList4(taskData, DEREFWORD(list),W,sizeof(Window),GetWindows); XRestackWindows(d,W,N); } } static Handle GetGeometry ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Drawable w ) { int x,y; unsigned width,height,borderWidth,depth; Window root; Handle dataHandle; int s = XGetGeometry(DEREFDISPLAYHANDLE(dsHandle)->display,w,&root,&x,&y,&width,&height,&borderWidth,&depth); if (s == 0) RaiseXWindows(taskData, "XGetGeometry failed"); dataHandle = alloc_and_save(taskData, 5, F_MUTABLE_BIT); #define data DEREFHANDLE(dataHandle) data->Set(0, DEREFWORD(EmptyWindow(taskData, dsHandle,root))); data->Set(1, DEREFWORD(CreatePoint(taskData, x,y))); data->Set(2, DEREFWORD(CreateArea(width,height))); data->Set(3, DEREFWORD(Make_arbitrary_precision(taskData, borderWidth))); data->Set(4, DEREFWORD(Make_arbitrary_precision(taskData, depth))); #undef data return FINISHED(taskData, dataHandle); } static Handle GetWindowAttributes ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Drawable w ) { XWindowAttributes wa; Handle dataHandle; int s = XGetWindowAttributes(DEREFDISPLAYHANDLE(dsHandle)->display,w,&wa); if (s == 0) RaiseXWindows(taskData, "XGetWindowAttributes failed"); dataHandle = alloc_and_save(taskData, 20, F_MUTABLE_BIT); /* HACKY - should define struct? */ DEREFHANDLE(dataHandle)->Set( 0, DEREFWORD(CreatePoint(taskData, wa.x,wa.y))); DEREFHANDLE(dataHandle)->Set( 1, DEREFWORD(CreateArea(wa.width,wa.height))); DEREFHANDLE(dataHandle)->Set( 2, DEREFWORD(Make_int(wa.border_width))); DEREFHANDLE(dataHandle)->Set( 3, DEREFWORD(Make_arbitrary_precision(taskData, wa.depth))); DEREFHANDLE(dataHandle)->Set( 4, DEREFWORD(EmptyVisual(taskData, dsHandle,wa.visual))); DEREFHANDLE(dataHandle)->Set( 5, DEREFWORD(EmptyWindow(taskData, dsHandle,wa.root))); DEREFHANDLE(dataHandle)->Set( 6, DEREFWORD(Make_arbitrary_precision(taskData, wa.c_class))); DEREFHANDLE(dataHandle)->Set( 7, DEREFWORD(Make_arbitrary_precision(taskData, wa.bit_gravity))); DEREFHANDLE(dataHandle)->Set( 8, DEREFWORD(Make_arbitrary_precision(taskData, wa.win_gravity))); DEREFHANDLE(dataHandle)->Set( 9, DEREFWORD(Make_arbitrary_precision(taskData, wa.backing_store))); DEREFHANDLE(dataHandle)->Set(10, DEREFWORD(Make_arbitrary_precision(taskData, wa.backing_planes))); DEREFHANDLE(dataHandle)->Set(11, DEREFWORD(Make_arbitrary_precision(taskData, wa.backing_pixel))); DEREFHANDLE(dataHandle)->Set(12, DEREFWORD(Make_bool(wa.save_under))); DEREFHANDLE(dataHandle)->Set(13, DEREFWORD(EmptyColormap(taskData, dsHandle,wa.colormap))); DEREFHANDLE(dataHandle)->Set(14, DEREFWORD(Make_bool(wa.map_installed))); DEREFHANDLE(dataHandle)->Set(15, DEREFWORD(Make_arbitrary_precision(taskData, wa.map_state))); DEREFHANDLE(dataHandle)->Set(16, DEREFWORD(Make_arbitrary_precision(taskData, wa.all_event_masks))); DEREFHANDLE(dataHandle)->Set(17, DEREFWORD(Make_arbitrary_precision(taskData, wa.your_event_mask))); DEREFHANDLE(dataHandle)->Set(18, DEREFWORD(Make_arbitrary_precision(taskData, wa.do_not_propagate_mask))); DEREFHANDLE(dataHandle)->Set(19, DEREFWORD(Make_bool(wa.override_redirect))); return FINISHED(taskData, dataHandle); } static void ChangeWindowAttributes ( TaskData *taskData, X_Window_Object *W, unsigned n, PolyWord P ) { XSetWindowAttributes a; unsigned mask = 1 << n; switch(mask) { case CWBitGravity: a.bit_gravity = get_C_ulong(taskData, P); break; case CWWinGravity: a.win_gravity = get_C_ulong(taskData, P); break; case CWBackingStore: a.backing_store = get_C_ulong(taskData, P); break; case CWBackingPlanes: a.backing_planes = get_C_ulong(taskData, P); break; case CWBackingPixel: a.backing_pixel = get_C_ulong(taskData, P); break; case CWOverrideRedirect: a.override_redirect = get_C_ulong(taskData, P); break; case CWSaveUnder: a.save_under = get_C_ulong(taskData, P); break; case CWEventMask: a.event_mask = get_C_ulong(taskData, P); break; case CWDontPropagate: a.do_not_propagate_mask = get_C_ulong(taskData, P); break; case CWBackPixel: a.background_pixel = get_C_ulong(taskData, P); W->backgroundPixmap = 0; break; case CWBackPixmap: a.background_pixmap = GetPixmap(taskData, (X_Object *)P.AsObjPtr()); W->backgroundPixmap = PixmapObject((X_Object *)P.AsObjPtr()); break; case CWBorderPixel: a.border_pixel = get_C_ulong(taskData, P); W->borderPixmap = 0; break; case CWBorderPixmap: a.border_pixmap = GetPixmap(taskData, (X_Object *)P.AsObjPtr()); W->borderPixmap = PixmapObject((X_Object *)P.AsObjPtr()); break; case CWColormap: a.colormap = GetColormap(taskData, (X_Object *)P.AsObjPtr()); W->colormap_object = ColormapObject((X_Object *)P.AsObjPtr()); break; case CWCursor: a.cursor = GetCursor(taskData, (X_Object *)P.AsObjPtr()); W->cursor_object = CursorObject((X_Object *)P.AsObjPtr()); break; default: Crash ("Bad window mask %u",mask); } XChangeWindowAttributes(GetDisplay(taskData, (X_Object *)W),GetWindow(taskData, (X_Object *)W),mask,&a); } static void ConfigureWindow ( TaskData *taskData, Display *d, Window w, PolyWord tup /* (P,S,w,d,s,flags) */ ) { PolyObject *tuple = tup.AsObjPtr(); XWindowChanges wc; unsigned mask = get_C_ulong(taskData, tuple->Get(5)); CheckZeroRect(taskData, tuple->Get(1)); wc.x = GetPointX (taskData,tuple->Get(0)); wc.y = GetPointY (taskData,tuple->Get(0)); wc.width = GetRectW (taskData,tuple->Get(1)); wc.height = GetRectH (taskData,tuple->Get(1)); wc.border_width = get_C_ulong(taskData, tuple->Get(2)); wc.sibling = GetWindow (taskData,(X_Object *)tuple->Get(3).AsObjPtr()); wc.stack_mode = get_C_ulong(taskData, tuple->Get(4)); XConfigureWindow(d,w,mask,&wc); } /* The order of these depends on the XColor datatype */ typedef struct { PolyWord red; /* ML bool */ PolyWord blue; /* ML bool */ PolyWord doRed; /* ML bool */ PolyWord green; /* ML int */ PolyWord pixel; /* ML int */ PolyWord doBlue; /* ML int */ PolyWord doGreen; /* ML int */ } MLXColor; /* in Poly heap */ static void ClearXColor(XColor *x) { x->red = x->green = x->blue = x->pixel = x->flags = 0; } static Handle CreateXColor(TaskData *taskData, XColor *x) { Handle XHandle = alloc_and_save(taskData, SIZEOF(MLXColor), F_MUTABLE_BIT); #define X ((MLXColor *)DEREFHANDLE(XHandle)) X->red = DEREFWORD(Make_arbitrary_precision(taskData, x->red)); X->green = DEREFWORD(Make_arbitrary_precision(taskData, x->green)); X->blue = DEREFWORD(Make_arbitrary_precision(taskData, x->blue)); X->pixel = DEREFWORD(Make_arbitrary_precision(taskData, x->pixel)); X->doRed = DEREFWORD(Make_bool(x->flags &DoRed)); X->doGreen = DEREFWORD(Make_bool(x->flags &DoGreen)); X->doBlue = DEREFWORD(Make_bool(x->flags &DoBlue)); #undef X return FINISHED(taskData, XHandle); } static Handle CreateXColorF(TaskData *taskData, void *p) { return CreateXColor(taskData, (XColor*)p); } static XColor xcolor1 = { 0 }; static XColor xcolor2 = { 0 }; static void GetXColor(TaskData *taskData, PolyWord p, void *v, unsigned) { MLXColor *P = (MLXColor *)p.AsObjPtr(); XColor *x = (XColor *)v; x->red = get_C_ushort(taskData, P->red); x->green = get_C_ushort(taskData, P->green); x->blue = get_C_ushort(taskData, P->blue); x->pixel = get_C_ulong (taskData, P->pixel); x->flags = (DoRed * get_C_ulong(taskData, P->doRed)) | (DoGreen * get_C_ulong(taskData, P->doGreen)) | (DoBlue * get_C_ulong(taskData, P->doBlue)); } static XColor *GetXColor1(TaskData *taskData, PolyWord P) { GetXColor(taskData, P, &xcolor1, 0); return &xcolor1; } static XColor *GetXColor2(TaskData *taskData, PolyWord P) { GetXColor(taskData, P, &xcolor2, 0); return &xcolor2; } static Handle AllocColor(TaskData *taskData, Display *d, Colormap cmap, XColor *x) { int s = XAllocColor(d,cmap,x); if (s == 0) RaiseXWindows(taskData, "XAllocColor failed"); return CreateXColor(taskData, x); } static Handle CreateUnsigned(TaskData *taskData, void *q) { unsigned *p = (unsigned *)q; return Make_arbitrary_precision(taskData, *p); } static Handle CreateUnsignedLong(TaskData *taskData, void *p) { return Make_arbitrary_precision(taskData, *(unsigned long*)p); } static Handle AllocColorCells ( TaskData *taskData, Display *d, Colormap cmap, unsigned contig, unsigned nplanes, unsigned ncolors ) { unsigned long *masks; /* was unsigned SPF 6/1/94 */ unsigned long *pixels; /* was unsigned SPF 6/1/94 */ int s; if (ncolors < 1) RaiseRange(taskData); masks = (unsigned long *) alloca(nplanes * sizeof(unsigned long)); pixels = (unsigned long *) alloca(ncolors * sizeof(unsigned long)); s = XAllocColorCells(d,cmap,contig,masks,nplanes,pixels,ncolors); if (s == 0) RaiseXWindows (taskData, "XAllocColorCells failed"); return CreatePair(taskData, CreateList4(taskData,nplanes,masks ,sizeof(unsigned long),CreateUnsignedLong), CreateList4(taskData,ncolors,pixels,sizeof(unsigned long),CreateUnsignedLong)); } static Handle AllocColorPlanes ( TaskData *taskData, Display *d, Colormap cmap, unsigned contig, unsigned ncolors, unsigned nreds, unsigned ngreens, unsigned nblues ) { unsigned long rmask; /* was unsigned SPF 6/1/94 */ unsigned long gmask; /* was unsigned SPF 6/1/94 */ unsigned long bmask; /* was unsigned SPF 6/1/94 */ unsigned long *pixels; /* was unsigned SPF 6/1/94 */ Handle tuple; int s; if (ncolors < 1) RaiseRange(taskData); pixels = (unsigned long *) alloca(ncolors * sizeof(unsigned long)); s = XAllocColorPlanes(d,cmap,contig,pixels,ncolors,nreds,ngreens,nblues,&rmask,&gmask,&bmask); if (s == 0) RaiseXWindows (taskData, "XAllocColorPlanes failed"); tuple = alloc_and_save(taskData, 4, F_MUTABLE_BIT); #define data DEREFHANDLE(tuple) data->Set(0, DEREFWORD(CreateList4(taskData,ncolors,pixels,sizeof(unsigned long),CreateUnsignedLong))); data->Set(1, DEREFWORD(Make_arbitrary_precision(taskData, rmask))); data->Set(2, DEREFWORD(Make_arbitrary_precision(taskData, gmask))); data->Set(3, DEREFWORD(Make_arbitrary_precision(taskData, bmask))); #undef data return FINISHED(taskData, tuple); } static Handle AllocNamedColor(TaskData *taskData, Display *d, Colormap cmap, PolyStringObject *string) { char name[500]; int s; XColor hardware; XColor database; ClearXColor(&hardware); ClearXColor(&database); Poly_string_to_C(string,name,sizeof(name)); s = XAllocNamedColor(d,cmap,name,&hardware,&database); if (s == 0) RaiseXWindows (taskData, "XAllocNamedColor failed"); return CreatePair(taskData, CreateXColor(taskData, &hardware),CreateXColor(taskData, &database)); } static Handle LookupColor(TaskData *taskData, Display *d, Colormap cmap, PolyStringObject *string) { char name[500]; int s; XColor hardware; XColor database; ClearXColor(&hardware); ClearXColor(&database); Poly_string_to_C(string,name,sizeof(name)); s = XLookupColor(d,cmap,name,&database,&hardware); if (s == 0) RaiseXWindows (taskData, "XLookupColor failed"); return CreatePair(taskData, CreateXColor(taskData, &database),CreateXColor(taskData, &hardware)); } static Handle ParseColor(TaskData *taskData, Display *d, Colormap cmap, PolyStringObject *string) { char name[500]; int s; XColor x; ClearXColor(&x); Poly_string_to_C(string,name,sizeof(name)); s = XParseColor(d,cmap,name,&x); if (s == 0) RaiseXWindows(taskData, "XParseColor failed"); return CreateXColor(taskData, &x); } static Handle QueryColor(TaskData *taskData, Display *d, Colormap cmap, unsigned pixel) { XColor x; ClearXColor(&x); x.pixel = pixel; XQueryColor(d,cmap,&x); return CreateXColor(taskData, &x); } static void GetXPixel(TaskData *taskData, PolyWord p, void *v, unsigned) { XColor *X = (XColor *)v; ClearXColor(X); X->pixel = get_C_ulong(taskData, p); } static Handle QueryColors(TaskData *taskData, Display *d, Colormap cmap, Handle list) { unsigned N = ListLength(DEREFWORD(list)); XColor *P = (XColor *) alloca(N * sizeof(XColor)); GetList4(taskData, DEREFWORD(list),P,sizeof(XColor),GetXPixel); XQueryColors(d,cmap,P,N); return CreateList4(taskData,N,P,sizeof(XColor),CreateXColorF); } static void StoreNamedColor ( Display *d, Colormap cmap, PolyStringObject *string, unsigned pixel, unsigned doRed, unsigned doGreen, unsigned doBlue ) { unsigned flags = (DoRed * doRed) | (DoGreen * doGreen) | (DoBlue * doBlue); char name[500]; Poly_string_to_C(string,name,sizeof(name)); XStoreNamedColor(d,cmap,name,pixel,flags); } static void StoreColors(TaskData *taskData, Display *d, Colormap cmap, Handle list) { unsigned N = ListLength(DEREFWORD(list)); XColor *P = (XColor *) alloca(N * sizeof(XColor)); GetList4(taskData, DEREFWORD(list),P,sizeof(XColor),GetXColor); XStoreColors(d,cmap,P,N); } static void GetUnsigned(TaskData *taskData, PolyWord p, void *v, unsigned) { unsigned *u = (unsigned *)v; *u = get_C_ulong(taskData, p); } static void GetUnsignedLong(TaskData *taskData, PolyWord p, void *v, unsigned) { unsigned long *u = (unsigned long *)v; *u = get_C_ulong(taskData, p); } static void FreeColors ( TaskData *taskData, Display *d, Colormap cmap, Handle list, unsigned planes ) { unsigned N = ListLength(DEREFWORD(list)); unsigned long *P = (unsigned long *) alloca(N * sizeof(unsigned long)); GetList4(taskData,DEREFWORD(list),P,sizeof(unsigned long),GetUnsignedLong); XFreeColors(d,cmap,P,N,planes); } static Handle CreateColormap ( TaskData *taskData, void *p, Handle dsHandle /* handle to (X_Display_Object *) */ ) { return EmptyColormap(taskData, dsHandle,*(Colormap *)p); } static Handle ListInstalledColormaps ( TaskData *taskData, Handle dsHandle, /* handle to (X_Display_Object *) */ Drawable drawable ) { int count; Colormap *cmaps; Handle list; cmaps = XListInstalledColormaps(DEREFDISPLAYHANDLE(dsHandle)->display,drawable,&count); if (cmaps == 0) RaiseXWindows(taskData, "XListInstalledColormaps failed"); list = CreateList5(taskData,count,cmaps,sizeof(Colormap),CreateColormap,dsHandle); XFree((char *)cmaps); return list; } static Handle GetTimeOfDay(TaskData *taskData) { TimeVal now; gettimeofday(&now, NULL); return CreatePair(taskData, Make_arbitrary_precision(taskData, now.tv_sec),Make_arbitrary_precision(taskData, now.tv_usec)); } static Handle GetState(TaskData *taskData, X_Window_Object *P) { assert(UNTAGGED(P->type) == X_Window); CheckExists((X_Object *)P,window); if (ISNIL(P->handler)) Crash ("No handler set"); return CreatePair(taskData, SAVE(P->handler),SAVE(P->state)); } static void SetState(X_Window_Object *W, PolyWord handler, PolyWord state) { if (! ResourceExists((X_Object *)W)) return; assert(W->type == TAGGED(X_Window)); if (NONNIL(handler)) { /* we are setting the handler and initial state */ /* so we need to remove all pending messages for */ /* this window since they will have the wrong type */ PurgePendingWindowMessages(W); W->handler = handler; W->state = state; } else W->state = state; /* just update state */ } /* Check if the first timer event has already expired. */ static void CheckTimerQueue(void) { if (TList) { TimeVal now; gettimeofday(&now, NULL); TList->expired = TimeLeq(&TList->timeout,&now); } } static void InsertTimeout ( TaskData *taskData, X_Window_Object *window_object, unsigned ms, PolyWord alpha, PolyWord handler ) { T_List **tail; T_List *newp; TimeVal now; assert(window_object->type == TAGGED(X_Window)); CheckExists((X_Object *)window_object,window); if (ISNIL(window_object->handler)) Crash ("No handler set"); if (window_object->handler != handler) RaiseXWindows(taskData, "Handler mismatch"); { /* find insertion point in list */ TimeVal dt; gettimeofday(&now, NULL); dt.tv_sec = ms / 1000; dt.tv_usec = 1000 * (ms % 1000); newp = (T_List *) malloc(sizeof(T_List)); TimeAdd(&now,&dt,&newp->timeout); /* We use TimeLt here, not TimeLeq, because we want to add new messages AFTER existing ones. SPF 21/3/97 */ for(tail = &TList; *tail; tail = &(*tail)->next) { if (TimeLt(&newp->timeout,&(*tail)->timeout)) break; } } newp->next = *tail; newp->window_object = window_object; newp->widget_object = (X_Widget_Object *)0; newp->alpha = alpha.AsObjPtr(); newp->handler = handler.AsObjPtr(); newp->expired = 0; *tail = newp; } /* called when a widget is destroyed by Xt/Motif */ static void DestroyWidgetCallback ( Widget widget, XtPointer client_data, XtPointer call_data ) { /* find the ML widget (if any) associated with the C widget */ X_Widget_Object *widget_object = FindWidget(widget); if (widget_object != NULL) { /* Destroy the ML widget representations */ DestroyXObject((X_Object *)widget_object); /* Assume we can't get a C callback from a destroyed widget */ PurgeCCallbacks(widget_object,widget); } debugReclaim(Widget,widget); } #if 0 #define CheckRealized(Widget,Where)\ { \ if (XtIsRealized(Widget) == False) \ RaiseXWindows(taskData, #Where ": widget is not realized"); \ } static Window WindowOfWidget(TaskData *taskData, Widget widget) { CheckRealized(widget,WindowOfWidget); return XtWindowOfObject(widget); } #endif /* Now returns NULL (None) for unrealized widgets SPF 1/2/94 */ static Window WindowOfWidget(Widget widget) { return XtIsRealized(widget) ? XtWindowOfObject(widget) : None; } static void InsertWidgetTimeout ( TaskData *taskData, X_Widget_Object *widget_object, unsigned ms, PolyWord alpha, PolyWord handler ) { T_List **tail; T_List *newp; TimeVal now; assert(widget_object->type == TAGGED(X_Widget)); CheckExists((X_Object *)widget_object,widget); #if NEVER CheckRealized(GetWidget(taskData, (X_Object *)widget_object),InsertWidgetTimeout); #endif /* check that handler occurs in widget's callback list */ { PolyWord p = widget_object->callbackList; for(; NONNIL(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { MLPair *q = (MLPair *)((ML_Cons_Cell*)p.AsObjPtr())->h.AsObjPtr(); if (SND(q) == handler) break; } if (ISNIL(p)) RaiseXWindows(taskData, "Handler mismatch"); } { TimeVal dt; gettimeofday(&now, NULL); dt.tv_sec = ms / 1000; dt.tv_usec = 1000 * (ms % 1000); newp = (T_List *) malloc(sizeof(T_List)); TimeAdd(&now,&dt,&newp->timeout); /* We use TimeNegative here, not TimeExpired, because we want to add new messages AFTER existing ones. SPF 21/3/97 */ for(tail = &TList; *tail; tail = &(*tail)->next) { if (TimeLt(&newp->timeout,&(*tail)->timeout)) break; } } newp->next = *tail; newp->window_object = (X_Window_Object *)0; newp->widget_object = widget_object; newp->alpha = alpha.AsObjPtr(); newp->handler = handler.AsObjPtr(); newp->expired = 0; *tail = newp; } // Test whether input is available and block if it is not. // N.B. There may be a GC while in here. // This was previously in basicio.cpp but has been moved here // since this is the only place it's used now. static void process_may_block(TaskData *taskData, int fd) { #ifdef __CYGWIN__ static struct timeval poll = {0,1}; #else static struct timeval poll = {0,0}; #endif fd_set read_fds; int selRes; while (1) { FD_ZERO(&read_fds); FD_SET(fd,&read_fds); /* If there is something there we can return. */ selRes = select(FD_SETSIZE, &read_fds, NULL, NULL, &poll); if (selRes > 0) return; /* Something waiting. */ else if (selRes < 0 && errno != EINTR) // Maybe another thread closed descr raise_syscall(taskData, "select failed", errno); WaitInputFD waiter(fd); processes->ThreadPauseForIO(taskData, &waiter); } } static Handle NextEvent(TaskData *taskData, Handle dsHandle /* handle to (X_Display_Object *) */) { for (;;) { /* Added here SPF 23/2/95 - check whether a timer event has expired */ CheckTimerQueue(); if (TList && TList->expired) { T_List *next = TList->next; EventHandle E = alloc_and_save(taskData, SIZEOF(ML_Event), F_MUTABLE_BIT); #define event ((ML_Event *)DEREFHANDLE(E)) event->type = DEREFWORD(Make_arbitrary_precision(taskData, 99)); event->sendEvent = DEREFWORD(Make_bool(True)); event->data = TList->alpha; if (TList->window_object != 0) { assert(TList->widget_object == 0); event->window = TList->window_object; event->callbacks = ListNull; event->events = ListNull; assert(TList->window_object->handler == TList->handler); } else /* it is a Widget message */ { /* TList->widget_object etc. act like Roots */ assert(TList->widget_object != 0); { Window w = WindowOfWidget(GetWidget(taskData, (X_Object *)TList->widget_object)); event->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, GetDS(taskData, (X_Object *)TList->widget_object),w)); } { /* create callback list - allocates storage */ Handle tailHandle = SAVE(ListNull); Handle widgetHandle = SAVE(TList->widget_object); Handle handlerHandle = SAVE(TList->handler); Handle pairHandle = CreatePair(taskData, widgetHandle,handlerHandle); event->callbacks = DEREFLISTHANDLE(CreatePair(taskData, pairHandle,tailHandle)); event->events = ListNull; } } #undef event free(TList); TList = next; return FINISHED(taskData, E); } else /* ! (TList && TList->expired) */ if (DEREFDISPLAYHANDLE(dsHandle)->app_context == 0) /* use XNextEvent to get next event */ { Display *display = DEREFDISPLAYHANDLE(dsHandle)->display; int pending = XPending(display); if (pending == 0) { process_may_block(taskData, display->fd); } else /* X Event arrived */ { XEvent ev; X_Window_Object *W; XNextEvent(display,&ev); W = FindWindow(dsHandle,ev.xany.window); if (W && NONNIL(W->handler)) { EventHandle E = CreateEvent(taskData, dsHandle,&ev,SAVE(W)); if (E) return E; } } } else /* use XtAppNextEvent to get next event */ { /* should use Xt to do time events as well */ int pending = XtAppPending(DEREFDISPLAYHANDLE(dsHandle)->app_context); if (pending == 0) { process_may_block(taskData, DEREFDISPLAYHANDLE(dsHandle)->display->fd); } else { if ((pending & XtIMXEvent) == 0) /* not an X Event, probably an Xt timer event */ { assert(FList == TAGGED(0)); callbacks_enabled = True; XtAppProcessEvent(DEREFDISPLAYHANDLE(dsHandle)->app_context,pending); callbacks_enabled = False; if (FList != TAGGED(0)) { EventHandle E = alloc_and_save(taskData, SIZEOF(ML_Event), F_MUTABLE_BIT); #define event ((ML_Event *)DEREFHANDLE(E)) event->type = DEREFWORD(Make_arbitrary_precision(taskData, 100)); event->sendEvent = DEREFWORD(Make_bool(True)); event->window = TAGGED(0); event->data = TAGGED(0); event->callbacks = FList; /* FList != 0 */ event->events = GList; #undef event FList = TAGGED(0); GList = TAGGED(0); return FINISHED(taskData, E); } } else /* Xt Event arrived */ { XEvent ev; int dispatched; assert(FList == TAGGED(0)); XtAppNextEvent(DEREFDISPLAYHANDLE(dsHandle)->app_context,&ev); callbacks_enabled = True; dispatched = XtDispatchEvent(&ev); callbacks_enabled = False; if (!dispatched) { X_Window_Object *W = FindWindow(dsHandle,ev.xany.window); assert(FList == TAGGED(0) && GList == TAGGED(0)); if (W && NONNIL(W->handler)) { EventHandle E = CreateEvent(taskData, dsHandle,&ev,SAVE(W)); if (E) return E; } } else if (! FList.IsTagged() || ! GList.IsTagged()) { EventHandle E = CreateEvent(taskData, dsHandle,&ev,EmptyWindow(taskData, dsHandle,ev.xany.window)); if (E) return E; } } } } } } static Handle GetInputFocus(TaskData *taskData, Handle dsHandle /* handle to (X_Display_Object *) */) { Window focus; int revertTo; XGetInputFocus(DEREFDISPLAYHANDLE(dsHandle)->display,&focus,&revertTo); return CreatePair(taskData, EmptyWindow(taskData, dsHandle,focus),Make_arbitrary_precision(taskData, revertTo)); } static void SetSelectionOwner ( Handle dsHandle, /* handle to (X_Display_Object *) */ unsigned selection, Window owner, unsigned time ) { Window old = XGetSelectionOwner(DEREFDISPLAYHANDLE(dsHandle)->display,selection); if (old != owner) { /* SelectionClear is only sent by the server when the ownership of a */ /* selection passes from one client to another. We want every ML */ /* window to behave like a separate client, so when the ownership of */ /* a selection passes from one ML window to another we have to send */ /* the SelectionClear ourselves. */ X_Window_Object *W = FindWindow(dsHandle,old); if (W && NONNIL(W->handler)) /* this clients window */ { XEvent event; /* was XSelectionClearEvent SPF 6/1/94 */ event.xselectionclear.type = SelectionClear; event.xselectionclear.serial = 0; event.xselectionclear.send_event = True; event.xselectionclear.display = DEREFDISPLAYHANDLE(dsHandle)->display; event.xselectionclear.window = old; event.xselectionclear.selection = selection; event.xselectionclear.time = time; XSendEvent(DEREFDISPLAYHANDLE(dsHandle)->display,old,True,0,&event); } } XSetSelectionOwner(DEREFDISPLAYHANDLE(dsHandle)->display,selection,owner,time); } static void SendSelectionNotify ( Display *d, unsigned selection, unsigned target, unsigned property, Window requestor, unsigned time ) { XEvent event; /* was XSelectionEvent SPF 6/1/94 */ event.xselection.type = SelectionNotify; event.xselection.serial = 0; event.xselection.send_event = True; event.xselection.display = d; event.xselection.requestor = requestor; event.xselection.selection = selection; event.xselection.target = target; event.xselection.property = property; event.xselection.time = time; XSendEvent(d,requestor,True,0,&event); } static Handle InternAtom ( TaskData *taskData, Display *d, PolyStringObject *string, Bool only_if_exists ) { char name[500]; Poly_string_to_C(string,name,sizeof(name)); return Make_arbitrary_precision(taskData, XInternAtom(d,name,only_if_exists)); } static Handle GetAtomName(TaskData *taskData, Display *d, unsigned atom) { Handle s; char *name = XGetAtomName(d,atom); if (name == NULL) RaiseXWindows(taskData, "XGetAtomName failed"); s = Make_string(name); XFree((char *)name); return s; } /* The order of these depends on the XCharStruct datatype */ typedef struct { PolyWord width; /* ML int */ PolyWord ascent; /* ML int */ PolyWord descent; /* ML int */ PolyWord lbearing; /* ML int */ PolyWord rbearing; /* ML int */ PolyWord attributes; /* ML int */ } MLXCharStruct; static Handle CreateCharStruct(TaskData *taskData, void *v) { XCharStruct *cs = (XCharStruct *)v; Handle dataHandle = alloc_and_save(taskData, SIZEOF(MLXCharStruct), F_MUTABLE_BIT); #define data ((MLXCharStruct *)DEREFHANDLE(dataHandle)) data->width = DEREFWORD(Make_int(cs->width)); data->ascent = DEREFWORD(Make_int(cs->ascent)); data->descent = DEREFWORD(Make_int(cs->descent)); data->lbearing = DEREFWORD(Make_int(cs->lbearing)); data->rbearing = DEREFWORD(Make_int(cs->rbearing)); data->attributes = DEREFWORD(Make_arbitrary_precision(taskData, cs->attributes)); #undef data return FINISHED(taskData, dataHandle); } /* The order of these depends on the XFontStruct datatype */ typedef struct { X_Font_Object *font_object; PolyWord ascent; /* ML int */ PolyWord descent; /* ML int */ PolyWord maxChar; /* ML int */ PolyWord minChar; /* ML int */ PolyWord perChar; /* ML XCharStruct list */ PolyWord maxByte1; /* ML int */ PolyWord minByte1; /* ML int */ PolyWord direction; /* (short ML int) FontLeftToRight | FontRightToLeft */ MLXCharStruct *maxBounds; MLXCharStruct *minBounds; PolyWord defaultChar; /* ML int */ PolyWord allCharsExist; /* ML bool */ } MLXFontStruct; static Handle CreateFontStruct ( TaskData *taskData, void *v, Handle dsHandle /* Handle to (X_Display_Object *) */ ) { XFontStruct *fs = (XFontStruct *)v; Handle dataHandle = alloc_and_save(taskData, SIZEOF(MLXFontStruct), F_MUTABLE_BIT); int n = fs->max_char_or_byte2 - fs->min_char_or_byte2 + 1; if (fs->per_char == 0) n = 0; #define data ((MLXFontStruct *)DEREFHANDLE(dataHandle)) data->font_object = (X_Font_Object *)DEREFHANDLE(EmptyFont(taskData, dsHandle,fs->fid,fs)); data->ascent = DEREFWORD(Make_int(fs->ascent)); data->descent = DEREFWORD(Make_int(fs->descent)); data->maxChar = DEREFWORD(Make_arbitrary_precision(taskData, fs->max_char_or_byte2)); data->minChar = DEREFWORD(Make_arbitrary_precision(taskData, fs->min_char_or_byte2)); data->perChar = DEREFHANDLE(CreateList4(taskData,n,fs->per_char,sizeof(XCharStruct),CreateCharStruct)); data->maxByte1 = DEREFWORD(Make_arbitrary_precision(taskData, fs->max_byte1)); data->minByte1 = DEREFWORD(Make_arbitrary_precision(taskData, fs->min_byte1)); data->direction = DEREFWORD(Make_arbitrary_precision(taskData, (fs->direction == FontLeftToRight) ? 1 : 2)); data->maxBounds = (MLXCharStruct *)DEREFHANDLE(CreateCharStruct(taskData, &fs->max_bounds)); data->minBounds = (MLXCharStruct *)DEREFHANDLE(CreateCharStruct(taskData, &fs->min_bounds)); data->defaultChar = DEREFWORD(Make_arbitrary_precision(taskData, fs->default_char)); data->allCharsExist = DEREFWORD(Make_bool(fs->all_chars_exist)); #undef data return FINISHED(taskData, dataHandle); } static XFontStruct *GetFS(TaskData *taskData, X_Font_Object *P) { assert(UNTAGGED(P->type) == X_Font); if (*(P->fs) == NULL) RaiseXWindows(taskData, "Not a real XFontStruct"); CheckExists((X_Object *)P,font); return *(P->fs); } static XFontStruct *GetFontStruct(TaskData *taskData,PolyWord p) { MLXFontStruct *P = (MLXFontStruct *)p.AsObjPtr(); return GetFS(taskData,P->font_object); } static Handle CreateString(TaskData *taskData, void *s) { return Make_string(*(char **)s); } static Handle GetFontPath(TaskData *taskData, Display *d) { Handle list; char **names; int count; names = XGetFontPath(d,&count); if (names == 0) RaiseXWindows(taskData, "XGetFontPath failed"); list = CreateList4(taskData,count,names,sizeof(char *),CreateString); XFreeFontNames(names); return list; } static void FreeStrings(char **s, int n) { while(n--) free(*s++); return; } static void SetFontPath(TaskData *taskData, Display *d, Handle list) { if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); char **D = (char **) alloca(N * sizeof(char *)); GetList4(taskData, DEREFWORD(list),D,sizeof(char *),CopyString); XSetFontPath(d,D,N); FreeStrings(D,N); } return; } static Handle ListFonts(TaskData *taskData,Display *d, PolyStringObject *string, unsigned maxnames) { char name[500]; Handle list; char **names; int count; Poly_string_to_C(string,name,sizeof(name)); names = XListFonts(d,name,maxnames,&count); if (names == 0) RaiseXWindows(taskData, "XListFonts failed"); list = CreateList4(taskData,count,names,sizeof(char *),CreateString); XFreeFontNames(names); return list; } static Handle ListFontsWithInfo ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ PolyStringObject *string, unsigned maxnames ) { char name[500]; char **names; int count; XFontStruct *info; Handle pair; Poly_string_to_C(string,name,sizeof(name)); names = XListFontsWithInfo(DEREFDISPLAYHANDLE(dsHandle)->display,name,maxnames,&count,&info); if (names == 0) RaiseXWindows(taskData, "XListFontsWithInfo failed"); pair = CreatePair(taskData, CreateList4(taskData,count,names,sizeof(char *),CreateString), CreateList5(taskData,count,info,sizeof(XFontStruct),CreateFontStruct,dsHandle)); XFree((char *)info); XFreeFontNames(names); return pair; } static Handle LoadFont ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ PolyStringObject *string ) { char name[500]; Font font; Poly_string_to_C(string,name,sizeof(name)); font = XLoadFont(DEREFDISPLAYHANDLE(dsHandle)->display,name); if (font == 0) RaiseXWindows(taskData, "XLoadFont failed"); return EmptyFont(taskData, dsHandle,font,(XFontStruct *)NULL); } static Handle LoadQueryFont ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ PolyStringObject *string ) { char name[500]; XFontStruct *fs; Poly_string_to_C(string,name,sizeof(name)); fs = XLoadQueryFont(DEREFDISPLAYHANDLE(dsHandle)->display,name); if (fs == 0) RaiseXWindows(taskData, "XLoadQueryFont failed"); return CreateFontStruct(taskData,fs,dsHandle); } static Handle QueryFont ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Font font ) { XFontStruct *fs; fs = XQueryFont(DEREFDISPLAYHANDLE(dsHandle)->display,font); if (fs == 0) RaiseXWindows(taskData, "XQueryFont failed"); return CreateFontStruct(taskData,fs,dsHandle); } static Handle TextExtents(TaskData *taskData, XFontStruct *fs, PolyStringObject *s) { Handle dataHandle = alloc_and_save(taskData, 4, F_MUTABLE_BIT); int direction,ascent,descent; XCharStruct overall; XTextExtents(fs,s->chars,s->length,&direction,&ascent,&descent,&overall); #define data DEREFHANDLE(dataHandle) data->Set(0, DEREFWORD(Make_arbitrary_precision(taskData, (direction == FontLeftToRight) ? 1 : 2))); data->Set(1, DEREFWORD(Make_int(ascent))); data->Set(2, DEREFWORD(Make_int(descent))); data->Set(3, DEREFWORD(CreateCharStruct(taskData, &overall))); #undef data return FINISHED(taskData, dataHandle); } static Handle TextExtents16(TaskData *taskData, XFontStruct *fs, Handle list) { Handle dataHandle = alloc_and_save(taskData, 4, F_MUTABLE_BIT); int direction,ascent,descent; XCharStruct overall; unsigned N = ListLength(DEREFWORD(list)); XChar2b *L = (XChar2b *) alloca(N * sizeof(XChar2b)); GetList4(taskData,DEREFWORD(list),L,sizeof(XChar2b),GetChar2); XTextExtents16(fs,L,N,&direction,&ascent,&descent,&overall); #define data DEREFHANDLE(dataHandle) data->Set(0, DEREFWORD(Make_arbitrary_precision(taskData, (direction == FontLeftToRight) ? 1 : 2))); data->Set(1, DEREFWORD(Make_int(ascent))); data->Set(2, DEREFWORD(Make_int(descent))); data->Set(3, DEREFWORD(CreateCharStruct(taskData, &overall))); #undef data return FINISHED(taskData, dataHandle); } static Handle TextWidth(TaskData *taskData, XFontStruct *fs, PolyStringObject *s) { if (fs->per_char == 0) return Make_int(s->length * fs->max_bounds.width); return Make_int(XTextWidth(fs,s->chars,s->length)); } static Handle TextWidth16(TaskData *taskData, XFontStruct *fs, Handle list) { unsigned N = ListLength(DEREFWORD(list)); XChar2b *L = (XChar2b *) alloca(N * sizeof(XChar2b)); GetList4(taskData, DEREFWORD(list),L,sizeof(XChar2b),GetChar2); return Make_int(XTextWidth16(fs,L,N)); } static Handle GetTextProperty(TaskData *taskData, Display *d, Window w, unsigned property) { XTextProperty T; Handle tuple; int s = XGetTextProperty(d,w,&T,property); if (s == 0) RaiseXWindows(taskData, "XGetTextProperty failed"); tuple = alloc_and_save(taskData, 4, F_MUTABLE_BIT); #define data DEREFHANDLE(tuple) data->Set(0, C_string_to_Poly(taskData, (char *)T.value,T.nitems * T.format / 8)); data->Set(1, DEREFWORD(Make_arbitrary_precision(taskData, T.encoding))); data->Set(2, DEREFWORD(Make_int(T.format))); data->Set(3, DEREFWORD(Make_arbitrary_precision(taskData, T.nitems))); #undef data return FINISHED(taskData, tuple); } static void GetXWMHints(TaskData *taskData, PolyWord p, void *v, unsigned) { PolyObject *P = p.AsObjPtr(); XWMHints *H = (XWMHints *)v; H->input = get_C_ulong(taskData, P->Get(0)); H->initial_state = get_C_ulong(taskData, P->Get(1)); H->icon_pixmap = GetPixmap(taskData, (X_Object *)P->Get(2).AsObjPtr()); H->icon_window = GetWindow(taskData, (X_Object *)P->Get(3).AsObjPtr()); H->icon_x = GetPointX(taskData, P->Get(4)); H->icon_y = GetPointY(taskData, P->Get(4)); H->icon_mask = GetPixmap(taskData, (X_Object *)P->Get(5).AsObjPtr()); H->flags = get_C_ulong(taskData, P->Get(6)); H->window_group = 0; } typedef struct { PolyWord x0; PolyWord x1; PolyWord x2; PolyWord x3; PolyWord x4; PolyWord x5; /* pair of points */ PolyWord x6; PolyWord x7; PolyWord x8; } MLXWMSizeHintsTuple; static void GetXWMSizeHints(TaskData *taskData, PolyWord p, void *v, unsigned) { MLXWMSizeHintsTuple *P = (MLXWMSizeHintsTuple *)p.AsObjPtr(); XSizeHints *H = (XSizeHints *)v; CheckZeroRect(taskData, P->x1); CheckZeroRect(taskData, P->x2); CheckZeroRect(taskData, P->x3); CheckZeroRect(taskData, P->x4); CheckZeroRect(taskData, P->x6); H->x = GetPointX(taskData, P->x0); H->y = GetPointY(taskData, P->x0); H->width = GetRectW(taskData, P->x1); H->height = GetRectH(taskData, P->x1); H->min_width = GetRectW(taskData, P->x2); H->min_height = GetRectH(taskData, P->x2); H->max_width = GetRectW(taskData, P->x3); H->max_height = GetRectH(taskData, P->x3); H->width_inc = GetRectW(taskData, P->x4); H->height_inc = GetRectH(taskData, P->x4); H->min_aspect.x = GetPointX(taskData, FST(P->x5)); H->min_aspect.y = GetPointY(taskData, FST(P->x5)); H->max_aspect.x = GetPointX(taskData, SND(P->x5)); H->max_aspect.y = GetPointY(taskData, SND(P->x5)); H->base_width = GetRectW(taskData, P->x6); H->base_height = GetRectH(taskData, P->x6); H->win_gravity = get_C_ulong(taskData, P -> x7); H->flags = get_C_ulong(taskData, P -> x8); } static void GetIconSize(TaskData *taskData, PolyWord p, void *v, unsigned) { MLTriple *P = (MLTriple *)p.AsObjPtr(); XIconSize *s = (XIconSize *)v; CheckZeroRect(taskData, FST(P)); CheckZeroRect(taskData, SND(P)); CheckZeroRect(taskData, THIRD(P)); s->min_width = GetRectW(taskData, FST(P)); s->min_height = GetRectH(taskData, FST(P)); s->max_width = GetRectW(taskData, SND(P)); s->max_height = GetRectH(taskData, SND(P)); s->width_inc = GetRectW(taskData, THIRD(P)); s->height_inc = GetRectH(taskData, THIRD(P)); } static void GetSigned(TaskData *taskData, PolyWord p, void *i, unsigned) { *(int*)i = get_C_long(taskData, p); } static void GetPixmaps(TaskData *taskData, PolyWord pp, void *m, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(Pixmap *)m = GetPixmap(taskData, p); } static void GetColormaps(TaskData *taskData, PolyWord pp, void *v, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(Colormap *)v = GetColormap(taskData, p); } static void GetCursors(TaskData *taskData, PolyWord pp, void *c, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(Cursor *)c = GetCursor(taskData, p); } static void GetDrawables(TaskData *taskData, PolyWord pp, void *d, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(Drawable *)d = GetDrawable(taskData, p); } static void GetFonts(TaskData *taskData, PolyWord pp, void *f, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(Font *)f = GetFont(taskData, p); } static void GetVisualIds(TaskData *taskData, PolyWord pp, void *u, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(unsigned *)u = GetVisual(taskData, p)->visualid; } static void SetProperty ( TaskData *taskData, Display *d, Window w, unsigned property, unsigned target, Handle list, unsigned encoding ) { unsigned format; unsigned bytes; uchar *value; /* SPF 7/7/94 - XA_STRING pulled out as special case; this enables */ /* gcc to understand the previously data-dependant control flow. */ if (encoding == XA_STRING) { PolyStringObject *s = GetString (DEREFHANDLE(list)); format = 8; bytes = s->length; value = (uchar *) s->chars; } else { unsigned length = ListLength(DEREFWORD(list)); unsigned size; GetFunc get; switch(encoding) { case XA_ATOM: size = sizeof(unsigned); get = GetUnsigned; format = 32; break; case XA_BITMAP: size = sizeof(Pixmap); get = GetPixmaps; format = 32; break; case XA_COLORMAP: size = sizeof(Colormap); get = GetColormaps; format = 32; break; case XA_CURSOR: size = sizeof(Cursor); get = GetCursors; format = 32; break; case XA_DRAWABLE: size = sizeof(Drawable); get = GetDrawables; format = 32; break; case XA_FONT: size = sizeof(Font); get = GetFonts; format = 32; break; case XA_PIXMAP: size = sizeof(Pixmap); get = GetPixmaps; format = 32; break; case XA_VISUALID: size = sizeof(unsigned); get = GetVisualIds; format = 32; break; case XA_CARDINAL: size = sizeof(unsigned); get = GetUnsigned; format = 32; break; case XA_INTEGER: size = sizeof(int); get = GetSigned; format = 32; break; case XA_WINDOW: size = sizeof(Window); get = GetWindows; format = 32; break; case XA_ARC: size = sizeof(XArc); get = GetArcs; format = 16; break; case XA_POINT: size = sizeof(XPoint); get = GetPoints; format = 16; break; case XA_RECTANGLE: size = sizeof(XRectangle); get = GetRects; format = 16; break; case XA_RGB_COLOR_MAP: size = sizeof(XStandardColormap); get = GetStandardColormap; format = 32; break; case XA_WM_HINTS: size = sizeof(XWMHints); get = GetXWMHints; format = 32; break; case XA_WM_SIZE_HINTS: size = sizeof(XSizeHints); get = GetXWMSizeHints; format = 32; break; case XA_WM_ICON_SIZE: size = sizeof(XIconSize); get = GetIconSize; format = 32; break; default: Crash ("Bad property type %x",encoding); /*NOTREACHED*/ } bytes = length * size; value = (uchar *) alloca(bytes); GetList4(taskData, DEREFWORD(list),value,(int)size,get); } { XTextProperty T; T.value = value; T.encoding = target; T.format = format; T.nitems = (bytes * 8) / format; XSetTextProperty(d,w,&T,property); } } static Handle GetWMHints ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w ) { Handle tuple = alloc_and_save(taskData, 7, F_MUTABLE_BIT); XWMHints *H = XGetWMHints(DEREFDISPLAYHANDLE(dsHandle)->display,w); if (H) { #define data DEREFHANDLE(tuple) data->Set(0, DEREFWORD(Make_arbitrary_precision(taskData, H->input))); data->Set(1, DEREFWORD(Make_arbitrary_precision(taskData, H->initial_state))); data->Set(2, DEREFWORD(EmptyPixmap(taskData, dsHandle,H->icon_pixmap))); data->Set(3, DEREFWORD(EmptyWindow(taskData, dsHandle,H->icon_window))); data->Set(4, DEREFWORD(CreatePoint(taskData, H->icon_x,H->icon_y))); data->Set(5, DEREFWORD(EmptyPixmap(taskData, dsHandle,H->icon_mask))); data->Set(6, DEREFWORD(Make_arbitrary_precision(taskData, H->flags))); #undef data XFree((char *)H); } /* else what (?) */ return FINISHED(taskData, tuple); } static Handle GetWMSizeHints ( TaskData *taskData, Display *d, Window w, unsigned property ) { XSizeHints H; long supplied; /* was unsigned SPF 6/1/94 */ Handle tuple = alloc_and_save(taskData, 9, F_MUTABLE_BIT); int s = XGetWMSizeHints(d,w,&H,&supplied,property); if (s) { Handle p1 = CreatePoint(taskData, H.min_aspect.x,H.min_aspect.y); Handle p2 = CreatePoint(taskData, H.max_aspect.x,H.max_aspect.y); #define data DEREFHANDLE(tuple) data->Set(0, DEREFWORD(CreatePoint(taskData, H.x,H.y))); data->Set(1, DEREFWORD(CreateArea(H.width,H.height))); data->Set(2, DEREFWORD(CreateArea(H.min_width,H.min_height))); data->Set(3, DEREFWORD(CreateArea(H.max_width,H.max_height))); data->Set(4, DEREFWORD(CreateArea(H.width_inc,H.height_inc))); data->Set(5, DEREFWORD(CreatePair(taskData, p1,p2))); data->Set(6, DEREFWORD(CreateArea(H.base_width,H.base_height))); data->Set(7, DEREFWORD(Make_arbitrary_precision(taskData, H.win_gravity))); data->Set(8, DEREFWORD(Make_arbitrary_precision(taskData, H.flags))); #undef data } /* else (?) */ return FINISHED(taskData, tuple); } #if 0 typedef struct { MLPair *x0; /* pair of points */ MLXRectangle *x1; PolyWord x2; /* ML int */ } MLWMGeometryTriple; #endif static Handle WMGeometry ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ PolyStringObject *user, PolyStringObject *def, unsigned borderWidth, PolyWord P ) { XSizeHints H; int x,y,width,height,gravity,mask; char userGeometry[500],defaultGeometry[500]; GetXWMSizeHints(taskData, P, &H, 0); Poly_string_to_C(user,userGeometry ,sizeof(userGeometry)); Poly_string_to_C(def ,defaultGeometry,sizeof(defaultGeometry)); mask = XWMGeometry(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen, userGeometry, defaultGeometry, borderWidth, &H,&x,&y,&width,&height,&gravity); return CreateTriple(taskData, CreatePoint(taskData, x,y),CreateArea(width,height),Make_arbitrary_precision(taskData, gravity)); } static Handle CreateIconSize(TaskData *taskData, void *v) { XIconSize *s = (XIconSize *)v; return CreateTriple(taskData, CreateArea(s->min_width,s->min_height), CreateArea(s->max_width,s->max_height), CreateArea(s->width_inc,s->height_inc)); } static Handle GetIconSizes(TaskData *taskData, Display *d, Window w) { XIconSize *sizes; int count; int s = XGetIconSizes(d,w,&sizes,&count); if (s) { Handle list = CreateList4(taskData,count,sizes,sizeof(XIconSize),CreateIconSize); XFree((char *)sizes); return list; } return SAVE(ListNull); } static Handle GetTransientForHint ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w ) { Window p; int s = XGetTransientForHint(DEREFDISPLAYHANDLE(dsHandle)->display,w,&p); if (s == 0) RaiseXWindows(taskData, "XGetTransientForHint failed"); return EmptyWindow(taskData, dsHandle,p); } static Handle GetWMColormapWindows ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window parent ) { Window *windows; int count; int s = XGetWMColormapWindows(DEREFDISPLAYHANDLE(dsHandle)->display,parent,&windows,&count); if (s) { Handle list = CreateList5(taskData,count,windows,sizeof(Window),CreateDrawable,dsHandle); XFree((char *)windows); return list; } return SAVE(ListNull); } static Handle GetRGBColormaps ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w, unsigned property ) { XStandardColormap *maps; int count; int s = XGetRGBColormaps(DEREFDISPLAYHANDLE(dsHandle)->display,w,&maps,&count,property); if (s) { Handle list = CreateList5(taskData,count,maps,sizeof(XStandardColormap),CreateStandardColormap,dsHandle); XFree((char *)maps); return list; } return SAVE(ListNull); } static Handle GetID(TaskData *taskData, X_Object *P) { switch(UNTAGGED(P->type)) { case X_GC: return Make_arbitrary_precision(taskData, GetGC(taskData, P)->gid); /* GCID */ case X_Font: return Make_arbitrary_precision(taskData, GetFont(taskData, P)); /* FontID */ case X_Cursor: return Make_arbitrary_precision(taskData, GetCursor(taskData, P)); /* CursorId */ case X_Window: return Make_arbitrary_precision(taskData, GetWindow(taskData, P)); /* DrawableID */ case X_Pixmap: return Make_arbitrary_precision(taskData, GetPixmap(taskData, P)); /* DrawableID */ case X_Colormap: return Make_arbitrary_precision(taskData, GetColormap(taskData, P)); /* ColormapID */ case X_Visual: return Make_arbitrary_precision(taskData, GetVisual(taskData, P)->visualid); /* VisualID */ case X_Widget: return Make_arbitrary_precision(taskData, (unsigned long)GetNWidget(taskData, P)); /* Widget -- SAFE(?) */ default: Crash ("Bad X_Object type (%d) in GetID",UNTAGGED(P->type)) /*NOTREACHED*/; } } static Handle OpenDisplay(TaskData *taskData, PolyStringObject *string) { char name[500]; Display *display; Handle dsHandle /* Handle to (X_Display_Object *) */; Poly_string_to_C(string,name,sizeof(name)); display = XOpenDisplay(name); if (display == 0) RaiseXWindows(taskData, "XOpenDisplay failed"); /* I don't think this is needed. DCJM 26/5/2000. */ /* add_file_descr(display->fd); */ dsHandle = alloc_and_save(taskData, SIZEOF(X_Display_Object), F_MUTABLE_BIT|F_BYTE_OBJ); debug1 ("%s display opened\n",DisplayString(display)); debug1 ("%x display fd\n",display->fd); #define ds DEREFDISPLAYHANDLE(dsHandle) /* Ok to store C values because this is a byte object */ ds->type = TAGGED(X_Display); ds->display = display; ds->screen = DefaultScreen(display); ds->app_context = 0; #undef ds return AddXObject(FINISHED(taskData, dsHandle)); } /* indirection removed SPF 11/11/93 */ static XmFontList GetXmFontList(PolyWord p /* NOT a handle */) { if (NONNIL(p)) { char charset[500]; XmFontList L; MLPair *q = (MLPair *)(((ML_Cons_Cell*)p.AsObjPtr())->h.AsObjPtr()); Poly_string_to_C(SND(q),charset,sizeof(charset)); L = XmFontListCreate((XFontStruct *)FST(q).AsObjPtr(),charset); /* cast added SPF 6/1/94 */ p = ((ML_Cons_Cell*)p.AsObjPtr())->t; while(NONNIL(p)) { q = (MLPair *)(((ML_Cons_Cell*)p.AsObjPtr())->h.AsObjPtr()); Poly_string_to_C(SND(q),charset,sizeof(charset)); L = XmFontListAdd(L,(XFontStruct *)FST(q).AsObjPtr(),charset); /* cast added SPF 6/1/94 */ p = ((ML_Cons_Cell*)p.AsObjPtr())->t; } return L; } return 0; } /* datatype CType = CAccelerators of XtAccelerators | CBool of bool | CColormap of Colormap | CCursor of Cursor | CDimension of int | CFontList of (XFontStruct * string) list | CInt of int | CIntTable of int list | CKeySym of int | CPixmap of Drawable | CPosition of int | CString of string | CStringTable of string list | CTrans of XtTranslations | CUnsignedChar of int | CUnsignedTable of int list | CVisual of Visual | CWidget of Widget | CWidgetList of Widget list | CXmString of XmString | CXmStringTable of XmString list; */ #define CAccelerators 1 #define CBool 2 #define CColormap 3 #define CCursor 4 #define CDimension 5 #define CFontList 6 #define CInt 7 #define CIntTable 8 #define CKeySym 9 #define CPixmap 10 #define CPosition 11 #define CString 12 #define CStringTable 13 #define CTrans 14 #define CUnsignedChar 15 #define CUnsignedTable 16 #define CVisual 17 #define CWidget 18 #define CWidgetList 19 #define CXmString 20 #define CXmStringTable 21 typedef struct { unsigned tag; unsigned N; char *name; union { XtAccelerators acc; Boolean boolean; Colormap cmap; Cursor cursor; Dimension dim; XmFontList F; int i; int *I; KeySym keysym; Pixmap pixmap; Position posn; char *string; char **S; XtTranslations trans; uchar u; uchar *U; Visual *visual; Widget widget; WidgetList W; XmString xmString; XmString *X; } u; } ArgType; static void GetXmString(TaskData *taskData, PolyWord w, void *v, unsigned ) { XmString *p = (XmString *)v; char *s; CopyString(taskData, w, &s, 0); *p = XmStringCreateLtoR(s, (char *)XmSTRING_DEFAULT_CHARSET); free(s); } static void GetXmStrings(TaskData *taskData, PolyWord list, ArgType *T) { T->N = 0; T->u.X = 0; if (NONNIL(list)) { T->N = ListLength(list); T->u.X = (XmString *) malloc(T->N * sizeof(XmString)); GetList4(taskData, list,T->u.X,sizeof(XmString),GetXmString); } } static void GetStrings(TaskData *taskData, PolyWord list, ArgType *T) { T->N = 0; T->u.S = 0; if (NONNIL(list)) { T->N = ListLength(list); T->u.S = (char **) malloc(T->N * sizeof(char *)); GetList4(taskData, list,T->u.S,sizeof(char *),CopyString); } } static void FreeXmStrings(ArgType *T) { for(unsigned i = 0; i < T->N; i++) XmStringFree (T->u.X[i]); free(T->u.X); } static void GetITable(TaskData *taskData, PolyWord list, ArgType *T) { T->N = 0; T->u.I = 0; if (NONNIL(list)) { T->N = ListLength(list); T->u.I = (int *) malloc(T->N * sizeof(int)); GetList4(taskData, list,T->u.I,sizeof(int),GetUnsigned); } } static void GetUTable(TaskData *taskData, PolyWord list, ArgType *T) { T->N = 0; T->u.U = 0; if (NONNIL(list)) { T->N = ListLength(list); T->u.U = (uchar *)malloc(T->N * sizeof(uchar)); GetList4(taskData, list,T->u.U,sizeof(uchar),GetUChars); } } /* case CIntTable: GetITable ((ML_Cons_Cell *)v,T); break; case CUnsignedTable: GetUTable ((ML_Cons_Cell *)v,T); break; case CString: CopyString (v,&T->u.string); break; case CStringTable: GetStrings ((ML_Cons_Cell *)v,T); break; case CXmString: GetXmString (v,&T->u.xmString); break; case CXmStringTable: GetXmStrings((ML_Cons_Cell *)v,T); break; */ static void FreeArgs(ArgType *T, unsigned N) { while(N--) { free(T->name); switch(T->tag) { case CAccelerators: break; case CBool: break; case CColormap: break; case CCursor: break; case CDimension: break; case CFontList: XmFontListFree(T->u.F); break; case CInt: break; case CIntTable: break; case CKeySym: break; case CPixmap: break; case CPosition: break; case CString: XtFree(T->u.string); break; case CStringTable: FreeStrings(T->u.S,T->N); free(T->u.S); break; case CTrans: break; case CUnsignedChar: break; case CUnsignedTable: break; case CVisual: break; case CWidget: break; case CWidgetList: break; case CXmString: XmStringFree (T->u.xmString); break; case CXmStringTable: FreeXmStrings(T); break; default: Crash ("Bad arg type %x",T->tag); } T++; } } /* type Arg sharing type Arg = exn; val Exn: Arg -> Exn = Cast; val Arg: Exn -> Arg = Cast; datatype Exn = EXN of unit ref * string * unit; */ /* (string,(v,tag)) */ static void SetArgTypeP(TaskData *taskData, PolyWord fst, PolyWord snd, ArgType *T) { PolyWord v = FST(snd); T->tag = UNTAGGED(SND(snd)); T->N = 0; T->u.i = 0; CopyString(taskData, fst, &T->name, 0); switch(T->tag) { case CAccelerators: T->u.acc = GetAcc (taskData, (X_Object *)v.AsObjPtr()); break; case CBool: T->u.boolean = get_C_ulong (taskData, v); break; case CColormap: T->u.cmap = GetColormap (taskData, (X_Object *)v.AsObjPtr()); break; case CCursor: T->u.cursor = GetCursor (taskData, (X_Object *)v.AsObjPtr()); break; case CDimension: T->u.dim = get_C_ushort (taskData, v); break; case CFontList: T->u.F = GetXmFontList(v); break; case CInt: T->u.i = get_C_long (taskData, v); break; case CKeySym: T->u.keysym = get_C_ulong (taskData, v); break; case CPixmap: T->u.pixmap = GetPixmap (taskData, (X_Object *)v.AsObjPtr()); break; case CPosition: T->u.posn = get_C_short (taskData, v); break; case CTrans: T->u.trans = GetTrans (taskData, (X_Object *)v.AsObjPtr()); break; case CUnsignedChar: T->u.u = get_C_uchar (taskData, v); break; case CVisual: T->u.visual = GetVisual (taskData, (X_Object *)v.AsObjPtr()); break; case CWidget: T->u.widget = GetNWidget (taskData, (X_Object *)v.AsObjPtr()); break; /* The following types allocate memory, but only in the C heap */ case CIntTable: GetITable (taskData, v,T); break; case CUnsignedTable: GetUTable (taskData, v,T); break; case CString: CopyString (taskData, v, &T->u.string, 0); break; case CStringTable: GetStrings (taskData, v,T); break; case CXmString: GetXmString (taskData, v, &T->u.xmString, 0); break; case CXmStringTable: GetXmStrings(taskData, v,T); break; default: Crash ("Bad arg type %x",T->tag); } } static void SetArgType(TaskData *taskData, PolyWord p, void *v, unsigned) { ArgType *T = (ArgType *)v; SetArgTypeP(taskData, FST(p), SND(p), T); } static void SetArgs(Arg *A, ArgType *T, unsigned N) { while(N--) { A->name = T->name; switch(T->tag) { case CAccelerators: A->value = (XtArgVal) T->u.acc; break; case CBool: A->value = (XtArgVal) T->u.boolean; break; case CColormap: A->value = (XtArgVal) T->u.cmap; break; case CCursor: A->value = (XtArgVal) T->u.cursor; break; case CDimension: A->value = (XtArgVal) T->u.dim; break; case CFontList: A->value = (XtArgVal) T->u.F; break; case CInt: A->value = (XtArgVal) T->u.i; break; case CIntTable: A->value = (XtArgVal) T->u.I; break; case CKeySym: A->value = (XtArgVal) T->u.keysym; break; case CPixmap: A->value = (XtArgVal) T->u.pixmap; break; case CPosition: A->value = (XtArgVal) T->u.posn; break; case CString: A->value = (XtArgVal) T->u.string; break; case CStringTable: A->value = (XtArgVal) T->u.S; break; case CTrans: A->value = (XtArgVal) T->u.trans; break; case CUnsignedChar: A->value = (XtArgVal) T->u.u; break; case CUnsignedTable: A->value = (XtArgVal) T->u.U; break; case CVisual: A->value = (XtArgVal) T->u.visual; break; case CWidget: A->value = (XtArgVal) T->u.widget; break; case CXmString: A->value = (XtArgVal) T->u.xmString; break; case CXmStringTable: A->value = (XtArgVal) T->u.X; break; default: Crash ("Bad arg type %x",T->tag); } A++; T++; } } /* add current callback to (pending?) FList */ static void RunWidgetCallback(Widget w, XtPointer closure, XtPointer call_data) { C_List *C = (C_List *)closure; if (callbacks_enabled) { // Only synchronous callbacks are handled. TaskData *taskData = processes->GetTaskDataForThread(); Handle tailHandle = SAVE(FList); Handle widgetHandle = SAVE(C->widget_object); Handle functionHandle = SAVE(C->function); Handle pairHandle = CreatePair(taskData, widgetHandle,functionHandle); FList = DEREFWORD(CreatePair(taskData, pairHandle,tailHandle)); } #if 0 else printf("Ignoring event for widget %p\n",C->widget_object); #endif } static void SetCallbacks(TaskData *taskData, X_Widget_Object *W, PolyWord list, PolyWord initial) { char name[100]; Widget w = GetWidget(taskData, (X_Object *)W); assert(w != NULL); /* SPF */ assert(w != (Widget)1); /* SPF */ for(PolyWord pp = W->callbackList; NONNIL(pp); pp = ((ML_Cons_Cell*)pp.AsObjPtr())->t) { MLPair *q = (MLPair *)((ML_Cons_Cell*)pp.AsObjPtr())->h.AsObjPtr(); Poly_string_to_C(FST(q),name,sizeof(name)); if (strcmp(name,"messageCallback") != 0 && strcmp(name,XtNdestroyCallback) != 0) { XtRemoveAllCallbacks(w,name); } } #if 0 /* We no longer need the old callback data for this widget, assuming we've replaced all the callbacks. But what if we've only replaced some of them? It's probably better to allow this space leak that to delete vital callback data. I'll have to think about this hard sometime. (Of course, the user isn't supposed to call XtSetCallbacks more than once, in which case the problem doesn't even arise.) SPF 29/2/96 */ PurgeCCallbacks(W,w); #endif for(PolyWord p = list; NONNIL(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { C_List *C = (C_List *)malloc(sizeof(C_List)); MLPair *q = (MLPair *)((ML_Cons_Cell*)p.AsObjPtr())->h.AsObjPtr(); C->function = SND(q).AsObjPtr(); C->widget_object = W; C->next = CList; debugCreateCallback(W,w,C); CList = C; Poly_string_to_C(FST(q),name,sizeof(name)); if (strcmp(name,"messageCallback") != 0 && strcmp(name,XtNdestroyCallback) != 0) { XtAddCallback(w,name,RunWidgetCallback,C); } } W->state = initial; W->callbackList = list; } static void RunWidgetEventhandler (Widget w, XtPointer p, XEvent *ev, Boolean *c) { C_List *C = (C_List *)p; if ( callbacks_enabled ) { TaskData *taskData = processes->GetTaskDataForThread(); Handle tailHandle = SAVE(GList); Handle widgetHandle = SAVE(C->widget_object); Handle functionHandle = SAVE(C->function); Handle pairHandle = CreatePair(taskData, widgetHandle,functionHandle); GList = (ML_Cons_Cell *)DEREFHANDLE(CreatePair(taskData, pairHandle,tailHandle)); } } static void AddEventhandler ( TaskData *taskData, X_Widget_Object *W, EventMask EventM, Boolean nonmask, Handle p) { Widget w = GetWidget(taskData, (X_Object *)W) ; C_List *C = (C_List *) malloc ( sizeof(C_List) ) ; /* Add the function to the callback list, so that it will not be G.C'ed away. */ C->function = DEREFHANDLE(p); C->widget_object = W ; C->next = CList ; CList = C ; XtAddEventHandler (w, EventM, nonmask, RunWidgetEventhandler, C); } static Handle AppInitialise ( TaskData *taskData, PolyWord s1, PolyWord s2, PolyWord s3, Handle fallbackHead, Handle argHead ) { char displayName[500]; char appName[500]; char appClass[500]; XtAppContext app_context; Display *display; Widget shell; Handle dsHandle /* Handle to (X_Display_Object *) */; int argc = 0; /* an "int" for Solaris, but should be "unsigned" for SunOS */ unsigned F = ListLength(DEREFWORD(fallbackHead)) + 1; unsigned N = ListLength(DEREFWORD(argHead)); char **S = (char **) alloca(F * sizeof(char *)); Arg *R = (Arg *) alloca(N * sizeof(Arg)); ArgType *T = (ArgType *) alloca(N * sizeof(ArgType)); Poly_string_to_C(s1,displayName ,sizeof(displayName)); Poly_string_to_C(s2,appName ,sizeof(appName)); Poly_string_to_C(s3,appClass ,sizeof(appClass)); app_context = XtCreateApplicationContext(); GetList4(taskData, DEREFWORD(fallbackHead),S,sizeof(char *),CopyString); S[F-1] = NULL; /* list must be NULL terminated */ XtAppSetFallbackResources(app_context,S); display = XtOpenDisplay(app_context,displayName,appName,appClass,NULL,0,&argc,0); if (display == 0) RaiseXWindows(taskData, "XtAppInitialise failed (can't open display)"); /* I don't think this is needed. DCJM 26/5/2000 */ /* add_file_descr(display->fd); */ debug1 ("%s display opened\n",DisplayString(display)); debug1 ("%x display fd\n",display->fd); /* ok to store C values because this is a BYTE object */ dsHandle = alloc_and_save(taskData, SIZEOF(X_Display_Object), F_MUTABLE_BIT|F_BYTE_OBJ); DEREFDISPLAYHANDLE(dsHandle)->type = TAGGED(X_Display); DEREFDISPLAYHANDLE(dsHandle)->display = display; DEREFDISPLAYHANDLE(dsHandle)->screen = DefaultScreen(display); DEREFDISPLAYHANDLE(dsHandle)->app_context = app_context; AddXObject(FINISHED(taskData, dsHandle)); GetList4(taskData, DEREFWORD(argHead),T,sizeof(ArgType),SetArgType); SetArgs(R,T,N); shell = XtAppCreateShell(appName,appClass,applicationShellWidgetClass,display,R,N); FreeArgs(T,N); if (shell == 0) RaiseXWindows(taskData, "XtAppInitialise failed (can't create application shell)"); /* added 7/12/94 SPF */ XtAddCallback(shell,XtNdestroyCallback,DestroyWidgetCallback,NULL); return NewWidget(taskData, dsHandle,shell); } static Handle CreatePopupShell ( TaskData *taskData, PolyStringObject *s, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget parent, Handle list ) { char name[100]; Widget shell; unsigned N = ListLength(DEREFWORD(list)); Arg *A = (Arg *) alloca(N * sizeof(Arg)); ArgType *T = (ArgType *) alloca(N * sizeof(ArgType)); GetList4(taskData, DEREFWORD(list),T,sizeof(ArgType),SetArgType); SetArgs(A,T,N); Poly_string_to_C(s,name,sizeof(name)); shell = XtCreatePopupShell(name,applicationShellWidgetClass,parent,A,N); FreeArgs(T,N); if (shell == 0) RaiseXWindows(taskData, "XtCreatePopupShell failed"); /* added 7/12/94 SPF */ XtAddCallback(shell,XtNdestroyCallback,DestroyWidgetCallback,NULL); return NewWidget(taskData, dsHandle,shell); } static Handle CreateXm ( TaskData *taskData, Widget (*create)(Widget, String, ArgList, Cardinal), char *failed, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget parent, PolyStringObject *s, Handle list /* Handle to (ML_Cons_Cell *) */ ) { char name[100]; Widget w; unsigned N = ListLength(DEREFWORD(list)); Arg *A = (Arg *) alloca(N * sizeof(Arg)); ArgType *T = (ArgType *) alloca(N * sizeof(ArgType)); GetList4(taskData, DEREFWORD(list),T,sizeof(ArgType),SetArgType); SetArgs(A,T,N); Poly_string_to_C(s,name,sizeof(name)); w = (* create)(parent,name,A,N); FreeArgs(T,N); if (w == 0) RaiseXWindows(taskData, failed); XtAddCallback(w,XtNdestroyCallback,DestroyWidgetCallback,NULL); return NewWidget(taskData, dsHandle,w); } static void SetValues(TaskData *taskData, Widget w, Handle list) { unsigned N = ListLength(DEREFWORD(list)); Arg *A = (Arg *) alloca(N * sizeof(Arg)); ArgType *T = (ArgType *) alloca(N * sizeof(ArgType)); GetList4(taskData, DEREFWORD(list),T,sizeof(ArgType),SetArgType); SetArgs(A,T,N); XtSetValues(w,A,N); FreeArgs(T,N); } typedef struct { const char *listName; char *intName; } StringPair; static StringPair listTypes[] = { {"argv" ,(char *) "argc"}, {"buttonAccelerators" ,(char *) "buttonCount"}, {"buttonAcceleratorText" ,(char *) "buttonCount"}, {"buttonMnemonicCharSets",(char *) "buttonCount"}, {"buttonMnemonics" ,(char *) "buttonCount"}, {"buttons" ,(char *) "buttonCount"}, {"buttonType" ,(char *) "buttonCount"}, {"children" ,(char *) "numChildren"}, {"dirListItems" ,(char *) "dirListItemCount"}, {"fileListItems" ,(char *) "fileListItemCount"}, {"historyItems" ,(char *) "historyItemCount"}, {"items" ,(char *) "itemCount"}, {"listItems" ,(char *) "listItemCount"}, {"selectedItems" ,(char *) "selectedItemCount"}, {"selectionArray" ,(char *) "selectionArrayCount"}, }; #define MAXListTYPES (sizeof(listTypes)/sizeof(listTypes[0])) /* (string,(v,tag)) - ML (string*Ctype) */ static void GetArgType ( TaskData *taskData, PolyWord p, ArgType *T, int i, /* not used; needed to keep function type right */ Widget w ) { T->tag = UNTAGGED(SND(SND(p))); T->N = 0; T->u.i = 0; CopyString(taskData, FST(p), &T->name, 0); if (T->tag == CIntTable || T->tag == CUnsignedTable || T->tag == CWidgetList || T->tag == CStringTable || T->tag == CXmStringTable) /* if it is a list type we need to get the length from another resource */ { Arg arg; unsigned i; int result; for(i = 0; i < MAXListTYPES; i++) { if (strcmp(listTypes[i].listName,T->name) == 0) break; } if (i == MAXListTYPES) Crash ("Bad list resource name %s",T->name); arg.name = listTypes[i].intName; arg.value = (XtArgVal) &result; /* Bug fix here which only appeared in OpenMotif and LessTif. We need to pass the address of an integer here to receive the result. DCJM 17/5/02. */ XtGetValues(w, &arg, 1); T->N = result; } } static Handle CreateWidget(TaskData *taskData, void *p, Handle dsHandle /* Handle to (X_Display_Object *) */) { return EmptyWidget(taskData, dsHandle, *(Widget*)p); } static Handle CreateXmString(TaskData *taskData, void *t) { char *s; Handle S; XmStringGetLtoR(*(XmString *)t,(char *) XmSTRING_DEFAULT_CHARSET,&s); S = Make_string(s); XtFree(s); return S; } static Handle CreateFontList ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ XmFontList F ) { XmFontContext C; XmStringCharSet charset; XFontStruct *fs; Handle list = 0; Handle tail = 0; if (XmFontListInitFontContext(&C,F) == False) return SAVE(ListNull); // TODO: This previously reset the save vector each time to make sure it // didn't overflow. I've removed that code but it needs to be put back. while (XmFontListGetNextFont(C,&charset,&fs)) { Handle L = alloc_and_save(taskData, SIZEOF(ML_Cons_Cell), F_MUTABLE_BIT); if (list == 0) list = L; // This is the first. if (tail != 0) { DEREFLISTHANDLE(tail)->t = DEREFWORD(L); FINISHED(taskData, tail); } tail = L; /* the new list element is joined on, but not filled in */ DEREFLISTHANDLE(tail)->h = DEREFWORD(CreatePair(taskData, CreateFontStruct(taskData,fs,dsHandle),Make_string(charset))); DEREFLISTHANDLE(tail)->t = ListNull; } XmFontListFreeFontContext(C); if (tail != 0) FINISHED(taskData, tail); return list; } static Handle CreateUChar(TaskData *taskData, void *p) { return Make_arbitrary_precision(taskData, *(uchar *)p); } static Handle CreateArg(TaskData *taskData, void *v, Handle dsHandle /* Handle to (X_Display_Object *) */) { ArgType *T = (ArgType *)v; Handle value; switch(T->tag) { case CAccelerators: value = EmptyAcc (taskData, T->u.acc); break; case CBool: value = Make_bool (T->u.boolean); break; case CColormap: value = EmptyColormap (taskData, dsHandle,T->u.cmap); break; case CCursor: value = EmptyCursor (taskData, dsHandle,T->u.cursor); break; case CDimension: value = Make_int (T->u.dim); break; case CFontList: value = CreateFontList(taskData, dsHandle,T->u.F); break; case CInt: value = Make_int (T->u.i); break; case CKeySym: value = Make_arbitrary_precision (taskData, T->u.keysym); break; case CPixmap: value = EmptyPixmap (taskData, dsHandle,T->u.pixmap); break; case CPosition: value = Make_int (T->u.posn); break; case CString: value = Make_string (T->u.string); break; case CTrans: value = EmptyTrans (taskData, T->u.trans); break; case CUnsignedChar: value = Make_arbitrary_precision (taskData, T->u.u); break; case CVisual: value = EmptyVisual (taskData, dsHandle,T->u.visual); break; case CWidget: value = EmptyWidget (taskData, dsHandle,T->u.widget); break; case CXmString: value = CreateXmString(taskData, &T->u.xmString); break; case CIntTable: value = CreateList4(taskData, T->N,T->u.I,sizeof(int), CreateUnsigned); break; case CUnsignedTable: value = CreateList4(taskData, T->N,T->u.U,sizeof(uchar), CreateUChar); break; case CStringTable: value = CreateList4(taskData, T->N,T->u.S,sizeof(char *), CreateString); break; case CWidgetList: value = CreateList5(taskData,T->N,T->u.W,sizeof(Widget), CreateWidget,dsHandle); break; case CXmStringTable: value = CreateList4(taskData, T->N,T->u.X,sizeof(XmString),CreateXmString); break; default: Crash ("Bad arg type %x",T->tag); /*NOTREACHED*/ } return value; } static Handle GetValue ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget w, PolyWord pair /* ML (string*Ctype) */ ) { Arg A; ArgType T; XmString *X = (XmString *) 0x55555555; XmString *Y = (XmString *) 0xAAAAAAAA; GetArgType(taskData,pair,&T,0,w); A.name = T.name; A.value = (XtArgVal) &T.u; T.u.X = X; /* The value is set to X. If it is left set to X */ /* then this may be a value this widget doesn't have. */ XtGetValues(w,&A,1); if (T.u.X == X) { T.u.X = Y; XtGetValues(w,&A,1); if (T.u.X == Y) { char buffer[500]; sprintf(buffer,"XtGetValues (%s) failed",T.name); RaiseXWindows(taskData, buffer); } } return CreateArg(taskData, &T,dsHandle); } /* What is the real ML type of p? (string*Ctype*string*string*string*Ctype) */ static void GetResource ( TaskData *taskData, PolyWord pp, XtResource *R, int i, ArgType *T, ArgType *D, Widget w ) { PolyObject *p = pp.AsObjPtr(); GetArgType(taskData,pp,&T[i],0,w); /* HACK !!! */ CopyString(taskData, p->Get(0), &R->resource_name, 0); CopyString(taskData, p->Get(2), &R->resource_class, 0); CopyString(taskData, p->Get(3), &R->resource_type, 0); R->resource_size = 4; R->resource_offset = (byte*)(&T[i].u) - (byte*)(T); SetArgTypeP(taskData, p->Get(4), p->Get(5), &D[i]); /* This was a hack. I hope I converted it correctly. DCJM */ R->default_type = D[i].name; if (UNTAGGED(p->Get(5).AsObjPtr()->Get(1)) == CString) R->default_addr = (XtPointer) D[i].u.string; else R->default_addr = (XtPointer) &D[i].u; } static Handle GetSubresources ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget w, PolyStringObject *s1, PolyStringObject *s2, Handle list ) { char name [100]; char clas[100]; unsigned N = ListLength(DEREFWORD(list)); ArgType *T = (ArgType *) alloca(N * sizeof(ArgType)); ArgType *D = (ArgType *) alloca(N * sizeof(ArgType)); XtResource *R = (XtResource *) alloca(N * sizeof(XtResource)); { unsigned i = 0; for(PolyWord p = DEREFWORD(list); NONNIL(p); p = ((ML_Cons_Cell *)p.AsObjPtr())->t) { GetResource(taskData,((ML_Cons_Cell *)p.AsObjPtr())->h,&R[i],i,T,D,w); i++; } } Poly_string_to_C(s1,name ,sizeof(name)); Poly_string_to_C(s2,clas,sizeof(clas)); XtGetSubresources(w,T,name,clas,R,N,NULL,0); return CreateList5(taskData,N,T,sizeof(ArgType),CreateArg,dsHandle); } static Handle GetApplicationResources (TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget w, Handle list ) { unsigned N = ListLength (DEREFLISTHANDLE(list)) ; ArgType *T = (ArgType *) alloca ( N * sizeof(ArgType) ) ; ArgType *D = (ArgType *) alloca ( N * sizeof(ArgType) ) ; XtResource *R = (XtResource *) alloca ( N * sizeof(XtResource) ) ; { unsigned i = 0; for(PolyWord p = DEREFWORD(list); NONNIL(p); p = ((ML_Cons_Cell *)p.AsObjPtr())->t) { GetResource(taskData,((ML_Cons_Cell *)p.AsObjPtr())->h,&R[i],i,T,D,w); i++; } } XtGetApplicationResources ( w,T,R,N,NULL,0 ) ; return CreateList5 (taskData, N,T,sizeof(ArgType),CreateArg,dsHandle ) ; } static void GetChild(TaskData *taskData, PolyWord p, void *v, unsigned) { Widget *w = (Widget *)v; *w = GetWidget(taskData, (X_Object *)p.AsObjPtr()); if (XtParent(*w) == NULL) RaiseXWindows(taskData, "not a child"); } static void ManageChildren(TaskData *taskData, Handle list) { unsigned N = ListLength(DEREFWORD(list)); Widget *W = (Widget *) alloca(N * sizeof(Widget)); GetList4(taskData, DEREFWORD(list),W,sizeof(Widget),GetChild); XtManageChildren(W,N); } static void UnmanageChildren(TaskData *taskData, Handle list) { unsigned N = ListLength(DEREFWORD(list)); Widget *W = (Widget *) alloca(N * sizeof(Widget)); GetList4(taskData, DEREFWORD(list),W,sizeof(Widget),GetChild); XtUnmanageChildren(W,N); } static Handle ParseTranslationTable(TaskData *taskData, PolyStringObject *s) { XtTranslations table; int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); table = XtParseTranslationTable(buffer); return EmptyTrans(taskData, table); } static void CommandError(TaskData *taskData, Widget w, PolyWord s) { XmString p; GetXmString(taskData, s, &p, 0); XmCommandError(w,p); XmStringFree (p); } static void FileSelectionDoSearch(TaskData *taskData, Widget w, PolyWord s) { XmString p; GetXmString(taskData, s, &p, 0); XmFileSelectionDoSearch(w,p); XmStringFree (p); } static void MenuPosition (Widget w, int x, int y) { XButtonPressedEvent ev; memset (&ev, 0, sizeof(ev)); ev.type = 4; /* Must be button. */ ev.x_root = x; ev.y_root = y; ev.button = 3; /* Is this required? */ ev.same_screen = 1; /* Assume this. */ XmMenuPosition (w, &ev); } static Handle XmIsSomething(TaskData *taskData, unsigned is_code, Widget widget) { unsigned i; switch(is_code) { case 1: i = XmIsArrowButton (widget); break; case 2: i = XmIsArrowButtonGadget (widget); break; case 3: i = XmIsBulletinBoard (widget); break; case 4: i = XmIsCascadeButton (widget); break; case 5: i = XmIsCascadeButtonGadget(widget); break; case 6: i = XmIsCommand (widget); break; case 7: i = XmIsDesktopObject (widget); break; /* ok - SPF 9/8/94 */ case 8: i = XmIsDialogShell (widget); break; /* Unsupported in Motif 1.2 case 9: i = XmIsDisplayObject (widget); break; */ case 10: i = XmIsDrawingArea (widget); break; case 11: i = XmIsDrawnButton (widget); break; case 12: i = XmIsExtObject (widget); break; /* ok - SPF 9/8/94 */ case 13: i = XmIsFileSelectionBox (widget); break; case 14: i = XmIsForm (widget); break; case 15: i = XmIsFrame (widget); break; case 16: i = XmIsGadget (widget); break; case 17: i = XmIsLabel (widget); break; case 18: i = XmIsLabelGadget (widget); break; case 19: i = XmIsList (widget); break; case 20: i = XmIsMainWindow (widget); break; case 21: i = XmIsManager (widget); break; case 22: i = XmIsMenuShell (widget); break; case 23: i = XmIsMessageBox (widget); break; case 24: i = XmIsMotifWMRunning (widget); break; case 25: i = XmIsPanedWindow (widget); break; case 26: i = XmIsPrimitive (widget); break; case 27: i = XmIsPushButton (widget); break; case 28: i = XmIsPushButtonGadget (widget); break; case 29: i = XmIsRowColumn (widget); break; case 30: i = XmIsScale (widget); break; /* Unsupported in Motif 1.2 case 31: i = XmIsScreenObject (widget); break; */ case 32: i = XmIsScrollBar (widget); break; case 33: i = XmIsScrolledWindow (widget); break; case 34: i = XmIsSelectionBox (widget); break; case 35: i = XmIsSeparator (widget); break; case 36: i = XmIsSeparatorGadget (widget); break; #ifdef LESSTIF_VERSION /* This is not supported in LessTif, at least not 0.89. */ case 37: RaiseXWindows(taskData, "XmIsShellExt: not implemented"); #else case 37: i = XmIsShellExt (widget); break; /* ok - SPF 9/8/94 */ #endif case 38: i = XmIsText (widget); break; case 39: i = XmIsTextField (widget); break; case 40: i = XmIsToggleButton (widget); break; case 41: i = XmIsToggleButtonGadget (widget); break; case 42: i = XmIsVendorShell (widget); break; case 43: i = XmIsVendorShellExt (widget); break; /* ok - SPF 9/8/94 */ /* Unsupported in Motif 1.2 case 44: i = XmIsWorldObject (widget); break; */ default: Crash ("Bad code (%d) in XmIsSomething",is_code); /* NOTREACHED*/ } return Make_bool(i); } /******************************************************************************/ /* */ /* Wrappers for standard widget operations */ /* */ /******************************************************************************/ /************************* 0 parameters, no result ****************************/ /* widget -> unit */ static void WidgetAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData,func_name,arg1); applyFunc(w); } /************************* 1 parameter, no result *****************************/ /* widget -> bool -> unit */ static void WidgetBoolAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, Boolean), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); Boolean b = (get_C_short(taskData, arg2) != 0); applyFunc(w,b); } /* widget -> int -> unit */ static void WidgetIntAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, int), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); int i = get_C_long(taskData, arg2); applyFunc(w,i); } /* widget -> int -> unit */ static void WidgetLongAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, long), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); long i = get_C_long(taskData, arg2); applyFunc(w,i); } /* widget -> string -> unit */ static void WidgetXmstringAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, XmString), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); XmString s; GetXmString(taskData, arg2, &s, 0); applyFunc(w,s); XmStringFree(s); } /* widget -> string list -> unit */ static void WidgetXmstringlistAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, XmString *, int), X_Object *arg1, ML_Cons_Cell *arg2 ) { Widget w = getWidget(taskData,func_name,arg1); unsigned n = ListLength(arg2); XmString *strings = (XmString *)alloca(n * sizeof(XmString)); GetList4(taskData, arg2,strings,sizeof(XmString),GetXmString); applyFunc(w,strings,n); for (unsigned i = 0; i < n; i ++) XmStringFree(strings[i]); } /************************* 2 parameters, no result ****************************/ /* widget -> int -> bool -> unit */ static void WidgetIntBoolAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, int, Boolean), X_Object *arg1, PolyWord arg2, PolyWord arg3 ) { Widget w = getWidget(taskData,func_name,arg1); int i = get_C_long(taskData, arg2); Boolean b = (get_C_ushort(taskData, arg3) != 0); applyFunc(w,i,b); } /* widget -> int -> int -> unit */ static void WidgetIntIntAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, int, int), X_Object *arg1, PolyWord arg2, PolyWord arg3 ) { Widget w = getWidget(taskData,func_name,arg1); int x = get_C_long(taskData, arg2); int y = get_C_long(taskData, arg3); applyFunc(w,x,y); } /* widget -> string -> bool -> unit */ static void WidgetXmstringBoolAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, XmString, Boolean), X_Object *arg1, PolyWord arg2, PolyWord arg3 ) { Widget w = getWidget(taskData,func_name,arg1); XmString s; Boolean b = (get_C_ushort(taskData, arg3) != 0); GetXmString(taskData, arg2, &s, 0); applyFunc(w,s,b); XmStringFree(s); } /* widget -> string -> int -> unit */ static void WidgetXmstringIntAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, XmString, int), X_Object *arg1, PolyWord arg2, PolyWord arg3 ) { Widget w = getWidget(taskData,func_name,arg1); XmString s; int i = get_C_long(taskData, arg3); GetXmString(taskData, arg2, &s, 0); applyFunc(w,s,i); XmStringFree(s); } /* widget -> string list -> int -> unit */ static void WidgetXmstringlistIntAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, XmString *, int, int), X_Object *arg1, ML_Cons_Cell *arg2, PolyWord arg3 ) { Widget w = getWidget(taskData,func_name,arg1); unsigned n = ListLength(arg2); int i = get_C_long(taskData, arg3); XmString *strings = (XmString *)alloca(n * sizeof(XmString)); GetList4(taskData, arg2,strings,sizeof(XmString),GetXmString); applyFunc(w,strings,n,i); for (unsigned i = 0; i < n; i ++) XmStringFree(strings[i]); } /************************* n parameters, some result **************************/ static Handle int_ptr_to_arb(TaskData *taskData, void *p) { return Make_arbitrary_precision(taskData, *(int *)p); } /* widget -> int */ static Handle WidgetToInt ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), int applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData, func_name,arg1); int res = applyFunc(w); return(Make_arbitrary_precision(taskData, res)); } /* widget -> int */ static Handle WidgetToLong ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *taskData, char *, X_Object *), long applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData, func_name,arg1); long res = applyFunc(w); return(Make_arbitrary_precision(taskData, res)); } #if 0 /* widget -> int */ static Handle WidgetToUnsigned ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), unsigned applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData, func_name,arg1); unsigned res = applyFunc(w); return(Make_arbitrary_precision(taskData, res)); } #endif /* widget -> bool */ static Handle WidgetToBool ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), Boolean applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData, func_name,arg1); Boolean res = applyFunc(w); return(Make_bool(res)); } /* widget -> string */ static Handle WidgetToString ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), char *applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData, func_name,arg1); char *s = applyFunc(w); Handle res = Make_string(s); /* safe, even if C pointer is NULL */ XtFree(s); return(res); } /* widget -> int list */ static Handle WidgetToIntlist ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), Boolean applyFunc(Widget, int**, int *), X_Object *arg1 ) { int item_count, *items; Boolean non_empty; Widget w = getWidget(taskData,func_name,arg1); non_empty = applyFunc(w, &items, &item_count); if (non_empty != TRUE) /* nothing found, and Motif hasn't allocated any space */ /* so just retun nil */ { return (SAVE(ListNull)); } else /* copy the list into the ML heap, then free it */ { Handle res = CreateList4(taskData, item_count,items,sizeof(int),int_ptr_to_arb); XtFree((char *)items); return res; } } /* widget -> string -> int list */ static Handle WidgetXmstringToIntlist ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), Boolean applyFunc(Widget, XmString, int**, int *), X_Object *arg1, PolyWord arg2 ) { int item_count, *items; Boolean non_empty; Widget w = getWidget(taskData,func_name,arg1); XmString s; GetXmString(taskData, arg2, &s, 0); non_empty = applyFunc(w, s, &items, &item_count); XmStringFree(s); if (non_empty != TRUE) /* nothing found, so just retun nil */ { return (SAVE(ListNull)); } else /* copy the list into the ML heap, then free it */ { Handle res = CreateList4(taskData, item_count,items,sizeof(int),int_ptr_to_arb); XtFree((char *)items); return res; } } /* widget -> string -> int */ static Handle WidgetXmstringToInt ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), int applyFunc(Widget, XmString), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); XmString s; int res; GetXmString(taskData, arg2, &s, 0); res = applyFunc(w, s); XmStringFree(s); return (Make_int(res)); } /* widget -> string -> bool */ static Handle WidgetXmstringToBool ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), Boolean applyFunc(Widget, XmString), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); XmString s; Boolean res; GetXmString(taskData, arg2, &s, 0); res = applyFunc(w, s); XmStringFree(s); return (Make_bool(res)); } /******************************************************************************/ /* code added SPF 25/2/95 */ static bool isPossibleString(PolyObject *P) { if (!OBJ_IS_DATAPTR(P)) return false; POLYUNSIGNED L = P->LengthWord(); if (! OBJ_IS_BYTE_OBJECT(L)) return false; /* get object PolyWord count */ POLYUNSIGNED n = OBJ_OBJECT_LENGTH(L); if (n < 1) return false; /* get string byte count */ POLYUNSIGNED m = P->Get(0).AsUnsigned(); /* number of words to hold the bytes */ m = (m + 3) / 4; /* number of words to hold the bytes, plus the byte count */ m = m + 1; /* If that's the same as the object PolyWord count, we've probably got a genuine string! */ return (m == n); } /* Prints out the contents of a PolyWord in the X interface tuple */ static void DebugPrintWord(PolyWord P /* was X_Object *P */) { TaskData *taskData = processes->GetTaskDataForThread(); if (IS_INT((P))) { printf("Short %d", (int)UNTAGGED(P)); return; } if (isPossibleString(P.AsObjPtr())) { if (((PolyStringObject*)P.AsObjPtr())->length <= 40) { printf("String: \""); print_string((PolyStringObject*) P.AsObjPtr()); printf("\""); return; } else { printf("Long String: %p", P.AsAddress()); return; } } /* The problem with the following code was that we can't be sure that the object we have is really an X_Object - it might just look like one. If this is the case, when we try to validate the object using ResourceExists we may get a core dump because ResourceExists assumes it has a valid X_Object and calls hashId which dereferences fields within the so-called X_object. That's why we redefine ResourceExists to be SafeResourceExists which doesn't make any assumptions about the contents of the so-called X_object. SPF 6/4/95 */ #define XP ((X_Object *)P.AsObjPtr()) #define ResourceExists SafeResourceExists { switch(UNTAGGED(XP->type)) { case X_GC: (ResourceExists(XP) ? printf("GC %lx", GetGC(taskData, XP)->gid) : printf("Old GC <%lx>",P.AsUnsigned())); return; case X_Font: (ResourceExists(XP) ? printf("Font %lx",GetFont(taskData, XP)) : printf("Old Font <%x>",(int)P.AsUnsigned())); return; case X_Cursor: (ResourceExists(XP) ? printf("Cursor %lx",GetCursor(taskData, XP)) : printf("Old Cursor <%x>",(int)P.AsUnsigned())); return; case X_Window: (ResourceExists(XP) ? printf("Window %lx",GetWindow(taskData, XP)) : printf("Old Window <%p>",P.AsAddress())); return; case X_Pixmap: (ResourceExists(XP) ? printf("Pixmap %lx",GetPixmap(taskData, XP)) : printf("Old Pixmap <%p>",P.AsAddress())); return; case X_Colormap: (ResourceExists(XP) ? printf("Colormap %lx",GetColormap(taskData, XP)) : printf("Old Colormap <%p>",P.AsAddress())); return; case X_Visual: (ResourceExists(XP) ? printf("Visual %lx",GetVisual(taskData, XP)->visualid) : printf("Old Visual <%p>",P.AsAddress())); return; case X_Widget: (ResourceExists(XP) ? printf("Widget %p",GetNWidget(taskData, XP)) : printf("Old Widget <%p>",P.AsAddress())); return; case X_Trans: (ResourceExists(XP) ? printf("Trans %p",GetTrans(taskData, XP)) : printf("Old Trans <%p>",P.AsAddress())); return; case X_Acc: (ResourceExists(XP) ? printf("Acc %p",GetAcc(taskData, XP)) : printf("Old Acc <%p>",P.AsAddress())); return; case X_Display: (ResourceExists(XP) ? printf("Display %s", DisplayString(GetDisplay(taskData, XP))) + printf(":%x", GetDisplay(taskData, XP)->fd) : printf("Old Display <%p>",P.AsAddress())); return; default: printf("Pointer "ZERO_X"%p",P.AsAddress()); return; } } #undef ResourceExists #undef XP } /* Prints out the contents of the X interface tuple */ static void DebugPrintCode(PolyObject *pt) { POLYUNSIGNED N = pt->Length(); POLYUNSIGNED i = 1; assert(IS_INT(pt->Get(0))); printf("%ld:(", UNTAGGED(pt->Get(0))); while(i < N) { DebugPrintWord(pt->Get(i++)); if (i < N) printf(","); } printf(")\n"); } #define P0 DEREFHANDLE(params)->Get(0) #define P1 DEREFHANDLE(params)->Get(1) #define P2 DEREFHANDLE(params)->Get(2) #define P3 DEREFHANDLE(params)->Get(3) #define P4 DEREFHANDLE(params)->Get(4) #define P5 DEREFHANDLE(params)->Get(5) #define P6 DEREFHANDLE(params)->Get(6) #define P7 DEREFHANDLE(params)->Get(7) #define P8 DEREFHANDLE(params)->Get(8) #define P9 DEREFHANDLE(params)->Get(9) #define P10 DEREFHANDLE(params)->Get(10) #define P11 DEREFHANDLE(params)->Get(11) #define P12 DEREFHANDLE(params)->Get(12) #define XP1 ((X_Object *)P1.AsObjPtr()) #define XP2 ((X_Object *)P2.AsObjPtr()) #define XP3 ((X_Object *)P3.AsObjPtr()) #define XP4 ((X_Object *)P4.AsObjPtr()) #define XP5 ((X_Object *)P5.AsObjPtr()) #define XP6 ((X_Object *)P6.AsObjPtr()) #define XP7 ((X_Object *)P7.AsObjPtr()) /* Xwindows_c gets passed the address of an object in save_vec, */ /* which is itself a pointer to a tuple in the Poly heap. */ Handle XWindows_c(TaskData *taskData, Handle params) { int code = get_C_short(taskData, P0); if ((debugOptions & DEBUG_X)) DebugPrintCode(DEREFHANDLE(params)); switch(code) { case XCALL_Not: return Make_arbitrary_precision(taskData, ~ get_C_ulong(taskData, P1)); case XCALL_And: return Make_arbitrary_precision(taskData, get_C_ulong(taskData, P1) & get_C_ulong(taskData, P2)); case XCALL_Or: return Make_arbitrary_precision(taskData, get_C_ulong(taskData, P1) | get_C_ulong(taskData, P2)); case XCALL_Xor: return Make_arbitrary_precision(taskData, get_C_ulong(taskData, P1) ^ get_C_ulong(taskData, P2)); case XCALL_DownShift: return Make_arbitrary_precision(taskData, get_C_ulong(taskData, P1) >> get_C_ulong(taskData, P2)); case XCALL_UpShift: return Make_arbitrary_precision(taskData, get_C_ulong(taskData, P1) << get_C_ulong(taskData, P2)); case XCALL_NoDrawable: return EmptyPixmap(taskData, SAVE(ListNull),(Pixmap)get_C_ulong(taskData, P1)); case XCALL_NoCursor: return EmptyCursor(taskData, SAVE(ListNull),(Cursor)None); case XCALL_NoFont: return EmptyFont(taskData, SAVE(ListNull),(Font)None,(XFontStruct *)NULL); case XCALL_NoColormap: return EmptyColormap(taskData, SAVE(ListNull),(Colormap) None); case XCALL_NoVisual: return EmptyVisual(taskData, SAVE(ListNull),(Visual *)None); case XCALL_GetTimeOfDay: return GetTimeOfDay(taskData); /* Colorcells 100 */ case XCALL_XAllocColor: return AllocColor(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),GetXColor1(taskData, P2)); case XCALL_XAllocColorCells: return AllocColorCells(taskData, GetDisplay(taskData, XP1), GetColormap(taskData, XP1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), get_C_ulong(taskData, P4)); case XCALL_XAllocColorPlanes: return AllocColorPlanes(taskData, GetDisplay(taskData, XP1), GetColormap(taskData, XP1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), get_C_ulong(taskData, P4), get_C_ulong(taskData, P5), get_C_ulong(taskData, P6)); case XCALL_XAllocNamedColor: return AllocNamedColor(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),GetString(P2)); case XCALL_XFreeColors: FreeColors(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),SAVE(P2),get_C_ulong(taskData, P3)); break; case XCALL_XLookupColor: return LookupColor(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),GetString(P2)); case XCALL_XParseColor: return ParseColor(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),GetString(P2)); case XCALL_XQueryColor: return QueryColor(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),get_C_ulong(taskData, P2)); case XCALL_XQueryColors: return QueryColors(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),SAVE(P2)); case XCALL_XStoreColor: XStoreColor(GetDisplay(taskData, XP1),GetColormap(taskData, XP1),GetXColor1(taskData, P2)); break; case XCALL_XStoreColors: StoreColors(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),SAVE(P2)); break; case XCALL_XStoreNamedColor: StoreNamedColor(GetDisplay(taskData, XP1), GetColormap(taskData, XP1), GetString(P2), get_C_ulong(taskData, P3), get_C_ulong(taskData, P4), get_C_ulong(taskData, P5), get_C_ulong(taskData, P6)); break; case XCALL_BlackPixel: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, BlackPixel(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } case XCALL_WhitePixel: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, WhitePixel(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } /* Colormaps 150 */ case XCALL_XCopyColormapAndFree: return EmptyColormap(taskData, GetDS(taskData, XP1),XCopyColormapAndFree(GetDisplay(taskData, XP1),GetColormap(taskData, XP1))); case XCALL_XCreateColormap: return EmptyColormap(taskData, GetDS(taskData, XP1),XCreateColormap(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetVisual(taskData, XP2),get_C_ulong(taskData, P3))); case XCALL_XInstallColormap: XInstallColormap(GetDisplay(taskData, XP1),GetColormap(taskData, XP1)); break; case XCALL_XListInstalledColormaps: return ListInstalledColormaps(taskData, GetDS(taskData, XP1),GetDrawable(taskData, XP1)); case XCALL_XUninstallColormap: XUninstallColormap(GetDisplay(taskData, XP1),GetColormap(taskData, XP1)); break; case XCALL_DefaultColormap: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return EmptyColormap(taskData, dsHandle, DefaultColormap(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } case XCALL_DefaultVisual: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return EmptyVisual(taskData, dsHandle, DefaultVisual(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } case XCALL_DisplayCells: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, DisplayCells(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } case XCALL_VisualClass: return Make_arbitrary_precision(taskData, GetVisual(taskData, XP1)->c_class); case XCALL_VisualRedMask: return Make_arbitrary_precision(taskData, GetVisual(taskData, XP1)->red_mask); case XCALL_VisualGreenMask: return Make_arbitrary_precision(taskData, GetVisual(taskData, XP1)->green_mask); case XCALL_VisualBlueMask: return Make_arbitrary_precision(taskData, GetVisual(taskData, XP1)->blue_mask); /* Cursors 200 */ case XCALL_XCreateFontCursor: return CreateFontCursor(taskData, GetDS(taskData, XP1),get_C_ulong(taskData, P2)); case XCALL_XCreateGlyphCursor: return CreateGlyphCursor(taskData, GetDS(taskData, XP1), GetFont(taskData, XP1), GetFont(taskData, XP2), get_C_ulong(taskData, P3), get_C_ulong(taskData, P4), GetXColor1(taskData, P5), GetXColor2(taskData, P6)); case XCALL_XCreatePixmapCursor: return CreatePixmapCursor(taskData, GetDS(taskData, XP1), GetPixmap(taskData, XP1), /* source */ GetPixmap(taskData, XP2), /* mask */ GetXColor1(taskData, P3), /* foreground */ GetXColor2(taskData, P4), /* background */ GetOffsetX(taskData, P5), /* x */ GetOffsetY(taskData, P5) /* y */); case XCALL_XDefineCursor: XDefineCursor(GetDisplay(taskData, XP1),GetWindow(taskData, XP1),GetCursor(taskData, XP2)); WindowObject(XP1)->cursor_object = CursorObject(XP2); break; case XCALL_XQueryBestCursor: CheckZeroRect(taskData, P2); return QueryBest(taskData, XQueryBestCursor, GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetRectW(taskData, P2), GetRectH(taskData, P2)); case XCALL_XRecolorCursor: XRecolorCursor(GetDisplay(taskData, XP1), GetCursor(taskData, XP1), GetXColor1(taskData, P2), GetXColor2(taskData, P3)); break; case XCALL_XUndefineCursor: XUndefineCursor(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); WindowObject(XP1)->cursor_object = 0; break; /* Display Specifications 250 */ case XCALL_XOpenDisplay: return OpenDisplay(taskData, GetString(XP1)); #define DODISPLAYOP(op) \ {\ Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1);\ return Make_arbitrary_precision(taskData, op(DEREFDISPLAYHANDLE(dsHandle)->display,\ DEREFDISPLAYHANDLE(dsHandle)->screen));\ } case XCALL_CellsOfScreen: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, CellsOfScreen(ScreenOfDisplay(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen))); } case XCALL_DefaultDepth: DODISPLAYOP(DefaultDepth) case XCALL_DisplayHeight: DODISPLAYOP(DisplayHeight) case XCALL_DisplayHeightMM: DODISPLAYOP(DisplayHeightMM) case XCALL_DisplayPlanes: DODISPLAYOP(DisplayPlanes) case XCALL_DisplayString: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_string(DisplayString(DEREFDISPLAYHANDLE(dsHandle)->display)); } case XCALL_DisplayWidth: DODISPLAYOP(DisplayWidth) case XCALL_DisplayWidthMM: DODISPLAYOP(DisplayWidthMM) #undef DODISPLAYOP #define DODISPLAYSCREENOP(op) \ {\ Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1);\ return Make_arbitrary_precision(taskData, op(ScreenOfDisplay(DEREFDISPLAYHANDLE(dsHandle)->display,\ DEREFDISPLAYHANDLE(dsHandle)->screen)));\ } case XCALL_DoesBackingStore: DODISPLAYSCREENOP(DoesBackingStore) case XCALL_DoesSaveUnders: DODISPLAYSCREENOP(DoesSaveUnders) case XCALL_EventMaskOfScreen: DODISPLAYSCREENOP(EventMaskOfScreen) case XCALL_MaxCmapsOfScreen: DODISPLAYSCREENOP(MaxCmapsOfScreen) case XCALL_MinCmapsOfScreen: DODISPLAYSCREENOP(MinCmapsOfScreen) #undef DODISPLAYSCREENOP case XCALL_ProtocolRevision: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, ProtocolRevision(DEREFDISPLAYHANDLE(dsHandle)->display)); } case XCALL_ProtocolVersion: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, ProtocolVersion(DEREFDISPLAYHANDLE(dsHandle)->display)); } case XCALL_ServerVendor: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_string (ServerVendor(DEREFDISPLAYHANDLE(dsHandle)->display)); } case XCALL_VendorRelease: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, VendorRelease(DEREFDISPLAYHANDLE(dsHandle)->display)); } /* Drawing Primitives 300 */ case XCALL_XClearArea: XClearArea(GetDisplay(taskData, XP1), GetWindow(taskData, XP1), GetRectX(taskData, P2), GetRectY(taskData, P2), GetRectW(taskData, P2), GetRectH(taskData, P2), get_C_ulong(taskData, P3)); break; case XCALL_XClearWindow: XClearWindow(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XCopyArea: XCopyArea(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetDrawable(taskData, XP2), GetGC(taskData, XP3), GetPointX(taskData, P4), GetPointY(taskData, P4), GetRectW(taskData, P5), GetRectH(taskData, P5), GetRectX(taskData, P5), GetRectY(taskData, P5)); break; case XCALL_XCopyPlane: XCopyPlane(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetDrawable(taskData, XP2), GetGC(taskData, XP3), GetPointX(taskData, P4), GetPointY(taskData, P4), GetRectW(taskData, P5), GetRectH(taskData, P5), GetRectX(taskData, P5), GetRectY(taskData, P5), get_C_ulong(taskData, P6)); break; case XCALL_XDrawArc: XDrawArc(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetRectX(taskData, GetArcR(P3)), GetRectY(taskData, GetArcR(P3)), GetRectW(taskData, GetArcR(P3)), GetRectH(taskData, GetArcR(P3)), GetArcA1(taskData, P3), GetArcA2(taskData, P3)); break; case XCALL_XDrawArcs: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XArc *L = (XArc *)alloca(N * sizeof(XArc)); GetList4(taskData, DEREFWORD(list), L, sizeof(XArc), GetArcs); XDrawArcs(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), L, N); } } break; case XCALL_XDrawImageString: XDrawImageString(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3), GetString(P4)->chars, GetString(P4)->length); break; case XCALL_XDrawImageString16: { Handle list = SAVE(P4); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XChar2b *L = (XChar2b *)alloca(N * sizeof(XChar2b)); GetList4(taskData, DEREFWORD(list),L, sizeof(XChar2b), GetChar2); XDrawImageString16(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),GetPointX(taskData, P3),GetPointY(taskData, P3),L,N); } } break; case XCALL_XDrawLine: XDrawLine(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3), GetPointX(taskData, P4), GetPointY(taskData, P4)); break; case XCALL_XDrawLines: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XPoint *L = (XPoint *)alloca(N * sizeof(XPoint)); GetList4(taskData, DEREFWORD(list), L, sizeof(XPoint), GetPoints); XDrawLines(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), L, N, get_C_ulong(taskData, P4)); } } break; case XCALL_XDrawPoint: XDrawPoint(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3)); break; case XCALL_XDrawPoints: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XPoint *L = (XPoint *)alloca(N * sizeof(XPoint)); GetList4(taskData, DEREFWORD(list),L,sizeof(XPoint),GetPoints); XDrawPoints(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), L, N, get_C_ulong(taskData, P4)); } } break; case XCALL_XDrawRectangle: XDrawRectangle(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetRectX(taskData, P3), GetRectY(taskData, P3), GetRectW(taskData, P3), GetRectH(taskData, P3)); break; case XCALL_XDrawRectangles: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XRectangle *L = (XRectangle *)alloca(N * sizeof(XRectangle)); GetList4(taskData, DEREFWORD(list),L,sizeof(XRectangle),GetRects); XDrawRectangles(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),L,N); } } break; case XCALL_XDrawSegments: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XSegment *L = (XSegment *)alloca(N * sizeof(XSegment)); GetList4(taskData, DEREFWORD(list),L,sizeof(XSegment),GetSegments); XDrawSegments(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),L,N); } } break; case XCALL_XDrawString: XDrawString(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3), GetString(P4)->chars, GetString(P4)->length); break; case XCALL_XDrawString16: { Handle list = SAVE(P4); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XChar2b *L = (XChar2b *)alloca(N * sizeof(XChar2b)); GetList4(taskData, DEREFWORD(list),L,sizeof(XChar2b),GetChar2); XDrawString16(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),GetPointX(taskData, P3),GetPointY(taskData, P3),L,N); } } break; case XCALL_XDrawText: { Handle list = SAVE(P4); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XTextItem *L = (XTextItem *)alloca(N * sizeof(XTextItem)); GetList4(taskData, DEREFWORD(list),L,sizeof(XTextItem),GetText); XDrawText(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),GetPointX(taskData, P3),GetPointY(taskData, P3),L,N); while (N--) { free(L->chars); L++; } } } break; case XCALL_XDrawText16: { Handle list = SAVE(P4); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XTextItem16 *L = (XTextItem16 *)alloca(N * sizeof(XTextItem16)); GetList4(taskData, DEREFWORD(list),L,sizeof(XTextItem16), GetText16); XDrawText16(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),GetPointX(taskData, P3),GetPointY(taskData, P3),L,N); while (N--) { free(L->chars); L++; } } } break; case XCALL_XFillArc: XFillArc(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetRectX(taskData, GetArcR(P3)), GetRectY(taskData, GetArcR(P3)), GetRectW(taskData, GetArcR(P3)), GetRectH(taskData, GetArcR(P3)), GetArcA1(taskData, P3), GetArcA2(taskData, P3)); break; case XCALL_XFillArcs: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XArc *L = (XArc *)alloca(N * sizeof(XArc)); GetList4(taskData, DEREFWORD(list),L,sizeof(XArc),GetArcs); XFillArcs(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),L,N); } } break; case XCALL_XFillPolygon: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XPoint *L = (XPoint *)alloca(N * sizeof(XPoint)); GetList4(taskData, DEREFWORD(list),L,sizeof(XPoint),GetPoints); XFillPolygon(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),L,N,get_C_ulong(taskData, P4),get_C_ulong(taskData, P5)); } } break; case XCALL_XFillRectangle: XFillRectangle(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetRectX(taskData, P3), GetRectY(taskData, P3), GetRectW(taskData, P3), GetRectH(taskData, P3)); break; case XCALL_XFillRectangles: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XRectangle *L = (XRectangle *)alloca(N * sizeof(XRectangle)); GetList4(taskData, DEREFWORD(list),L,sizeof(XRectangle),GetRects); XFillRectangles(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),L,N); } } break; /* Events 350 */ case XCALL_XSelectInput: (WindowObject(XP1))->eventMask->Set(0, PolyWord::FromUnsigned(get_C_ulong(taskData, P2))); XSelectInput(GetDisplay(taskData, XP1),GetWindow(taskData, XP1),XMASK((WindowObject(XP1))->eventMask->Get(0).AsUnsigned())); break; case XCALL_XSynchronize: XSynchronize(GetDisplay(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_GetState: return GetState(taskData, WindowObject(XP1)); /* WindowObject added SPF */ case XCALL_SetState: SetState(WindowObject(XP1),P2,P3); /* WindowObject added SPF */ break; case XCALL_NextEvent: return NextEvent(taskData, GetDS(taskData, XP1)); case XCALL_InsertTimeout: InsertTimeout(taskData, WindowObject(XP1),get_C_ulong(taskData, P2),P3,P4); /* WindowObject added SPF */ break; case XCALL_XSetInputFocus: XSetInputFocus(GetDisplay(taskData, XP1),GetWindow(taskData, XP2),get_C_ulong(taskData, P3),get_C_ulong(taskData, P4)); break; case XCALL_XGetInputFocus: return GetInputFocus(taskData, GetDS(taskData, XP1)); case XCALL_XSetSelectionOwner: SetSelectionOwner(GetDS(taskData, XP1),get_C_ulong(taskData, P2),GetWindow(taskData, XP3),get_C_ulong(taskData, P4)); break; case XCALL_XGetSelectionOwner: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return EmptyWindow(taskData, dsHandle,XGetSelectionOwner(DEREFDISPLAYHANDLE(dsHandle)->display, get_C_ulong(taskData, P2))); } case XCALL_XConvertSelection: XConvertSelection(GetDisplay(taskData, XP4), get_C_ulong(taskData, P1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), GetWindow(taskData, XP4), get_C_ulong(taskData, P5)); break; case XCALL_XSendSelectionNotify: SendSelectionNotify(GetDisplay(taskData, XP4), get_C_ulong(taskData, P1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), GetWindow(taskData, XP4), get_C_ulong(taskData, P5)); break; case XCALL_XDeleteProperty: XDeleteProperty(GetDisplay(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_XInternAtom: return InternAtom(taskData, GetDisplay(taskData, XP1),GetString(P2),get_C_long(taskData, P3)); case XCALL_XGetAtomName: return GetAtomName(taskData, GetDisplay(taskData, XP1),get_C_ulong(taskData, P2)); /* Fonts 400 */ case XCALL_XGetFontPath: return GetFontPath(taskData, GetDisplay(taskData, XP1)); case XCALL_XListFonts: return ListFonts(taskData, GetDisplay(taskData, XP1),GetString(P2),get_C_ulong(taskData, P3)); case XCALL_XListFontsWithInfo: return ListFontsWithInfo(taskData, GetDS(taskData, XP1),GetString(P2),get_C_ulong(taskData, P3)); case XCALL_XLoadFont: return LoadFont(taskData, GetDS(taskData, XP1),GetString(P2)); case XCALL_XLoadQueryFont: return LoadQueryFont(taskData, GetDS(taskData, XP1),GetString(P2)); case XCALL_XQueryFont: return QueryFont(taskData, GetDS(taskData, XP1),GetFont(taskData, XP1)); case XCALL_XSetFontPath: SetFontPath(taskData, GetDisplay(taskData, XP1),SAVE(P2)); break; /* Grabbing 450 */ /* Graphics Context 500 */ case XCALL_DefaultGC: return GetDefaultGC(taskData, GetDS(taskData, XP1)); case XCALL_UpdateGC: ChangeGC(taskData, GCObject(XP1),get_C_ulong(taskData, P2),P3); break; case XCALL_XCreateGC: return CreateGC(taskData, GetDS(taskData, XP1),GetDrawable(taskData, XP1)); case XCALL_XSetClipRectangles: SetClipRectangles(taskData, GetDisplay(taskData, XP1), GetGC(taskData, XP1), GetPointX(taskData, P2), GetPointY(taskData, P2), SAVE(P3), get_C_ulong(taskData, P4)); break; case XCALL_XSetDashes: SetDashes(taskData, GetDisplay(taskData, XP1), GetGC(taskData, XP1), get_C_ulong(taskData, P2), SAVE(P3)); break; /* Images 550 */ case XCALL_XAddPixel: AddPixel(GetXImage(taskData, GetDisplay(taskData, XP1),P2),get_C_ulong(taskData, P3)); break; case XCALL_XGetImage: return GetImage(taskData, GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetRectX(taskData, P2), GetRectY(taskData, P2), GetRectW(taskData, P2), GetRectH(taskData, P2), get_C_ulong(taskData, P3), get_C_long(taskData, P4)); case XCALL_XGetPixel: return GetPixel(taskData, GetXImage(taskData, GetDisplay(taskData, XP1),P2), GetPointX(taskData, P3), GetPointY(taskData, P3)); case XCALL_XGetSubImage: GetSubImage(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetRectX(taskData, P2), GetRectY(taskData, P2), GetRectW(taskData, P2), GetRectH(taskData, P2), get_C_ulong(taskData, P3), get_C_long(taskData, P4), GetXImage(taskData, GetDisplay(taskData, XP1),P5), GetPointX(taskData, P6), GetPointY(taskData, P6)); break; case XCALL_XPutImage: PutImage(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetXImage(taskData, GetDisplay(taskData, XP1),P3), GetPointX(taskData, P4), GetPointY(taskData, P4), GetRectX(taskData, P5), GetRectY(taskData, P5), GetRectW(taskData, P5), GetRectH(taskData, P5)); break; case XCALL_XPutPixel: PutPixel(GetXImage(taskData, GetDisplay(taskData, XP1),P2), GetPointX(taskData, P3), GetPointY(taskData, P3), get_C_ulong(taskData, P4)); break; case XCALL_XSubImage: return SubImage(taskData, GetXImage(taskData, GetDisplay(taskData, XP1),P2), GetRectX(taskData, P3), GetRectY(taskData, P3), GetRectW(taskData, P3), GetRectH(taskData, P3)); case XCALL_BitmapBitOrder: return Make_arbitrary_precision(taskData, MLImageOrder(BitmapBitOrder(GetDisplay(taskData, XP1)))); case XCALL_BitmapPad: return Make_arbitrary_precision(taskData, BitmapPad(GetDisplay(taskData, XP1))); case XCALL_BitmapUnit: return Make_arbitrary_precision(taskData, BitmapUnit(GetDisplay(taskData, XP1))); case XCALL_ByteOrder: return Make_arbitrary_precision(taskData, MLImageOrder(ImageByteOrder(GetDisplay(taskData, XP1)))); /* Keyboard 600 */ case XCALL_XLookupString: return LookupString(taskData, GetDisplay(taskData, XP1),get_C_ulong(taskData, P2),get_C_ulong(taskData, P3)); case XCALL_XQueryKeymap: return QueryKeymap(taskData, GetDisplay(taskData, XP1)); case XCALL_IsCursorKey: return Make_bool(IsCursorKey(get_C_ulong(taskData, P1))); case XCALL_IsFunctionKey: return Make_bool(IsFunctionKey(get_C_ulong(taskData, P1))); case XCALL_IsKeypadKey: return Make_bool(IsKeypadKey(get_C_ulong(taskData, P1))); case XCALL_IsMiscFunctionKey: return Make_bool(IsMiscFunctionKey(get_C_ulong(taskData, P1))); case XCALL_IsModifierKey: return Make_bool(IsModifierKey(get_C_ulong(taskData, P1))); case XCALL_IsPFKey: return Make_bool(IsPFKey(get_C_ulong(taskData, P1))); /* Output Buffer 650 */ case XCALL_XFlush: XFlush(GetDisplay(taskData, XP1)); break; case XCALL_XSync: XSync(GetDisplay(taskData, XP1),get_C_ulong(taskData, P2)); break; /* Pointers 700 */ case XCALL_XQueryPointer: return QueryPointer(taskData, GetDS(taskData, XP1),GetWindow(taskData, XP1)); /* Regions 750*/ /* SAVE Set 800 */ /* Screen Saver 850 */ case XCALL_XActivateScreenSaver: XActivateScreenSaver(GetDisplay(taskData, XP1)); break; case XCALL_XForceScreenSaver: XForceScreenSaver(GetDisplay(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_XGetScreenSaver: return GetScreenSaver(taskData, GetDisplay(taskData, XP1)); case XCALL_XResetScreenSaver: XResetScreenSaver(GetDisplay(taskData, XP1)); break; case XCALL_XSetScreenSaver: XSetScreenSaver(GetDisplay(taskData, XP1), get_C_long(taskData, P2), get_C_long(taskData, P3), get_C_ulong(taskData, P4), get_C_ulong(taskData, P5)); break; /* Standard Geometry 900 */ case XCALL_XTranslateCoordinates: return TranslateCoordinates(taskData, GetDS(taskData, XP1), GetWindow(taskData, XP1), GetWindow(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3)); /* Text 950 */ case XCALL_XTextExtents: return TextExtents(taskData, GetFontStruct(taskData, P1),GetString(P2)); case XCALL_XTextExtents16: return TextExtents16(taskData, GetFontStruct(taskData, P1),SAVE(P2)); case XCALL_XTextWidth: return TextWidth(taskData, GetFontStruct(taskData, P1),GetString(P2)); case XCALL_XTextWidth16: return TextWidth16(taskData, GetFontStruct(taskData, P1),SAVE(P2)); /* Tiles, Pixmaps, Stipples and Bitmaps 1000 */ case XCALL_XCreateBitmapFromData: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); CheckZeroRect(taskData, P3); return EmptyPixmap(taskData, dsHandle, XCreateBitmapFromData( DEREFDISPLAYHANDLE(dsHandle)->display, GetDrawable(taskData, XP1), /* drawable */ GetString(P2)->chars, /* data */ GetRectW(taskData, P3), /* width */ GetRectH(taskData, P3))); /* height */ } case XCALL_XCreatePixmap: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); CheckZeroRect(taskData, P2); return EmptyPixmap(taskData, dsHandle, XCreatePixmap( DEREFDISPLAYHANDLE(dsHandle)->display, GetDrawable(taskData, XP1), /* drawable */ GetRectW(taskData, P2), /* width */ GetRectH(taskData, P2), /* height */ get_C_ulong(taskData, P3))); /* depth */ } case XCALL_XCreatePixmapFromBitmapData: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); CheckZeroRect(taskData, P3); return EmptyPixmap(taskData, dsHandle, XCreatePixmapFromBitmapData( DEREFDISPLAYHANDLE(dsHandle)->display, GetDrawable(taskData, XP1), /* drawable */ GetString(P2)->chars, /* data */ GetRectW(taskData, P3), /* width */ GetRectH(taskData, P3), /* height */ get_C_ulong(taskData, P4), /* foreground */ get_C_ulong(taskData, P5), /* background */ get_C_ulong(taskData, P6))); /* depth */ } case XCALL_XQueryBestStipple: CheckZeroRect(taskData, P2); return QueryBest(taskData, XQueryBestStipple, GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetRectW(taskData, P2), GetRectH(taskData, P2)); case XCALL_XQueryBestTile: CheckZeroRect(taskData, P2); return QueryBest(taskData, XQueryBestTile, GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetRectW(taskData, P2), GetRectH(taskData, P2)); case XCALL_XReadBitmapFile: return ReadBitmap(taskData, GetDS(taskData, XP1),GetDrawable(taskData, XP1),GetString(P2)); case XCALL_XWriteBitmapFile: CheckZeroRect(taskData, P3); return WriteBitmapFile(taskData, GetString(XP1), GetDisplay(taskData, XP2), GetPixmap(taskData, XP2), GetRectW(taskData, P3), GetRectH(taskData, P3), GetPointX(taskData, P4), GetPointY(taskData, P4)); /* User Preferences 1050 */ case XCALL_XAutoRepeatOff: XAutoRepeatOff(GetDisplay(taskData, XP1)); break; case XCALL_XAutoRepeatOn: XAutoRepeatOn (GetDisplay(taskData, XP1)); break; case XCALL_XBell: XBell(GetDisplay(taskData, XP1),get_C_short(taskData, P2)); break; case XCALL_XGetDefault: return GetDefault(taskData, GetDisplay(taskData, XP1),GetString(P2),GetString(P3)); /* Window Attributes 1100 */ case XCALL_ChangeWindow: ChangeWindowAttributes(taskData, WindowObject(XP1),get_C_ulong(taskData, P2),P3); break; case XCALL_XGetGeometry: return GetGeometry(taskData, GetDS(taskData, XP1),GetDrawable(taskData, XP1)); case XCALL_XGetWindowAttributes: return GetWindowAttributes(taskData, GetDS(taskData, XP1),GetDrawable(taskData, XP1)); case XCALL_XSetWindowBorderWidth: XSetWindowBorderWidth(GetDisplay(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); break; /* Window Configuration 1150 */ case XCALL_XCirculateSubwindows: XCirculateSubwindows(GetDisplay(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_XConfigureWindow: ConfigureWindow(taskData, GetDisplay(taskData, XP1),GetWindow(taskData, XP1), P2); break; case XCALL_XLowerWindow: XLowerWindow(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XMapRaised: XMapRaised(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XMapSubwindows: XMapSubwindows(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XMapWindow: XMapWindow(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XMoveResizeWindow: CheckZeroRect(taskData, P3); XMoveResizeWindow(GetDisplay(taskData, XP1), GetWindow(taskData, XP1), GetPointX(taskData, P2), GetPointY(taskData, P2), GetRectW(taskData, P3), GetRectH(taskData, P3)); break; case XCALL_XMoveWindow: XMoveWindow(GetDisplay(taskData, XP1), GetWindow(taskData, XP1), GetPointX(taskData, P2), GetPointY(taskData, P2)); break; case XCALL_XQueryTree: return QueryTree(taskData,GetDS(taskData, XP1),GetWindow(taskData, XP1)); case XCALL_XRaiseWindow: XRaiseWindow(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XReparentWindow: XReparentWindow(GetDisplay(taskData, XP1), GetWindow(taskData, XP1), GetWindow(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3)); break; case XCALL_XResizeWindow: CheckZeroRect(taskData, P2); XResizeWindow(GetDisplay(taskData, XP1), GetWindow(taskData, XP1), GetRectW(taskData, P2), GetRectH(taskData, P2)); break; case XCALL_XRestackWindows: RestackWindows(taskData, SAVE(P1)); break; case XCALL_XUnmapSubwindows: XUnmapSubwindows(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XUnmapWindow: XUnmapWindow(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; /* Window Existence 1200 */ case XCALL_RootWindow: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return EmptyWindow(taskData, dsHandle, RootWindow(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } case XCALL_DestroyXObject: DestroyXObject(XP1); break; case XCALL_XDestroySubwindows: DestroySubwindows(XP1); break; case XCALL_XCreateSimpleWindow: CheckZeroRect(taskData, P3); return CreateSimpleWindow(taskData, SAVE(XP1), /* parent */ GetPointX(taskData, P2), /* x */ GetPointY(taskData, P2), /* y */ GetRectW(taskData, P3), /* w */ GetRectH(taskData, P3), /* h */ get_C_ulong(taskData, P4), /* borderWidth */ get_C_ulong(taskData, P5), /* border */ get_C_ulong(taskData, P6), /* background */ SAVE(P7), /* handler */ SAVE(P8)); /* state */ case XCALL_XCreateWindow: CheckZeroRect(taskData, P3); return CreateWindow(taskData, SAVE(XP1), /* parent */ GetPointX(taskData, P2), /* x */ GetPointY(taskData, P2), /* y */ GetRectW(taskData, P3), /* w */ GetRectH(taskData, P3), /* h */ get_C_ulong(taskData, P4), /* borderWidth */ get_C_ulong(taskData, P5), /* depth */ get_C_ulong(taskData, P6), /* class */ GetVisual(taskData, XP7), /* visual */ SAVE(P8), /* handler */ SAVE(P9)); /* state */ /* Window Manager 1250 */ case XCALL_XSetProperty: SetProperty(taskData, GetDisplay(taskData, XP1), GetWindow(taskData, XP1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), SAVE(P4), get_C_ulong(taskData, P5)); break; case XCALL_XGetTextProperty: return GetTextProperty(taskData, GetDisplay(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); case XCALL_XGetWMHints: return GetWMHints(taskData, GetDS(taskData, XP1),GetWindow(taskData, XP1)); case XCALL_XGetWMSizeHints: return GetWMSizeHints(taskData, GetDisplay(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); case XCALL_XGetIconSizes: return GetIconSizes(taskData, GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); case XCALL_XGetTransientForHint: return GetTransientForHint(taskData, GetDS(taskData, XP1),GetWindow(taskData, XP1)); case XCALL_XGetWMColormapWindows: return GetWMColormapWindows(taskData, GetDS(taskData, XP1),GetWindow(taskData, XP1)); case XCALL_XGetRGBColormaps: return GetRGBColormaps(taskData, GetDS(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); case XCALL_XWMGeometry: return WMGeometry(taskData, GetDS(taskData, XP1), GetString(P2), GetString(P3), get_C_ulong(taskData, P4), P5); /* Miscellaneous 1300 */ case XCALL_GetID: return GetID(taskData, XP1); case XCALL_ResourceExists: return Make_bool(ResourceExists(XP1)); case XCALL_GetDisplay: return GetDS(taskData, XP1); /******************************************************************************/ /* */ /* Xt Calls */ /* */ /******************************************************************************/ case XCALL_NoWidget: return EmptyWidget(taskData, SAVE(ListNull), (Widget)NULL); case XCALL_AppInitialise: return AppInitialise(taskData, P1, /* display name */ P2, /* application name */ P3, /* application class */ SAVE(P4), /* Fallback list */ SAVE(P5) /* Arg list */); case XCALL_XtRealizeWidget: XtRealizeWidget(GetWidget(taskData, XP1)); break; case XCALL_XtManageChildren: ManageChildren(taskData, SAVE(P1)); break; case XCALL_XtUnmanageChildren: UnmanageChildren(taskData, SAVE(P1)); break; case XCALL_XtDestroyWidget: { Widget w = GetWidget(taskData, XP1); XtDestroyWidget(w); /* The following test seems necessary - sometimes the callback from */ /* the above call destroys the widget, sometimes it doesn't. I think */ /* it always should, and I can't work out why this strange behaviour */ /* occurs. SPF 9/12/93 */ if (ResourceExists(XP1)) { DestroyXObject(XP1); PurgeCCallbacks((X_Widget_Object *)XP1,w); } break; } case XCALL_SetCallbacks: SetCallbacks (taskData, WidgetObject(taskData, XP1),P2,P3); break; /* WidgetObject added SPF */ case XCALL_XtSetValues: SetValues(taskData, GetWidget(taskData, XP1),SAVE(P2)); break; case XCALL_GetValue: return GetValue(taskData, GetDS(taskData, XP1),GetWidget(taskData, XP1),P2); case XCALL_XtParent: return EmptyWidget(taskData, GetDS(taskData, XP1),XtParent(GetWidget(taskData, XP1))); case XCALL_XtWindow: return EmptyWindow(taskData, GetDS(taskData, XP1),WindowOfWidget(GetWidget(taskData, XP1))); case XCALL_XtDisplay: return GetDS(taskData, XP1); case XCALL_XtUnrealizeWidget: XtUnrealizeWidget(GetWidget(taskData, XP1)); break; case XCALL_XtName: return Make_string(XtName(GetWidget(taskData, XP1))); case XCALL_XtParseTranslationTable: return ParseTranslationTable(taskData, GetString(XP1)); case XCALL_XtOverrideTranslations: XtOverrideTranslations(GetWidget(taskData, XP1),GetTrans(taskData, XP2)); break; case XCALL_XtAugmentTranslations: XtAugmentTranslations(GetWidget(taskData, XP1),GetTrans(taskData, XP2)); break; case XCALL_XtUninstallTranslations: XtUninstallTranslations(GetWidget(taskData, XP1)); break; /* case XCALL_XtTranslateTablePrint: _XtTranslateTablePrint(GetTrans(taskData, XP1)); break; */ case XCALL_XtCreatePopupShell: return CreatePopupShell(taskData, GetString(XP1),GetDS(taskData, XP2),GetWidget(taskData, XP2),SAVE(P3)); case XCALL_InsertWidgetTimeout: InsertWidgetTimeout(taskData, WidgetObject(taskData, XP1),get_C_ulong(taskData, P2),P3,P4); break; /* WidgetObject added SPF */ case XCALL_GetWidgetState: return SAVE(WidgetObjectToken(XP1)->state); /* was WidgetObject(XP1) (SPF) */ case XCALL_SetWidgetState: WidgetObjectToken(XP1)->state = P2; break; /* was WidgetObject(XP1) (SPF) */ case XCALL_XtSetSensitive: XtSetSensitive(GetWidget(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_XtIsSensitive: return Make_bool(XtIsSensitive(GetWidget(taskData, XP1))); case XCALL_GetSubresources: return GetSubresources(taskData, GetDS(taskData, XP1), GetWidget(taskData, XP1), GetString(P2), GetString(P3), SAVE(P4)); case XCALL_Cast: return SAVE(P1); case XCALL_XtPopup: XtPopup(GetWidget(taskData, XP1),GetXtGrabKind(taskData, P2)); break; case XCALL_XtPopdown: XtPopdown(GetWidget(taskData, XP1)); break; case XCALL_XtMapWidget: XtMapWidget(GetRealizedWidget(taskData, (char *) "XtMapWidget",XP1)); break; case XCALL_XtUnmapWidget: XtUnmapWidget(GetRealizedWidget(taskData, (char *) "XtUnmapWidget",XP1)); break; case XCALL_XtIsManaged: return Make_bool(XtIsManaged(GetWidget(taskData, XP1))); case XCALL_XtIsRealized: return Make_bool(XtIsRealized(GetWidget(taskData, XP1))); /* Added DCJM. */ case XCALL_XtGetApplicationResources: return GetApplicationResources (taskData, GetDS(taskData, XP1),GetWidget(taskData, XP1),SAVE(P2) ) ; case XCALL_XtAddEventHandler: AddEventhandler (taskData, WidgetObject(taskData, XP1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), SAVE(P4)); break; /******************************************************************************/ /* */ /* Motif Calls - widget creation */ /* */ /******************************************************************************/ /* Motif 4000 */ #define XMCREATE(number,name) \ case number: return CreateXm(taskData, name, (char *) \ #name " failed", \ GetDS(taskData, XP1), \ GetWidget(taskData, XP1), \ GetString(P2), \ SAVE(P3)) XMCREATE(XCALL_XmCreateArrowButton,XmCreateArrowButton); XMCREATE(XCALL_XmCreateArrowButtonGadget,XmCreateArrowButtonGadget); XMCREATE(XCALL_XmCreateBulletinBoard,XmCreateBulletinBoard); XMCREATE(XCALL_XmCreateBulletinBoardDialog,XmCreateBulletinBoardDialog); XMCREATE(XCALL_XmCreateCascadeButton,XmCreateCascadeButton); XMCREATE(XCALL_XmCreateCascadeButtonGadget,XmCreateCascadeButtonGadget); XMCREATE(XCALL_XmCreateCommand,XmCreateCommand); XMCREATE(XCALL_XmCreateDialogShell,XmCreateDialogShell); XMCREATE(XCALL_XmCreateDrawingArea,XmCreateDrawingArea); XMCREATE(XCALL_XmCreateDrawnButton,XmCreateDrawnButton); XMCREATE(XCALL_XmCreateErrorDialog,XmCreateErrorDialog); XMCREATE(XCALL_XmCreateFileSelectionBox,XmCreateFileSelectionBox); XMCREATE(XCALL_XmCreateFileSelectionDialog,XmCreateFileSelectionDialog); XMCREATE(XCALL_XmCreateForm,XmCreateForm); XMCREATE(XCALL_XmCreateFormDialog,XmCreateFormDialog); XMCREATE(XCALL_XmCreateFrame,XmCreateFrame); XMCREATE(XCALL_XmCreateInformationDialog,XmCreateInformationDialog); XMCREATE(XCALL_XmCreateLabel,XmCreateLabel); XMCREATE(XCALL_XmCreateLabelGadget,XmCreateLabelGadget); XMCREATE(XCALL_XmCreateList,XmCreateList); XMCREATE(XCALL_XmCreateMainWindow,XmCreateMainWindow); XMCREATE(XCALL_XmCreateMenuBar,XmCreateMenuBar); XMCREATE(XCALL_XmCreateMenuShell,XmCreateMenuShell); XMCREATE(XCALL_XmCreateMessageBox,XmCreateMessageBox); XMCREATE(XCALL_XmCreateMessageDialog,XmCreateMessageDialog); XMCREATE(XCALL_XmCreateOptionMenu,XmCreateOptionMenu); XMCREATE(XCALL_XmCreatePanedWindow,XmCreatePanedWindow); XMCREATE(XCALL_XmCreatePopupMenu,XmCreatePopupMenu); XMCREATE(XCALL_XmCreatePromptDialog,XmCreatePromptDialog); XMCREATE(XCALL_XmCreatePulldownMenu,XmCreatePulldownMenu); XMCREATE(XCALL_XmCreatePushButton,XmCreatePushButton); XMCREATE(XCALL_XmCreatePushButtonGadget,XmCreatePushButtonGadget); XMCREATE(XCALL_XmCreateQuestionDialog,XmCreateQuestionDialog); XMCREATE(XCALL_XmCreateRadioBox,XmCreateRadioBox); XMCREATE(XCALL_XmCreateRowColumn,XmCreateRowColumn); XMCREATE(XCALL_XmCreateScale,XmCreateScale); XMCREATE(XCALL_XmCreateScrollBar,XmCreateScrollBar); XMCREATE(XCALL_XmCreateScrolledList,XmCreateScrolledList); XMCREATE(XCALL_XmCreateScrolledText,XmCreateScrolledText); XMCREATE(XCALL_XmCreateScrolledWindow,XmCreateScrolledWindow); XMCREATE(XCALL_XmCreateSelectionBox,XmCreateSelectionBox); XMCREATE(XCALL_XmCreateSelectionDialog,XmCreateSelectionDialog); XMCREATE(XCALL_XmCreateSeparator,XmCreateSeparator); XMCREATE(XCALL_XmCreateSeparatorGadget,XmCreateSeparatorGadget); XMCREATE(XCALL_XmCreateSimpleCheckBox,XmCreateSimpleCheckBox); XMCREATE(XCALL_XmCreateSimpleMenuBar,XmCreateSimpleMenuBar); XMCREATE(XCALL_XmCreateSimpleOptionMenu,XmCreateSimpleOptionMenu); XMCREATE(XCALL_XmCreateSimplePopupMenu,XmCreateSimplePopupMenu); XMCREATE(XCALL_XmCreateSimplePulldownMenu,XmCreateSimplePulldownMenu); XMCREATE(XCALL_XmCreateSimpleRadioBox,XmCreateSimpleRadioBox); XMCREATE(XCALL_XmCreateText,XmCreateText); XMCREATE(XCALL_XmCreateTextField,XmCreateTextField); XMCREATE(XCALL_XmCreateToggleButton,XmCreateToggleButton); XMCREATE(XCALL_XmCreateToggleButtonGadget,XmCreateToggleButtonGadget); XMCREATE(XCALL_XmCreateWarningDialog,XmCreateWarningDialog); XMCREATE(XCALL_XmCreateWorkArea,XmCreateWorkArea); XMCREATE(XCALL_XmCreateWorkingDialog,XmCreateWorkingDialog); #undef XMCREATE /******************************************************************************/ /* */ /* Motif Calls - miscellaneous */ /* */ /******************************************************************************/ case XCALL_XmCascadeButtonHighlight: XmCascadeButtonHighlight(GetWidget(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_XmCommandError: CommandError(taskData, GetWidget(taskData, XP1),P2); break; case XCALL_XmCommandGetChild: return EmptyWidget(taskData, GetDS(taskData, XP1), XmCommandGetChild(GetWidget(taskData, XP1),get_C_ulong(taskData, P2))); case XCALL_XmFileSelectionBoxGetChild: return EmptyWidget(taskData, GetDS(taskData, XP1), XmFileSelectionBoxGetChild(GetWidget(taskData, XP1),get_C_ulong(taskData, P2))); case XCALL_XmFileSelectionDoSearch: FileSelectionDoSearch(taskData, GetWidget(taskData, XP1),P2); break; case XCALL_XmIsSomething: return XmIsSomething(taskData, get_C_ulong(taskData, P1),GetWidget(taskData, XP2)); case XCALL_XmMainWindowSetAreas: XmMainWindowSetAreas(GetWidget(taskData, XP1), GetNWidget(taskData, XP2), GetNWidget(taskData, XP3), GetNWidget(taskData, XP4), GetNWidget(taskData, XP5), GetNWidget(taskData, XP6)); break; case XCALL_XmMainWindowSepX: switch(get_C_ulong(taskData, P2)) { case 1: return EmptyWidget(taskData, GetDS(taskData, XP1),XmMainWindowSep1(GetWidget(taskData, XP1))); case 2: return EmptyWidget(taskData, GetDS(taskData, XP1),XmMainWindowSep2(GetWidget(taskData, XP1))); default: return EmptyWidget(taskData, GetDS(taskData, XP1),XmMainWindowSep3(GetWidget(taskData, XP1))); } case XCALL_XmMessageBoxGetChild: return EmptyWidget(taskData, GetDS(taskData, XP1), XmMessageBoxGetChild(GetWidget(taskData, XP1),get_C_ulong(taskData, P2))); case XCALL_XmOptionButtonGadget: return EmptyWidget(taskData, GetDS(taskData, XP1),XmOptionButtonGadget(GetWidget(taskData, XP1))); case XCALL_XmOptionLabelGadget: return EmptyWidget(taskData, GetDS(taskData, XP1),XmOptionLabelGadget (GetWidget(taskData, XP1))); case XCALL_XmSelectionBoxGetChild: return EmptyWidget(taskData, GetDS(taskData, XP1), XmSelectionBoxGetChild(GetWidget(taskData, XP1),get_C_ulong(taskData, P2))); case XCALL_XmSetMenuCursor: XmSetMenuCursor(GetDisplay(taskData, XP1),GetCursor(taskData, XP2)); break; case XCALL_XmScrolledWindowSetAreas: XmScrolledWindowSetAreas(GetWidget(taskData, XP1), GetNWidget(taskData, XP2), GetNWidget(taskData, XP3), GetNWidget(taskData, XP4)); break; /******************************************************************************/ /* */ /* Operations on XmText widgets */ /* */ /******************************************************************************/ #define TextWidgetToLong(func) \ case XCALL_ ## func : \ return(WidgetToLong(taskData,(char *) #func,GetTextWidget,func,XP1)) #define TextWidgetToInt(func) \ case XCALL_ ## func : \ return(WidgetToInt(taskData,(char *) #func,GetTextWidget,func,XP1)) #define TextWidgetToBool(func) \ case XCALL_ ## func : \ return(WidgetToBool(taskData,(char *) #func,GetTextWidget,func,XP1)) #define TextWidgetToString(func) \ case XCALL_ ## func : \ return(WidgetToString(taskData,(char *) #func,GetTextWidget,func,XP1)) #define TextWidgetIntAction(func) \ case XCALL_ ## func : \ WidgetIntAction(taskData,(char *) #func,GetTextWidget,func,XP1,P2); \ break #define TextWidgetLongAction(func) \ case XCALL_ ## func : \ WidgetLongAction(taskData,(char *) #func,GetTextWidget,func,XP1,P2); \ break #define TextWidgetBoolAction(func) \ case XCALL_ ## func : \ WidgetBoolAction(taskData,(char *) #func,GetTextWidget,func,XP1,P2); \ break /* XmTextClearSelection not supported */ /* XmTextCopy not supported */ /* XmTextCut not supported */ #ifdef LESSTIF_VERSION /* This is not supported in LessTif, at least not 0.89. */ case XCALL_XmTextGetAddMode: RaiseXWindows(taskData, "XmTextGetAddMode: not implemented"); #else TextWidgetToBool(XmTextGetAddMode); #endif TextWidgetToLong(XmTextGetCursorPosition); TextWidgetToInt(XmTextGetBaseline); TextWidgetToBool(XmTextGetEditable); TextWidgetToLong(XmTextGetInsertionPosition); TextWidgetToLong(XmTextGetLastPosition); TextWidgetToInt(XmTextGetMaxLength); TextWidgetToString(XmTextGetSelection); /* XmTextGetSelectionPosition not supported */ TextWidgetToString(XmTextGetString); /* XmTextGetSource not supported */ TextWidgetToLong(XmTextGetTopCharacter); case XCALL_XmTextInsert: { Widget w = GetTextWidget(taskData, (char *) "XmTextInsert",XP1); { unsigned pos = get_C_ulong(taskData, P2); PolyStringObject *s = GetString(P3); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextInsert(w,pos,buffer); break; } } TextWidgetToBool(XmTextPaste); /* with side effect! */ /* XmTextPosToXY not supported */ TextWidgetToBool(XmTextRemove); /* with side effect! */ case XCALL_XmTextReplace: { Widget w = GetTextWidget(taskData, (char *) "XmTextReplace",XP1); { unsigned from_pos = get_C_ulong(taskData, P2); unsigned to_pos = get_C_ulong(taskData, P3); PolyStringObject *s = GetString(P4); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextReplace(w,from_pos,to_pos,buffer); break; } } TextWidgetIntAction(XmTextScroll); /* for side effect! */ TextWidgetBoolAction(XmTextSetAddMode); TextWidgetLongAction(XmTextSetCursorPosition); TextWidgetBoolAction(XmTextSetEditable); /* XmTextSetHighlight not supported */ TextWidgetLongAction(XmTextSetInsertionPosition); TextWidgetIntAction(XmTextSetMaxLength); /* XmTextSetSelection not supported */ /* XmTextSetSource not supported */ /* inlined SPF 15/2/94 */ case XCALL_XmTextSetString: { Widget w = GetTextWidget(taskData, (char *) "XmTextSetString",XP1); { PolyStringObject *s = GetString(P2); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextSetString(w,buffer); break; } } TextWidgetLongAction(XmTextSetTopCharacter); TextWidgetLongAction(XmTextShowPosition); case XCALL_XmTextXYToPos: { Widget w = GetTextWidget(taskData, (char *) "XmTextXYToPos",XP1); { int x = get_C_long(taskData, P2); int y = get_C_long(taskData, P3); return Make_int(XmTextXYToPos(w,x,y)); } } #undef TextWidgetToLong #undef TextWidgetToInt #undef TextWidgetToBool #undef TextWidgetToString #undef TextWidgetIntAction #undef TextWidgetBoolAction /******************************************************************************/ /* */ /* Operations on XmTextField widgets */ /* */ /******************************************************************************/ #define TextFieldWidgetToLong(func) \ case XCALL_ ## func : \ return(WidgetToLong(taskData, (char *) #func,GetTextFieldWidget,func,XP1)) #define TextFieldWidgetToInt(func) \ case XCALL_ ## func : \ return(WidgetToInt(taskData, (char *) #func,GetTextFieldWidget,func,XP1)) #define TextFieldWidgetToBool(func) \ case XCALL_ ## func : \ return(WidgetToBool(taskData, (char *) #func,GetTextFieldWidget,func,XP1)) #define TextFieldWidgetToString(func) \ case XCALL_ ## func : \ return(WidgetToString(taskData, (char *) #func,GetTextFieldWidget,func,XP1)) #define TextFieldWidgetIntAction(func) \ case XCALL_ ## func : \ WidgetIntAction(taskData, (char *) #func,GetTextFieldWidget,func,XP1,P2); \ break #define TextFieldWidgetLongAction(func) \ case XCALL_ ## func : \ WidgetLongAction(taskData, (char *) #func,GetTextFieldWidget,func,XP1,P2); \ break #define TextFieldWidgetBoolAction(func) \ case XCALL_ ## func : \ WidgetBoolAction(taskData, (char *) #func,GetTextFieldWidget,func,XP1,P2); \ break /* XmTextFieldClearSelection not supported */ /* XmTextFieldCopy not supported */ /* XmTextFieldCut not supported */ #ifdef LESSTIF_VERSION /* This is not supported in LessTif, at least not 0.89. */ case XCALL_XmTextFieldGetAddMode: RaiseXWindows(taskData, "XmTextFieldGetAddMode: not implemented"); #else TextFieldWidgetToBool(XmTextFieldGetAddMode); #endif TextFieldWidgetToInt(XmTextFieldGetBaseline); TextFieldWidgetToLong(XmTextFieldGetCursorPosition); TextFieldWidgetToBool(XmTextFieldGetEditable); TextFieldWidgetToLong(XmTextFieldGetInsertionPosition); TextFieldWidgetToLong(XmTextFieldGetLastPosition); TextFieldWidgetToInt(XmTextFieldGetMaxLength); TextFieldWidgetToString(XmTextFieldGetSelection); /* XmTextFieldGetSelectionPosition not supported */ TextFieldWidgetToString(XmTextFieldGetString); /* XmTextFieldGetSource not supported */ case XCALL_XmTextFieldInsert: { Widget w = GetTextFieldWidget(taskData, (char *) "XmTextFieldInsert",XP1); { unsigned pos = get_C_ulong(taskData, P2); PolyStringObject *s = GetString(P3); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextFieldInsert(w,pos,buffer); break; } } TextFieldWidgetToBool(XmTextFieldPaste); /* for side effect! */ /* XmTextFieldPosToXY not supported */ TextFieldWidgetToBool(XmTextFieldRemove); /* for side effect! */ case XCALL_XmTextFieldReplace: { Widget w = GetTextFieldWidget(taskData, (char *) "XmTextFieldReplace",XP1); { unsigned from_pos = get_C_ulong(taskData, P2); unsigned to_pos = get_C_ulong(taskData, P3); PolyStringObject *s = GetString(P4); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextFieldReplace(w,from_pos,to_pos,buffer); break; } } TextFieldWidgetBoolAction(XmTextFieldSetAddMode); TextFieldWidgetLongAction(XmTextFieldSetCursorPosition); TextFieldWidgetBoolAction(XmTextFieldSetEditable); /* XmTextFieldSetHighlight not supported */ TextFieldWidgetLongAction(XmTextFieldSetInsertionPosition); TextFieldWidgetIntAction(XmTextFieldSetMaxLength); /* XmTextFieldSetSelection not supported */ /* inlined SPF 15/2/94 */ case XCALL_XmTextFieldSetString: { Widget w = GetTextFieldWidget(taskData, (char *) "XmTextFieldSetString",XP1); { PolyStringObject *s = GetString(P2); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextFieldSetString(w,buffer); break; } } TextFieldWidgetLongAction(XmTextFieldShowPosition); /* for side effect! */ case XCALL_XmTextFieldXYToPos: { Widget w = GetTextFieldWidget(taskData, (char *) "XmTextFieldXYToPos",XP1); { int x = get_C_long(taskData, P2); int y = get_C_long(taskData, P3); return Make_int(XmTextFieldXYToPos(w,x,y)); } } case XCALL_XmTrackingLocate: return EmptyWidget(taskData, GetDS(taskData, XP1), XmTrackingLocate(GetWidget(taskData, XP1),GetCursor(taskData, XP2),get_C_ulong(taskData, P3))); case XCALL_XmUpdateDisplay: XmUpdateDisplay(GetWidget(taskData, XP1)); break; #undef TextFieldWidgetToLong #undef TextFieldWidgetToInt #undef TextFieldWidgetToBool #undef TextFieldWidgetToString #undef TextFieldWidgetIntAction #undef TextFieldWidgetLongAction #undef TextFieldWidgetBoolAction /******************************************************************************/ /* */ /* Operations on XmList widgets */ /* */ /******************************************************************************/ #define ListWidgetAction(func) \ case XCALL_ ## func : \ WidgetAction(taskData, (char *) #func,GetListWidget,func,XP1); \ break #define ListWidgetBoolAction(func) \ case XCALL_ ## func : \ WidgetBoolAction(taskData, (char *) #func,GetListWidget,func,XP1,P2); \ break #define ListWidgetXmstringAction(func) \ case XCALL_ ## func : \ WidgetXmstringAction(taskData, (char *) #func,GetListWidget,func,XP1,P2); \ break #define ListWidgetXmstringlistAction(func) \ case XCALL_ ## func : \ WidgetXmstringlistAction(taskData, (char *) #func,GetListWidget,func,XP1,(ML_Cons_Cell *)XP2); \ break #define ListWidgetIntAction(func) \ case XCALL_ ## func : \ WidgetIntAction(taskData, (char *) #func,GetListWidget,func,XP1,P2); \ break #define ListWidgetIntIntAction(func) \ case XCALL_ ## func : \ WidgetIntIntAction(taskData, (char *) #func,GetListWidget,func,XP1,P2,P3); \ break #define ListWidgetXmstringIntAction(func) \ case XCALL_ ## func : \ WidgetXmstringIntAction(taskData, (char *) #func,GetListWidget,func,XP1,P2,P3); \ break #define ListWidgetIntBoolAction(func) \ case XCALL_ ## func : \ WidgetIntBoolAction(taskData, (char *) #func,GetListWidget,func,XP1,P2,P3); \ break #define ListWidgetXmstringBoolAction(func) \ case XCALL_ ## func : \ WidgetXmstringBoolAction(taskData, (char *) #func,GetListWidget,func,XP1,P2,P3); \ break #define ListWidgetXmstringlistIntAction(func) \ case XCALL_ ## func : \ WidgetXmstringlistIntAction(taskData, (char *) #func,GetListWidget,func,XP1,(ML_Cons_Cell *)XP2,P3); \ break #define ListWidgetXmstringToIntlist(func) \ case XCALL_ ## func : \ return(WidgetXmstringToIntlist(taskData, (char *) #func,GetListWidget,func,XP1,P2)) #define ListWidgetToIntlist(func) \ case XCALL_ ## func : \ return(WidgetToIntlist(taskData, (char *) #func,GetListWidget,func,XP1)) #define ListWidgetXmstringToBool(func) \ case XCALL_ ## func : \ return(WidgetXmstringToBool(taskData, (char *) #func,GetListWidget,func,XP1,P2)) #define ListWidgetXmstringToInt(func) \ case XCALL_ ## func : \ return(WidgetXmstringToInt(taskData, (char *) #func,GetListWidget,func,XP1,P2)) /************************* Adding Items to List *******************************/ ListWidgetXmstringIntAction(XmListAddItem); ListWidgetXmstringIntAction(XmListAddItemUnselected); ListWidgetXmstringlistIntAction(XmListAddItems); /************************* Deleting Items from List ***************************/ ListWidgetAction(XmListDeleteAllItems); ListWidgetXmstringAction(XmListDeleteItem); ListWidgetXmstringlistAction(XmListDeleteItems); ListWidgetIntAction(XmListDeletePos); ListWidgetIntIntAction(XmListDeleteItemsPos); /************************* Deselecting Items **********************************/ ListWidgetAction(XmListDeselectAllItems); ListWidgetXmstringAction(XmListDeselectItem); ListWidgetIntAction(XmListDeselectPos); /************************* Query Functions ************************************/ ListWidgetXmstringToIntlist(XmListGetMatchPos); ListWidgetToIntlist(XmListGetSelectedPos); ListWidgetXmstringToBool(XmListItemExists); ListWidgetXmstringToInt(XmListItemPos); /************************* Replacing Items in the List ************************/ case XCALL_XmListReplaceItems: /* Unpairing the strings is done in the ML, because it's easier there. */ { Widget w = GetListWidget(taskData, (char *) "XmListReplaceItems",XP1); unsigned n = ListLength(P2); unsigned n2 = ListLength(P3); if (n != n2) { RaiseXWindows(taskData, "XmListReplaceItems: strings lists are different lengths"); } else { XmString *oldstrings = (XmString *)alloca(n * sizeof(XmString)); XmString *newstrings = (XmString *)alloca(n * sizeof(XmString)); GetList4(taskData, P2,oldstrings,sizeof(XmString),GetXmString); GetList4(taskData, P3,newstrings,sizeof(XmString),GetXmString); XmListReplaceItems(w,oldstrings,n,newstrings); for (unsigned i = 0; i < n; i ++) XmStringFree(oldstrings[i]); for (unsigned i = 0; i < n; i ++) XmStringFree(newstrings[i]); } break; } ListWidgetXmstringlistIntAction(XmListReplaceItemsPos); /************************* Selecting Items in the List ************************/ ListWidgetXmstringBoolAction(XmListSelectItem); ListWidgetIntBoolAction(XmListSelectPos); /************************* Set Add Mode ***************************************/ ListWidgetBoolAction(XmListSetAddMode); /************************* Set Appearance *************************************/ ListWidgetXmstringAction(XmListSetBottomItem); ListWidgetIntAction(XmListSetBottomPos); ListWidgetIntAction(XmListSetHorizPos); ListWidgetXmstringAction(XmListSetItem); ListWidgetIntAction(XmListSetPos); #undef ListWidgetAction #undef ListWidgetBoolAction #undef ListWidgetXmstringAction #undef ListWidgetXmstringlistAction #undef ListWidgetIntAction #undef ListWidgetIntIntAction #undef ListWidgetXmstringIntAction #undef ListWidgetXmstringBoolAction #undef ListWidgetXmstringlistIntAction #undef ListWidgetXmstringToIntlist #undef ListWidgetToIntlist #undef ListWidgetXmstringToBool #undef ListWidgetXmstringToInt /* Calls added by DCJM. */ case XCALL_XmMenuPosition: MenuPosition( GetWidget(taskData, XP1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3)); break; /******************************************************************************/ /* */ /* Default case */ /* */ /******************************************************************************/ default: Crash ("Unimplemented X Windows call %d", code); } return Make_bool(False); } typedef struct { int code; const char *name; } CodeName; static CodeName ProtocolNames[] = { { X_CreateWindow,"XCreateWindow"}, { X_ChangeWindowAttributes,"XChangeWindowAttributes"}, { X_GetWindowAttributes,"XGetWindowAttributes"}, { X_DestroyWindow,"XDestroyWindow"}, { X_DestroySubwindows,"XDestroySubwindows"}, { X_ChangeSaveSet,"XChangeSAVESet"}, { X_ReparentWindow,"XReparentWindow"}, { X_MapWindow,"XMapWindow"}, { X_MapSubwindows,"XMapSubwindows"}, { X_UnmapWindow,"XUnmapWindow"}, { X_UnmapSubwindows,"XUnmapSubwindows"}, { X_ConfigureWindow,"XConfigureWindow"}, { X_CirculateWindow,"XCirculateWindow"}, { X_GetGeometry,"XGetGeometry"}, { X_QueryTree,"XQueryTree"}, { X_InternAtom,"XInternAtom"}, { X_GetAtomName,"XGetAtomName"}, { X_ChangeProperty,"XChangeProperty"}, { X_DeleteProperty,"XDeleteProperty"}, { X_GetProperty,"XGetProperty"}, { X_ListProperties,"XListProperties"}, { X_SetSelectionOwner,"XSetSelectionOwner"}, { X_GetSelectionOwner,"XGetSelectionOwner"}, { X_ConvertSelection,"XConvertSelection"}, { X_SendEvent,"XSendEvent"}, { X_GrabPointer,"XGrabPointer"}, { X_UngrabPointer,"XUngrabPointer"}, { X_GrabButton,"XGrabButton"}, { X_UngrabButton,"XUngrabButton"}, { X_ChangeActivePointerGrab,"XChangeActivePointerGrab"}, { X_GrabKeyboard,"XGrabKeyboard"}, { X_UngrabKeyboard,"XUngrabKeyboard"}, { X_GrabKey,"XGrabKey"}, { X_UngrabKey,"XUngrabKey"}, { X_AllowEvents,"XAllowEvents"}, { X_GrabServer,"XGrabServer"}, { X_UngrabServer,"XUngrabServer"}, { X_QueryPointer,"XQueryPointer"}, { X_GetMotionEvents,"XGetMotionEvents"}, { X_TranslateCoords,"XTranslateCoords"}, { X_WarpPointer,"XWarpPointer"}, { X_SetInputFocus,"XSetInputFocus"}, { X_GetInputFocus,"XGetInputFocus"}, { X_QueryKeymap,"XQueryKeymap"}, { X_OpenFont,"XOpenFont"}, { X_CloseFont,"XCloseFont"}, { X_QueryFont,"XQueryFont"}, { X_QueryTextExtents,"XQueryTextExtents"}, { X_ListFonts,"XListFonts"}, { X_ListFontsWithInfo,"XListFontsWithInfo"}, { X_SetFontPath,"XSetFontPath"}, { X_GetFontPath,"XGetFontPath"}, { X_CreatePixmap,"XCreatePixmap"}, { X_FreePixmap,"XFreePixmap"}, { X_CreateGC,"XCreateGC"}, { X_ChangeGC,"XChangeGC"}, { X_CopyGC,"XCopyGC"}, { X_SetDashes,"XSetDashes"}, { X_SetClipRectangles,"XSetClipRectangles"}, { X_FreeGC,"XFreeGC"}, { X_ClearArea,"XClearArea"}, { X_CopyArea,"XCopyArea"}, { X_CopyPlane,"XCopyPlane"}, { X_PolyPoint,"XPolyPoint"}, { X_PolyLine,"XPolyLine"}, { X_PolySegment,"XPolySegment"}, { X_PolyRectangle,"XPolyRectangle"}, { X_PolyArc,"XPolyArc"}, { X_FillPoly,"XFillPoly"}, { X_PolyFillRectangle,"XPolyFillRectangle"}, { X_PolyFillArc,"XPolyFillArc"}, { X_PutImage,"XPutImage"}, { X_GetImage,"XGetImage"}, { X_PolyText8,"XPolyText8"}, { X_PolyText16,"XPolyText16"}, { X_ImageText8,"XImageText8"}, { X_ImageText16,"XImageText16"}, { X_CreateColormap,"XCreateColormap"}, { X_FreeColormap,"XFreeColormap"}, { X_CopyColormapAndFree,"XCopyColormapAndFree"}, { X_InstallColormap,"XInstallColormap"}, { X_UninstallColormap,"XUninstallColormap"}, { X_ListInstalledColormaps,"XListInstalledColormaps"}, { X_AllocColor,"XAllocColor"}, { X_AllocNamedColor,"XAllocNamedColor"}, { X_AllocColorCells,"XAllocColorCells"}, { X_AllocColorPlanes,"XAllocColorPlanes"}, { X_FreeColors,"XFreeColors"}, { X_StoreColors,"XStoreColors"}, { X_StoreNamedColor,"XStoreNamedColor"}, { X_QueryColors,"XQueryColors"}, { X_LookupColor,"XLookupColor"}, { X_CreateCursor,"XCreateCursor"}, { X_CreateGlyphCursor,"XCreateGlyphCursor"}, { X_FreeCursor,"XFreeCursor"}, { X_RecolorCursor,"XRecolorCursor"}, { X_QueryBestSize,"XQueryBestSize"}, { X_QueryExtension,"XQueryExtension"}, { X_ListExtensions,"XListExtensions"}, { X_ChangeKeyboardMapping,"XChangeKeyboardMapping"}, { X_GetKeyboardMapping,"XGetKeyboardMapping"}, { X_ChangeKeyboardControl,"XChangeKeyboardControl"}, { X_GetKeyboardControl,"XGetKeyboardControl"}, { X_Bell,"XBell"}, { X_ChangePointerControl,"XChangePointerControl"}, { X_GetPointerControl,"XGetPointerControl"}, { X_SetScreenSaver,"XSetScreenSaver"}, { X_GetScreenSaver,"XGetScreenSaver"}, { X_ChangeHosts,"XChangeHosts"}, { X_ListHosts,"XListHosts"}, { X_SetAccessControl,"XSetAccessControl"}, { X_SetCloseDownMode,"XSetCloseDownMode"}, { X_KillClient,"XKillClient"}, { X_RotateProperties,"XRotateProperties"}, { X_ForceScreenSaver,"XForceScreenSaver"}, { X_SetPointerMapping,"XSetPointerMapping"}, { X_GetPointerMapping,"XGetPointerMapping"}, { X_SetModifierMapping,"XSetModifierMapping"}, { X_GetModifierMapping,"XGetModifierMapping"}, { X_NoOperation,"XNoOperation"} }; static CodeName ProtocolErrors[] = { { Success,"Success"}, { BadRequest,"BadRequest"}, { BadValue,"BadValue"}, { BadWindow,"BadWindow"}, { BadPixmap,"BadPixmap"}, { BadAtom,"BadAtom"}, { BadCursor,"BadCursor"}, { BadFont,"BadFont"}, { BadMatch,"BadMatch"}, { BadDrawable,"BadDrawable"}, { BadAccess,"BadAccess"}, { BadAlloc,"BadAlloc"}, { BadColor,"BadColor"}, { BadGC,"BadGC"}, { BadIDChoice,"BadIDChoice"}, { BadName,"BadName"}, { BadLength,"BadLength"}, { BadImplementation,"BadImplementation"} }; static int XWindowsError(Display *display, XErrorEvent *error) { const char *errorName = "unknown"; const char *requestName = "unknown"; int i,n; char buffer[500]; n = sizeof(ProtocolErrors) / sizeof(ProtocolErrors[0]); for(i = 0; i < n; i++) { if (ProtocolErrors[i].code == error->error_code) { errorName = ProtocolErrors[i].name; } } n = sizeof(ProtocolNames) / sizeof(ProtocolNames[0]); for(i = 0; i < n; i++) { if (ProtocolNames[i].code == error->request_code) { requestName = ProtocolNames[i].name; } } sprintf(buffer,"%s in %s",errorName,requestName); printf("\nX Error %s\n\n", buffer); #if NEVER /* Raise exception if we are running in synchronous mode */ if (display->private15) RaiseXWindows(taskData, buffer); #endif return 0; /* DUMMY value - SPF 6/1/94 */ } struct _entrypts xwindowsEPT[] = { { "PolyXWindowsGeneral", (polyRTSFunction)&PolyXWindowsGeneral}, { NULL, NULL} // End of list. }; class XWinModule: public RtsModule { public: virtual void Init(void); void GarbageCollect(ScanAddress *process); }; // Declare this. It will be automatically added to the table. static XWinModule xwinModule; void XWinModule::GarbageCollect(ScanAddress *process) { /* Process all the objects in the list. If an object */ /* is not found from outside then it is removed. */ T_List **T = &TList; C_List **C = &CList; int i; /* process all XList headers */ for (i = 0; i < XLISTSIZE; i++) { X_List *L = XList[i]; while(L) { PolyObject *P = L->object; /* copy object pointer */ X_List *N = L->next; /* copy next pointer */ process->ScanRuntimeAddress(&P, ScanAddress::STRENGTH_WEAK); /* P may have been moved, or overwritten with a 0 if not accessible */ if (P == 0) DestroyXObject(L->object); else L->object = (X_Object*)P; L = N; } } /* Process the timeout/message list */ while (*T) { T_List *t = *T; process->ScanRuntimeAddress(&t->alpha, ScanAddress::STRENGTH_STRONG); process->ScanRuntimeAddress(&t->handler, ScanAddress::STRENGTH_STRONG); PolyObject *obj = t->window_object; process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_WEAK); t->window_object = (X_Window_Object*)obj; obj = t->widget_object; process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_STRONG); t->widget_object = (X_Widget_Object*)obj; // DCJM: I don't understand this. The widget entry will never go // to zero since it's strong not weak. if (t->window_object == 0 && t->widget_object == 0) { *T = t->next; free(t); } else T = &t->next; } /* Process the callback list */ while(*C) { C_List *c = *C; process->ScanRuntimeAddress(&c->function, ScanAddress::STRENGTH_STRONG); PolyObject *obj = c->widget_object; process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_STRONG); c->widget_object = (X_Widget_Object*)obj; /* DCJM: This doesn't make sense. The widget entry will only go to zero if the G.C. operation was weak, not strong as in the line above. */ if (c->widget_object == 0) { *C = c->next; free(c); } else C = &c->next; } /* Process the callback waiting list */ if (! FList.IsTagged()) { PolyObject *obj = FList.AsObjPtr(); process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_STRONG); FList = obj; } /* and the Xt event waiting list. */ if (! GList.IsTagged()) { PolyObject *obj = GList.AsObjPtr(); process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_STRONG) ; GList = obj; } } void XWinModule::Init(void) { initXList(); /* added 9/12/93 SPF */ XtToolkitThreadInitialize(); XtToolkitInitialize(); XSetErrorHandler(XWindowsError); } -POLYUNSIGNED PolyXWindowsGeneral(PolyObject *threadId, PolyWord params) +POLYUNSIGNED PolyXWindowsGeneral(FirstArgument threadId, PolyWord params) { TaskData *taskData = TaskData::FindTaskForId(threadId); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(params); Handle result = 0; try { result = XWindows_c(taskData, pushedArg); } catch (KillException &) { processes->ThreadExit(taskData); // May test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } #else // We haven't got X or we haven't got Motif #include "globals.h" #include "run_time.h" #include "sys.h" #include "save_vec.h" #include "machine_dep.h" #include "processes.h" #include "rtsentry.h" #include "xwindows.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyXWindowsGeneral(PolyObject *threadId, PolyWord params); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyXWindowsGeneral(FirstArgument threadId, PolyWord params); } Handle XWindows_c(TaskData *taskData, Handle/*params*/) { raise_exception_string(taskData, EXC_XWindows, "Not implemented"); /*NOTREACHED*/ return taskData->saveVec.push(TAGGED(0)); /* just to keep lint happy */ } -POLYUNSIGNED PolyXWindowsGeneral(PolyObject *threadId, PolyWord /*params*/) +POLYUNSIGNED PolyXWindowsGeneral(FirstArgument threadId, PolyWord /*params*/) { TaskData *taskData = TaskData::FindTaskForId(threadId); taskData->PreRTSCall(); try { raise_exception_string(taskData, EXC_XWindows, "Not implemented"); } catch (...) { } // Handle the C++ exception taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); // Return unit since we're raising an exception } struct _entrypts xwindowsEPT[] = { { "PolyXWindowsGeneral", (polyRTSFunction)&PolyXWindowsGeneral}, { NULL, NULL} // End of list. }; #endif diff --git a/mlsource/MLCompiler/BUILTINS.sml b/mlsource/MLCompiler/BUILTINS.sml index 1b43abb2..fc865ec6 100644 --- a/mlsource/MLCompiler/BUILTINS.sml +++ b/mlsource/MLCompiler/BUILTINS.sml @@ -1,101 +1,108 @@ (* Signature for built-in functions - Copyright David C. J. Matthews 2016, 2018 + Copyright David C. J. Matthews 2016, 2018-19 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) signature BUILTINS = sig datatype testConditions = TestEqual (* No TestNotEqual because that is always generated with "not" *) | TestLess | TestLessEqual | TestGreater | TestGreaterEqual | TestUnordered (* Reals only. *) datatype arithmeticOperations = ArithAdd | ArithSub | ArithMult | ArithQuot | ArithRem | ArithDiv | ArithMod datatype logicalOperations = LogicalAnd | LogicalOr | LogicalXor datatype shiftOperations = ShiftLeft | ShiftRightLogical (* Logical shift - zero added bits. *) | ShiftRightArithmetic (* Arithmetic shift - add the sign bit. *) datatype unaryOps = NotBoolean (* true => false; false => true - XOR *) | IsTaggedValue (* Test the tag bit. *) | MemoryCellLength (* Return the length of a memory cell (heap object) *) | MemoryCellFlags (* Return the flags byte of a memory cell (heap object) *) | ClearMutableFlag (* Remove the mutable flag from the flags byte *) | AtomicIncrement | AtomicDecrement | AtomicReset (* Set a value to (tagged) zero atomically. *) | LongWordToTagged (* Convert a LargeWord.word to a Word.word or FixedInt.int. *) | SignedToLongWord (* Convert a tagged value to a LargeWord with sign extension. *) | UnsignedToLongWord (* Convert a tagged value to a LargeWord without sign extension. *) | RealAbs of precision (* Set the sign bit of a real to positive. *) | RealNeg of precision (* Invert the sign bit of a real. *) | RealFixedInt of precision (* Convert an integer value into a real value. *) | FloatToDouble (* Convert a single precision floating point value to double precision. *) | DoubleToFloat of IEEEReal.rounding_mode option (* Convert a double precision floating point value to single precision. *) | RealToInt of precision * IEEEReal.rounding_mode (* Convert a double or float to a fixed precision int. *) and precision = PrecSingle | PrecDouble (* Single or double precision floating pt. *) and binaryOps = (* Compare two words and return the result. This is used for both word values (isSigned=false) and fixed precision integer (isSigned=true). Tests for (in)equality can also be done on pointers in which case this is pointer equality. *) WordComparison of { test: testConditions, isSigned: bool } (* Fixed precision int operations. These may raise Overflow. *) | FixedPrecisionArith of arithmeticOperations (* Arithmetic operations on word values. These do not raise Overflow. *) | WordArith of arithmeticOperations (* Load a word at a specific offset in a heap object. If this is immutable and the arguments are constants it can be folded at compile time since the result will never change. *) | WordLogical of logicalOperations (* Logical operations on words. *) | WordShift of shiftOperations (* Shift operations on words. *) (* Allocate a heap cell for byte data. The first argument is the number of words (not bytes) needed. The second argument is the "flags" byte which must include F_bytes and F_mutable. The new cell is not initialised. *) | AllocateByteMemory (* Operations on LargeWords. These are 32/64 bit values that are "boxed". *) | LargeWordComparison of testConditions | LargeWordArith of arithmeticOperations | LargeWordLogical of logicalOperations | LargeWordShift of shiftOperations | RealComparison of testConditions * precision | RealArith of arithmeticOperations * precision + + and nullaryOps = + (* Get the current thread id *) + GetCurrentThreadId + (* Check whether the last RTS call set the exception status and raise it if it had. *) + | CheckRTSException val unaryRepr: unaryOps -> string and binaryRepr: binaryOps -> string and testRepr: testConditions -> string and arithRepr: arithmeticOperations -> string + and nullaryRepr: nullaryOps -> string end; diff --git a/mlsource/MLCompiler/CODETREESIG.ML b/mlsource/MLCompiler/CODETREESIG.ML index bb3dd98f..ce4b234f 100644 --- a/mlsource/MLCompiler/CODETREESIG.ML +++ b/mlsource/MLCompiler/CODETREESIG.ML @@ -1,159 +1,160 @@ (* - Copyright (c) 2012,13,15-18 David C.J. Matthews + Copyright (c) 2012,13,15-19 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) signature CODETREESIG = sig type machineWord type codetree type pretty type codeBinding type level datatype argumentType = GeneralType | DoubleFloatType | SingleFloatType and loadStoreKind = LoadStoreMLWord of {isImmutable: bool} | LoadStoreMLByte of {isImmutable: bool} | LoadStoreC8 | LoadStoreC16 | LoadStoreC32 | LoadStoreC64 | LoadStoreCFloat | LoadStoreCDouble | LoadStoreUntaggedUnsigned and blockOpKind = BlockOpMove of {isByteMove: bool} | BlockOpEqualByte | BlockOpCompareByte structure BuiltIns: BUILTINS datatype arbPrecisionOps = ArbCompare of BuiltIns.testConditions | ArbArith of BuiltIns.arithmeticOperations val CodeTrue: codetree (* code for "true" *) val CodeFalse: codetree (* code for "false" *) val CodeZero: codetree (* code for 0, nil etc. *) val mkFunction: { body: codetree, argTypes:argumentType list, resultType: argumentType, name: string, closure: codetree list, numLocals: int } -> codetree val mkInlineFunction: { body: codetree, argTypes:argumentType list, resultType: argumentType, name: string, closure: codetree list, numLocals: int } -> codetree val mkCall: codetree * (codetree * argumentType) list * argumentType -> codetree val mkLoadLocal: int -> codetree and mkLoadArgument: int -> codetree and mkLoadClosure: int -> codetree val mkConst: machineWord -> codetree val mkInd: int * codetree -> codetree val mkVarField: int * codetree -> codetree val mkProc: codetree * int * string * codetree list * int -> codetree val mkInlproc: codetree * int * string * codetree list * int -> codetree val mkMacroProc: codetree * int * string * codetree list * int -> codetree val mkIf: codetree * codetree * codetree -> codetree val mkWhile: codetree * codetree -> codetree val mkEnv: codeBinding list * codetree -> codetree val mkStr: string -> codetree val mkTuple: codetree list -> codetree val mkDatatype: codetree list -> codetree val mkRaise: codetree -> codetree val mkCor: codetree * codetree -> codetree val mkCand: codetree * codetree -> codetree val mkHandle: codetree * codetree * int -> codetree val mkEval: codetree * codetree list -> codetree val identityFunction: string -> codetree val mkSetContainer: codetree * codetree * int -> codetree val mkTupleFromContainer: int * int -> codetree val mkTagTest: codetree * word * word -> codetree val mkBeginLoop: codetree * (int * codetree) list -> codetree val mkLoop: codetree list -> codetree val mkDec: int * codetree -> codeBinding val mkMutualDecs: (int * codetree) list -> codeBinding val mkNullDec: codetree -> codeBinding val mkContainer: int * int * codetree -> codeBinding val mkNot: codetree -> codetree val mkIsShort: codetree -> codetree val mkEqualWord: codetree * codetree -> codetree val mkEqualArbShort: codetree * codetree -> codetree val equalWordFn: codetree val decSequenceWithFinalExp: codeBinding list -> codetree val pretty: codetree -> pretty val evalue: codetree -> machineWord option val genCode: codetree * Universal.universal list * int -> (unit -> codetree) (* Helper functions to build closure. *) val mkLoad: int * level * level -> codetree and mkLoadParam: int * level * level -> codetree val baseLevel: level val newLevel: level -> level val getClosure: level -> codetree list val multipleUses: codetree * (unit -> int) * level -> {load: level -> codetree, dec: codeBinding list} val mkUnary: BuiltIns.unaryOps * codetree -> codetree and mkBinary: BuiltIns.binaryOps * codetree * codetree -> codetree val mkUnaryFn: BuiltIns.unaryOps -> codetree and mkBinaryFn: BuiltIns.binaryOps -> codetree and mkArbitraryFn: arbPrecisionOps -> codetree val getCurrentThreadId: codetree and getCurrentThreadIdFn: codetree + and checkRTSException: codetree val mkAllocateWordMemory: codetree * codetree * codetree -> codetree and mkAllocateWordMemoryFn: codetree (* Load and store operations. At this level the first operand is the base address and the second is an index. *) val mkLoadOperation: loadStoreKind * codetree * codetree -> codetree val mkLoadOperationFn: loadStoreKind -> codetree val mkStoreOperation: loadStoreKind * codetree * codetree * codetree -> codetree val mkStoreOperationFn: loadStoreKind -> codetree val mkBlockOperation: {kind:blockOpKind, leftBase: codetree, rightBase: codetree, leftIndex: codetree, rightIndex: codetree, length: codetree} -> codetree val mkBlockOperationFn: blockOpKind -> codetree structure Foreign: FOREIGNCALLSIG structure Sharing: sig type machineWord = machineWord type codetree = codetree type pretty = pretty type argumentType=argumentType type codeBinding = codeBinding type level = level end end; diff --git a/mlsource/MLCompiler/CodeTree/BackendIntermediateCode.sml b/mlsource/MLCompiler/CodeTree/BackendIntermediateCode.sml index 33f3307f..fa88df56 100644 --- a/mlsource/MLCompiler/CodeTree/BackendIntermediateCode.sml +++ b/mlsource/MLCompiler/CodeTree/BackendIntermediateCode.sml @@ -1,724 +1,731 @@ (* - Copyright (c) 2012, 2016-18 David C.J. Matthews + Copyright (c) 2012, 2016-19 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Intermediate code tree for the back end of the compiler. *) structure BackendIntermediateCode: BackendIntermediateCodeSig = struct open Address structure BuiltIns = struct datatype testConditions = TestEqual | TestLess | TestLessEqual | TestGreater | TestGreaterEqual | TestUnordered (* Reals only. *) datatype arithmeticOperations = ArithAdd | ArithSub | ArithMult | ArithQuot | ArithRem | ArithDiv | ArithMod datatype logicalOperations = LogicalAnd | LogicalOr | LogicalXor datatype shiftOperations = ShiftLeft | ShiftRightLogical | ShiftRightArithmetic datatype unaryOps = NotBoolean | IsTaggedValue | MemoryCellLength | MemoryCellFlags | ClearMutableFlag | AtomicIncrement | AtomicDecrement | AtomicReset | LongWordToTagged | SignedToLongWord | UnsignedToLongWord | RealAbs of precision | RealNeg of precision | RealFixedInt of precision | FloatToDouble | DoubleToFloat of IEEEReal.rounding_mode option | RealToInt of precision * IEEEReal.rounding_mode and precision = PrecSingle | PrecDouble and binaryOps = WordComparison of { test: testConditions, isSigned: bool } | FixedPrecisionArith of arithmeticOperations | WordArith of arithmeticOperations | WordLogical of logicalOperations | WordShift of shiftOperations | AllocateByteMemory | LargeWordComparison of testConditions | LargeWordArith of arithmeticOperations | LargeWordLogical of logicalOperations | LargeWordShift of shiftOperations | RealComparison of testConditions * precision | RealArith of arithmeticOperations * precision - + + and nullaryOps = + GetCurrentThreadId + | CheckRTSException + fun unaryRepr NotBoolean = "NotBoolean" | unaryRepr IsTaggedValue = "IsTaggedValue" | unaryRepr MemoryCellLength = "MemoryCellLength" | unaryRepr MemoryCellFlags = "MemoryCellFlags" | unaryRepr ClearMutableFlag = "ClearMutableFlag" | unaryRepr AtomicIncrement = "AtomicIncrement" | unaryRepr AtomicDecrement = "AtomicDecrement" | unaryRepr AtomicReset = "AtomicReset" | unaryRepr LongWordToTagged = "LongWordToTagged" | unaryRepr SignedToLongWord = "SignedToLongWord" | unaryRepr UnsignedToLongWord = "UnsignedToLongWord" | unaryRepr (RealAbs prec) = "RealAbs" ^ precRepr prec | unaryRepr (RealNeg prec) = "RealNeg" ^ precRepr prec | unaryRepr (RealFixedInt prec) = "RealFixedInt" ^ precRepr prec | unaryRepr FloatToDouble = "FloatToDouble" | unaryRepr (DoubleToFloat NONE) = "DoubleToFloat" | unaryRepr (DoubleToFloat (SOME mode)) = "DoubleToFloat" ^ rndModeRepr mode | unaryRepr (RealToInt (prec, mode)) = "RealToInt" ^ precRepr prec ^ rndModeRepr mode and binaryRepr (WordComparison{test, isSigned}) = "Test" ^ (testRepr test) ^ (if isSigned then "Signed" else "Unsigned") | binaryRepr (FixedPrecisionArith arithOp) = (arithRepr arithOp) ^ "Fixed" | binaryRepr (WordArith arithOp) = (arithRepr arithOp) ^ "Word" | binaryRepr (WordLogical logOp) = (logicRepr logOp) ^ "Word" | binaryRepr (WordShift shiftOp) = (shiftRepr shiftOp) ^ "Word" | binaryRepr AllocateByteMemory = "AllocateByteMemory" | binaryRepr (LargeWordComparison test) = "Test" ^ (testRepr test) ^ "LargeWord" | binaryRepr (LargeWordArith arithOp) = (arithRepr arithOp) ^ "LargeWord" | binaryRepr (LargeWordLogical logOp) = (logicRepr logOp) ^ "LargeWord" | binaryRepr (LargeWordShift shiftOp) = (shiftRepr shiftOp) ^ "LargeWord" | binaryRepr (RealComparison (test, prec)) = "Test" ^ testRepr test ^ precRepr prec | binaryRepr (RealArith (arithOp, prec)) = arithRepr arithOp ^ precRepr prec + and nullaryRepr GetCurrentThreadId = "GetCurrentThreadId" + | nullaryRepr CheckRTSException = "CheckRTSException" + and testRepr TestEqual = "Equal" | testRepr TestLess = "Less" | testRepr TestLessEqual = "LessEqual" | testRepr TestGreater = "Greater" | testRepr TestGreaterEqual = "GreaterEqual" | testRepr TestUnordered = "Unordered" and arithRepr ArithAdd = "Add" | arithRepr ArithSub = "Sub" | arithRepr ArithMult = "Mult" | arithRepr ArithQuot = "Quot" | arithRepr ArithRem = "Rem" | arithRepr ArithDiv = "Div" | arithRepr ArithMod = "Mod" and logicRepr LogicalAnd = "And" | logicRepr LogicalOr = "Or" | logicRepr LogicalXor = "Xor" and shiftRepr ShiftLeft = "Left" | shiftRepr ShiftRightLogical = "RightLogical" | shiftRepr ShiftRightArithmetic = "RightArithmetic" and precRepr PrecSingle = "Single" | precRepr PrecDouble = "Double" and rndModeRepr IEEEReal.TO_NEAREST = "Round" | rndModeRepr IEEEReal.TO_NEGINF = "Down" | rndModeRepr IEEEReal.TO_POSINF = "Up" | rndModeRepr IEEEReal.TO_ZERO = "Trunc" end datatype argumentType = GeneralType | DoubleFloatType | SingleFloatType datatype backendIC = BICNewenv of bicCodeBinding list * backendIC (* Set of bindings with an expression. *) | BICConstnt of machineWord * Universal.universal list (* Load a constant *) | BICExtract of bicLoadForm (* Get a local variable, an argument or a closure value *) | BICField of {base: backendIC, offset: int } (* Load a field from a tuple or record *) | BICEval of (* Evaluate a function with an argument list. *) { function: backendIC, argList: (backendIC * argumentType) list, resultType: argumentType } (* Built-in functions. *) + | BICNullary of {oper: BuiltIns.nullaryOps} | BICUnary of {oper: BuiltIns.unaryOps, arg1: backendIC} | BICBinary of {oper: BuiltIns.binaryOps, arg1: backendIC, arg2: backendIC} | BICArbitrary of {oper: BuiltIns.arithmeticOperations, shortCond: backendIC, arg1: backendIC, arg2: backendIC, longCall: backendIC} | BICLambda of bicLambdaForm (* Lambda expressions. *) | BICCond of backendIC * backendIC * backendIC (* If-then-else expression *) | BICCase of (* Case expressions *) { cases : backendIC option list, (* NONE means "jump to the default". *) test : backendIC, default : backendIC, isExhaustive: bool, firstIndex: word } | BICBeginLoop of (* Start of tail-recursive inline function. *) { loop: backendIC, arguments: (bicSimpleBinding * argumentType) list } | BICLoop of (backendIC * argumentType) list (* Jump back to start of tail-recursive function. *) | BICRaise of backendIC (* Raise an exception *) | BICHandle of (* Exception handler. *) { exp: backendIC, handler: backendIC, exPacketAddr: int } | BICTuple of backendIC list (* Tuple *) | BICSetContainer of (* Copy a tuple to a container. *) { container: backendIC, tuple: backendIC, filter: BoolVector.vector } | BICLoadContainer of {base: backendIC, offset: int } | BICTagTest of { test: backendIC, tag: word, maxTag: word } | BICLoadOperation of { kind: loadStoreKind, address: bicAddress } | BICStoreOperation of { kind: loadStoreKind, address: bicAddress, value: backendIC } | BICBlockOperation of { kind: blockOpKind, sourceLeft: bicAddress, destRight: bicAddress, length: backendIC } - | BICGetThreadId - | BICAllocateWordMemory of {numWords: backendIC, flags: backendIC, initial: backendIC} and bicCodeBinding = BICDeclar of bicSimpleBinding (* Make a local declaration or push an argument *) | BICRecDecs of { addr: int, lambda: bicLambdaForm } list (* Set of mutually recursive declarations. *) | BICNullBinding of backendIC (* Just evaluate the expression and discard the result. *) | BICDecContainer of { addr: int, size: int } (* Create a container for a tuple on the stack. *) and caseType = CaseWord (* Word or fixed-precision integer. *) | CaseTag of word and bicLoadForm = BICLoadLocal of int (* Local binding *) | BICLoadArgument of int (* Argument - 0 is first arg etc.*) | BICLoadClosure of int (* Closure - 0 is first closure item etc *) | BICLoadRecursive (* Recursive call *) and loadStoreKind = LoadStoreMLWord of {isImmutable: bool} (* Load/Store an ML word in an ML word cell. *) | LoadStoreMLByte of {isImmutable: bool} (* Load/Store a byte, tagging and untagging as appropriate, in an ML byte cell. *) | LoadStoreC8 (* Load/Store C values - The base address is a boxed SysWord.word value. *) | LoadStoreC16 | LoadStoreC32 | LoadStoreC64 | LoadStoreCFloat | LoadStoreCDouble | LoadStoreUntaggedUnsigned and blockOpKind = BlockOpMove of {isByteMove: bool} | BlockOpEqualByte | BlockOpCompareByte withtype bicSimpleBinding = { (* Declare a value or push an argument. *) value: backendIC, addr: int } and bicLambdaForm = { (* Lambda expressions. *) body : backendIC, name : string, closure : bicLoadForm list, argTypes : argumentType list, resultType : argumentType, localCount : int, heapClosure : bool } and bicAddress = (* Address form used in loads, store and block operations. The base is an ML address if this is to/from ML memory or a (boxed) SysWord.word if it is to/from C memory. The index is a value in units of the size of the item being loaded/stored and the offset is always in bytes. *) {base: backendIC, index: backendIC option, offset: word} structure CodeTags = struct open Universal val tupleTag: universal list list tag = tag() fun splitProps _ [] = (NONE, []) | splitProps tag (hd::tl) = if Universal.tagIs tag hd then (SOME hd, tl) else let val (p, l) = splitProps tag tl in (p, hd :: l) end fun mergeTupleProps(p, []) = p | mergeTupleProps([], p) = p | mergeTupleProps(m, n) = ( case (splitProps tupleTag m, splitProps tupleTag n) of ((SOME mp, ml), (SOME np, nl)) => let val mpl = Universal.tagProject tupleTag mp and npl = Universal.tagProject tupleTag np val merge = ListPair.mapEq mergeTupleProps (mpl, npl) in Universal.tagInject tupleTag merge :: (ml @ nl) end | _ => m @ n ) end fun loadStoreKindRepr(LoadStoreMLWord {isImmutable=true}) = "MLWordImmutable" | loadStoreKindRepr(LoadStoreMLWord {isImmutable=false}) = "MLWord" | loadStoreKindRepr(LoadStoreMLByte {isImmutable=true}) = "MLByteImmutable" | loadStoreKindRepr(LoadStoreMLByte {isImmutable=false}) = "MLByte" | loadStoreKindRepr LoadStoreC8 = "C8Bit" | loadStoreKindRepr LoadStoreC16 = "C16Bit" | loadStoreKindRepr LoadStoreC32 = "C32Bit" | loadStoreKindRepr LoadStoreC64 = "C64Bit" | loadStoreKindRepr LoadStoreCFloat = "CFloat" | loadStoreKindRepr LoadStoreCDouble = "CDouble" | loadStoreKindRepr LoadStoreUntaggedUnsigned = "MLWordUntagged" fun blockOpKindRepr (BlockOpMove{isByteMove=false}) = "MoveWord" | blockOpKindRepr (BlockOpMove{isByteMove=true}) = "MoveByte" | blockOpKindRepr BlockOpEqualByte = "EqualByte" | blockOpKindRepr BlockOpCompareByte = "CompareByte" open Pretty fun pList ([]: 'b list, _: string, _: 'b->pretty) = [] | pList ([h], _, disp) = [disp h] | pList (h::t, sep, disp) = PrettyBlock (0, false, [], [ disp h, PrettyBreak (0, 0), PrettyString sep ] ) :: PrettyBreak (1, 0) :: pList (t, sep, disp) fun pretty (pt : backendIC) : pretty = let fun printList(start, lst, sep) : pretty = PrettyBlock (1, true, [], PrettyString (start ^ "(") :: pList(lst, sep, pretty) @ [ PrettyBreak (0, 0), PrettyString (")") ] ) fun prettyArgType GeneralType = PrettyString "G" | prettyArgType DoubleFloatType = PrettyString "D" | prettyArgType SingleFloatType = PrettyString "F" fun prettyArg (c, t) = PrettyBlock(1, false, [], [pretty c, PrettyBreak (1, 0), prettyArgType t]) fun prettyArgs(start, lst, sep) : pretty = PrettyBlock (1, true, [], PrettyString (start ^ "(") :: pList(lst, sep, prettyArg) @ [ PrettyBreak (0, 0), PrettyString (")") ] ) fun prettyAddress({base, index, offset}: bicAddress): pretty = let in PrettyBlock (1, true, [], [ PrettyString "[", PrettyBreak (0, 3), pretty base, PrettyBreak (0, 0), PrettyString ",", PrettyBreak (1, 0), case index of NONE => PrettyString "-" | SOME i => pretty i, PrettyBreak (0, 0), PrettyString ",", PrettyBreak (1, 0), PrettyString(Word.toString offset), PrettyBreak (0, 0), PrettyString "]" ]) end in case pt of BICEval {function, argList, resultType} => let val prettyArgs = PrettyBlock (1, true, [], PrettyString ("$(") :: pList(argList, ",", prettyArg) @ [ PrettyBreak (0, 0), PrettyString (")") ] ) in PrettyBlock (3, false, [], [ pretty function, PrettyBreak(1, 0), prettyArgType resultType, PrettyBreak(1, 0), prettyArgs ] ) end - | BICGetThreadId => PrettyString "GetThreadId" - | BICUnary { oper, arg1 } => PrettyBlock (3, false, [], [ PrettyString(BuiltIns.unaryRepr oper), PrettyBreak(1, 0), printList("", [arg1], ",") ] ) | BICBinary { oper, arg1, arg2 } => PrettyBlock (3, false, [], [ PrettyString(BuiltIns.binaryRepr oper), PrettyBreak(1, 0), printList("", [arg1, arg2], ",") ] ) + | BICNullary { oper } => PrettyString(BuiltIns.nullaryRepr oper) + | BICArbitrary { oper, shortCond, arg1, arg2, longCall } => PrettyBlock (3, false, [], [ PrettyString(BuiltIns.arithRepr oper), PrettyBreak(1, 0), printList("", [shortCond, arg1, arg2, longCall], ",") ] ) | BICAllocateWordMemory { numWords, flags, initial } => PrettyBlock (3, false, [], [ PrettyString "AllocateWordMemory", PrettyBreak(1, 0), printList("", [numWords, flags, initial], ",") ] ) | BICExtract (BICLoadLocal addr) => let val str : string = concat ["LOCAL(", Int.toString addr, ")"] in PrettyString str end | BICExtract (BICLoadArgument addr) => let val str : string = concat ["PARAM(", Int.toString addr, ")"] in PrettyString str end | BICExtract (BICLoadClosure addr) => let val str : string = concat ["CLOS(", Int.toString addr, ")"] in PrettyString str end | BICExtract (BICLoadRecursive) => let val str : string = concat ["RECURSIVE(", ")"] in PrettyString str end | BICField {base, offset} => let val str = "INDIRECT(" ^ Int.toString offset ^ ", "; in PrettyBlock(0, false, [], [ PrettyString str, pretty base, PrettyString ")" ] ) end | BICLambda {body, name, closure, argTypes, heapClosure, resultType, localCount} => let fun prettyArgTypes [] = [] | prettyArgTypes [last] = [prettyArgType last] | prettyArgTypes (hd::tl) = prettyArgType hd :: PrettyBreak(1, 0) :: prettyArgTypes tl in PrettyBlock (1, true, [], [ PrettyString ("LAMBDA("), PrettyBreak (1, 0), PrettyString name, PrettyBreak (1, 0), PrettyString ( "CL=" ^ Bool.toString heapClosure), PrettyString (" LOCALS=" ^ Int.toString localCount), PrettyBreak(1, 0), PrettyBlock (1, false, [], PrettyString "ARGS=" :: prettyArgTypes argTypes), PrettyBreak(1, 0), PrettyBlock (1, false, [], [PrettyString "RES=", prettyArgType resultType]), printList (" CLOS=", map BICExtract closure, ","), PrettyBreak (1, 0), pretty body, PrettyString "){LAMBDA}" ] ) end | BICConstnt (w, _) => PrettyString (stringOfWord w) | BICCond (f, s, t) => PrettyBlock (1, true, [], [ PrettyString "IF(", pretty f, PrettyString ", ", PrettyBreak (0, 0), pretty s, PrettyString ", ", PrettyBreak (0, 0), pretty t, PrettyBreak (0, 0), PrettyString (")") ] ) | BICNewenv(decs, final) => PrettyBlock (1, true, [], PrettyString ("BLOCK" ^ "(") :: pList(decs, ";", prettyBinding) @ [ PrettyBreak (1, 0), pretty final, PrettyBreak (0, 0), PrettyString (")") ] ) | BICBeginLoop{loop=loopExp, arguments=args } => let fun prettyArg (c, t) = PrettyBlock(1, false, [], [prettySimpleBinding c, PrettyBreak (1, 0), prettyArgType t]) in PrettyBlock (3, false, [], [ PrettyBlock (1, true, [], PrettyString ("BEGINLOOP(") :: pList(args, ",", prettyArg) @ [ PrettyBreak (0, 0), PrettyString (")") ] ), PrettyBreak (0, 0), PrettyString "(", PrettyBreak (0, 0), pretty loopExp, PrettyBreak (0, 0), PrettyString ")" ] ) end | BICLoop ptl => prettyArgs("LOOP", ptl, ",") | BICRaise c => PrettyBlock (1, true, [], [ PrettyString "RAISE(", pretty c, PrettyBreak (0, 0), PrettyString (")") ] ) | BICHandle {exp, handler, exPacketAddr} => PrettyBlock (3, false, [], [ PrettyString "HANDLE(", pretty exp, PrettyString ("WITH exid=" ^ Int.toString exPacketAddr), PrettyBreak (1, 0), pretty handler, PrettyString ")" ] ) | BICCase {cases, test, default, isExhaustive, firstIndex, ...} => PrettyBlock (1, true, [], PrettyString "CASE (" :: pretty test :: PrettyBreak (1, 0) :: PrettyString ("( from " ^ Word.toString firstIndex ^ (if isExhaustive then " exhaustive" else "")) :: PrettyBreak (1, 0) :: pList(cases, ",", fn (SOME exp) => PrettyBlock (1, true, [], [ PrettyString "=>", PrettyBreak (1, 0), pretty exp ]) | NONE => PrettyString "=> default" ) @ [ PrettyBreak (1, 0), PrettyBlock (1, false, [], [ PrettyString "ELSE:", PrettyBreak (1, 0), pretty default ] ), PrettyBreak (1, 0), PrettyString (") {"^"CASE"^"}") ] ) | BICTuple ptl => printList("RECCONSTR", ptl, ",") | BICSetContainer{container, tuple, filter} => let val source = BoolVector.length filter val dest = BoolVector.foldl(fn (true, n) => n+1 | (false, n) => n) 0 filter in PrettyBlock (3, false, [], [ PrettyString (concat["SETCONTAINER(", Int.toString dest, "/", Int.toString source, ", "]), pretty container, PrettyBreak (0, 0), PrettyString ",", PrettyBreak (1, 0), pretty tuple, PrettyBreak (0, 0), PrettyString ")" ] ) end | BICLoadContainer {base, offset} => let val str = "INDIRECTCONTAINER(" ^ Int.toString offset ^ ", "; in PrettyBlock(0, false, [], [ PrettyString str, pretty base, PrettyString ")" ] ) end | BICTagTest { test, tag, maxTag } => PrettyBlock (3, false, [], [ PrettyString (concat["TAGTEST(", Word.toString tag, ", ", Word.toString maxTag, ","]), PrettyBreak (1, 0), pretty test, PrettyBreak (0, 0), PrettyString ")" ] ) | BICLoadOperation{ kind, address } => PrettyBlock (3, false, [], [ PrettyString("Load" ^ loadStoreKindRepr kind), PrettyBreak (1, 0), prettyAddress address ] ) | BICStoreOperation{ kind, address, value } => PrettyBlock (3, false, [], [ PrettyString("Store" ^ loadStoreKindRepr kind), PrettyBreak (1, 0), prettyAddress address, PrettyBreak (1, 0), PrettyString "<=", PrettyBreak (1, 0), pretty value ] ) | BICBlockOperation{ kind, sourceLeft, destRight, length } => PrettyBlock (3, false, [], [ PrettyString(blockOpKindRepr kind ^ "("), PrettyBreak (1, 0), prettyAddress sourceLeft, PrettyBreak (1, 0), PrettyString ",", prettyAddress destRight, PrettyBreak (1, 0), PrettyString ",", pretty length, PrettyBreak (1, 0), PrettyString ")" ] ) (* That list should be exhaustive! *) end (* pretty *) and prettyBinding(BICDeclar dec) = prettySimpleBinding dec | prettyBinding(BICRecDecs ptl) = let fun prettyRDec {lambda, addr} = PrettyBlock (1, false, [], [ PrettyString (concat ["DECL #", Int.toString addr, "="]), PrettyBreak (1, 0), pretty(BICLambda lambda) ] ) in PrettyBlock (1, true, [], PrettyString ("MUTUAL" ^ "(") :: pList(ptl, " AND ", prettyRDec) @ [ PrettyBreak (0, 0), PrettyString (")") ] ) end | prettyBinding(BICNullBinding c) = pretty c | prettyBinding(BICDecContainer{addr, size}) = PrettyString (concat ["CONTAINER #", Int.toString addr, "=", Int.toString size]) and prettySimpleBinding{value, addr} = PrettyBlock (1, false, [], [ PrettyString (concat ["DECL #", Int.toString addr, "="]), PrettyBreak (1, 0), pretty value ] ) structure Sharing = struct type backendIC = backendIC and bicLoadForm = bicLoadForm and caseType = caseType and pretty = pretty and argumentType = argumentType and bicCodeBinding = bicCodeBinding and bicSimpleBinding = bicSimpleBinding and loadStoreKind = loadStoreKind and blockOpKind = blockOpKind and unaryOps = BuiltIns.unaryOps and binaryOps = BuiltIns.binaryOps + and nullaryOps = BuiltIns.nullaryOps and testConditions = BuiltIns.testConditions and arithmeticOperations = BuiltIns.arithmeticOperations end end; diff --git a/mlsource/MLCompiler/CodeTree/BackendIntermediateCodeSig.sml b/mlsource/MLCompiler/CodeTree/BackendIntermediateCodeSig.sml index 48fbeb6d..4bc209aa 100644 --- a/mlsource/MLCompiler/CodeTree/BackendIntermediateCodeSig.sml +++ b/mlsource/MLCompiler/CodeTree/BackendIntermediateCodeSig.sml @@ -1,187 +1,187 @@ (* - Copyright (c) 2012, 2016-18 David C.J. Matthews + Copyright (c) 2012, 2016-19 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Intermediate code tree for the back end of the compiler. *) signature BackendIntermediateCodeSig = sig type machineWord = Address.machineWord datatype argumentType = GeneralType | DoubleFloatType | SingleFloatType structure BuiltIns: BUILTINS datatype backendIC = BICNewenv of bicCodeBinding list * backendIC (* Set of bindings with an expression. *) | BICConstnt of machineWord * Universal.universal list (* Load a constant *) | BICExtract of bicLoadForm (* Get a local variable, an argument or a closure value *) | BICField of {base: backendIC, offset: int } (* Load a field from a tuple or record *) | BICEval of (* Evaluate a function with an argument list. *) { function: backendIC, argList: (backendIC * argumentType) list, resultType: argumentType } (* Built-in functions. *) + | BICNullary of {oper: BuiltIns.nullaryOps} | BICUnary of {oper: BuiltIns.unaryOps, arg1: backendIC} | BICBinary of {oper: BuiltIns.binaryOps, arg1: backendIC, arg2: backendIC} | BICArbitrary of {oper: BuiltIns.arithmeticOperations, shortCond: backendIC, arg1: backendIC, arg2: backendIC, longCall: backendIC} | BICLambda of bicLambdaForm (* Lambda expressions. *) | BICCond of backendIC * backendIC * backendIC (* If-then-else expression *) | BICCase of (* Case expressions *) { cases : backendIC option list, (* NONE means "jump to the default". *) test : backendIC, default : backendIC, isExhaustive: bool, firstIndex: word } | BICBeginLoop of (* Start of tail-recursive inline function. *) { loop: backendIC, arguments: (bicSimpleBinding * argumentType) list } | BICLoop of (backendIC * argumentType) list (* Jump back to start of tail-recursive function. *) | BICRaise of backendIC (* Raise an exception *) | BICHandle of (* Exception handler. *) { exp: backendIC, handler: backendIC, exPacketAddr: int } | BICTuple of backendIC list (* Tuple *) | BICSetContainer of (* Copy a tuple to a container. *) { container: backendIC, tuple: backendIC, filter: BoolVector.vector } | BICLoadContainer of {base: backendIC, offset: int } | BICTagTest of { test: backendIC, tag: word, maxTag: word } | BICLoadOperation of { kind: loadStoreKind, address: bicAddress } | BICStoreOperation of { kind: loadStoreKind, address: bicAddress, value: backendIC } | BICBlockOperation of { kind: blockOpKind, sourceLeft: bicAddress, destRight: bicAddress, length: backendIC } - - | BICGetThreadId | BICAllocateWordMemory of {numWords: backendIC, flags: backendIC, initial: backendIC} and bicCodeBinding = BICDeclar of bicSimpleBinding (* Make a local declaration or push an argument *) | BICRecDecs of { addr: int, lambda: bicLambdaForm } list (* Set of mutually recursive declarations. *) | BICNullBinding of backendIC (* Just evaluate the expression and discard the result. *) | BICDecContainer of { addr: int, size: int } (* Create a container for a tuple on the stack. *) and caseType = CaseWord (* Word or fixed-precision integer. *) | CaseTag of word and bicLoadForm = BICLoadLocal of int (* Local binding *) | BICLoadArgument of int (* Argument - 0 is first arg etc.*) | BICLoadClosure of int (* Closure - 0 is first closure item etc *) | BICLoadRecursive (* Recursive call *) and loadStoreKind = LoadStoreMLWord of {isImmutable: bool} (* Load/Store an ML word in an ML word cell. *) | LoadStoreMLByte of {isImmutable: bool} (* Load/Store a byte, tagging and untagging as appropriate, in an ML byte cell. *) | LoadStoreC8 (* Load/Store C values - The base address is a boxed SysWord.word value. *) | LoadStoreC16 | LoadStoreC32 | LoadStoreC64 | LoadStoreCFloat | LoadStoreCDouble | LoadStoreUntaggedUnsigned and blockOpKind = BlockOpMove of {isByteMove: bool} | BlockOpEqualByte | BlockOpCompareByte withtype bicSimpleBinding = { (* Declare a value or push an argument. *) value: backendIC, addr: int } and bicLambdaForm = { (* Lambda expressions. *) body : backendIC, name : string, closure : bicLoadForm list, argTypes : argumentType list, resultType : argumentType, localCount : int, heapClosure : bool } and bicAddress = (* Address form used in loads, store and block operations. The base is an ML address if this is to/from ML memory or a (boxed) SysWord.word if it is to/from C memory. The index is a value in units of the size of the item being loaded/stored and the offset is always in bytes. *) {base: backendIC, index: backendIC option, offset: word} type pretty val pretty : backendIC -> pretty val loadStoreKindRepr: loadStoreKind -> string and blockOpKindRepr: blockOpKind -> string structure CodeTags: sig val tupleTag: Universal.universal list list Universal.tag val mergeTupleProps: Universal.universal list * Universal.universal list -> Universal.universal list end structure Sharing: sig type backendIC = backendIC and bicLoadForm = bicLoadForm and caseType = caseType and pretty = pretty and argumentType = argumentType and bicCodeBinding = bicCodeBinding and bicSimpleBinding = bicSimpleBinding and loadStoreKind = loadStoreKind and blockOpKind = blockOpKind and unaryOps = BuiltIns.unaryOps and binaryOps = BuiltIns.binaryOps + and nullaryOps = BuiltIns.nullaryOps and testConditions = BuiltIns.testConditions and arithmeticOperations = BuiltIns.arithmeticOperations end end; diff --git a/mlsource/MLCompiler/CodeTree/BaseCodeTree.sml b/mlsource/MLCompiler/CodeTree/BaseCodeTree.sml index 4b8cae79..35222a03 100644 --- a/mlsource/MLCompiler/CodeTree/BaseCodeTree.sml +++ b/mlsource/MLCompiler/CodeTree/BaseCodeTree.sml @@ -1,775 +1,775 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited - Modified David C. J. Matthews 2008-2010, 2013, 2015, 2017 + Modified David C. J. Matthews 2008-2010, 2013, 2015, 2017-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 *) (* Basic code-tree data structure. This was previously partly in GCODE.ML and partly in CODETREE.ML. *) structure BaseCodeTree: BaseCodeTreeSig = struct open Address datatype argumentType = datatype BackendIntermediateCode.argumentType datatype loadStoreKind = datatype BackendIntermediateCode.loadStoreKind datatype blockOpKind = datatype BackendIntermediateCode.blockOpKind structure BuiltIns = BackendIntermediateCode.BuiltIns datatype arbPrecisionOps = ArbCompare of BuiltIns.testConditions | ArbArith of BuiltIns.arithmeticOperations datatype inlineStatus = NonInline | Inline (* How variables are used. Added and examined by the optimisation pass. *) datatype codeUse = UseGeneral (* Used in some other context. *) | UseExport (* Exported i.e. the result of a top-level binding. *) | UseApply of codeUse list * codetree list (* Applied as a function - the list is where the result goes, the codetree list is the code that was used for each argument. *) | UseField of int * codeUse list (* Selected as a field - the list is where the result goes *) and codetree = Newenv of codeBinding list * codetree (* Set of bindings with an expression. *) | Constnt of machineWord * Universal.universal list (* Load a constant *) | Extract of loadForm (* Get a local variable, an argument or a closure value *) | Indirect of {base: codetree, offset: int, indKind: indKind } (* Load a value from the heap or the stack. *) | Eval of (* Evaluate a function with an argument list. *) { function: codetree, argList: (codetree * argumentType) list, resultType: argumentType } (* Built-in functions. *) + | Nullary of {oper: BuiltIns.nullaryOps} | Unary of {oper: BuiltIns.unaryOps, arg1: codetree} | Binary of {oper: BuiltIns.binaryOps, arg1: codetree, arg2: codetree} (* Arbitrary precision operations. This combines some conditionals with the operation. shortCond is the condition that must be satisfied for the short precision operation to be executed. longCall is called if either argument is long or the evaluation overflows. *) | Arbitrary of {oper: arbPrecisionOps, shortCond: codetree, arg1: codetree, arg2: codetree, longCall: codetree} | Lambda of lambdaForm (* Lambda expressions. *) | Cond of codetree * codetree * codetree (* If-statement *) | BeginLoop of (* Start of tail-recursive inline function. *) { loop: codetree, arguments: (simpleBinding * argumentType) list } | Loop of (codetree * argumentType) list (* Jump back to start of tail-recursive function. *) | Raise of codetree (* Raise an exception *) | Handle of (* Exception handler. *) { exp: codetree, handler: codetree, exPacketAddr: int } | Tuple of { fields: codetree list, isVariant: bool } (* Tuples and datatypes *) | SetContainer of (* Copy a tuple to a container. *) { container: codetree, tuple: codetree, filter: BoolVector.vector } | TagTest of { test: codetree, tag: word, maxTag: word } | LoadOperation of { kind: loadStoreKind, address: codeAddress } | StoreOperation of { kind: loadStoreKind, address: codeAddress, value: codetree } | BlockOperation of { kind: blockOpKind, sourceLeft: codeAddress, destRight: codeAddress, length: codetree } - | GetThreadId - | AllocateWordMemory of {numWords: codetree, flags: codetree, initial: codetree} and codeBinding = Declar of simpleBinding (* Make a local declaration or push an argument *) | RecDecs of { addr: int, lambda: lambdaForm, use: codeUse list } list (* Set of mutually recursive declarations. *) | NullBinding of codetree (* Just evaluate the expression and discard the result. *) | Container of { addr: int, use: codeUse list, size: int, setter: codetree } (* Container: allocate a piece of stack space and set it to the values from a tuple. *) and loadForm = LoadArgument of int | LoadLocal of int | LoadClosure of int | LoadRecursive (* When we look up an entry in the environment we get a pair of a "general" value, which is either a constant or a load, and an optional special value, which is either a tuple or an inline function. Tuple entries are functions from an integer offset to one of these pairs; inline function entries are a lambda together with a map for the free variables. *) and envGeneral = EnvGenLoad of loadForm | EnvGenConst of machineWord * Universal.universal list (* Special entries. The type of both EnvSpecTuple and EnvSpecInlineFunction includes a function from int, the index, to the (general, special) pair rather than a list of either fields or closure entries. The main reason is that if we have a function that contains a reference to, say a tuple, in its closure we can pass in a EnvSpecTuple entry with a function that only adds a field to the closure if the field is actually used. Passing a list would require adding all the fields to the closure at the time the EnvSpecTuple was passed. EnvSpecBuiltInX are used for a small number of built-in functions which can be simplied if they occur in combination with others. *) and envSpecial = EnvSpecNone | EnvSpecTuple of int * (int -> envGeneral * envSpecial) | EnvSpecInlineFunction of lambdaForm * (int -> envGeneral * envSpecial) | EnvSpecUnary of BuiltIns.unaryOps * codetree | EnvSpecBinary of BuiltIns.binaryOps * codetree * codetree (* Indirection types. IndTuple is from a tuple so the field will always be present; IndVariant is from a datatype which may have other variants that do not have the field; IndContainer is from a container (a set of words on the stack). *) and indKind = IndTuple | IndVariant | IndContainer withtype simpleBinding = { (* Declare a value or push an argument. *) value: codetree, addr: int, use: codeUse list } and lambdaForm = { (* Lambda expressions. *) body : codetree, isInline : inlineStatus, name : string, closure : loadForm list, argTypes : (argumentType * codeUse list) list, resultType : argumentType, localCount : int, recUse : codeUse list } and codeAddress = {base: codetree, index: codetree option, offset: word} structure CodeTags = struct open Universal (* Import tags from back end *) open BackendIntermediateCode.CodeTags val inlineCodeTag: envSpecial tag = tag() end open Pretty (* Common cases. *) val space = PrettyBreak (1, 0) fun block l = PrettyBlock (0, false, [], l) val string = PrettyString fun pList ([]: 'b list, _: string, _: 'b->pretty) = [] | pList ([h], _, disp) = [disp h] | pList (h::t, sep, disp) = PrettyBlock (0, false, [], [ disp h, PrettyBreak (0, 0), PrettyString sep ] ) :: PrettyBreak (1, 0) :: pList (t, sep, disp) fun pretty (pt : codetree) : pretty = let fun printList(start, lst, sep) : pretty = PrettyBlock (1, true, [], PrettyString (start ^ "(") :: pList(lst, sep, pretty) @ [ PrettyBreak (0, 0), PrettyString (")") ] ) fun prettyArg (c, _) = pretty c fun prettyArgs(start, lst, sep) : pretty = PrettyBlock (1, true, [], PrettyString (start ^ "(") :: pList(lst, sep, prettyArg) @ [ PrettyBreak (0, 0), PrettyString (")") ] ) fun prettyBuiltin(opers, arglist) = PrettyBlock (2, false, [], [ PrettyString opers, PrettyBreak(1, 2), PrettyBlock(2, true, [], [ printList("", arglist, ","), PrettyBreak (0, 0), PrettyString (")") ] ) ] ) fun prettyAddress({base, index, offset}: codeAddress): pretty = let in PrettyBlock (1, true, [], [ PrettyString "[", PrettyBreak (0, 3), pretty base, PrettyBreak (0, 0), PrettyString ",", PrettyBreak (1, 0), case index of NONE => PrettyString "-" | SOME i => pretty i, PrettyBreak (0, 0), PrettyString ",", PrettyBreak (1, 0), PrettyString(Word.toString offset), PrettyBreak (0, 0), PrettyString "]" ]) end in case pt of Eval {function, argList, ...} => PrettyBlock (2, false, [], [ case function of Extract _ => pretty function | Constnt _ => pretty function | _ => PrettyBlock(2, true, [], [ string "(", PrettyBreak(0, 0), pretty function, PrettyBreak(0, 0), string ")" ] ) , PrettyBreak(1, 2), PrettyBlock(2, true, [], ( string "(" :: PrettyBreak(0, 0) :: pList(argList, ",", prettyArg) @ [PrettyBreak (0, 0), PrettyString (")")] ) ) ] ) - | GetThreadId => prettyBuiltin("GetThreadId", []) - | Unary { oper, arg1 } => prettyBuiltin(BuiltIns.unaryRepr oper, [arg1]) | Binary { oper, arg1, arg2 } => prettyBuiltin(BuiltIns.binaryRepr oper, [arg1, arg2]) + | Nullary { oper } => PrettyString(BuiltIns.nullaryRepr oper) + | Arbitrary { oper, shortCond, arg1, arg2, longCall } => let val operName = case oper of ArbCompare test => BuiltIns.testRepr test | ArbArith arith => BuiltIns.arithRepr arith in prettyBuiltin(operName ^ "Arbitrary", [shortCond, arg1, arg2, longCall]) end | AllocateWordMemory { numWords, flags, initial } => prettyBuiltin("AllocateWordMemory", [numWords, flags, initial]) | Extract(LoadArgument addr) => string ("Arg" ^ Int.toString addr) | Extract(LoadLocal addr) => string ("Local" ^ Int.toString addr) | Extract(LoadClosure addr) => string ("Closure" ^ Int.toString addr) | Extract LoadRecursive => string "Recursive" | Indirect {base, offset, indKind} => PrettyBlock(2, false, [], [ pretty base, PrettyBreak(0, 2), string(concat["[", Int.toString offset, "]", case indKind of IndTuple => "" | IndVariant => "(*V*)" | IndContainer => "(*C*)"]) ] ) | Lambda {body, isInline, name, closure, argTypes, localCount, recUse, resultType, ...} => let val inl = case isInline of NonInline => "" | Inline => "inline," fun genType GeneralType = [] | genType DoubleFloatType = [ space, string ":double" ] | genType SingleFloatType = [ space, string ":float" ] fun printArgs(n, (t, u) :: rest) = PrettyBlock(4, false, [], [ string("Arg"^Int.toString n), space, prettyUses "" u ] @ genType t @ ( if null rest then [] else [PrettyBreak(0,0), string ",", space] ) ) :: printArgs(n+1, rest) | printArgs(_, []) = [] in PrettyBlock(2, true, [], [ PrettyBlock(4, false, [], [ string "fn(", space, block(printArgs(0, argTypes)), space, string ")"] @ genType resultType @ [ space, string "(*", space, string("\"" ^ name ^ "\""), space, string inl, space, string(Int.toString localCount ^ " locals,"), space, printList ("closure=", map Extract closure, ","), space, prettyUses "recursive use=" recUse, space, string "*)" ]), PrettyBreak(1, 2), pretty body ]) end | Constnt(w, m) => if isShort w andalso toShort w = 0w0 then ( case List.find (Universal.tagIs CodeTags.inlineCodeTag) m of SOME h => ( case Universal.tagProject CodeTags.inlineCodeTag h of EnvSpecInlineFunction(lambda, _) => pretty(Lambda lambda) | _ => PrettyString (stringOfWord w) ) | NONE => PrettyString (stringOfWord w) ) else PrettyString (stringOfWord w) | Cond (f, s, t) => PrettyBlock (0, true, [], [ PrettyBlock(2, false, [], [string "if", space, pretty f]), space, PrettyBlock(2, false, [], [string "then", space, pretty s]), space, PrettyBlock(2, false, [], [string "else", space, pretty t]) ] ) | Newenv(decs, final) => PrettyBlock (0, true, [], [ string "let", PrettyBreak (1, 2), PrettyBlock(2, true, [], pList(decs, ";", prettyBinding)), space, string "in", PrettyBreak(1, 2), PrettyBlock(2, true, [], [pretty final]), space, string "end" ] ) | BeginLoop{loop=loopExp, arguments=args } => let fun prettyArg (c, _) = prettySimpleBinding c in PrettyBlock (3, false, [], [ PrettyBlock (1, true, [], PrettyString ("BEGINLOOP(") :: pList(args, ",", prettyArg) @ [ PrettyBreak (0, 0), PrettyString (")") ] ), PrettyBreak (0, 0), PrettyString "(", PrettyBreak (0, 0), pretty loopExp, PrettyBreak (0, 0), PrettyString ")" ] ) end | Loop ptl => prettyArgs("LOOP", ptl, ",") | Raise c => PrettyBlock (1, true, [], [ PrettyString "RAISE(", pretty c, PrettyBreak (0, 0), PrettyString (")") ] ) | Handle {exp, handler, exPacketAddr} => PrettyBlock (3, false, [], [ PrettyString "HANDLE(", pretty exp, PrettyString ("WITH exid=" ^ Int.toString exPacketAddr), PrettyBreak (1, 0), pretty handler, PrettyString ")" ] ) | Tuple { fields, isVariant } => printList(if isVariant then "DATATYPE" else "TUPLE", fields, ",") | SetContainer{container, tuple, filter} => let val source = BoolVector.length filter val dest = BoolVector.foldl(fn (true, n) => n+1 | (false, n) => n) 0 filter in PrettyBlock (3, false, [], [ string (concat["SETCONTAINER(", Int.toString dest, "/", Int.toString source, ", "]), pretty container, PrettyBreak (0, 0), PrettyString ",", PrettyBreak (1, 0), pretty tuple, PrettyBreak (0, 0), PrettyString ")" ] ) end | TagTest { test, tag, maxTag } => PrettyBlock (3, false, [], [ PrettyString (concat["TAGTEST(", Word.toString tag, ", ", Word.toString maxTag, ","]), PrettyBreak (1, 0), pretty test, PrettyBreak (0, 0), PrettyString ")" ] ) | LoadOperation{ kind, address } => PrettyBlock (3, false, [], [ PrettyString("Load" ^ BackendIntermediateCode.loadStoreKindRepr kind), PrettyBreak (1, 0), prettyAddress address ] ) | StoreOperation{ kind, address, value } => PrettyBlock (3, false, [], [ PrettyString("Store" ^ BackendIntermediateCode.loadStoreKindRepr kind), PrettyBreak (1, 0), prettyAddress address, PrettyBreak (1, 0), PrettyString "<=", PrettyBreak (1, 0), pretty value ] ) | BlockOperation{ kind, sourceLeft, destRight, length } => PrettyBlock (3, false, [], [ PrettyString(BackendIntermediateCode.blockOpKindRepr kind ^ "("), PrettyBreak (1, 0), prettyAddress sourceLeft, PrettyBreak (1, 0), PrettyString ",", prettyAddress destRight, PrettyBreak (1, 0), PrettyString ",", pretty length, PrettyBreak (1, 0), PrettyString ")" ] ) (* That list should be exhaustive! *) end (* pretty *) and prettyBinding(Declar dec) = prettySimpleBinding dec | prettyBinding(RecDecs ptl) = let fun prettyRDec {lambda, addr, use, ...} = block [ string ("Local" ^ Int.toString addr), space, string "(*", prettyUses "" use, space, string "*)", space, string "=", PrettyBreak (1, 2), PrettyBlock (2, false, [], [pretty(Lambda lambda)]) ] in PrettyBlock(0, true, [], string "val rec " :: pList(ptl, " and ", prettyRDec) ) end | prettyBinding(NullBinding c) = pretty c | prettyBinding(Container{addr, use, size, setter}) = PrettyBlock(1, false, [], [ string ("val Local" ^ Int.toString addr), space, string "(*", string "", space, prettyUses "" use, space, string "*)", space, string ("= Container " ^ Int.toString size), space, string "with", space, pretty setter ] ) and prettySimpleBinding{value, addr, use, ...} = PrettyBlock (1, false, [], [ string ("val Local" ^ Int.toString addr), space, string "(*", string "", space, prettyUses "" use, space, string "*)", space, string "=", PrettyBreak (1, 2), PrettyBlock (2, false, [], [pretty value]) ] ) and prettyUses prefix cl = PrettyBlock (1, true, [], PrettyString (prefix ^ "[") :: pList(cl, ",", prettyUsage) @ [ PrettyBreak (0, 0), PrettyString ("]") ] ) and prettyUsage UseGeneral = PrettyString "_" | prettyUsage UseExport = PrettyString "Export" | prettyUsage (UseApply (cl, al)) = PrettyBlock (1, true, [], string "(" :: pList(al, "|", fn _ => string "-") @ string ")" :: space :: string "->" :: space :: string "(" :: pList(cl, "|", prettyUsage) @ [ PrettyBreak (0, 0), string ")" ] ) | prettyUsage (UseField (n, cl)) = PrettyBlock (1, true, [], string ("UseField"^ Int.toString n ^ "[") :: pList(cl, ",", prettyUsage) @ [ PrettyBreak (0, 0), string "]" ] ) (* Mapping function to enable parts of the tree to be replaced. *) fun mapCodetree f code = let (* We use these functions to allow all nodes to be processed even if they are not full codetree nodes. *) fun deExtract(Extract l) = l | deExtract _ = raise Misc.InternalError "deExtract" fun deLambda (Lambda l) = l | deLambda _ = raise Misc.InternalError "deLambda" fun mapt (Newenv(decs, exp)) = let fun mapbinding(Declar{value, addr, use}) = Declar{value=mapCodetree f value, addr=addr, use=use} | mapbinding(RecDecs l) = RecDecs(map(fn {addr, lambda, use} => {addr=addr, use = use, lambda = deLambda(mapCodetree f (Lambda lambda))}) l) | mapbinding(NullBinding exp) = NullBinding(mapCodetree f exp) | mapbinding(Container{addr, use, size, setter}) = Container{addr=addr, use=use, size=size, setter=mapCodetree f setter} in Newenv(map mapbinding decs, mapCodetree f exp) end | mapt (c as Constnt _) = c | mapt (e as Extract _) = e | mapt (Indirect { base, offset, indKind }) = Indirect{ base = mapCodetree f base, offset = offset, indKind = indKind } | mapt (Eval { function, argList, resultType }) = Eval { function = mapCodetree f function, argList = map (fn(c, a) => (mapCodetree f c, a)) argList, resultType = resultType } - | mapt GetThreadId = GetThreadId + | mapt(nullary as Nullary _) = nullary | mapt(Unary { oper, arg1 }) = Unary { oper = oper, arg1 = mapCodetree f arg1 } | mapt(Binary { oper, arg1, arg2 }) = Binary { oper = oper, arg1 = mapCodetree f arg1, arg2 = mapCodetree f arg2 } | mapt(Arbitrary { oper, shortCond, arg1, arg2, longCall }) = Arbitrary { oper = oper, shortCond = mapCodetree f shortCond, arg1 = mapCodetree f arg1, arg2 = mapCodetree f arg2, longCall = mapCodetree f longCall } | mapt(AllocateWordMemory { numWords, flags, initial }) = AllocateWordMemory { numWords = mapCodetree f numWords, flags = mapCodetree f flags, initial = mapCodetree f initial } | mapt (Lambda { body, isInline, name, closure, argTypes, resultType, localCount, recUse }) = Lambda { body = mapCodetree f body, isInline = isInline, name = name, closure = map (deExtract o (mapCodetree f) o Extract) closure, argTypes = argTypes, resultType = resultType, localCount = localCount, recUse = recUse } | mapt (Cond(i, t, e)) = Cond(mapCodetree f i, mapCodetree f t, mapCodetree f e) | mapt (BeginLoop{loop, arguments}) = BeginLoop { loop = mapCodetree f loop, arguments = map(fn({value, addr, use}, t) => ({value=mapCodetree f value, addr=addr, use=use}, t)) arguments } | mapt (Loop l) = Loop (map(fn(c, t) => (mapCodetree f c, t)) l) | mapt (Raise r) = Raise(mapCodetree f r) | mapt (Handle{exp, handler, exPacketAddr}) = Handle{exp=mapCodetree f exp, handler=mapCodetree f handler, exPacketAddr=exPacketAddr } | mapt (Tuple { fields, isVariant} ) = Tuple { fields = map (mapCodetree f) fields, isVariant = isVariant } | mapt (SetContainer{container, tuple, filter}) = SetContainer{ container = mapCodetree f container, tuple = mapCodetree f tuple, filter = filter } | mapt (TagTest{test, tag, maxTag}) = TagTest{test = mapCodetree f test, tag = tag, maxTag = maxTag } | mapt (LoadOperation{kind, address}) = LoadOperation{kind = kind, address = maptAddress address } | mapt (StoreOperation{kind, address, value}) = StoreOperation{kind = kind, address = maptAddress address, value=mapCodetree f value } | mapt (BlockOperation{kind, sourceLeft, destRight, length}) = BlockOperation{kind = kind, sourceLeft = maptAddress sourceLeft, destRight = maptAddress destRight, length=mapCodetree f length } and maptAddress({base, index, offset}: codeAddress): codeAddress = {base=mapCodetree f base, index=case index of NONE => NONE | SOME i => SOME(mapCodetree f i), offset=offset} in (* Apply f to node. If it returns SOME c use that otherwise traverse the tree. *) case f code of SOME c => c | NONE => mapt code end (* Fold a function over the tree. f is applied to the node and the input value and returns an output and a flag. If the flag is FOLD_DONT_DESCEND the output value is used and the code tree is not examined further. Otherwise this function descends into the tree and folds over the subtree. *) datatype foldControl = FOLD_DESCEND | FOLD_DONT_DESCEND fun foldtree (f: codetree * 'a -> 'a * foldControl) (input: 'a) code = let fun ftree (Newenv(decs, exp), v) = let fun foldbinding(Declar{value, ...}, w) = foldtree f w value | foldbinding(RecDecs l, w) = foldl(fn ({lambda, ...}, x) => foldtree f x (Lambda lambda)) w l | foldbinding(NullBinding exp, w) = foldtree f w exp | foldbinding(Container{setter, ...}, w) = foldtree f w setter in foldtree f (foldl foldbinding v decs) exp end | ftree (Constnt _, v) = v | ftree (Extract _, v) = v | ftree (Indirect{base, ...}, v) = foldtree f v base | ftree (Eval { function, argList, ...}, v) = foldl(fn((c, _), w) => foldtree f w c) (foldtree f v function) argList - | ftree (GetThreadId, v) = v + | ftree (Nullary _, v) = v | ftree (Unary {arg1, ...}, v) = foldtree f v arg1 | ftree (Binary {arg1, arg2, ...}, v) = foldtree f (foldtree f v arg1) arg2 | ftree (Arbitrary {shortCond, arg1, arg2, longCall, ...}, v) = foldtree f (foldtree f (foldtree f (foldtree f v shortCond) arg1) arg2) longCall | ftree (AllocateWordMemory {numWords, flags, initial}, v) = foldtree f (foldtree f (foldtree f v numWords) flags) initial | ftree (Lambda { body, closure, ...}, v) = foldtree f (foldl (fn (c, w) => foldtree f w (Extract c)) v closure) body | ftree (Cond(i, t, e), v) = foldtree f (foldtree f (foldtree f v i) t) e | ftree (BeginLoop{loop, arguments, ...}, v) = foldtree f (foldl (fn (({value, ...}, _), w) => foldtree f w value) v arguments) loop | ftree (Loop l, v) = foldl (fn ((c, _), w) => foldtree f w c) v l | ftree (Raise r, v) = foldtree f v r | ftree (Handle{exp, handler, ...}, v) = foldtree f (foldtree f v exp) handler | ftree (Tuple { fields, ...}, v) = foldl (fn (c, w) => foldtree f w c) v fields | ftree (SetContainer { container, tuple, ...}, v) = foldtree f (foldtree f v container) tuple | ftree (TagTest{test, ...}, v) = foldtree f v test | ftree (LoadOperation{address, ...}, v) = fAddress address v | ftree (StoreOperation{address, value, ...}, v) = foldtree f (fAddress address v) value | ftree (BlockOperation{sourceLeft, destRight, length, ...}, v) = foldtree f (fAddress sourceLeft (fAddress destRight v)) length and fAddress {base, index=NONE, ...} v = foldtree f v base | fAddress {base, index=SOME index, ...} v = foldtree f (foldtree f v base) index in case f (code, input) of (v, FOLD_DONT_DESCEND) => v | (v, FOLD_DESCEND) => ftree(code, v) end structure Sharing = struct type codetree = codetree and pretty = pretty and inlineStatus = inlineStatus and argumentType = argumentType and loadStoreKind = loadStoreKind and blockOpKind = blockOpKind and codeBinding = codeBinding and simpleBinding = simpleBinding and loadForm = loadForm and envGeneral = envGeneral and envSpecial = envSpecial and codeUse = codeUse and foldControl = foldControl and unaryOps = BuiltIns.unaryOps and binaryOps = BuiltIns.binaryOps + and nullaryOps = BuiltIns.nullaryOps and arbPrecisionOps = arbPrecisionOps and testConditions = BuiltIns.testConditions and arithmeticOperations = BuiltIns.arithmeticOperations end end; diff --git a/mlsource/MLCompiler/CodeTree/BaseCodeTreeSig.sml b/mlsource/MLCompiler/CodeTree/BaseCodeTreeSig.sml index c28c71bb..74c3712b 100644 --- a/mlsource/MLCompiler/CodeTree/BaseCodeTreeSig.sml +++ b/mlsource/MLCompiler/CodeTree/BaseCodeTreeSig.sml @@ -1,219 +1,219 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited - Modified David C. J. Matthews 2008-2010, 2013, 2016-18 + Modified David C. J. Matthews 2008-2010, 2013, 2016-19 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Signature for the basic codetree types and operations. *) signature BaseCodeTreeSig = sig type machineWord = Address.machineWord datatype inlineStatus = NonInline | Inline datatype argumentType = GeneralType | DoubleFloatType | SingleFloatType datatype loadStoreKind = LoadStoreMLWord of {isImmutable: bool} (* Load/Store an ML word in an ML word cell. *) | LoadStoreMLByte of {isImmutable: bool} (* Load/Store a byte, tagging and untagging as appropriate, in an ML byte cell. *) | LoadStoreC8 (* Load/Store C values - The base address is a boxed SysWord.word value. *) | LoadStoreC16 | LoadStoreC32 | LoadStoreC64 | LoadStoreCFloat | LoadStoreCDouble | LoadStoreUntaggedUnsigned datatype blockOpKind = BlockOpMove of {isByteMove: bool} | BlockOpEqualByte | BlockOpCompareByte structure BuiltIns: BUILTINS datatype arbPrecisionOps = ArbCompare of BuiltIns.testConditions | ArbArith of BuiltIns.arithmeticOperations (* How variables are used. Added and examined by the optimisation pass. *) datatype codeUse = UseGeneral (* Used in some other context. *) | UseExport (* Exported i.e. the result of a top-level binding. *) | UseApply of codeUse list * codetree list (* Applied as a function - the list is where the result goes, the codetree list is the code that was used for each argument. *) | UseField of int * codeUse list (* Selected as a field - the list is where the result goes *) and codetree = Newenv of codeBinding list * codetree (* Set of bindings with an expression. *) | Constnt of machineWord * Universal.universal list (* Load a constant *) | Extract of loadForm | Indirect of {base: codetree, offset: int, indKind: indKind } (* Load a value from the heap or the stack. *) | Eval of (* Evaluate a function with an argument list. *) { function: codetree, argList: (codetree * argumentType) list, resultType: argumentType } (* Built-in functions. *) + | Nullary of {oper: BuiltIns.nullaryOps} | Unary of {oper: BuiltIns.unaryOps, arg1: codetree} | Binary of {oper: BuiltIns.binaryOps, arg1: codetree, arg2: codetree} (* Arbitrary precision operations. This combines some conditionals with the operation. shortCond is the condition that must be satisfied for the short precision operation to be executed. longCall is called if either argument is long or the evaluation overflows. *) | Arbitrary of {oper: arbPrecisionOps, shortCond: codetree, arg1: codetree, arg2: codetree, longCall: codetree} | Lambda of lambdaForm (* Lambda expressions. *) | Cond of codetree * codetree * codetree (* If-statement *) | BeginLoop of (* Start of tail-recursive inline function. *) { loop: codetree, arguments: (simpleBinding * argumentType) list } | Loop of (codetree * argumentType) list (* Jump back to start of tail-recursive function. *) | Raise of codetree (* Raise an exception *) | Handle of (* Exception handler. *) { exp: codetree, handler: codetree, exPacketAddr: int } | Tuple of { fields: codetree list, isVariant: bool } (* Tuples and datatypes *) | SetContainer of { container: codetree, tuple: codetree, filter: BoolVector.vector} (* Copy a tuple to a container. *) | TagTest of { test: codetree, tag: word, maxTag: word } | LoadOperation of { kind: loadStoreKind, address: codeAddress } | StoreOperation of { kind: loadStoreKind, address: codeAddress, value: codetree } | BlockOperation of { kind: blockOpKind, sourceLeft: codeAddress, destRight: codeAddress, length: codetree } - | GetThreadId - | AllocateWordMemory of {numWords: codetree, flags: codetree, initial: codetree} and codeBinding = Declar of simpleBinding (* Make a local declaration or push an argument *) | RecDecs of { addr: int, lambda: lambdaForm, use: codeUse list } list (* Set of mutually recursive declarations. *) | NullBinding of codetree (* Just evaluate the expression and discard the result. *) | Container of { addr: int, use: codeUse list, size: int, setter: codetree } and loadForm = LoadArgument of int | LoadLocal of int | LoadClosure of int | LoadRecursive (* When we look up an entry in the environment we get a pair of a "general" value, which is either a constant or a load, and an optional special value, which is either a tuple or an inline function. Tuple entries are functions from an integer offset to one of these pairs; inline function entries are a lambda together with a map for the free variables. *) and envGeneral = EnvGenLoad of loadForm | EnvGenConst of machineWord * Universal.universal list and envSpecial = EnvSpecNone | EnvSpecTuple of int * (int -> envGeneral * envSpecial) | EnvSpecInlineFunction of lambdaForm * (int -> envGeneral * envSpecial) | EnvSpecUnary of BuiltIns.unaryOps * codetree | EnvSpecBinary of BuiltIns.binaryOps * codetree * codetree (* Indirection types. IndTuple is from a tuple so the field will always be present; IndVariant is from a datatype which may have other variants that do not have the field; IndContainer is from a container (a set of words on the stack). *) and indKind = IndTuple | IndVariant | IndContainer withtype simpleBinding = { (* Declare a value or push an argument. *) value: codetree, addr: int, use: codeUse list } and lambdaForm = { (* Lambda expressions. *) body : codetree, (* The body of the function. *) isInline : inlineStatus, (* Whether it's inline - modified by optimiser *) name : string, (* Text name for profiling etc. *) closure : loadForm list, (* List of items for closure. *) argTypes : (argumentType * codeUse list) list, (* "Types" and usage of arguments. *) resultType : argumentType, (* Result "type" of the function. *) localCount : int, (* Maximum (+1) declaration address for locals. *) recUse : codeUse list (* Recursive use of the function *) } and codeAddress = {base: codetree, index: codetree option, offset: word} type pretty val pretty : codetree -> pretty val mapCodetree: (codetree -> codetree option) -> codetree -> codetree datatype foldControl = FOLD_DESCEND | FOLD_DONT_DESCEND val foldtree: (codetree * 'a -> 'a * foldControl) -> 'a -> codetree -> 'a structure CodeTags: sig val tupleTag: Universal.universal list list Universal.tag val inlineCodeTag: envSpecial Universal.tag val mergeTupleProps: Universal.universal list * Universal.universal list -> Universal.universal list end structure Sharing: sig type codetree = codetree and pretty = pretty and inlineStatus = inlineStatus and argumentType = argumentType and loadStoreKind = loadStoreKind and blockOpKind = blockOpKind and codeBinding = codeBinding and simpleBinding = simpleBinding and loadForm = loadForm and envGeneral = envGeneral and envSpecial = envSpecial and codeUse = codeUse and foldControl = foldControl and unaryOps = BuiltIns.unaryOps and binaryOps = BuiltIns.binaryOps + and nullaryOps = BuiltIns.nullaryOps and arbPrecisionOps = arbPrecisionOps and testConditions = BuiltIns.testConditions and arithmeticOperations = BuiltIns.arithmeticOperations end end; diff --git a/mlsource/MLCompiler/CodeTree/CODETREE.ML b/mlsource/MLCompiler/CodeTree/CODETREE.ML index f97f2fad..bd4245bd 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE.ML +++ b/mlsource/MLCompiler/CodeTree/CODETREE.ML @@ -1,585 +1,587 @@ (* - Copyright (c) 2012,13,15-17 David C.J. Matthews + Copyright (c) 2012,13,15-19 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor CODETREE ( structure DEBUG: DEBUGSIG structure PRETTY : PRETTYSIG structure BASECODETREE: BaseCodeTreeSig structure CODETREE_FUNCTIONS: CodetreeFunctionsSig structure BACKEND: sig type codetree type machineWord = Address.machineWord val codeGenerate: codetree * int * Universal.universal list -> (unit -> machineWord) * Universal.universal list structure Foreign: FOREIGNCALLSIG structure Sharing : sig type codetree = codetree end end structure OPTIMISER: sig type codetree and envSpecial and codeBinding val codetreeOptimiser: codetree * Universal.universal list * int -> { numLocals: int, general: codetree, bindings: codeBinding list, special: envSpecial } structure Sharing: sig type codetree = codetree and envSpecial = envSpecial and codeBinding = codeBinding end end sharing type PRETTY.pretty = BASECODETREE.pretty sharing BASECODETREE.Sharing = CODETREE_FUNCTIONS.Sharing = BACKEND.Sharing = OPTIMISER.Sharing ) : CODETREESIG = struct open Address; open StretchArray; open BASECODETREE; open PRETTY; open CODETREE_FUNCTIONS exception InternalError = Misc.InternalError and Interrupt = Thread.Thread.Interrupt infix 9 sub; fun mkDec (laddr, res) = Declar{value = res, addr = laddr, use=[]} fun deExtract(Extract ext) = ext | deExtract _ = raise InternalError "deExtract" datatype level = Level of { lev: int, closure: createClosure, lookup: int * int * bool -> loadForm } local (* We can have locals at the outer level. *) fun bottomLevel(addr, 0, false) = if addr < 0 then raise InternalError "load: negative" else LoadLocal addr | bottomLevel _ = (* Either the level is wrong or it's a parameter. *) raise InternalError "bottom level" in val baseLevel = Level { lev = 0, closure = makeClosure(), lookup = bottomLevel } end fun newLevel (Level{ lev, lookup, ...}) = let val closureList = makeClosure() val makeClosure = addToClosure closureList fun check n = if n < 0 then raise InternalError "load: negative" else n fun thisLevel(addr, level, isParam) = if level < 0 then raise InternalError "mkLoad: level must be non-negative" else if level > 0 then makeClosure(lookup(addr, level-1, isParam)) else (* This level *) if isParam then LoadArgument(check addr) else LoadLocal(check addr) in Level { lev = lev+1, closure = closureList, lookup = thisLevel } end fun getClosure(Level{ closure, ...}) = List.map Extract (extractClosure closure) fun mkLoad (addr, Level { lev = newLevel, lookup, ... } , Level { lev = oldLevel, ... }) = Extract(lookup(addr, newLevel - oldLevel, false)) and mkLoadParam(addr, Level { lev = newLevel, lookup, ... } , Level { lev = oldLevel, ... }) = Extract(lookup(addr, newLevel - oldLevel, true)) (* Transform a function so that free variables are converted to closure form. Returns the maximum local address used. *) fun genCode(pt, debugSwitches, numLocals) = let val printCodeTree = DEBUG.getParameter DEBUG.codetreeTag debugSwitches and compilerOut = PRETTY.getCompilerOutput debugSwitches (* val printCodeTree = true and compilerOut = PRETTY.prettyPrint(TextIO.print, 70) *) (* If required, print it first. This is the code that the front-end has produced. *) val () = if printCodeTree then compilerOut(pretty pt) else () (* This ensures that everything is printed just before it is code-generated. *) fun codeAndPrint(code, localCount) = let val () = if printCodeTree then compilerOut (BASECODETREE.pretty code) else (); in BACKEND.codeGenerate(code, localCount, debugSwitches) end (* Optimise it. *) val { numLocals = localCount, general = gen, bindings = decs, special = spec } = OPTIMISER.codetreeOptimiser(pt, debugSwitches, numLocals) (* At this stage we have a "general" value and also, possibly a "special" value. We could simply create mkEnv(decs, gen) and run preCode and genCode on that. However, we would lose the ability to insert any inline functions from this code into subsequent top-level expressions. We can't simply retain the "special" entry either because that may refer to values that have to be created once when the code is run. Such values will be referenced by "load" entries which refer to entries in the "decs". We construct a tuple which will contain the actual values after the code is run. Then if we want the value at some time in the future when we use something from the "special" entry we can extract the corresponding value from this tuple. Previously, this code always generated a tuple containing every declaration. That led to some very long compilation times because the back-end has some code which is quadratic in the number of entries on the stack. We now try to prune bindings by only generating the tuple if we have an inline function somewhere and only generating bindings we actually need. *) fun simplifySpec (EnvSpecTuple(size, env)) = let (* Get all the field entries. *) fun simpPair (gen, spec) = (gen, simplifySpec spec) val fields = List.tabulate(size, simpPair o env) in if List.all(fn (_, EnvSpecNone) => true | _ => false) fields then EnvSpecNone else EnvSpecTuple(size, fn n => List.nth(fields, n)) end | simplifySpec s = s (* None or inline function. *) in case simplifySpec spec of EnvSpecNone => let val (code, props) = codeAndPrint (mkEnv(decs, gen), localCount) in fn () => Constnt(code(), props) end | simpleSpec => let (* The bindings are marked using a three-valued mark. A binding is needed if it is referenced in any way. During the scan to find the references we need to avoid processing an entry that has already been processed but it is possible that a binding may be referenced as a general value only (e.g. from a function closure) and separately as a special value. See Test148.ML *) datatype visit = UnVisited | VisitedGeneral | VisitedSpecial local val refArray = Array.array(localCount, UnVisited) fun findDecs EnvSpecNone = () | findDecs (EnvSpecTuple(size, env)) = let val fields = List.tabulate(size, env) in List.app processGenAndSpec fields end | findDecs (EnvSpecInlineFunction({closure, ...}, env)) = let val closureItems = List.tabulate(List.length closure, env) in List.app processGenAndSpec closureItems end | findDecs (EnvSpecUnary _) = () | findDecs (EnvSpecBinary _) = () and processGenAndSpec (gen, spec) = (* The spec part needs only to be processed if this entry has not yet been visited, *) case gen of EnvGenLoad(LoadLocal addr) => let val previous = Array.sub(refArray, addr) in case (previous, spec) of (VisitedSpecial, _) => () (* Fully done *) | (VisitedGeneral, EnvSpecNone) => () (* Nothing useful *) | (_, EnvSpecNone) => (* We need this entry but we don't have any special entry to process. We could find another reference with a special entry. *) Array.update(refArray, addr, VisitedGeneral) | (_, _) => ( (* This has a special entry. Mark it and process. *) Array.update(refArray, addr, VisitedSpecial); findDecs spec ) end | EnvGenConst _ => () | _ => raise InternalError "doGeneral: not LoadLocal or Constant" val () = findDecs simpleSpec in (* Convert to an immutable data structure. This will continue to be referenced in any inline function after the code has run. *) val refVector = Array.vector refArray end val decArray = Array.array(localCount, CodeZero) fun addDec(addr, dec) = if Vector.sub(refVector, addr) <> UnVisited then Array.update(decArray, addr, dec) else () fun addDecs(Declar{addr, ...}) = addDec(addr, mkLoadLocal addr) | addDecs(RecDecs decs) = List.app(fn {addr, ...} => addDec(addr, mkLoadLocal addr)) decs | addDecs(NullBinding _) = () | addDecs(Container{addr, size, ...}) = addDec(addr, mkTupleFromContainer(addr, size)) val () = List.app addDecs decs (* Construct the tuple and add the "general" value at the start. *) val resultTuple = mkTuple(gen :: Array.foldr(op ::) nil decArray) (* Now generate the machine code and return it as a function that can be called. *) val (code, codeProps) = codeAndPrint (mkEnv (decs, resultTuple), localCount) in (* Return a function that executes the compiled code and then creates the final "global" value as the result. *) fn () => let local (* Execute the code. This will perform any side-effects the user has programmed and may raise an exception if that is required. *) val resVector = code () (* The result is a vector containing the "general" value as the first word and the evaluated bindings for any "special" entries in subsequent words. *) val decVals : address = if isShort resVector then raise InternalError "Result vector is not an address" else toAddress resVector in fun resultWordN n = loadWord (decVals, n) (* Get the general value, the zero'th entry in the vector. *) val generalVal = resultWordN 0w0 (* Get the properties for a field in the tuple. Because the result is a tuple all the properties should be contained in a tupleTag entry. *) val fieldProps = case Option.map (Universal.tagProject CodeTags.tupleTag) (List.find(Universal.tagIs CodeTags.tupleTag) codeProps) of NONE => (fn _ => []) | SOME p => (fn n => List.nth(p, n)) val generalProps = fieldProps 0 end (* Construct a new environment so that when an entry is looked up the corresponding constant is returned. *) fun newEnviron (oldEnv) args = let val (oldGeneral, oldSpecial) = oldEnv args val genPair = case oldGeneral of EnvGenLoad(LoadLocal addr) => ( (* For the moment retain this check. It's better to have an assertion failure than a segfault. *) Vector.sub(refVector, addr) <> UnVisited orelse raise InternalError "Reference to non-existent binding"; (resultWordN(Word.fromInt addr+0w1), fieldProps(addr+1)) ) | EnvGenConst c => c | _ => raise InternalError "codetree newEnviron: Not Extract or Constnt" val specVal = mapSpec oldSpecial in (EnvGenConst genPair, specVal) end and mapSpec EnvSpecNone = EnvSpecNone | mapSpec (EnvSpecTuple(size, env)) = EnvSpecTuple(size, newEnviron env) | mapSpec (EnvSpecInlineFunction(spec, env)) = EnvSpecInlineFunction(spec, (newEnviron env)) | mapSpec (EnvSpecUnary _) = EnvSpecNone | mapSpec (EnvSpecBinary _) = EnvSpecNone in (* and return the whole lot as a global value. *) Constnt(generalVal, setInline(mapSpec simpleSpec) generalProps) end end end (* genCode *) (* Constructor functions for the front-end of the compiler. *) local fun mkSimpleFunction inlineType (lval, args, name, closure, numLocals) = { body = lval, isInline = inlineType, name = if name = "" then "" else name, closure = map deExtract closure, argTypes = List.tabulate(args, fn _ => (GeneralType, [])), resultType = GeneralType, localCount = numLocals, recUse = [] } in val mkProc = Lambda o mkSimpleFunction NonInline (* Normal function *) and mkInlproc = Lambda o mkSimpleFunction Inline (* Explicitly inlined by the front-end *) (* Unless Compiler.inlineFunctor is false functors are treated as macros and expanded when they are applied. Unlike core-language functions they are not first-class values so if they are inline the "value" returned in the initial binding can just be zero except if there is something in the closure. Almost always the closure will be empty since free variables will come from previous topdecs and will be constants, The exception is if a structure and a functor using the structure appear in the same topdec (no semicolon between them). In that case we can't leave it. We would have to update the closure even if we leave the body untouched but we could have closure entries that are constants. e.g. structure S = struct val x = 1 end functor F() = struct open S end *) fun mkMacroProc (args as (_, _, _, [], _)) = Constnt(toMachineWord 0, setInline ( EnvSpecInlineFunction(mkSimpleFunction Inline args, fn _ => raise InternalError "mkMacroProc: closure")) []) | mkMacroProc args = Lambda(mkSimpleFunction Inline args) end local fun mkFunWithTypes inlineType { body, argTypes=argsAndTypes, resultType, name, closure, numLocals } = Lambda { body = body, isInline = inlineType, name = if name = "" then "" else name, closure = map deExtract closure, argTypes = map (fn t => (t, [])) argsAndTypes, resultType = resultType, localCount = numLocals, recUse = [] } in val mkFunction = mkFunWithTypes NonInline and mkInlineFunction = mkFunWithTypes Inline end fun mkEval (ct, clist) = Eval { function = ct, argList = List.map(fn c => (c, GeneralType)) clist, resultType=GeneralType } fun mkCall(func, argsAndTypes, resultType) = Eval { function = func, argList = argsAndTypes, resultType=resultType } (* Basic built-in operations. *) fun mkUnary (oper, arg1) = Unary { oper = oper, arg1 = arg1 } and mkBinary (oper, arg1, arg2) = Binary { oper = oper, arg1 = arg1, arg2 = arg2 } - val getCurrentThreadId = GetThreadId - and getCurrentThreadIdFn = - mkInlproc(GetThreadId, 1 (* Ignores argument *), "GetThreadId()", [], 0) + val getCurrentThreadId = Nullary{oper=BuiltIns.GetCurrentThreadId} + val getCurrentThreadIdFn = + mkInlproc(getCurrentThreadId, 1 (* Ignores argument *), "GetThreadId()", [], 0) + + val checkRTSException = Nullary{oper=BuiltIns.CheckRTSException} fun mkAllocateWordMemory (numWords, flags, initial) = AllocateWordMemory { numWords = numWords, flags = flags, initial = initial } val mkAllocateWordMemoryFn = mkInlproc( mkAllocateWordMemory(mkInd(0, mkLoadArgument 0), mkInd(1, mkLoadArgument 0), mkInd(2, mkLoadArgument 0)), 1, "AllocateWordMemory()", [], 0) (* Builtins wrapped as functions. N.B. These all take a single argument which may be a tuple. *) fun mkUnaryFn oper = mkInlproc(mkUnary(oper, mkLoadArgument 0), 1, BuiltIns.unaryRepr oper ^ "()", [], 0) and mkBinaryFn oper = mkInlproc(mkBinary(oper, mkInd(0, mkLoadArgument 0), mkInd(1, mkLoadArgument 0)), 1, BuiltIns.binaryRepr oper ^ "()", [], 0) local open BuiltIns (* Word equality. The value of isSigned doesn't matter. *) val eqWord = WordComparison{test=TestEqual, isSigned=false} in fun mkNot arg = Unary{oper=NotBoolean, arg1=arg} and mkIsShort arg = Unary{oper=IsTaggedValue, arg1=arg} and mkEqualWord (arg1, arg2) = Binary{oper=eqWord, arg1=arg1, arg2=arg2} val equalWordFn = (* This takes two words, not a tuple. *) mkInlproc(mkBinary(eqWord, mkLoadArgument 0, mkLoadArgument 1), 2, "EqualWord()", [], 0) end (* Equality for arbitrary precision if at least one of the arguments is known to be short. *) fun mkEqualArbShort (arg1, arg2) = Arbitrary { oper=ArbCompare BuiltIns.TestEqual, shortCond=Constnt(toMachineWord 1, []), arg1=arg1, arg2=arg2, longCall=CodeZero} fun mkLoadOperation(oper, base, index) = LoadOperation{kind=oper, address={base=base, index=SOME index, offset=0w0}} fun mkLoadOperationFn oper = mkInlproc(mkLoadOperation(oper, mkInd(0, mkLoadArgument 0), mkInd(1, mkLoadArgument 0)), 1, "loadOperation()", [], 0) fun mkStoreOperation(oper, base, index, value) = StoreOperation{kind=oper, address={base=base, index=SOME index, offset=0w0}, value=value} fun mkStoreOperationFn oper = mkInlproc(mkStoreOperation(oper, mkInd(0, mkLoadArgument 0), mkInd(1, mkLoadArgument 0), mkInd(2, mkLoadArgument 0)), 1, "storeOperation()", [], 0) fun mkBlockOperation {kind, leftBase, leftIndex, rightBase, rightIndex, length } = BlockOperation { kind = kind, sourceLeft={base=leftBase, index=SOME leftIndex, offset=0w0}, destRight={base=rightBase, index=SOME rightIndex, offset=0w0}, length=length} (* Construct a function that takes five arguments. The order is left-base, right-base, left-index, right-index, length. *) fun mkBlockOperationFn kind = mkInlproc( mkBlockOperation{kind=kind, leftBase=mkInd(0, mkLoadArgument 0), rightBase=mkInd(1, mkLoadArgument 0), leftIndex=mkInd(2, mkLoadArgument 0), rightIndex=mkInd(3, mkLoadArgument 0), length=mkInd(4, mkLoadArgument 0)}, 1, "blockOperation()", [], 0) fun identityFunction (name : string) : codetree = mkInlproc (mkLoadArgument 0, 1, name, [], 0) (* Returns its argument. *); (* Test a tag value. *) fun mkTagTest(test: codetree, tagValue: word, maxTag: word) = TagTest {test=test, tag=tagValue, maxTag=maxTag } fun mkHandle (exp, handler, exId) = Handle {exp = exp, handler = handler, exPacketAddr = exId} fun mkStr (strbuff:string) = Constnt (toMachineWord strbuff, []) (* If we have multiple references to a piece of code we may have to save it in a temporary and then use it from there. If the code has side-effects we certainly must do that to ensure that the side-effects are done exactly once and in the correct order, however if the code is just a constant or a load we can reduce the amount of code we generate by simply returning the original code. *) fun multipleUses (code as Constnt _, _, _) = {load = (fn _ => code), dec = []} (* | multipleUses (code as Extract(LoadLegacy{addr, level=loadLevel, ...}), _, level) = let (* May have to adjust the level. *) fun loadFn lev = if lev = level then code else mkLoad (addr, loadLevel + lev, level)) in {load = loadFn, dec = []} end | multipleUses (code as Extract(LoadLocal addr), _, level) = let (* May have to adjust the level. *) fun loadFn lev = if lev = level then code else mkLoad (addr, lev - level) in {load = loadFn, dec = []} end | multipleUses (code as Extract(LoadArgument _), _, level) = let (* May have to adjust the level. *) fun loadFn lev = if lev = level then code else raise InternalError "multipleUses: different level" (*else mkLoad (addr, lev - level)*) in {load = loadFn, dec = []} end | multipleUses (Extract _, _, _) = raise InternalError "multipleUses: TODO" *) | multipleUses (code, nextAddress, level) = let val addr = nextAddress(); fun loadFn lev = mkLoad (addr, lev, level); in {load = loadFn, dec = [mkDec (addr, code)]} end (* multipleUses *); fun mkMutualDecs [] = raise InternalError "mkMutualDecs: empty declaration list" | mkMutualDecs l = let fun convertDec(a, Lambda lam) = {lambda = lam, addr = a, use=[]} | convertDec _ = raise InternalError "mkMutualDecs: Recursive declaration is not a function" in RecDecs(List.map convertDec l) end val mkNullDec = NullBinding fun mkContainer(addr, size, setter) = Container{addr=addr, size=size, use=[], setter=setter} val mkIf = Cond and mkRaise = Raise fun mkConst v = Constnt(v, []) (* For the moment limit these to general arguments. *) fun mkLoop args = Loop (List.map(fn c => (c, GeneralType)) args) and mkBeginLoop(exp, args) = BeginLoop{loop=exp, arguments=List.map(fn(i, v) => ({value=v, addr=i, use=[]}, GeneralType)) args} fun mkWhile(b, e) = (* Generated as if b then (e; ) else (). *) mkBeginLoop(mkIf(b, mkEnv([NullBinding e], mkLoop[]), CodeZero), []) (* We previously had conditional-or and conditional-and as separate instructions. I've taken them out since they can be implemented just as efficiently as a normal conditional. In addition they were interfering with the optimisation where the second expression contained the last reference to something. We needed to add a "kill entry" to the other branch but there wasn't another branch to add it to. DCJM 7/12/00. *) fun mkCor(xp1, xp2) = mkIf(xp1, CodeTrue, xp2); fun mkCand(xp1, xp2) = mkIf(xp1, xp2, CodeZero); val mkSetContainer = fn (container, tuple, size) => mkSetContainer(container, tuple, BoolVector.tabulate(size, fn _ => true)) (* An arbitrary precision operation takes a tuple consisting of a pair of arguments and a function. The code that is constructed checks both arguments to see if they are short. If they are not or the short precision operation overflows the code to call the function is executed. *) fun mkArbitraryFn oper = mkInlproc( Arbitrary{oper=oper, shortCond=mkCand(mkIsShort(mkInd(0, mkLoadArgument 0)), mkIsShort(mkInd(1, mkLoadArgument 0))), arg1=mkInd(0, mkLoadArgument 0), arg2=mkInd(1, mkLoadArgument 0), longCall= mkEval(mkInd(2, mkLoadArgument 0), [mkTuple[mkInd(0, mkLoadArgument 0), mkInd(1, mkLoadArgument 0)]])}, 1, "Arbitrary" ^ (case oper of ArbCompare test => BuiltIns.testRepr test | ArbArith arith => BuiltIns.arithRepr arith) ^ "()", [], 0) structure Foreign = BACKEND.Foreign structure Sharing = struct type machineWord = machineWord type codetree = codetree type pretty = pretty type argumentType=argumentType type codeBinding = codeBinding type level = level end end (* CODETREE functor body *); diff --git a/mlsource/MLCompiler/CodeTree/CODETREE_FUNCTIONS.sml b/mlsource/MLCompiler/CodeTree/CODETREE_FUNCTIONS.sml index 1f6c2a2b..b3f75d25 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE_FUNCTIONS.sml +++ b/mlsource/MLCompiler/CodeTree/CODETREE_FUNCTIONS.sml @@ -1,491 +1,492 @@ (* - Copyright (c) 2012,13,16,18 David C.J. Matthews + Copyright (c) 2012,13,16,18-19 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Miscellaneous construction and operation functions on the code-tree. *) functor CODETREE_FUNCTIONS( structure BASECODETREE: BaseCodeTreeSig structure STRONGLY: sig val stronglyConnectedComponents: {nodeAddress: 'a -> int, arcs: 'a -> int list } -> 'a list -> 'a list list end ) : CodetreeFunctionsSig = struct open BASECODETREE open STRONGLY open Address exception InternalError = Misc.InternalError fun mkEnv([], exp) = exp | mkEnv(decs, exp) = Newenv(decs, exp) val word0 = toMachineWord 0 and word1 = toMachineWord 1 val False = word0 and True = word1 val F_mutable_words : Word8.word = Word8.orb (F_words, F_mutable) val CodeFalse = Constnt(False, []) and CodeTrue = Constnt(True, []) and CodeZero = Constnt(word0, []) (* Properties of code. This indicates the extent to which the code has side-effects (i.e. where even if the result is unused the code still needs to be produced) or is applicative (i.e. where its value depends only arguments and can safely be reordered). *) (* The RTS has a table of properties for RTS functions. The 103 call returns these Or-ed into the register mask. *) val PROPWORD_NORAISE = 0wx40000000 and PROPWORD_NOUPDATE = 0wx20000000 and PROPWORD_NODEREF = 0wx10000000 (* Since RTS calls are being eliminated leave residual versions of these. *) fun earlyRtsCall _ = false and sideEffectFreeRTSCall _ = false local infix orb andb val op orb = Word.orb and op andb = Word.andb val noSideEffect = PROPWORD_NORAISE orb PROPWORD_NOUPDATE val applicative = noSideEffect orb PROPWORD_NODEREF in fun codeProps (Lambda _) = applicative | codeProps (Constnt _) = applicative | codeProps (Extract _) = applicative | codeProps (TagTest{ test, ... }) = codeProps test | codeProps (Cond(i, t, e)) = codeProps i andb codeProps t andb codeProps e | codeProps (Newenv(decs, exp)) = List.foldl (fn (d, r) => bindingProps d andb r) (codeProps exp) decs | codeProps (Handle { exp, handler, ... }) = (* A handler processes all the exceptions in the body *) (codeProps exp orb PROPWORD_NORAISE) andb codeProps handler | codeProps (Tuple { fields, ...}) = testList fields | codeProps (Indirect{base, ...}) = codeProps base (* A built-in function may be side-effect free. This can occur if we have, for example, "if exp1 orelse exp2" where exp2 can be reduced to "true", typically because it's inside an inline function and some of the arguments to the function are constants. This then gets converted to (exp1; true) and we can eliminate exp1 if it is simply a comparison. *) - | codeProps GetThreadId = Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) - | codeProps (Unary{oper, arg1}) = let open BuiltIns val operProps = case oper of NotBoolean => applicative | IsTaggedValue => applicative | MemoryCellLength => applicative (* MemoryCellFlags could return a different result if a mutable cell was locked. *) | MemoryCellFlags => applicative | ClearMutableFlag => Word.orb(PROPWORD_NODEREF, PROPWORD_NORAISE) | AtomicIncrement => PROPWORD_NORAISE | AtomicDecrement => PROPWORD_NORAISE | AtomicReset => Word.orb(PROPWORD_NODEREF, PROPWORD_NORAISE) | LongWordToTagged => applicative | SignedToLongWord => applicative | UnsignedToLongWord => applicative | RealAbs _ => applicative (* Does not depend on rounding setting. *) | RealNeg _ => applicative (* Does not depend on rounding setting. *) (* If we float a 64-bit int to a 64-bit floating point value we may lose precision so this depends on the current rounding mode. *) | RealFixedInt _ => Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) | FloatToDouble => applicative (* The rounding mode is set explicitly. *) | DoubleToFloat _ => applicative (* May raise the overflow exception *) | RealToInt _ => PROPWORD_NOUPDATE orb PROPWORD_NODEREF in operProps andb codeProps arg1 end | codeProps (Binary{oper, arg1, arg2}) = let open BuiltIns val mayRaise = PROPWORD_NOUPDATE orb PROPWORD_NODEREF val operProps = case oper of WordComparison _ => applicative | FixedPrecisionArith _ => mayRaise | WordArith _ => applicative (* Quot and Rem don't raise exceptions - zero checking is done before. *) | WordLogical _ => applicative | WordShift _ => applicative | AllocateByteMemory => Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) (* Allocation returns a different value on each call. *) | LargeWordComparison _ => applicative | LargeWordArith _ => applicative (* Quot and Rem don't raise exceptions - zero checking is done before. *) | LargeWordLogical _ => applicative | LargeWordShift _ => applicative | RealComparison _ => applicative (* Real arithmetic operations depend on the current rounding setting. *) | RealArith _ => Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) in operProps andb codeProps arg1 andb codeProps arg2 end + | codeProps (Nullary{oper=BuiltIns.GetCurrentThreadId}) = Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) + | codeProps (Nullary{oper=BuiltIns.CheckRTSException}) = PROPWORD_NOUPDATE + | codeProps (Arbitrary{shortCond, arg1, arg2, longCall, ...}) = (* Arbitrary precision operations are applicative but the longCall is a function call. It should never have a side-effect so it might be better to remove it. *) codeProps shortCond andb codeProps arg1 andb codeProps arg2 andb codeProps longCall | codeProps (AllocateWordMemory {numWords, flags, initial}) = let val operProps = Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) in operProps andb codeProps numWords andb codeProps flags andb codeProps initial end | codeProps (Eval _) = 0w0 | codeProps(Raise exp) = codeProps exp andb (Word.notb PROPWORD_NORAISE) (* Treat these as unsafe at least for the moment. *) | codeProps(BeginLoop _) = 0w0 | codeProps(Loop _) = 0w0 | codeProps (SetContainer _) = 0w0 | codeProps (LoadOperation {address, kind}) = let val operProps = case kind of LoadStoreMLWord {isImmutable=true} => applicative | LoadStoreMLByte {isImmutable=true} => applicative | _ => Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) in operProps andb addressProps address end | codeProps (StoreOperation {address, value, ...}) = Word.orb(PROPWORD_NODEREF, PROPWORD_NORAISE) andb addressProps address andb codeProps value | codeProps (BlockOperation {kind, sourceLeft, destRight, length}) = let val operProps = case kind of BlockOpMove _ => PROPWORD_NORAISE | BlockOpEqualByte => applicative | BlockOpCompareByte => applicative in operProps andb addressProps sourceLeft andb addressProps destRight andb codeProps length end and testList t = List.foldl(fn (c, r) => codeProps c andb r) applicative t and bindingProps(Declar{value, ...}) = codeProps value | bindingProps(RecDecs _) = applicative (* These should all be lambdas *) | bindingProps(NullBinding c) = codeProps c | bindingProps(Container{setter, ...}) = codeProps setter and addressProps{base, index=NONE, ...} = codeProps base | addressProps{base, index=SOME index, ...} = codeProps base andb codeProps index (* sideEffectFree - does not raise an exception or make an assignment. *) fun sideEffectFree c = (codeProps c andb noSideEffect) = noSideEffect (* reorderable - does not raise an exception or access a reference. *) and reorderable c = codeProps c = applicative end (* Return the inline property if it is set. *) fun findInline [] = EnvSpecNone | findInline (h::t) = if Universal.tagIs CodeTags.inlineCodeTag h then Universal.tagProject CodeTags.inlineCodeTag h else findInline t (* Makes a constant value from an expression which is known to be constant but may involve inline functions, tuples etc. *) fun makeConstVal (cVal:codetree) = let fun makeVal (c as Constnt _) = c (* should just be a tuple *) (* Get a vector, copy the entries into it and return it as a constant. *) | makeVal (Tuple {fields= [], ...}) = CodeZero (* should have been optimised already! *) | makeVal (Tuple {fields, ...}) = let val tupleSize = List.length fields val vec : address = allocWordData(Word.fromInt tupleSize, F_mutable_words, word0) val fieldCode = map makeVal fields fun copyToVec ([], _) = [] | copyToVec (Constnt(w, prop) :: t, locn) = ( assignWord (vec, locn, w); prop :: copyToVec (t, locn + 0w1) ) | copyToVec _ = raise InternalError "not constant" val props = copyToVec(fieldCode, 0w0) (* If any of the constants have properties create a tuple property for the result. *) val tupleProps = if List.all null props then [] else let (* We also need to construct an EnvSpecTuple property because findInline does not look at tuple properties. *) val inlineProps = map findInline props val inlineProp = if List.all (fn EnvSpecNone => true | _ => false) inlineProps then [] else let fun tupleEntry n = (EnvGenConst(loadWord(vec, Word.fromInt n), List.nth(props, n)), List.nth(inlineProps, n)) in [Universal.tagInject CodeTags.inlineCodeTag (EnvSpecTuple(tupleSize, tupleEntry))] end in Universal.tagInject CodeTags.tupleTag props :: inlineProp end in lock vec; Constnt(toMachineWord vec, tupleProps) end | makeVal _ = raise InternalError "makeVal - not constant or tuple" in makeVal cVal end local fun allConsts [] = true | allConsts (Constnt _ :: t) = allConsts t | allConsts _ = false fun mkRecord isVar xp = let val tuple = Tuple{fields = xp, isVariant = isVar } in if allConsts xp then (* Make it now. *) makeConstVal tuple else tuple end; in val mkTuple = mkRecord false and mkDatatype = mkRecord true end (* Set the inline property. If the property is already present it is replaced. If the property we are setting is EnvSpecNone no property is set. *) fun setInline p (h::t) = if Universal.tagIs CodeTags.inlineCodeTag h then setInline p t else h :: setInline p t | setInline EnvSpecNone [] = [] | setInline p [] = [Universal.tagInject CodeTags.inlineCodeTag p] (* These are very frequently used and it might be worth making special bindings for values such as 0, 1, 2, 3 etc to reduce garbage. *) fun checkNonZero n = if n < 0 then raise InternalError "mkLoadxx: argument negative" else n val mkLoadLocal = Extract o LoadLocal o checkNonZero and mkLoadArgument = Extract o LoadArgument o checkNonZero and mkLoadClosure = Extract o LoadClosure o checkNonZero (* Set the container to the fields of the record. Try to push this down as far as possible. *) fun mkSetContainer(container, Cond(ifpt, thenpt, elsept), filter) = Cond(ifpt, mkSetContainer(container, thenpt, filter), mkSetContainer(container, elsept, filter)) | mkSetContainer(container, Newenv(decs, exp), filter) = Newenv(decs, mkSetContainer(container, exp, filter)) | mkSetContainer(_, r as Raise _, _) = r (* We may well have the situation where one branch of an "if" raises an exception. We can simply raise the exception on that branch. *) | mkSetContainer(container, Handle {exp, handler, exPacketAddr}, filter) = Handle{exp=mkSetContainer(container, exp, filter), handler=mkSetContainer(container, handler, filter), exPacketAddr = exPacketAddr} | mkSetContainer(container, tuple, filter) = SetContainer{container = container, tuple = tuple, filter = filter } local val except: exn = InternalError "Invalid load encountered in compiler" (* Exception value to use for invalid cases. We put this in the code but it should never actually be executed. *) val raiseError = Raise (Constnt (toMachineWord except, [])) in (* Look for an entry in a tuple. Used in both the optimiser and in mkInd. *) fun findEntryInBlock (Tuple { fields, isVariant, ...}, offset, isVar) = ( isVariant = isVar orelse raise InternalError "findEntryInBlock: tuple/datatype mismatch"; if offset < List.length fields then List.nth(fields, offset) (* This can arise if we're processing a branch of a case discriminating on a datatype which won't actually match at run-time. e.g. Tests/Succeed/Test030. *) else if isVar then raiseError else raise InternalError "findEntryInBlock: invalid address" ) | findEntryInBlock (Constnt (b, props), offset, isVar) = let (* Find the tuple property if it is present and extract the field props. *) val fieldProps = case List.find(Universal.tagIs CodeTags.tupleTag) props of NONE => [] | SOME p => List.nth(Universal.tagProject CodeTags.tupleTag p, offset) in case findInline props of EnvSpecTuple(_, env) => (* Do the selection now. This is especially useful if we have a global structure *) (* At the moment at least we assume that we can get all the properties from the tuple selection. *) ( case env offset of (EnvGenConst(w, p), inl) => Constnt(w, setInline inl p) (* The general value from selecting a field from a constant tuple must be a constant. *) | _ => raise InternalError "findEntryInBlock: not constant" ) | _ => (* The ML compiler may generate loads from invalid addresses as a result of a val binding to a constant which has the wrong shape. e.g. val a :: b = nil It will always result in a Bind exception being generated before the invalid load, but we have to be careful that the optimiser does not fall over. *) if isShort b orelse not (Address.isWords (toAddress b)) orelse Address.length (toAddress b) <= Word.fromInt offset then if isVar then raiseError else raise InternalError "findEntryInBlock: invalid address" else Constnt (loadWord (toAddress b, Word.fromInt offset), fieldProps) end | findEntryInBlock(base, offset, isVar) = Indirect {base = base, offset = offset, indKind = if isVar then IndVariant else IndTuple} (* anything else *) end (* Exported indirect load operation i.e. load a field from a tuple. We can't use findEntryInBlock in every case since that discards unused entries in a tuple and at this point we haven't checked that the unused entries don't have side-effects/raise exceptions e.g. #1 (1, raise Fail "bad") *) local fun mkIndirect isVar (addr, base as Constnt _) = findEntryInBlock(base, addr, isVar) | mkIndirect isVar (addr, base) = Indirect {base = base, offset = addr, indKind = if isVar then IndVariant else IndTuple} in val mkInd = mkIndirect false and mkVarField = mkIndirect true end fun mkIndContainer(addr, base) = Indirect{offset=addr, base=base, indKind=IndContainer} (* Create a tuple from a container. *) fun mkTupleFromContainer(addr, size) = Tuple{fields = List.tabulate(size, fn n => mkIndContainer(n, mkLoadLocal addr)), isVariant = false} (* Get the value from the code. *) fun evalue (Constnt(c, _)) = SOME c | evalue _ = NONE (* This is really to simplify the change from mkEnv taking a codetree list to taking a codeBinding list * code. This extracts the last entry which must be a NullBinding and packages the declarations with it. *) fun decSequenceWithFinalExp decs = let fun splitLast _ [] = raise InternalError "decSequenceWithFinalExp: empty" | splitLast decs [NullBinding exp] = (List.rev decs, exp) | splitLast _ [_] = raise InternalError "decSequenceWithFinalExp: last is not a NullDec" | splitLast decs (hd::tl) = splitLast (hd:: decs) tl in mkEnv(splitLast [] decs) end local type node = { addr: int, lambda: lambdaForm, use: codeUse list } fun nodeAddress({addr, ...}: node) = addr and arcs({lambda={closure, ...}, ...}: node) = List.foldl(fn (LoadLocal addr, l) => addr :: l | (_, l) => l) [] closure in val stronglyConnected = stronglyConnectedComponents{nodeAddress=nodeAddress, arcs=arcs} end (* In general any mutually recursive declaration can refer to any other. It's better to partition the recursive declarations into strongly connected components i.e. those that actually refer to each other. *) fun partitionMutableBindings(RecDecs rlist) = let val processed = stronglyConnected rlist (* Convert the result. Note that stronglyConnectedComponents returns the dependencies in the reverse order i.e. if X depends on Y but not the other way round then X will appear before Y in the list. We need to reverse it so that X goes after Y. *) fun rebuild ([], _) = raise InternalError "partitionMutableBindings" (* Should not happen *) | rebuild ([{addr, lambda, use}], tl) = Declar{addr=addr, use=use, value=Lambda lambda} :: tl | rebuild (multiple, tl) = RecDecs multiple :: tl in List.foldl rebuild [] processed end (* This is only intended for RecDecs but it's simpler to handle all bindings. *) | partitionMutableBindings other = [other] (* Functions to help in building a closure. *) datatype createClosure = Closure of (loadForm * int) list ref fun makeClosure() = Closure(ref []) (* Function to build a closure. Items are added to the closure if they are not already there. *) fun addToClosure (Closure closureList) (ext: loadForm): loadForm = case (List.find (fn (l, _) => l = ext) (!closureList), ! closureList) of (SOME(_, n), _) => (* Already there *) LoadClosure n | (NONE, []) => (* Not there - first *) (closureList := [(ext, 0)]; LoadClosure 0) | (NONE, cl as (_, n) :: _) => (closureList := (ext, n+1) :: cl; LoadClosure(n+1)) fun extractClosure(Closure (ref closureList)) = List.foldl (fn ((ext, _), l) => ext :: l) [] closureList structure Sharing = struct type codetree = codetree and codeBinding = codeBinding and loadForm = loadForm and createClosure = createClosure and envSpecial = envSpecial end end; diff --git a/mlsource/MLCompiler/CodeTree/CODETREE_OPTIMISER.sml b/mlsource/MLCompiler/CodeTree/CODETREE_OPTIMISER.sml index 7c3305f3..a5e38637 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE_OPTIMISER.sml +++ b/mlsource/MLCompiler/CodeTree/CODETREE_OPTIMISER.sml @@ -1,1540 +1,1540 @@ (* - Copyright (c) 2012,13,15,17 David C.J. Matthews + Copyright (c) 2012,13,15,17-19 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor CODETREE_OPTIMISER( structure BASECODETREE: BaseCodeTreeSig structure CODETREE_FUNCTIONS: CodetreeFunctionsSig structure REMOVE_REDUNDANT: sig type codetree type loadForm type codeUse val cleanProc : (codetree * codeUse list * (int -> loadForm) * int) -> codetree structure Sharing: sig type codetree = codetree and loadForm = loadForm and codeUse = codeUse end end structure SIMPLIFIER: sig type codetree and codeBinding and envSpecial val simplifier: codetree * int -> (codetree * codeBinding list * envSpecial) * int * bool val specialToGeneral: codetree * codeBinding list * envSpecial -> codetree structure Sharing: sig type codetree = codetree and codeBinding = codeBinding and envSpecial = envSpecial end end structure DEBUG: DEBUGSIG structure PRETTY : PRETTYSIG structure BACKEND: sig type codetree type machineWord = Address.machineWord val codeGenerate: codetree * int * Universal.universal list -> (unit -> machineWord) * Universal.universal list structure Sharing : sig type codetree = codetree end end sharing BASECODETREE.Sharing = CODETREE_FUNCTIONS.Sharing = REMOVE_REDUNDANT.Sharing = SIMPLIFIER.Sharing = PRETTY.Sharing = BACKEND.Sharing ) : sig type codetree and envSpecial and codeBinding val codetreeOptimiser: codetree * Universal.universal list * int -> { numLocals: int, general: codetree, bindings: codeBinding list, special: envSpecial } structure Sharing: sig type codetree = codetree and envSpecial = envSpecial and codeBinding = codeBinding end end = struct open BASECODETREE open Address open CODETREE_FUNCTIONS open StretchArray infix 9 sub exception InternalError = Misc.InternalError datatype inlineTest = TooBig | NonRecursive | TailRecursive of bool vector | NonTailRecursive of bool vector fun evaluateInlining(function, numArgs, maxInlineSize) = let (* This checks for the possibility of inlining a function. It sees if it is small enough according to some rough estimate of the cost and it also looks for recursive uses of the function. Typically if the function is small enough to inline there will be only one recursive use but we consider the possibility of more than one. If the only uses are tail recursive we can replace the recursive calls by a Loop with a BeginLoop outside it. If there are non-tail recursive calls we may be able to lift out arguments that are unchanged. For example for fun map f [] = [] | map f (a::b) = f a :: map f b it may be worth lifting out f and generating specific mapping functions for each application. *) val hasRecursiveCall = ref false (* Set to true if rec call *) val allTail = ref true (* Set to false if non recursive *) (* An element of this is set to false if the actual value if anything other than the original argument. At the end we are then left with the arguments that are unchanged. *) val argMod = Array.array(numArgs, true) infix 6 -- (* Subtract y from x but return 0 rather than a negative number. *) fun x -- y = if x >= y then x-y else 0 (* Check for the code size and also recursive references. N,B. We assume in hasLoop that tail recursion applies only with Cond, Newenv and Handler. *) fun checkUse _ (_, 0, _) = 0 (* The function is too big to inline. *) | checkUse isMain (Newenv(decs, exp), cl, isTail) = let fun checkBind (Declar{value, ...}, cl) = checkUse isMain(value, cl, false) | checkBind (RecDecs decs, cl) = List.foldl(fn ({lambda, ...}, n) => checkUse isMain (Lambda lambda, n, false)) cl decs | checkBind (NullBinding c, cl) = checkUse isMain (c, cl, false) | checkBind (Container{setter, ...}, cl) = checkUse isMain(setter, cl -- 1, false) in checkUse isMain (exp, List.foldl checkBind cl decs, isTail) end | checkUse _ (Constnt(w, _), cl, _) = if isShort w then cl else cl -- 1 (* A recursive reference in any context other than a call prevents any inlining. *) | checkUse true (Extract LoadRecursive, _, _) = 0 | checkUse _ (Extract _, cl, _) = cl -- 1 | checkUse isMain (Indirect{base, ...}, cl, _) = checkUse isMain (base, cl -- 1, false) | checkUse _ (Lambda {body, argTypes, closure, ...}, cl, _) = (* For the moment, any recursive use in an inner function prevents inlining. *) if List.exists (fn LoadRecursive => true | _ => false) closure then 0 else checkUse false (body, cl -- (List.length argTypes + List.length closure), false) | checkUse true (Eval{function = Extract LoadRecursive, argList, ...}, cl, isTail) = let (* If the actual argument is anything but the original argument then the corresponding entry in the array is set to false. *) fun testArg((exp, _), n) = ( if (case exp of Extract(LoadArgument a) => n = a | _ => false) then () else Array.update(argMod, n, false); n+1 ) in List.foldl testArg 0 argList; hasRecursiveCall := true; if isTail then () else allTail := false; List.foldl(fn ((e, _), n) => checkUse true (e, n, false)) (cl--3) argList end | checkUse isMain (Eval{function, argList, ...}, cl, _) = checkUse isMain (function, List.foldl(fn ((e, _), n) => checkUse isMain (e, n, false)) (cl--2) argList, false) - | checkUse _ (GetThreadId, cl, _) = cl -- 1 + | checkUse _ (Nullary _, cl, _) = cl -- 1 | checkUse isMain (Unary{arg1, ...}, cl, _) = checkUse isMain (arg1, cl -- 1, false) | checkUse isMain (Binary{arg1, arg2, ...}, cl, _) = checkUseList isMain ([arg1, arg2], cl -- 1) | checkUse isMain (Arbitrary{arg1, arg2, ...}, cl, _) = checkUseList isMain ([arg1, arg2], cl -- 4) | checkUse isMain (AllocateWordMemory {numWords, flags, initial}, cl, _) = checkUseList isMain ([numWords, flags, initial], cl -- 1) | checkUse isMain (Cond(i, t, e), cl, isTail) = checkUse isMain (i, checkUse isMain (t, checkUse isMain (e, cl -- 2, isTail), isTail), false) | checkUse isMain (BeginLoop { loop, arguments, ...}, cl, _) = checkUse isMain (loop, List.foldl (fn (({value, ...}, _), n) => checkUse isMain (value, n, false)) cl arguments, false) | checkUse isMain (Loop args, cl, _) = List.foldl(fn ((e, _), n) => checkUse isMain (e, n, false)) cl args | checkUse isMain (Raise c, cl, _) = checkUse isMain (c, cl -- 1, false) | checkUse isMain (Handle {exp, handler, ...}, cl, isTail) = checkUse isMain (exp, checkUse isMain (handler, cl, isTail), false) | checkUse isMain (Tuple{ fields, ...}, cl, _) = checkUseList isMain (fields, cl) | checkUse isMain (SetContainer{container, tuple = Tuple { fields, ...}, ...}, cl, _) = (* This can be optimised *) checkUse isMain (container, checkUseList isMain (fields, cl), false) | checkUse isMain (SetContainer{container, tuple, filter}, cl, _) = checkUse isMain (container, checkUse isMain (tuple, cl -- (BoolVector.length filter), false), false) | checkUse isMain (TagTest{test, ...}, cl, _) = checkUse isMain (test, cl -- 1, false) | checkUse isMain (LoadOperation{address, ...}, cl, _) = checkUseAddress isMain (address, cl -- 1) | checkUse isMain (StoreOperation{address, value, ...}, cl, _) = checkUse isMain (value, checkUseAddress isMain (address, cl -- 1), false) | checkUse isMain (BlockOperation{sourceLeft, destRight, length, ...}, cl, _) = checkUse isMain (length, checkUseAddress isMain (destRight, checkUseAddress isMain (sourceLeft, cl -- 1)), false) and checkUseList isMain (elems, cl) = List.foldl(fn (e, n) => checkUse isMain (e, n, false)) cl elems and checkUseAddress isMain ({base, index=NONE, ...}, cl) = checkUse isMain (base, cl, false) | checkUseAddress isMain ({base, index=SOME index, ...}, cl) = checkUseList isMain ([base, index], cl) val costLeft = checkUse true (function, maxInlineSize, true) in if costLeft = 0 then TooBig else if not (! hasRecursiveCall) then NonRecursive else if ! allTail then TailRecursive(Array.vector argMod) else NonTailRecursive(Array.vector argMod) end (* Turn a list of fields to use into a filter for SetContainer. *) fun fieldsToFilter useList = let val maxDest = List.foldl Int.max ~1 useList val fields = BoolArray.array(maxDest+1, false) val _ = List.app(fn n => BoolArray.update(fields, n, true)) useList in BoolArray.vector fields end and filterToFields filter = BoolVector.foldri (fn (i, true, l) => i :: l | (_, _, l) => l) [] filter and setInFilter filter = BoolVector.foldl (fn (true, n) => n+1 | (false, n) => n) 0 filter (* Work-around for bug in bytevector equality. *) and boolVectorEq(a, b) = filterToFields a = filterToFields b fun buildFullTuple(filter, select) = let fun extArg(t, u) = if t = BoolVector.length filter then [] else if BoolVector.sub(filter, t) then select u :: extArg(t+1, u+1) else CodeZero :: extArg (t+1, u) in mkTuple(extArg(0, 0)) end (* When transforming code we only process one level and do not descend into sub-functions. *) local fun deExtract(Extract l) = l | deExtract _ = raise Misc.InternalError "deExtract" fun onlyFunction repEntry (Lambda{ body, isInline, name, closure, argTypes, resultType, localCount, recUse }) = SOME( Lambda { body = body, isInline = isInline, name = name, closure = map (deExtract o mapCodetree repEntry o Extract) closure, argTypes = argTypes, resultType = resultType, localCount = localCount, recUse = recUse } ) | onlyFunction repEntry code = repEntry code in fun mapFunctionCode repEntry = mapCodetree (onlyFunction repEntry) end local (* This transforms the body of a "small" recursive function replacing any reference to the arguments by the appropriate entry and the recursive calls themselves by either a Loop or a recursive call. *) fun mapCodeForFunctionRewriting(code, argMap, modVec, transformCall) = let fun repEntry(Extract(LoadArgument n)) = SOME(Extract(Vector.sub(argMap, n))) | repEntry(Eval { function = Extract LoadRecursive, argList, resultType }) = let (* Filter arguments to include only those that are changed and map any values we pass. They may include references to the parameters. *) fun mapArg((arg, argT)::rest, n) = if Vector.sub(modVec, n) then mapArg(rest, n+1) else (mapCode arg, argT) :: mapArg(rest, n+1) | mapArg([], _) = [] in SOME(transformCall(mapArg(argList, 0), resultType)) end | repEntry _ = NONE and mapCode code = mapFunctionCode repEntry code in mapCode code end in (* If we have a tail recursive function we can replace the tail calls by a loop. modVec indicates the arguments that have not changed. *) fun replaceTailRecursiveWithLoop(body, argTypes, modVec, nextAddress) = let (* We need to create local bindings for arguments that will change. Those that do not can be reused. *) local fun mapArgs((argT, use):: rest, n, decs, mapList) = if Vector.sub(modVec, n) then mapArgs (rest, n+1, decs, LoadArgument n :: mapList) else let val na = ! nextAddress before nextAddress := !nextAddress + 1 in mapArgs (rest, n+1, ({addr = na, value = mkLoadArgument n, use=use}, argT) :: decs, LoadLocal na :: mapList) end | mapArgs([], _, decs, mapList) = (List.rev decs, List.rev mapList) val (decs, mapList) = mapArgs(argTypes, 0, [], []) in val argMap = Vector.fromList mapList val loopArgs = decs end in BeginLoop { arguments = loopArgs, loop = mapCodeForFunctionRewriting(body, argMap, modVec, fn (l, _) => Loop l) } end (* If we have a small recursive function where some arguments are passed through unchanged we can transform it by extracting the stable arguments and only passing the changing arguments. The advantage is that this allows the stable arguments to be inserted inline which is important if they are functions. The canonical example is List.map. *) fun liftRecursiveFunction(body, argTypes, modVec, closureSize, name, resultType, localCount) = let local fun getArgs((argType, use)::rest, nArg, clCount, argCount, stable, change, mapList) = let (* This is the argument from the outer function. It is either added to the closure or passed to the inner function. *) val argN = LoadArgument nArg in if Vector.sub(modVec, nArg) then getArgs(rest, nArg+1, clCount+1, argCount, argN :: stable, change, LoadClosure clCount :: mapList) else getArgs(rest, nArg+1, clCount, argCount+1, stable, (Extract argN, argType, use) :: change, LoadArgument argCount :: mapList) end | getArgs([], _, _, _, stable, change, mapList) = (List.rev stable, List.rev change, List.rev mapList) in (* The stable args go into the closure. The changeable args are passed in. *) val (stableArgs, changeArgsAndTypes, mapList) = getArgs(argTypes, 0, closureSize, 0, [], [], []) val argMap = Vector.fromList mapList end val subFunction = Lambda { body = mapCodeForFunctionRewriting(body, argMap, modVec, fn (l, t) => Eval { function = Extract LoadRecursive, argList = l, resultType = t }), isInline = NonInline, (* Don't inline this function. *) name = name ^ "()", closure = List.tabulate(closureSize, fn n => LoadClosure n) @ stableArgs, argTypes = List.map (fn (_, t, u) => (t, u)) changeArgsAndTypes, resultType = resultType, localCount = localCount, recUse = [UseGeneral] } in Eval { function = subFunction, argList = map (fn (c, t, _) => (c, t)) changeArgsAndTypes, resultType = resultType } end end (* If the function arguments are used in a way that could be optimised the data structure represents it. *) datatype functionArgPattern = ArgPattTuple of { filter: BoolVector.vector, allConst: bool, fromFields: bool } (* ArgPattCurry is a list, one per level of application, of a list, one per argument of the pattern for that argument. *) | ArgPattCurry of functionArgPattern list list * functionArgPattern | ArgPattSimple (* Returns ArgPattCurry even if it is just a single application. *) local (* Control how we check for side-effects. *) datatype curryControl = CurryNoCheck | CurryCheck | CurryReorderable local open Address (* Return the width of a tuple. Returns 1 for non-tuples including datatypes where different variants could have different widths. Also returns a flag indicating if the value came from a constant. Constants are already tupled so there's no advantage in untupling them unless there are other non-constant arguments as well. *) fun findTuple(Tuple{fields, isVariant=false}) = (List.length fields, false) | findTuple(Constnt(w, _)) = if isShort w orelse flags (toAddress w) <> F_words then (1, false) else (Word.toInt(length (toAddress w)), true) | findTuple(Extract _) = (1, false) (* TODO: record this for variables *) | findTuple(Cond(_, t, e)) = let val (tl, tc) = findTuple t and (el, ec) = findTuple e in if tl = el then (tl, tc andalso ec) else (1, false) end | findTuple(Newenv(_, e)) = findTuple e | findTuple _ = (1, false) in fun mapArg c = let val (n, f) = findTuple c in if n <= 1 then ArgPattSimple else ArgPattTuple{filter=BoolVector.tabulate(n, fn _ => true), allConst=f, fromFields=false} end end fun useToPattern _ [] = ArgPattSimple | useToPattern checkCurry (hd::tl) = let (* Construct a possible pattern from the head. *) val p1 = case hd of UseApply(resl, arguments) => let (* If the result is also curried extend the list. *) val subCheck = case checkCurry of CurryCheck => CurryReorderable | c => c val (resultPatts, resultResult) = case useToPattern subCheck resl of ArgPattCurry l => l | tupleOrSimple => ([], tupleOrSimple) val thisArg = map mapArg arguments in (* If we have an argument that is a curried function we can safely apply it to the first argument even if that has a side-effect but we can't uncurry further than that because the behaviour could rely on a side-effect of the first application. *) if checkCurry = CurryReorderable andalso List.exists(not o reorderable) arguments then ArgPattSimple else ArgPattCurry(thisArg :: resultPatts, resultResult) end | UseField (n, _) => ArgPattTuple{filter=BoolVector.tabulate(n+1, fn m => m=n), allConst=false, fromFields=true} | _ => ArgPattSimple fun mergePattern(ArgPattCurry(l1, r1), ArgPattCurry(l2, r2)) = let (* Each argument list should be the same length. The length here is the number of arguments provided to this application. *) fun mergeArgLists(al1, al2) = ListPair.mapEq mergePattern (al1, al2) (* The currying lists could be different lengths because some applications could only partially apply it. It is essential not to assume more currying than the minimum so we stop with the shorter. *) val prefix = ListPair.map mergeArgLists (l1, l2) in if null prefix then ArgPattSimple else ArgPattCurry(prefix, mergePattern(r1, r2)) end | mergePattern(ArgPattTuple{filter=n1, allConst=c1, fromFields=f1}, ArgPattTuple{filter=n2, allConst=c2, fromFields=f2}) = (* If the tuples are different sizes we can't use a tuple. Unlike currying it would be safe to assume tupling where there isn't (unless the function is actually polymorphic). *) if boolVectorEq(n1, n2) then ArgPattTuple{filter=n1, allConst=c1 andalso c2, fromFields = f1 andalso f2} else if f1 andalso f2 then let open BoolVector val l1 = length n1 and l2 = length n2 fun safesub(n, v) = if n < length v then v sub n else false val union = tabulate(Int.max(l1, l2), fn n => safesub(n, n1) orelse safesub(n, n2)) in ArgPattTuple{filter=union, allConst=c1 andalso c2, fromFields = f1 andalso f2} end else ArgPattSimple | mergePattern _ = ArgPattSimple in case tl of [] => p1 | tl => mergePattern(p1, useToPattern checkCurry tl) end (* If the result is just a function where all the arguments are simple it's not actually curried. *) fun usageToPattern checkCurry use = case useToPattern checkCurry use of (* a as ArgPattCurry [s] => if List.all(fn ArgPattSimple => true | _ => false) s then ArgPattSimple else a |*) patt => patt in (* Decurrying involves reordering (f exp1) exp2 into code where any effects of evaluating exp2 are done before the application. That's only safe if either (f exp1) or exp2 have no side-effects and do not depend on references. In the case of the function body we can check that the body does not depend on any references (typically it's a lambda) but for function arguments we have to check how it is applied. *) val usageForFunctionBody = usageToPattern CurryNoCheck and usageForFunctionArg = usageToPattern CurryCheck (* To decide whether we want to detuple the argument we look to see if the function is ever applied to a tuple. This is rather different to currying where we only decurry if every application is to multiple arguments. This information is then merged with information about the arguments within the function. *) fun existTupling (use: codeUse list): functionArgPattern list = let val argListLists = List.foldl (fn (UseApply(_, args), l) => map mapArg args :: l | (_, l) => l) [] use fun orMerge [] = raise Empty | orMerge [hd] = hd | orMerge (hd1 :: hd2 :: tl) = let fun merge(a as ArgPattTuple _, _) = a | merge(_, b) = b in orMerge(ListPair.mapEq merge (hd1, hd2) :: tl) end in orMerge argListLists end (* If the result of a function contains a tuple but it is not detupled on every path, see if it is detupled on at least one. *) fun existDetupling(UseApply(resl, _) :: rest) = List.exists(fn UseField _ => true | _ => false) resl orelse existDetupling rest | existDetupling(_ :: rest) = existDetupling rest | existDetupling [] = false end (* Return a tuple if any of the branches returns a tuple. The idea is that if the body actually constructs a tuple on the heap on at least one branch it is probably worth attempting to detuple the result. *) fun bodyReturnsTuple (Tuple{fields, isVariant=false}) = ArgPattTuple{ filter=BoolVector.tabulate(List.length fields, fn _ => true), allConst=false, fromFields=false } | bodyReturnsTuple(Cond(_, t, e)) = ( case bodyReturnsTuple t of a as ArgPattTuple _ => a | _ => bodyReturnsTuple e ) | bodyReturnsTuple(Newenv(_, exp)) = bodyReturnsTuple exp | bodyReturnsTuple _ = ArgPattSimple (* If the usage indicates that the body of the function should be transformed these do the transformation. It is possible that each of these cases could apply and it would be possible to merge them all. For the moment keep them separate. If another of the cases applies this will be re-entered on a subsequent pass. *) fun detupleResult({ argTypes, name, resultType, closure, isInline, localCount, body, ...}: lambdaForm , filter, makeAddress) = (* The function returns a tuple or at least the uses of the function take apart a tuple. Transform it to take a container as an argument and put the result in there. *) let local fun mapArg f n ((t, _) :: tl) = (Extract(f n), t) :: mapArg f (n+1) tl | mapArg _ _ [] = [] in fun mapArgs f l = mapArg f 0 l end val mainAddress = makeAddress() and shimAddress = makeAddress() (* The main function performs the previous computation but puts the result into the container. We need to replace any recursive references with calls to the shim.*) local val recEntry = LoadClosure(List.length closure) fun doMap(Extract LoadRecursive) = SOME(Extract recEntry) | doMap _ = NONE in val transBody = mapFunctionCode doMap body end local val containerArg = Extract(LoadArgument(List.length argTypes)) val newBody = SetContainer{container = containerArg, tuple = transBody, filter=filter } val mainLambda: lambdaForm = { body = newBody, name = name, resultType=GeneralType, argTypes=argTypes @ [(GeneralType, [])], closure=closure @ [LoadLocal shimAddress], localCount=localCount + 1, isInline=isInline, recUse = [UseGeneral] } in val mainFunction = (mainAddress, mainLambda) end (* The shim function creates a container, passes it to the main function and then builds a tuple from the container. *) val shimBody = mkEnv( [Container{addr = 0, use = [], size = setInFilter filter, setter= Eval { function = Extract(LoadClosure 0), argList = mapArgs LoadArgument argTypes @ [(Extract(LoadLocal 0), GeneralType)], resultType = GeneralType } } ], buildFullTuple(filter, fn n => mkIndContainer(n, mkLoadLocal 0)) ) val shimLambda = { body = shimBody, name = name, argTypes = argTypes, closure = [LoadLocal mainAddress], resultType = resultType, isInline = Inline, localCount = 1, recUse = [UseGeneral] } val shimFunction = (shimAddress, shimLambda) in (shimLambda, [mainFunction, shimFunction]) end fun transformFunctionArgs({ argTypes, name, resultType, closure, isInline, localCount, body, ...} , usage, makeAddress) = (* Not curried - just a single argument. *) let (* We need to construct an inline "shim" function that has the same calling pattern as the original. This simply calls the transformed main function. We need to construct the arguments to call the transformed main function. That needs, for example, to unpack tuples and repack argument functions. We need to produce an argument map to transform the main function. This needs, for example, to pack the arguments into tuples. Then when the code is run through the simplifier the tuples will be optimised away. *) val localCounter = ref localCount fun mapPattern(ArgPattTuple{filter, allConst=false, ...} :: patts, n, m) = let val fieldList = filterToFields filter val (decs, args, mapList) = mapPattern(patts, n+1, m + setInFilter filter) val newAddr = ! localCounter before localCounter := ! localCounter + 1 val tuple = buildFullTuple(filter, fn u => mkLoadArgument(m+u)) val thisDec = Declar { addr = newAddr, use = [], value = tuple } (* Arguments for the call *) val thisArg = List.map(fn p => mkInd(p, mkLoadArgument n)) fieldList in (thisDec :: decs, thisArg @ args, LoadLocal newAddr :: mapList) end | mapPattern(ArgPattCurry(currying as [_], ArgPattTuple{allConst=false, filter, ...}) :: patts, n, m) = (* It's a function that returns a tuple. The function must not be curried because otherwise it returns a function not a tuple. *) let val (thisDec, thisArg, thisMap) = transformFunctionArgument(currying, [LoadArgument m], [LoadArgument n], SOME filter) val (decs, args, mapList) = mapPattern(patts, n+1, m+1) in (thisDec :: decs, thisArg :: args, thisMap :: mapList) end | mapPattern(ArgPattCurry(currying as firstArgSet :: _, _) :: patts, n, m) = (* Transform it if it's curried or if there is a tuple in the first arg. *) if (*List.length currying >= 2 orelse *) (* This transformation is unsafe. *) List.exists(fn ArgPattTuple{allConst=false, ...} => true | _ => false) firstArgSet then let val (thisDec, thisArg, thisMap) = transformFunctionArgument(currying, [LoadArgument m], [LoadArgument n], NONE) val (decs, args, mapList) = mapPattern(patts, n+1, m+1) in (thisDec :: decs, thisArg :: args, thisMap :: mapList) end else let val (decs, args, mapList) = mapPattern(patts, n+1, m+1) in (decs, Extract(LoadArgument n) :: args, LoadArgument m :: mapList) end | mapPattern(_ :: patts, n, m) = let val (decs, args, mapList) = mapPattern(patts, n+1, m+1) in (decs, Extract(LoadArgument n) :: args, LoadArgument m :: mapList) end | mapPattern([], _, _) = ([], [], []) and transformFunctionArgument(argumentArgs, loadPack, loadThisArg, filterOpt) = let (* Disable the transformation of curried arguments for the moment. This is unsafe. See Test146. The problem is that this transformation is only safe if the function is applied immediately to all the arguments. However the usage information is propagated so that if the result of the first application is bound to a variable and then that variable is applied it still appears as curried. *) val argumentArgs = [hd argumentArgs] (* We have a function that takes a series of curried argument. Change that so that the function takes a list of arguments. *) val newAddr = ! localCounter before localCounter := ! localCounter + 1 (* In the main function we are expecting to call the argument in a curried fashion. We need to construct a function that packages up the arguments and, when all of them have been provided, calls the actual argument. *) local fun curryPack([], fnclosure) = let (* We're ready to call the function. We now need to unpack any tupled arguments. *) fun mapArgs(c :: ctl, args) = let fun mapArg([], args) = mapArgs(ctl, args) | mapArg(ArgPattTuple{filter, allConst=false, ...} :: patts, arg :: argctl) = let val fields = filterToFields filter in List.map(fn p => (mkInd(p, Extract arg), GeneralType)) fields @ mapArg(patts, argctl) end | mapArg(_ :: patts, arg :: argctl) = (Extract arg, GeneralType) :: mapArg(patts, argctl) | mapArg(_, []) = raise InternalError "mapArgs: mismatch" in mapArg(c, args) end | mapArgs _ = [] val argList = mapArgs(argumentArgs, tl fnclosure) in case filterOpt of NONE => Eval { function = Extract(hd fnclosure), resultType = GeneralType, argList = argList } | SOME filter => (* We need a container here for the result. *) mkEnv( [ Container{addr=0, size=setInFilter filter, use=[UseGeneral], setter= Eval { function = Extract(hd fnclosure), resultType = GeneralType, argList = argList @ [(mkLoadLocal 0, GeneralType)] } } ], buildFullTuple(filter, fn n => mkIndContainer(n, mkLoadLocal 0)) ) end | curryPack(hd :: tl, fnclosure) = let val nArgs = List.length hd (* If this is the last then we need to include the container if required. *) val needContainer = case (tl, filterOpt) of ([], SOME _) => true | _ => false in Lambda { closure = fnclosure, isInline = Inline, name = name ^ "-P", resultType = GeneralType, argTypes = List.tabulate(nArgs, fn _ => (GeneralType, [UseGeneral])), localCount = if needContainer then 1 else 0, recUse = [], body = curryPack(tl, (* The closure for the next level is the current closure together with all the arguments at this level. *) List.tabulate(List.length fnclosure, fn n => LoadClosure n) @ List.tabulate(nArgs, LoadArgument)) } end in val packFn = curryPack(argumentArgs, loadPack) end val thisDec = Declar { addr = newAddr, use = [], value = packFn } fun argCount(ArgPattTuple{filter, allConst=false, ...}, m) = setInFilter filter + m | argCount(_, m) = m+1 local (* In the shim function, i.e. the inline function outside, we have a lambda that will be called when the main function wants to call its argument function. This is provided with all the arguments and so it has to call the actual argument, which is expected to be curried, an argument at a time. *) fun curryApply(hd :: tl, n, c) = let fun makeArgs(_, []) = [] | makeArgs(q, ArgPattTuple{filter, allConst=false, ...} :: args) = (buildFullTuple(filter, fn r => mkLoadArgument(r+q)), GeneralType) :: makeArgs(q + setInFilter filter, args) | makeArgs(q, _ :: args) = (mkLoadArgument q, GeneralType) :: makeArgs(q+1, args) val args = makeArgs(n, hd) in curryApply(tl, n + List.foldl argCount 0 hd, Eval{function=c, resultType = GeneralType, argList=args}) end | curryApply([], _, c) = c in val thisBody = curryApply (argumentArgs, 0, mkLoadClosure 0) end local (* We have one argument for each argument at each level of currying, or where we've expanded a tuple, one argument for each field. If the function is returning a tuple we have an extra argument for the container. *) val totalArgCount = List.foldl(fn (c, n) => n + List.foldl argCount 0 c) 0 argumentArgs + (case filterOpt of SOME _ => 1 | _ => 0) val functionBody = case filterOpt of NONE => thisBody | SOME filter => mkSetContainer(mkLoadArgument(totalArgCount-1), thisBody, filter) in val thisArg = Lambda { closure = loadThisArg, isInline = Inline, name = name ^ "-E", argTypes = List.tabulate(totalArgCount, fn _ => (GeneralType, [UseGeneral])), resultType = GeneralType, localCount = 0, recUse = [UseGeneral], body = functionBody } end in (thisDec, thisArg, LoadLocal newAddr) end val (extraBindings, transArgCode, argMapList) = mapPattern(usage, 0, 0) local (* Transform the body by replacing the arguments with the new arguments. *) val argMap = Vector.fromList argMapList (* If we have a recursive reference we have to replace it with a reference to the shim. *) val recEntry = LoadClosure(List.length closure) fun doMap(Extract(LoadArgument n)) = SOME(Extract(Vector.sub(argMap, n))) | doMap(Extract LoadRecursive) = SOME(Extract recEntry) | doMap _ = NONE in val transBody = mapFunctionCode doMap body end local (* The argument types for the main function have the tuples expanded, Functions are not affected. *) fun expand(ArgPattTuple{filter, allConst=false, ...}, _, r) = List.tabulate(setInFilter filter, fn _ => (GeneralType, [])) @ r | expand(_, a, r) = a :: r in val transArgTypes = ListPair.foldrEq expand [] (usage, argTypes) end (* Add the type information to the argument code. *) val transArgs = ListPair.mapEq(fn (c, (t, _)) => (c, t)) (transArgCode, transArgTypes) val mainAddress = makeAddress() and shimAddress = makeAddress() val transLambda = { body = mkEnv(extraBindings, transBody), name = name, argTypes = transArgTypes, closure = closure @ [LoadLocal shimAddress], resultType = resultType, isInline = isInline, localCount = ! localCounter, recUse = [UseGeneral] } (* Return the pair of functions. *) val mainFunction = (mainAddress, transLambda) val shimBody = Eval { function = Extract(LoadClosure 0), argList = transArgs, resultType = resultType } val shimLambda = { body = shimBody, name = name, argTypes = argTypes, closure = [LoadLocal mainAddress], resultType = resultType, isInline = Inline, localCount = 0, recUse = [UseGeneral] } val shimFunction = (shimAddress, shimLambda) (* TODO: We have two copies of the shim function here. *) in (shimLambda, [mainFunction, shimFunction]) end fun decurryFunction( { argTypes, name, resultType, closure, isInline, localCount, body as Lambda { argTypes=subArgTypes, resultType=subResultType, ... } , ...}, makeAddress) = (* Curried - just unwind one level this time. This case is normally dealt with by the front-end at least for fun bindings. *) let local fun mapArg f n ((t, _) :: tl) = (Extract(f n), t) :: mapArg f (n+1) tl | mapArg _ _ [] = [] in fun mapArgs f l = mapArg f 0 l end val mainAddress = makeAddress() and shimAddress = makeAddress() (* The main function calls the original body as a function. The body is a lambda which will contain references to the outer arguments but because we're just adding arguments these will be as before. *) (* We have to transform any recursive references to point to the shim. *) local val recEntry = LoadClosure(List.length closure) fun doMap(Extract LoadRecursive) = SOME(Extract recEntry) | doMap _ = NONE in val transBody = mapFunctionCode doMap body end val arg1Count = List.length argTypes val mainLambda = { body = Eval{ function = transBody, resultType = subResultType, argList = mapArgs (fn n => LoadArgument(n+arg1Count)) subArgTypes }, name = name, resultType = subResultType, closure = closure @ [LoadLocal shimAddress], isInline = isInline, localCount = localCount, argTypes = argTypes @ subArgTypes, recUse = [UseGeneral] } val mainFunction = (mainAddress, mainLambda) val shimInnerLambda = Lambda { (* The inner shim closure contains the main function and the outer arguments. *) closure = LoadClosure 0 :: List.tabulate(arg1Count, LoadArgument), body = Eval { function = Extract(LoadClosure 0), resultType = resultType, (* Calls main function with both sets of args. *) argList = mapArgs (fn n => LoadClosure(n+1)) argTypes @ mapArgs LoadArgument subArgTypes }, name = name ^ "-", resultType = subResultType, localCount = 0, isInline = Inline, argTypes = subArgTypes, recUse = [UseGeneral] } val shimOuterLambda = { body = shimInnerLambda, name = name, argTypes = argTypes, closure = [LoadLocal mainAddress], resultType = resultType, isInline = Inline, localCount = 0, recUse = [UseGeneral] } val shimFunction = (shimAddress, shimOuterLambda) in (shimOuterLambda: lambdaForm, [mainFunction, shimFunction]) end | decurryFunction _ = raise InternalError "decurryFunction" (* Process a Lambda slightly differently in different contexts. *) datatype lambdaContext = LCNormal | LCRecursive | LCImmediateCall (* Transforming a lambda may result in producing auxiliary functions that are in general mutually recursive. *) fun mapLambdaResult([], lambda) = lambda | mapLambdaResult(bindings, lambda) = mkEnv([RecDecs(map(fn(addr, lam) => {addr=addr, use=[], lambda=lam}) bindings)], lambda) fun optimise (context, use) (Lambda lambda) = SOME(mapLambdaResult(optLambda(context, use, lambda, LCNormal))) | optimise (context, use) (Newenv(envDecs, envExp)) = let fun mapExp mapUse = mapCodetree (optimise(context, mapUse)) fun mapbinding(Declar{value, addr, use}) = Declar{value=mapExp use value, addr=addr, use=use} | mapbinding(RecDecs l) = let fun mapRecDec({addr, lambda, use}, rest) = case optLambda(context, use, lambda, LCRecursive) of (bindings, Lambda lambdaRes) => (* Turn any bindings into extra mutually-recursive functions. *) {addr=addr, use = use, lambda = lambdaRes } :: map (fn (addr, res) => {addr=addr, use=use, lambda=res }) bindings @ rest | _ => raise InternalError "mapbinding: not lambda" in RecDecs(foldl mapRecDec [] l) end | mapbinding(NullBinding exp) = NullBinding(mapExp [UseGeneral] exp) | mapbinding(Container{addr, use, size, setter}) = Container{addr=addr, use=use, size=size, setter = mapExp [UseGeneral] setter} in SOME(Newenv(map mapbinding envDecs, mapExp use envExp)) end (* Immediate call to a function. We may be able to expand this inline unless it is recursive. *) | optimise (context, use) (Eval {function = Lambda lambda, argList, resultType}) = let val args = map (fn (c, t) => (optGeneral context c, t)) argList val argTuples = map #1 args val (bindings, newLambda) = optLambda(context, [UseApply(use, argTuples)], lambda, LCImmediateCall) val call = Eval { function=newLambda, argList=args, resultType = resultType } in SOME(mapLambdaResult(bindings, call)) end | optimise (context as { reprocess, ...}, use) (Eval {function = Cond(i, t, e), argList, resultType}) = let (* Transform "(if i then t else e) x" into "if i then t x else e x". This allows for other optimisations and inline expansion. *) (* We duplicate the function arguments which could cause the size of the code to blow-up if they involve complicated expressions. *) fun pushFunction l = mapCodetree (optimise(context, use)) (Eval{function=l, argList=argList, resultType=resultType}) in reprocess := true; SOME(Cond(i, pushFunction t, pushFunction e)) end | optimise (context, use) (Eval {function, argList, resultType}) = (* If nothing else we need to ensure that "use" is correctly set on the function and arguments and we don't simply pass the original. *) let val args = map (fn (c, t) => (optGeneral context c, t)) argList val argTuples = map #1 args in SOME( Eval{ function= mapCodetree (optimise (context, [UseApply(use, argTuples)])) function, argList=args, resultType = resultType }) end | optimise (context, use) (Indirect{base, offset, indKind = IndTuple}) = SOME(Indirect{base = mapCodetree (optimise(context, [UseField(offset, use)])) base, offset = offset, indKind = IndTuple}) | optimise (context, use) (code as Cond _) = (* If the result of the if-then-else is always taken apart as fields then we are better off taking it apart further down and putting the fields into a container on the stack. *) if List.all(fn UseField _ => true | _ => false) use then SOME(optFields(code, context, use)) else NONE | optimise (context, use) (code as BeginLoop _) = (* If the result of the loop is taken apart we should push this down as well. *) if List.all(fn UseField _ => true | _ => false) use then SOME(optFields(code, context, use)) else NONE | optimise _ _ = NONE and optGeneral context exp = mapCodetree (optimise(context, [UseGeneral])) exp and optLambda( { debugArgs, reprocess, makeAddr, ... }, contextUse, { body, name, argTypes, resultType, closure, localCount, isInline, recUse, ...}, lambdaContext) : (int * lambdaForm) list * codetree = (* Optimisations on lambdas. 1. A lambda that simply calls another function with all its own arguments can be replaced by a reference to the function provided the "function" is a side-effect-free expression. 2. Don't attempt to optimise inline functions that are exported. 3. Transform lambdas that take tuples as arguments or are curried or where an argument is a function with tupled or curried arguments into a pair of an inline function with the original argument set and a new "main" function with register/stack arguments. *) let (* The overall use of the function is the context plus the recursive use. *) val use = contextUse @ recUse (* Check if it's a call to another function with all the original arguments. This is really wanted when we are passing this lambda as an argument to another function and really only when we have produced a shim function that has been inline expanded. Otherwise this will be a "small" function and will be inline expanded when it's used. *) val replaceBody = case (body, lambdaContext = LCRecursive) of (Eval { function, argList, resultType=callresult }, false) => let fun argSequence((Extract(LoadArgument a), _) :: rest, b) = a = b andalso argSequence(rest, b+1) | argSequence([], _) = true | argSequence _ = false val argumentsMatch = argSequence(argList, 0) andalso ListPair.allEq(fn((_, a), (b, _)) => a = b) (argList, argTypes) andalso callresult = resultType in if not argumentsMatch then NONE else case function of (* This could be any function which has neither side-effects nor depends on a reference nor depends on another argument but if it has local variables they would have to be renumbered into the surrounding scope. In practice we're really only interested in simple cases that arise as a result of using a "shim" function created in the code below. *) c as Constnt _ => SOME c | Extract(LoadClosure addr) => SOME(Extract(List.nth(closure, addr))) | _ => NONE end | _ => NONE in case replaceBody of SOME c => ([], c) | NONE => if isInline = Inline andalso List.exists (fn UseExport => true | _ => false) use then let (* If it's inline any application of this will be optimised after inline expansion. We still apply any opimisations to the body at this stage because we will compile and code-generate a version for use if we want a "general" value. *) val addressAllocator = ref localCount val optContext = { makeAddr = fn () => (! addressAllocator) before addressAllocator := ! addressAllocator + 1, reprocess = reprocess, debugArgs = debugArgs } val optBody = mapCodetree (optimise(optContext, [UseGeneral])) body val lambdaRes = { body = optBody, isInline = isInline, name = name, closure = closure, argTypes = argTypes, resultType = resultType, recUse = recUse, localCount = !addressAllocator (* After optimising body. *) } in ([], Lambda lambdaRes) end else let (* Allocate any new addresses after the existing ones. *) val addressAllocator = ref localCount val optContext = { makeAddr = fn () => (! addressAllocator) before addressAllocator := ! addressAllocator + 1, reprocess = reprocess, debugArgs = debugArgs } val optBody = mapCodetree (optimise(optContext, [UseGeneral])) body (* See if this should be expanded inline. If we are calling the lambda immediately we try to expand it unless maxInlineSize is zero. We may not be able to expand it if it is recursive. (It may have been inside an inline function). *) val maxInlineSize = DEBUG.getParameter DEBUG.maxInlineSizeTag debugArgs val (inlineType, updatedBody, localCount) = case evaluateInlining(optBody, List.length argTypes, if maxInlineSize <> 0 andalso lambdaContext = LCImmediateCall then 1000 else FixedInt.toInt maxInlineSize) of NonRecursive => (Inline, optBody, ! addressAllocator) | TailRecursive bv => (Inline, replaceTailRecursiveWithLoop(optBody, argTypes, bv, addressAllocator), ! addressAllocator) | NonTailRecursive bv => if Vector.exists (fn n => n) bv then (Inline, liftRecursiveFunction( optBody, argTypes, bv, List.length closure, name, resultType, !addressAllocator), 0) else (NonInline, optBody, ! addressAllocator) (* All arguments have been modified *) | TooBig => (NonInline, optBody, ! addressAllocator) val lambda: lambdaForm = { body = updatedBody, name = name, argTypes = argTypes, closure = closure, resultType = resultType, isInline = inlineType, localCount = localCount, recUse = recUse } (* See if it should be transformed. We only do this if the function is not going to be inlined. If it is then there's no point because the transformation is going to be done as part of the inling process. Even if it's marked for inlining we may not actually call the function and instead pass it as an argument or return it as result but in that case transformation doesn't achieve anything because we are going to pass the untransformed "shim" function anyway. *) val (newLambda, bindings) = if isInline = NonInline then let val functionPattern = case usageForFunctionBody use of ArgPattCurry(arg1 :: arg2 :: moreArgs, res) => (* The function is always called with at least two curried arguments. We can decurry the function if the body is applicative - typically if it's a lambda - but not if applying the body would have a side-effect. We only do it one level at this stage. If it's curried more than that we'll come here again. *) (* In order to get the types we restrict this to the case of a body that is a lambda. The result is a function and therefore ArgPattSimple unless we are using up all the args. *) if (*reorderable body*) case updatedBody of Lambda _ => true | _ => false then ArgPattCurry([arg1, arg2], if null moreArgs then res else ArgPattSimple) else ArgPattCurry([arg1], ArgPattSimple) | usage => usage val argPatterns = map (usageForFunctionArg o #2) argTypes (* fullArgPattern is a list, one per level of currying, of a list, one per argument of the patterns. resultPattern is used to detect whether the result is a tuple that is taken apart. *) val (fullArgPattern, resultPattern) = case functionPattern of ArgPattCurry(_ :: rest, resPattern) => let (* The function is always applied at least to the first set of arguments. (It's never just passed). Merge the applications of the function with the use of the arguments. Return the usage within the function unless the function takes apart a tuple but no application passes in a tuple. *) fun merge(ArgPattTuple _, argUse as ArgPattTuple _) = argUse | merge(_, ArgPattTuple _) = ArgPattSimple | merge(_, argUse) = argUse val mergedArgs = (ListPair.mapEq merge (existTupling use, argPatterns)) :: rest (* *) val mergedResult = case (bodyReturnsTuple updatedBody, resPattern) of (bodyTuple as ArgPattTuple _, ArgPattSimple) => if existDetupling use then bodyTuple else ArgPattSimple | _ => resPattern in (mergedArgs, mergedResult) end | _ => (* Not called: either exported or passed as a value. *) (* This previously tried to see whether the body returned a tuple if the function was exported. This caused an infinite loop (see Tests/Succeed/Test164.ML) and anyway doesn't seem to optimise the cases we want. *) ([], ArgPattSimple) in case (fullArgPattern, resultPattern) of (_ :: _ :: _, _) => (* Curried *) ( reprocess := true; decurryFunction(lambda, makeAddr)) | (_, ArgPattTuple {filter, ...}) => (* Result is a tuple *) ( reprocess := true; detupleResult(lambda, filter, makeAddr)) | (first :: _, _) => let fun checkArg (ArgPattTuple{allConst=false, ...}) = true (* Function has at least one tupled arg. *) | checkArg (ArgPattCurry([_], ArgPattTuple{allConst=false, ...})) = true (* Function has an arg that is a function that returns a tuple. It must not be curried otherwise it returns a function not a tuple. *) (* This transformation is unsafe. See comment in transformFunctionArgument above. *) (*| checkArg (ArgPattCurry(_ :: _ :: _, _)) = true *) (* Function has an arg that is a curried function. *) | checkArg (ArgPattCurry(firstArgSet :: _, _)) = (* Function has an arg that is a function that takes a tuple in its first argument set. *) List.exists(fn ArgPattTuple{allConst=false, ...} => true | _ => false) firstArgSet | checkArg _ = false in (* It isn't curried - look at the arguments. *) if List.exists checkArg first then ( reprocess := true; transformFunctionArgs(lambda, first, makeAddr) ) else (lambda, []) end | _ => (lambda, []) end else (lambda, []) in (* If this is to be inlined but was not before we may need to reprocess. We don't reprocess if this is only exported. If it's only exported we're not going to expand it within this code and we can end up with repeated processing. *) if #isInline newLambda = Inline andalso isInline = NonInline andalso (case use of [UseExport] => false | _ => true) then reprocess := true else (); (bindings, Lambda newLambda) end end and optFields (code, context as { reprocess, makeAddr, ...}, use) = let (* We have an if-then-else or a loop whose result is only ever taken apart. We push this down. *) (* Find the fields that are used. Not all may be. *) local val maxField = List.foldl(fn (UseField(f, _), m) => Int.max(f, m) | (_, m) => m) 0 use val fieldUse = BoolArray.array(maxField+1, false) val _ = List.app(fn UseField(f, _) => BoolArray.update(fieldUse, f, true) | _ => ()) use in val maxField = maxField val useList = BoolArray.foldri (fn (i, true, l) => i :: l | (_, _, l) => l) [] fieldUse end fun pushContainer(Cond(ifpt, thenpt, elsept), leafFn) = Cond(ifpt, pushContainer(thenpt, leafFn), pushContainer(elsept, leafFn)) | pushContainer(Newenv(decs, exp), leafFn) = Newenv(decs, pushContainer(exp, leafFn)) | pushContainer(BeginLoop{loop, arguments}, leafFn) = (* If we push it through a BeginLoop we MUST then push it through anything that could contain the Loop i.e. Cond, Newenv, Handle. *) BeginLoop{loop = pushContainer(loop, leafFn), arguments=arguments} | pushContainer(l as Loop _, _) = l (* Within a BeginLoop only the non-Loop leaves return values. Loop entries go back to the BeginLoop so these are unchanged. *) | pushContainer(Handle{exp, handler, exPacketAddr}, leafFn) = Handle{exp=pushContainer(exp, leafFn), handler=pushContainer(handler, leafFn), exPacketAddr=exPacketAddr} | pushContainer(tuple, leafFn) = leafFn tuple (* Anything else. *) val () = reprocess := true in case useList of [offset] => (* We only want a single field. Push down an Indirect. *) let (* However the context still requires a tuple. We need to reconstruct one with unused fields set to zero. They will be filtered out later by the simplifier pass. *) val field = optGeneral context (pushContainer(code, fn t => mkInd(offset, t))) fun mkFields n = if n = offset then field else CodeZero in Tuple{ fields = List.tabulate(offset+1, mkFields), isVariant = false } end | _ => let (* We require a container. *) val containerAddr = makeAddr() val width = List.length useList val loadContainer = Extract(LoadLocal containerAddr) fun setContainer tuple = (* At the leaf set the container. *) SetContainer{container = loadContainer, tuple = tuple, filter = fieldsToFilter useList } val setCode = optGeneral context (pushContainer(code, setContainer)) val makeContainer = Container{addr=containerAddr, use=[], size=width, setter=setCode} (* The context requires a tuple of the original width. We need to add dummy fields where necessary. *) val container = if width = maxField+1 then mkTupleFromContainer(containerAddr, width) else let fun mkField(n, m, hd::tl) = if n = hd then mkIndContainer(m, loadContainer) :: mkField(n+1, m+1, tl) else CodeZero :: mkField(n+1, m, hd::tl) | mkField _ = [] in Tuple{fields = mkField(0, 0, useList), isVariant=false} end in mkEnv([makeContainer], container) end end (* TODO: convert "(if a then b else c) (args)" into if a then b(args) else c(args). This would allow for possible inlining and also passing information about call patterns. *) (* Once all the inlining is done we look for functions that can be compiled immediately. These are either functions with no free variables or functions where every use is a call, as opposed to being passed or returned as a closure. Functions that have free variables but are called can be lambda-lifted where the free variables are turned into extra parameters. The advantage compared with using a static-link or a closure on the stack is that they can be fully tail-recursive. With a static-link or stack closure the free variables have to remain on the stack until the function returns. *) fun lambdaLiftAndConstantFunction(code, debugSwitches, numLocals) = let val needReprocess = ref false (* At the moment this just code-generates immediately any lambdas without free-variables. The idea is to that we will get a constant which can then be inserted directly in references to the function. In general this takes a list of mutually recursive functions which can be code- generated immediately if all the free variables are other functions in the list. The simplifier has separated mutually recursive bindings into strongly connected components so we can consider the list as a single entity. *) fun processLambdas lambdaList = let (* First process the bodies of the functions. *) val needed = ! needReprocess val _ = needReprocess := false; val transLambdas = map (fn {lambda={body, isInline, name, closure, argTypes, resultType, localCount, recUse}, use, addr} => {lambda={body=mapChecks body, isInline=isInline, name=name, closure=closure, argTypes=argTypes, resultType=resultType, localCount=localCount, recUse=recUse}, use=use, addr=addr}) lambdaList val theseTransformed = ! needReprocess val _ = if needed then needReprocess := true else () fun hasFreeVariables{lambda={closure, ...}, ...} = let fun notInLambdas(LoadLocal lAddr) = (* A local is allowed if it only refers to another lambda. *) not (List.exists (fn {addr, ...} => addr = lAddr) lambdaList) | notInLambdas _ = true (* Anything else is not allowed. *) in List.exists notInLambdas closure end in if theseTransformed orelse List.exists (fn {lambda={isInline=Inline, ...}, ...} => true | _ => false) lambdaList orelse List.exists hasFreeVariables lambdaList (* If we have transformed any of the bodies we need to reprocess so defer any code-generation. Don't CG it if it is inline, or perhaps if it is inline and exported. Don't CG it if it has free variables. We still need to examine the bodies of the functions. *) then (transLambdas, []) else let (* Construct code to declare the functions and extract the values. *) val tupleFields = map (fn {addr, ...} => Extract(LoadLocal addr)) transLambdas val decsAndTuple = Newenv([RecDecs transLambdas], mkTuple tupleFields) val maxLocals = List.foldl(fn ({addr, ...}, n) => Int.max(addr, n)) 0 transLambdas val (code, props) = BACKEND.codeGenerate(decsAndTuple, maxLocals + 1, debugSwitches) val resultConstnt = Constnt(code(), props) fun getResults([], _) = [] | getResults({addr, use, ...} :: tail, n) = Declar {value=mkInd(n, resultConstnt), addr=addr, use=use} :: getResults(tail, n+1) val () = needReprocess := true in ([], getResults(transLambdas, 0)) end end and runChecks (Lambda (lambda as { isInline=NonInline, closure=[], ... })) = ( (* Bare lambda. *) case processLambdas[{lambda=lambda, use = [], addr = 0}] of ([{lambda=unCGed, ...}], []) => SOME(Lambda unCGed) | ([], [Declar{value, ...}]) => SOME value | _ => raise InternalError "processLambdas" ) | runChecks (Newenv(bindings, exp)) = let (* We have a block of bindings. Are any of them functions that are only ever called? *) fun checkBindings(Declar{value=Lambda lambda, addr, use}, tail) = ( (* Process this lambda and extract the result. *) case processLambdas[{lambda=lambda, use = use, addr = addr}] of ([{lambda=unCGed, use, addr}], []) => Declar{value=Lambda unCGed, use=use, addr=addr} :: tail | ([], cgedDec) => cgedDec @ tail | _ => raise InternalError "checkBindings" ) | checkBindings(Declar{value, addr, use}, tail) = Declar{value=mapChecks value, addr=addr, use=use} :: tail | checkBindings(RecDecs l, tail) = let val (notConsts, asConsts) = processLambdas l in asConsts @ (if null notConsts then [] else [RecDecs notConsts]) @ tail end | checkBindings(NullBinding exp, tail) = NullBinding(mapChecks exp) :: tail | checkBindings(Container{addr, use, size, setter}, tail) = Container{addr=addr, use=use, size=size, setter=mapChecks setter} :: tail in SOME(Newenv((List.foldr checkBindings [] bindings), mapChecks exp)) end | runChecks _ = NONE and mapChecks c = mapCodetree runChecks c in (mapCodetree runChecks code, numLocals, !needReprocess) end (* Main optimiser and simplifier loop. *) fun codetreeOptimiser(code, debugSwitches, numLocals) = let fun topLevel _ = raise InternalError "top level reached in optimiser" fun processTree (code, nLocals, optAgain) = let (* First run the simplifier. Among other things this does inline expansion and if it does any we at least need to run cleanProc on the code so it will have set simpAgain. *) val (simpCode, simpCount, simpAgain) = SIMPLIFIER.simplifier(code, nLocals) in if optAgain orelse simpAgain then let (* Identify usage information and remove redundant code. *) val printCodeTree = DEBUG.getParameter DEBUG.codetreeTag debugSwitches and compilerOut = PRETTY.getCompilerOutput debugSwitches val simpCode = SIMPLIFIER.specialToGeneral simpCode val () = if printCodeTree then compilerOut(PRETTY.PrettyString "Output of simplifier") else () val () = if printCodeTree then compilerOut (BASECODETREE.pretty simpCode) else () val preOptCode = REMOVE_REDUNDANT.cleanProc(simpCode, [UseExport], topLevel, simpCount) (* Print the code with the use information before it goes into the optimiser. *) val () = if printCodeTree then compilerOut(PRETTY.PrettyString "Output of cleaner") else () val () = if printCodeTree then compilerOut (BASECODETREE.pretty preOptCode) else () val reprocess = ref false (* May be set in the optimiser *) (* Allocate any new addresses after the existing ones. *) val addressAllocator = ref simpCount fun makeAddr() = (! addressAllocator) before addressAllocator := ! addressAllocator + 1 val optContext = { makeAddr = makeAddr, reprocess = reprocess, debugArgs = debugSwitches } (* Optimise the code, rewriting it as necessary. *) val optCode = mapCodetree (optimise(optContext, [UseExport])) preOptCode val (llCode, llCount, llAgain) = (* If we have optimised it or the simplifier has run something that it wants to run again we must rerun these before we try to generate any code. *) if ! reprocess (* Re-optimise *) orelse simpAgain (* The simplifier wants to run again on this. *) then (optCode, ! addressAllocator, ! reprocess) else (* We didn't detect any inlineable functions. Check for lambda-lifting. *) lambdaLiftAndConstantFunction(optCode, debugSwitches, ! addressAllocator) (* Print the code after the optimiser. *) val () = if printCodeTree then compilerOut(PRETTY.PrettyString "Output of optimiser") else () val () = if printCodeTree then compilerOut (BASECODETREE.pretty llCode) else () in (* Rerun the simplifier at least. *) processTree(llCode, llCount, llAgain) end else (simpCode, simpCount) (* We're done *) end val (postOptCode, postOptCount) = processTree(code, numLocals, true (* Once at least *)) val (rGeneral, rDecs, rSpec) = postOptCode in { numLocals = postOptCount, general = rGeneral, bindings = rDecs, special = rSpec } end structure Sharing = struct type codetree = codetree and envSpecial = envSpecial and codeBinding = codeBinding end end; diff --git a/mlsource/MLCompiler/CodeTree/CODETREE_STATIC_LINK_AND_CASES.sml b/mlsource/MLCompiler/CodeTree/CODETREE_STATIC_LINK_AND_CASES.sml index 4f38c18d..ec4601c9 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE_STATIC_LINK_AND_CASES.sml +++ b/mlsource/MLCompiler/CodeTree/CODETREE_STATIC_LINK_AND_CASES.sml @@ -1,879 +1,879 @@ (* Copyright (c) 2012-13, 2015-17 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor CODETREE_STATIC_LINK_AND_CASES( structure BASECODETREE: BaseCodeTreeSig structure CODETREE_FUNCTIONS: CodetreeFunctionsSig structure GCODE: GENCODESIG structure DEBUG: DEBUGSIG structure PRETTY : PRETTYSIG structure BACKENDTREE: BackendIntermediateCodeSig sharing BASECODETREE.Sharing = CODETREE_FUNCTIONS.Sharing = GCODE.Sharing = PRETTY.Sharing = BACKENDTREE.Sharing ) : CodegenTreeSig = struct open BASECODETREE open Address open BACKENDTREE datatype caseType = datatype BACKENDTREE.caseType exception InternalError = Misc.InternalError open BACKENDTREE.CodeTags (* Property tag to indicate which arguments to a function are functions that are only ever called. *) val closureFreeArgsTag: int list Universal.tag = Universal.tag() datatype maybeCase = IsACase of { cases : (backendIC * word) list, test : backendIC, caseType: caseType, default : backendIC } | NotACase of backendIC fun staticLinkAndCases (pt, localAddressCount) = let fun copyCode (pt, nonLocals, recursive, localCount, localAddresses, argClosure) = let (* "closuresForLocals" is a flag indicating that if the declaration is a function a closure must be made for it. *) val closuresForLocals = Array.array(localCount, false) val newLocalAddresses = Array.array (localCount, 0) val argProperties = Array.array(localCount, []) (* Reference to local or non-local bindings. This sets the "closure" property on the binding depending on how the binding will be used. *) fun locaddr (LoadLocal addr, closure) = let val () = if closure then Array.update (closuresForLocals, addr, true) else () val newAddr = Array.sub(newLocalAddresses, addr) in BICLoadLocal newAddr end | locaddr(LoadArgument addr, closure) = ( argClosure(addr, closure); BICLoadArgument addr ) | locaddr(LoadRecursive, closure) = recursive closure | locaddr(LoadClosure addr, closure) = #1 (nonLocals (addr, closure)) (* Argument properties. This returns information of which arguments can have functions passed in without requiring a full heap closure. *) fun argumentProps(LoadLocal addr) = Array.sub(argProperties, addr) | argumentProps(LoadArgument _) = [] | argumentProps LoadRecursive = [] | argumentProps (LoadClosure addr) = #2 (nonLocals (addr, false)) fun makeDecl addr = let val newAddr = ! localAddresses before (localAddresses := !localAddresses+1) val () = Array.update (closuresForLocals, addr, false) val () = Array.update (newLocalAddresses, addr, newAddr) val () = Array.update (argProperties, addr, []) in newAddr end fun insert(Eval { function = Extract LoadRecursive, argList, resultType, ...}) = let (* Recursive. If we pass an argument in the same position we don't necessarily need a closure. It depends on what else happens to it. *) fun mapArgs(n, (Extract (ext as LoadArgument m), t) :: tail) = (BICExtract(locaddr(ext, n <> m)), t) :: mapArgs(n+1, tail) | mapArgs(n, (c, t) :: tail) = (insert c, t) :: mapArgs(n+1, tail) | mapArgs(_, []) = [] val newargs = mapArgs(0, argList) val func = locaddr(LoadRecursive, (* closure = *) false) in (* If we are calling a function which has been declared this does not require it to have a closure. Any other use of the function would. *) BICEval {function = BICExtract func, argList = newargs, resultType=resultType} end | insert(Eval { function = Extract ext, argList, resultType, ...}) = let (* Non-recursive but a binding. *) val cfArgs = argumentProps ext fun isIn n = not(List.exists(fn m => m = n) cfArgs) fun mapArgs(n, (Extract ext, t) :: tail) = (BICExtract(locaddr(ext, isIn n)), t) :: mapArgs(n+1, tail) | mapArgs(n, (Lambda lam, t) :: tail) = (insertLambda(lam, isIn n), t) :: mapArgs(n+1, tail) | mapArgs(n, (c, t) :: tail) = (insert c, t) :: mapArgs(n+1, tail) | mapArgs(_, []) = [] val newargs = mapArgs(0, argList) val func = locaddr(ext, (* closure = *) false) in (* If we are calling a function which has been declared this does not require it to have a closure. Any other use of the function would. *) BICEval {function = BICExtract func, argList = newargs, resultType=resultType} end | insert(Eval { function = Constnt(w, p), argList, resultType, ...}) = let (* Constant function. *) val cfArgs = case List.find (Universal.tagIs closureFreeArgsTag) p of NONE => [] | SOME u => Universal.tagProject closureFreeArgsTag u fun isIn n = not(List.exists(fn m => m = n) cfArgs) fun mapArgs(n, (Extract ext, t) :: tail) = (BICExtract(locaddr(ext, isIn n)), t) :: mapArgs(n+1, tail) | mapArgs(n, (Lambda lam, t) :: tail) = (insertLambda(lam, isIn n), t) :: mapArgs(n+1, tail) | mapArgs(n, (c, t) :: tail) = (insert c, t) :: mapArgs(n+1, tail) | mapArgs(_, []) = [] val newargs = mapArgs(0, argList) in BICEval {function = BICConstnt (w, p), argList = newargs, resultType=resultType} end | insert(Eval { function = Lambda lam, argList, resultType, ...}) = let (* Call of a lambda. Typically this will be a recursive function that can't be inlined. *) val newargs = map(fn (c, t) => (insert c, t)) argList val (copiedLambda, newClosure, makeRecClosure, _) = copyLambda lam val func = copyProcClosure (copiedLambda, newClosure, makeRecClosure) in BICEval {function = func, argList = newargs, resultType=resultType} end | insert(Eval { function, argList, resultType, ...}) = let (* Process the arguments first. *) val newargs = map(fn (c, t) => (insert c, t)) argList val func = insert function in BICEval {function = func, argList = newargs, resultType=resultType} end - | insert GetThreadId = BICGetThreadId + | insert(Nullary{oper}) = BICNullary{oper=oper} | insert(Unary { oper, arg1 }) = BICUnary { oper = oper, arg1 = insert arg1 } | insert(Binary { oper, arg1, arg2 }) = BICBinary { oper = oper, arg1 = insert arg1, arg2 = insert arg2 } | insert(Arbitrary { oper=ArbCompare test, shortCond, arg1, arg2, longCall}) = let val insArg1 = insert arg1 and insArg2 = insert arg2 and insCall = insert longCall and insShort = insert shortCond (* We have to rewrite this. *) (* if isShort i andalso isShort j then toShort i < toShort j else callComp(i, j) < 0 *) fun fixedComp(arg1, arg2) = BICBinary { oper = BuiltIns.WordComparison{test=test, isSigned=true}, arg1 = arg1, arg2 = arg2 } val zeroFalse = BICConstnt(toMachineWord 0, []) in BICCond( insShort, fixedComp(insArg1, insArg2), fixedComp(insCall, zeroFalse) ) end | insert(Arbitrary { oper=ArbArith arith, shortCond, arg1, arg2, longCall}) = let val insArg1 = insert arg1 and insArg2 = insert arg2 and insCall = insert longCall and insShort = insert shortCond in BICArbitrary{oper=arith, shortCond=insShort, arg1=insArg1, arg2=insArg2, longCall=insCall} end | insert(AllocateWordMemory {numWords, flags, initial}) = BICAllocateWordMemory { numWords = insert numWords, flags = insert flags, initial = insert initial } | insert(Extract ext) = (* Load the value bound to an identifier. The closure flag is set to true since the only cases where a closure is not needed, eval and load-andStore, are handled separately. *) BICExtract(locaddr(ext, (* closure = *) true)) | insert(Indirect {base, offset, indKind=IndContainer}) = BICLoadContainer {base = insert base, offset = offset} | insert(Indirect {base, offset, ...}) = BICField {base = insert base, offset = offset} | insert(Constnt wp) = BICConstnt wp (* Constants can be returned untouched. *) | insert(BeginLoop{loop=body, arguments=argList, ...}) = (* Start of tail-recursive inline function. *) let (* Make entries in the tables for the arguments. *) val newAddrs = List.map (fn ({addr, ...}, _) => makeDecl addr) argList (* Process the body. *) val insBody = insert body (* Finally the initial argument values. *) local fun copyDec(({value, ...}, t), addr) = ({addr=addr, value=insert value}, t) in val newargs = ListPair.map copyDec (argList, newAddrs) end in (* Add the kill entries on after the loop. *) BICBeginLoop{loop=insBody, arguments=newargs} end | insert(Loop argList) = (* Jump back to start of tail-recursive function. *) BICLoop(List.map(fn (c, t) => (insert c, t)) argList) | insert(Raise x) = BICRaise (insert x) (* See if we can use a case-instruction. Arguably this belongs in the optimiser but it is only really possible when we have removed redundant declarations. *) | insert(Cond(condTest, condThen, condElse)) = reconvertCase(copyCond (condTest, condThen, condElse)) | insert(Newenv(ptElist, ptExp)) = let (* Process the body. Recurses down the list of declarations and expressions processing each, and then reconstructs the list on the way back. *) fun copyDeclarations ([]) = [] | copyDeclarations (Declar({addr=caddr, value = Lambda lam, ...}) :: vs) = let (* Binding a Lambda - process the function first. *) val newAddr = makeDecl caddr val (copiedLambda, newClosure, makeRecClosure, cfArgs) = copyLambda lam val () = Array.update(argProperties, caddr, cfArgs) (* Process all the references to the function. *) val rest = copyDeclarations vs (* We now know if we need a heap closure. *) val dec = copyProcClosure(copiedLambda, newClosure, makeRecClosure orelse Array.sub(closuresForLocals, caddr)) in BICDeclar{addr=newAddr, value=dec} :: rest end | copyDeclarations (Declar({addr=caddr, value = pt, ...}) :: vs) = let (* Non-function binding. *) val newAddr = makeDecl caddr val rest = copyDeclarations vs in BICDeclar{addr=newAddr, value=insert pt} :: rest end | copyDeclarations (RecDecs mutualDecs :: vs) = let (* Mutually recursive declarations. Any of the declarations may refer to any of the others. This causes several problems in working out the use-counts and whether the functions (they should be functions) need closures. A function will need a closure if any reference would require one (i.e. does anything other than call it). The reference may be from one of the other mutually recursive declarations and may be because that function requires a full closure. This means that once we have dealt with any references in the rest of the containing block we have to repeatedly scan the list of declarations removing those which need closures until we are left with those that do not. The use-counts can only be obtained when all the non-local lists have been copied. *) (* First go down the list making a declaration for each entry. This makes sure there is a table entry for all the declarations. *) val _ = List.map (fn {addr, ...} => makeDecl addr) mutualDecs (* Process the rest of the block. Identifies all other references to these declarations. *) val restOfBlock = copyDeclarations vs (* We now want to find out which of the declarations require closures. First we copy all the declarations, except that we don't copy the non-local lists of functions. *) fun copyDec ({addr=caddr, lambda, ...}) = let val (dec, newClosure, makeRecClosure, cfArgs) = copyLambda lambda val () = if makeRecClosure then Array.update (closuresForLocals, caddr, true) else () val () = Array.update(argProperties, caddr, cfArgs) in (caddr, dec, newClosure) end val copiedDecs = map copyDec mutualDecs (* We now have identified all possible references to the functions apart from those of the closures themselves. Any of closures may refer to any other function so we must iterate until all the functions which need full closures have been processed. *) fun processClosures([], outlist, true) = (* Sweep completed. - Must repeat. *) processClosures(outlist, [], false) | processClosures([], outlist, false) = (* We have processed the whole of the list without finding anything which needs a closure. The remainder do not need full closures. *) let fun mkLightClosure ((addr, value, newClosure)) = let val clos = copyProcClosure(value, newClosure, false) val newAddr = Array.sub(newLocalAddresses, addr) in {addr=newAddr, value=clos} end in map mkLightClosure outlist end | processClosures((h as (caddr, value, newClosure))::t, outlist, someFound) = if Array.sub(closuresForLocals, caddr) then let (* Must copy it. *) val clos = copyProcClosure(value, newClosure, true) val newAddr = Array.sub(newLocalAddresses, caddr) in {addr=newAddr, value=clos} :: processClosures(t, outlist, true) end (* Leave it for the moment. *) else processClosures(t, h :: outlist, someFound) val decs = processClosures(copiedDecs, [], false) local fun isLambda{value=BICLambda _, ...} = true | isLambda _ = false in val (lambdas, nonLambdas) = List.partition isLambda decs end fun asMutual{addr, value = BICLambda lambda} = {addr=addr, lambda=lambda} | asMutual _ = raise InternalError "asMutual" in (* Return the mutual declarations and the rest of the block. *) if null lambdas then map BICDeclar nonLambdas @ restOfBlock (* None left *) else BICRecDecs (map asMutual lambdas) :: (map BICDeclar nonLambdas @ restOfBlock) end (* copyDeclarations.isMutualDecs *) | copyDeclarations (NullBinding v :: vs) = let (* Not a declaration - process this and the rest. *) (* Must process later expressions before earlier ones so that the last references to variables are found correctly. DCJM 30/11/99. *) val copiedRest = copyDeclarations vs; val copiedNode = insert v in (* Expand out blocks *) case copiedNode of BICNewenv(decs, exp) => decs @ (BICNullBinding exp :: copiedRest) | _ => BICNullBinding copiedNode :: copiedRest end | copyDeclarations (Container{addr, size, setter, ...} :: vs) = let val newAddr = makeDecl addr val rest = copyDeclarations vs val setCode = insert setter in BICDecContainer{addr=newAddr, size=size} :: BICNullBinding setCode :: rest end val insElist = copyDeclarations(ptElist @ [NullBinding ptExp]) fun mkEnv([], exp) = exp | mkEnv(decs, exp) = BICNewenv(decs, exp) fun decSequenceWithFinalExp decs = let fun splitLast _ [] = raise InternalError "decSequenceWithFinalExp: empty" | splitLast decs [BICNullBinding exp] = (List.rev decs, exp) | splitLast _ [_] = raise InternalError "decSequenceWithFinalExp: last is not a NullDec" | splitLast decs (hd::tl) = splitLast (hd:: decs) tl in mkEnv(splitLast [] decs) end in (* TODO: Tidy this up. *) decSequenceWithFinalExp insElist end (* isNewEnv *) | insert(Tuple { fields, ...}) = BICTuple (map insert fields) | insert(Lambda lam) = (* Using a lambda in a context other than a call or being passed to a function that is known only to call the function. It requires a heap closure. *) insertLambda(lam, true) | insert(Handle { exp, handler, exPacketAddr }) = let (* The order here is important. We want to make sure that the last reference to a variable really is the last. *) val newAddr = makeDecl exPacketAddr val hand = insert handler val exp = insert exp in BICHandle {exp = exp, handler = hand, exPacketAddr=newAddr} end | insert(SetContainer {container, tuple, filter}) = BICSetContainer{container = insert container, tuple = insert tuple, filter = filter} | insert(TagTest{test, tag, maxTag}) = BICTagTest{test=insert test, tag=tag, maxTag=maxTag} | insert(LoadOperation{kind, address}) = BICLoadOperation{kind=kind, address=insertAddress address} | insert(StoreOperation{kind, address, value}) = BICStoreOperation{kind=kind, address=insertAddress address, value=insert value} | insert(BlockOperation{kind, sourceLeft, destRight, length}) = BICBlockOperation{ kind=kind, sourceLeft=insertAddress sourceLeft, destRight=insertAddress destRight, length=insert length} and insertLambda (lam, needsClosure) = let val (copiedLambda, newClosure, _, _) = copyLambda lam in copyProcClosure (copiedLambda, newClosure, needsClosure) end and insertAddress{base, index, offset} = {base=insert base, index=Option.map insert index, offset=offset} and copyCond (condTest, condThen, condElse): maybeCase = let (* Process the then-part. *) val insThen = insert condThen (* Process the else-part. If it's a conditional process it here. *) val insElse = case condElse of Cond(i, t, e) => copyCond(i, t, e) | _ => NotACase(insert condElse) (* Process the condition after the then- and else-parts. *) val insFirst = insert condTest type caseVal = { tag: word, test: codetree, caseType: caseType } option; (* True if both instructions are loads or indirections with the same effect. More complicated cases could be considered but function calls must always be treated as different. Note: the reason we consider Indirect entries here as well as Extract is because we (used to) defer Indirect entries. *) datatype similarity = Different | Similar of bicLoadForm fun similar (BICExtract a, BICExtract b) = if a = b then Similar a else Different | similar (BICField{offset=aOff, base=aBase}, BICField{offset=bOff, base=bBase}) = if aOff <> bOff then Different else similar (aBase, bBase) | similar _ = Different; (* If we have a call to the int equality operation then we may be able to use an indexed case. N.B. This works equally for word values (unsigned) and fixed precision int (unsigned) but is unsafe for arbitrary precision since the lower levels assume that all values are tagged. *) fun findCase (BICBinary{oper=BuiltIns.WordComparison{test=BuiltIns.TestEqual, ...}, arg1, arg2}) = let in case (arg1, arg2) of (BICConstnt(c1, _), arg2) => if isShort c1 then SOME{tag=toShort c1, test=arg2, caseType = CaseWord} else NONE (* Not a short constant. *) | (arg1, BICConstnt(c2, _)) => if isShort c2 then SOME{tag=toShort c2, test=arg1, caseType = CaseWord} else NONE (* Not a short constant. *) | _ => NONE (* Wrong number of arguments - should raise exception? *) end | findCase(BICTagTest { test, tag, maxTag }) = SOME { tag=tag, test=test, caseType=CaseTag maxTag } | findCase _ = NONE val testCase = findCase insFirst in case testCase of NONE => (* Can't use a case *) NotACase(BICCond (insFirst, insThen, reconvertCase insElse)) | SOME { tag=caseTags, test=caseTest, caseType=caseCaseTest } => (* Can use a case. Can we combine two cases? If we have an expression like "if x = a then .. else if x = b then ..." we can combine them into a single "case". *) case insElse of IsACase { cases=nextCases, test=nextTest, default=nextDefault, caseType=nextCaseType } => ( case (similar(nextTest, caseTest), caseCaseTest = nextCaseType) of (* Note - it is legal (though completely redundant) for the same case to appear more than once in the list. This is not checked for at this stage. *) (Similar _, true) => IsACase { cases = (insThen, caseTags) :: map (fn (c, l) => (c, l)) nextCases, test = nextTest, default = nextDefault, caseType = caseCaseTest } | _ => (* Two case expressions but they test different variables. We can't combine them. *) IsACase { cases = [(insThen, caseTags)], test = caseTest, default = reconvertCase insElse, caseType=caseCaseTest } ) | NotACase elsePart => (* insElse is not a case *) IsACase { cases = [(insThen, caseTags)], test = caseTest, default = elsePart, caseType=caseCaseTest } end (* Check something that's been created as a Case and see whether it is sparse. If it is turn it back into a sequence of conditionals. This was previously done at the bottom level and the choice of when to use an indexed case was made by the architecture-specific code-generator. That's probably unnecessary and complicates the code-generator. *) and reconvertCase(IsACase{cases, test, default, caseType}) = let (* Count the number of cases and compute the maximum and minimum. *) (* If we are testing on integers we could have negative values here. Because we're using "word" here any negative values are treated as large positive values and so we won't use a "case". If this is a case on constructor tags we know the range. There will always be a "default" which may be anywhere in the range but if we construct a jump table that covers all the values we don't need the range checks. *) val useIndexedCase = case caseType of CaseTag _ => (* Exhaustive *) List.length cases > 4 | _ => let val (_, aLabel) = hd cases fun foldCases((_, w), (min, max)) = (Word.min(w, min), Word.max(w, max)) val (min, max) = List.foldl foldCases (aLabel, aLabel) cases val numberOfCases = List.length cases in numberOfCases > 7 andalso Word.fromInt numberOfCases >= (max - min) div 0w3 end in if useIndexedCase then let (* Create a contiguous range of labels. Eliminate any duplicates which are legal but redundant. *) local val labelCount = List.length cases (* Add an extra field before sorting which retains the ordering for equal labels. *) val ordered = ListPair.zipEq (cases, List.tabulate(labelCount, fn n=>n)) fun leq ((_, w1: word), n1: int) ((_, w2), n2) = if w1 = w2 then n1 <= n2 else w1 < w2 val sorted = List.map #1 (Misc.quickSort leq ordered) (* Filter out any duplicates. *) fun filter [] = [] | filter [p] = [p] | filter ((p as (_, lab1)) :: (q as (_, lab2)) :: tl) = if lab1 = lab2 then p :: filter tl else p :: filter (q :: tl) in val cases = filter sorted end val (isExhaustive, min, max) = case caseType of CaseTag max => (true, 0w0, max) | _ => let val (_, aLabel) = hd cases fun foldCases((_, w), (min, max)) = (Word.min(w, min), Word.max(w, max)) val (min, max) = List.foldl foldCases (aLabel, aLabel) cases in (false, min, max) end (* Create labels for each of the cases. Fill in any gaps with entries that will point to the default. We have to be careful if max happens to be the largest value of Word.word. In that case adding one to the range will give us a value less than max. *) fun extendCase(indexVal, cl as ((c, caseValue) :: cps)) = if indexVal + min = caseValue then SOME c :: extendCase(indexVal+0w1, cps) else NONE :: extendCase(indexVal+0w1, cl) | extendCase(indexVal, []) = (* We may not be at the end if this came from a CaseTag *) if indexVal > max-min then [] else NONE :: extendCase(indexVal+0w1, []) val fullCaseRange = extendCase(0w0, cases) val _ = Word.fromInt(List.length fullCaseRange) = max-min+0w1 orelse raise InternalError "Cases" in BICCase{cases=fullCaseRange, test=test, default=default, isExhaustive=isExhaustive, firstIndex=min} end else let fun reconvert [] = default | reconvert ((c, t) :: rest) = let val test = case caseType of CaseWord => BICBinary{ oper=BuiltIns.WordComparison{test=BuiltIns.TestEqual, isSigned=false}, arg1=test, arg2=BICConstnt(toMachineWord t, [])} | CaseTag maxTag => BICTagTest { test=test, tag=t, maxTag=maxTag } in BICCond(test, c, reconvert rest) end in reconvert cases end end | reconvertCase (NotACase t) = t (* Just a simple conditional. *) (* If "makeClosure" is true the function will need a full closure. It may need a full closure even if makeClosure is false if it involves a recursive reference which will need a closure. *) and copyLambda ({body=lambdaBody, argTypes, name=lambdaName, resultType, localCount, closure=lambdaClosure, ...}: lambdaForm) = let val newGrefs: loadForm list ref = ref [] (* non-local references *) val newNorefs = ref 0 (* number of non-local refs *) val makeClosureForRecursion = ref false (* A new table for the new function. *) fun prev (closureAddr, closure) = let val loadEntry = List.nth(lambdaClosure, closureAddr) (* Returns the closure address of the non-local *) fun makeClosureEntry([], _) = (* not found - construct new entry *) let val () = newGrefs := loadEntry :: !newGrefs; val newAddr = !newNorefs + 1; in newNorefs := newAddr; (* increment count *) newAddr-1 end | makeClosureEntry(oldEntry :: t, newAddr) = if oldEntry = loadEntry then newAddr-1 else makeClosureEntry(t, newAddr - 1) (* Set the closure flag if necessary and get the argument props. At this point we discard the "Load" entry returned by nonLocals and "recursive". The closure will be processed later. *) val argProps = case loadEntry of LoadLocal addr => let val () = if closure then Array.update (closuresForLocals, addr, true) else () in Array.sub(argProperties, addr) end | LoadArgument addr => (argClosure(addr, closure); []) | LoadRecursive => (recursive closure; []) | LoadClosure entry => #2 (nonLocals (entry, closure)) in (* Just return the closure entry. *) (BICLoadClosure(makeClosureEntry (!newGrefs, !newNorefs)), argProps) end fun recCall closure = (* Reference to the closure itself. *) ( if closure then makeClosureForRecursion := true else (); BICLoadRecursive ) local datatype tri = TriUnref | TriCall | TriClosure val argClosureArray = Array.array(List.length argTypes, TriUnref) in fun argClosure(n, t) = Array.update(argClosureArray, n, (* If this is true it requires a closure. If it is false it requires a closure if any other reference does. *) if t orelse Array.sub(argClosureArray, n) = TriClosure then TriClosure else TriCall) fun closureFreeArgs() = Array.foldri(fn (n, TriCall, l) => n :: l | (_, _, l) => l) [] argClosureArray end (* process the body *) val newLocalAddresses = ref 0 val (insertedCode, _) = copyCode (lambdaBody, prev, recCall, localCount, newLocalAddresses, argClosure) val globalRefs = !newGrefs val cfArgs = closureFreeArgs() in (BICLambda { body = insertedCode, name = lambdaName, closure = [], argTypes = map #1 argTypes, resultType = resultType, localCount = ! newLocalAddresses, heapClosure = false }, globalRefs, ! makeClosureForRecursion, cfArgs) end (* copyLambda *) (* Copy the closure of a function which has previously been processed by copyLambda. *) and copyProcClosure (BICLambda{ body, name, argTypes, resultType, localCount, ...}, newClosure, heapClosure) = let (* process the non-locals in this function *) (* If a heap closure is needed then any functions referred to from the closure also need heap closures.*) fun makeLoads ext = locaddr(ext, heapClosure) val copyRefs = rev (map makeLoads newClosure) in BICLambda { body = body, name = name, closure = copyRefs, argTypes = argTypes, resultType = resultType, localCount = localCount, heapClosure = heapClosure orelse null copyRefs (* False if closure is empty *) } end | copyProcClosure(pt, _, _) = pt (* may now be a constant *) (* end copyProcClosure *) in case pt of Lambda lam => let val (copiedLambda, newClosure, _, cfArgs) = copyLambda lam val code = copyProcClosure (copiedLambda, newClosure, true) val props = if null cfArgs then [] else [Universal.tagInject closureFreeArgsTag cfArgs] in (code, props) end | c as Newenv(_, exp) => let val code = insert c fun getProps(Extract(LoadLocal addr)) = let val cfArgs = Array.sub(argProperties, addr) in if null cfArgs then [] else [Universal.tagInject closureFreeArgsTag cfArgs] end | getProps(Tuple { fields, ...}) = let val fieldProps = map getProps fields in if List.all null fieldProps then [] else [Universal.tagInject CodeTags.tupleTag fieldProps] end | getProps _ = [] val props = getProps exp in (code, props) end | c as Constnt(_, p) => (insert c, p) | pt => (insert pt, []) end (* copyCode *) val outputAddresses = ref 0 fun topLevel _ = raise InternalError "outer level reached in copyCode" val (insertedCode, argProperties) = copyCode (pt, topLevel, topLevel, localAddressCount, outputAddresses, fn _ => ()) in (insertedCode, argProperties) end (* staticLinkAndCases *) type closureRef = GCODE.closureRef fun codeGenerate(lambda: lambdaForm, debugSwitches, closure) = let val (code, argProperties) = staticLinkAndCases(Lambda lambda, 0) val backendCode = code val () = if DEBUG.getParameter DEBUG.codetreeAfterOptTag debugSwitches then PRETTY.getCompilerOutput debugSwitches (BACKENDTREE.pretty backendCode) else () val bicLambda = case backendCode of BACKENDTREE.BICLambda lam => lam | _ => raise InternalError "Not BICLambda" val () = GCODE.gencodeLambda(bicLambda, debugSwitches, closure) in argProperties end structure Foreign = GCODE.Foreign (* Sharing can be copied from CODETREE. *) structure Sharing = struct open BASECODETREE.Sharing type closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/ICodeSig.ML b/mlsource/MLCompiler/CodeTree/X86Code/ICodeSig.ML index 5cf191ea..d03a65dc 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/ICodeSig.ML +++ b/mlsource/MLCompiler/CodeTree/X86Code/ICodeSig.ML @@ -1,412 +1,413 @@ (* Signature for the high-level X86 code - Copyright David C. J. Matthews 2016-18 + Copyright David C. J. Matthews 2016-19 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) signature ICodeSig = sig type machineWord = Address.machineWord type address = Address.address type closureRef (* Registers. *) datatype genReg = GeneralReg of Word8.word * bool and fpReg = FloatingPtReg of Word8.word and xmmReg = SSE2Reg of Word8.word datatype reg = GenReg of genReg | FPReg of fpReg | XMMReg of xmmReg val regRepr: reg -> string val nReg: reg -> int val is32bit: LargeInt.int -> bool datatype targetArch = Native32Bit | Native64Bit | ObjectId32Bit val targetArch: targetArch (* Should we use SSE2 or X87 floating point? *) datatype fpMode = FPModeSSE2 | FPModeX87 val fpMode: fpMode val eax: genReg and ebx: genReg and ecx: genReg and edx: genReg and edi: genReg and esi: genReg and esp: genReg and ebp: genReg and r8: genReg and r9: genReg and r10: genReg and r11: genReg and r12: genReg and r13: genReg and r14: genReg and r15: genReg and fp0: fpReg and fp1: fpReg and fp2: fpReg and fp3: fpReg and fp4: fpReg and fp5: fpReg and fp6: fpReg and fp7: fpReg and xmm0:xmmReg and xmm1:xmmReg and xmm2:xmmReg and xmm3:xmmReg and xmm4:xmmReg and xmm5:xmmReg and xmm6:xmmReg datatype branchOps = JO | JNO | JE | JNE | JL | JGE | JLE | JG | JB | JNB | JNA | JA | JP | JNP and arithOp = ADD | OR (*|ADC | SBB*) | AND | SUB | XOR | CMP and shiftType = SHL | SHR | SAR datatype boxKind = BoxLargeWord | BoxSSE2Double | BoxSSE2Float | BoxX87Double | BoxX87Float and fpOps = FADD | FMUL | FCOM | FCOMP | FSUB | FSUBR | FDIV | FDIVR and fpUnaryOps = FABS | FCHS | FLD1 | FLDZ datatype sse2UnaryOps = SSE2UDoubleToFloat | SSE2UFloatToDouble and sse2BinaryOps = SSE2BAddDouble | SSE2BSubDouble | SSE2BMulDouble | SSE2BDivDouble | SSE2BXor | SSE2BAnd | SSE2BAddSingle | SSE2BSubSingle | SSE2BMulSingle | SSE2BDivSingle val memRegThreadSelf: int (* Copied from X86CodeSig *) + and memRegExceptionPacket: int datatype callKinds = Recursive | ConstantCode of machineWord | FullCall datatype preg = PReg of int (* A pseudo-register - an abstract register. *) (* A location on the stack. May be more than word if this is a container or a handler entry. *) datatype stackLocn = StackLoc of {size: int, rno: int } (* This combines pregKind and stackLocn. *) datatype regProperty = RegPropGeneral (* A general register. *) | RegPropUntagged (* An untagged general register. *) | RegPropStack of int (* A stack location or container. *) | RegPropCacheTagged | RegPropCacheUntagged | RegPropMultiple (* The result of a conditional or case. May be defined at multiple points. *) datatype argument = RegisterArgument of preg | AddressConstant of machineWord (* A constant that is an address. *) | IntegerConstant of LargeInt.int (* A non-address constant. Will usually be shifted and tagged. *) | MemoryLocation of { base: preg, offset: int, index: memoryIndex, cache: preg option } (* A memory location. *) (* Offset on the stack. The container is the stack location identifier, the field is an offset in a container. cache is an optional cache register. *) | StackLocation of { wordOffset: int, container: stackLocn, field: int, cache: preg option } (* Address of a container. *) | ContainerAddr of { container: stackLocn, stackOffset: int } (* Generally this indicates the index register if present. For 32-in-64 the "index" may be ObjectIndex in which case the base is actually an object index. *) and memoryIndex = NoMemIndex | MemIndex1 of preg | MemIndex2 of preg | MemIndex4 of preg | MemIndex8 of preg | ObjectIndex (* Kinds of moves. Move32Bit - 32-bit loads and stores Move64Bit - 64-bit loads and stores MoveByte - When loading, load a byte and zero extend. Move16Bit - Used for C-memory loads and stores. Zero extends on load. MoveFloat - Load and store a single-precision value MoveDouble - Load and store a double-precision value. *) datatype moveKind = MoveByte | Move16Bit | Move32Bit | Move64Bit | MoveFloat | MoveDouble val movePolyWord: moveKind and moveNativeWord: moveKind (* The reference to a condition code. *) datatype ccRef = CcRef of int (* Size of operand. OpSize64 is only valid in 64-bit mode. *) datatype opSize = OpSize32 | OpSize64 val polyWordOpSize: opSize and nativeWordOpSize: opSize datatype x86ICode = (* Move a value into a register. *) LoadArgument of { source: argument, dest: preg, kind: moveKind } (* Store a value into memory. The source will usually be a register but could be a constant depending on the value. If isMutable is true we're assigning to a ref and we need to flush the memory cache. *) | StoreArgument of { source: argument, base: preg, offset: int, index: memoryIndex, kind: moveKind, isMutable: bool } (* Load an entry from the "memory registers". Used just for ThreadSelf. *) | LoadMemReg of { offset: int, dest: preg } (* Start of function. Set the register arguments. stackArgs is the list of stack arguments. The last entry is the return address. If the function has a real closure regArgs includes the closure register (rdx). *) | BeginFunction of { regArgs: (preg * reg) list, stackArgs: stackLocn list } (* Call a function. If the code address is a constant it is passed here. Otherwise the address is obtained by indirecting through rdx which has been loaded as one of the argument registers. The result is stored in the destination register. *) | FunctionCall of { callKind: callKinds, regArgs: (argument * reg) list, stackArgs: argument list, dest: preg, realDest: reg, saveRegs: preg list} (* Jump to a tail-recursive function. This is similar to FunctionCall but complicated for stack arguments because the stack and the return address need to be overwritten. stackAdjust is the number of words to remove (positive) or add (negative) to the stack before the call. currStackSize contains the number of items currently on the stack. *) | TailRecursiveCall of { callKind: callKinds, regArgs: (argument * reg) list, stackArgs: {src: argument, stack: int} list, stackAdjust: int, currStackSize: int, workReg: preg } (* Allocate a fixed sized piece of memory. The size is the number of words required. This sets the length word including the flags bits. saveRegs is the list of registers that need to be saved if we need to do a garbage collection. *) | AllocateMemoryOperation of { size: int, flags: Word8.word, dest: preg, saveRegs: preg list } (* Allocate a piece of memory whose size is not known at compile-time. The size argument is the number of words. *) | AllocateMemoryVariable of { size: preg, dest: preg, saveRegs: preg list } (* Initialise a piece of memory. N.B. The size is an untagged value containing the number of words. This uses REP STOSL/Q so addr must be rdi, size must be rcx and init must be rax. *) | InitialiseMem of { size: preg, addr: preg, init: preg } (* Signal that a tuple has been fully initialised. Really a check in the low-level code-generator. *) | InitialisationComplete (* Mark the beginning of a loop. This is really only to prevent the initialisation code being duplicated in ICodeOptimise. *) | BeginLoop (* Set up the registers for a jump back to the start of a loop. *) | JumpLoop of { regArgs: (argument * preg) list, stackArgs: (argument * int * stackLocn) list, checkInterrupt: preg list option, workReg: preg option } (* Raise an exception. The packet is always loaded into rax. *) | RaiseExceptionPacket of { packetReg: preg } (* Reserve a contiguous area on the stack to receive a result tuple. *) | ReserveContainer of { size: int, container: stackLocn } (* Indexed case. *) | IndexedCaseOperation of { testReg: preg, workReg: preg } (* Lock a mutable cell by turning off the mutable bit. *) | LockMutable of { addr: preg } (* Compare two word values. The first argument must be a register. *) | WordComparison of { arg1: preg, arg2: argument, ccRef: ccRef, opSize: opSize } (* Compare with a literal. This is generally used to compare a memory or stack location with a literal and overlaps to some extent with WordComparison. *) | CompareLiteral of { arg1: argument, arg2: LargeInt.int, opSize: opSize, ccRef: ccRef } (* Compare a byte location with a literal. This is the only operation that specifically deals with single bytes. Other cases will use word operations. *) | CompareByteMem of { arg1: { base: preg, offset: int, index: memoryIndex }, arg2: Word8.word, ccRef: ccRef } (* Exception handling. - Set up an exception handler. *) | PushExceptionHandler of { workReg: preg } (* End of a handled section. Restore the previous handler. *) | PopExceptionHandler of { workReg: preg } (* Marks the start of a handler. This sets the stack pointer and restores the old handler. Sets the exception packet register. *) | BeginHandler of { packetReg: preg, workReg: preg } (* Return from the function. *) | ReturnResultFromFunction of { resultReg: preg, realReg: reg, numStackArgs: int } (* Arithmetic or logical operation. These can set the condition codes. *) | ArithmeticFunction of { oper: arithOp, resultReg: preg, operand1: preg, operand2: argument, ccRef: ccRef, opSize: opSize } (* Test the tag bit of a word. Sets the Zero bit if the value is an address i.e. untagged. *) | TestTagBit of { arg: argument, ccRef: ccRef } (* Push a value to the stack. Added during translation phase. *) | PushValue of { arg: argument, container: stackLocn } (* Copy a value to a cache register. LoadArgument could be used for this but it may be better to keep it separate. *) | CopyToCache of { source: preg, dest: preg, kind: moveKind } (* Remove items from the stack. Added during translation phase. *) | ResetStackPtr of { numWords: int, preserveCC: bool } (* Store a value into the stack. *) | StoreToStack of { source: argument, container: stackLocn, field: int, stackOffset: int } (* Tag a value by shifting and setting the tag bit. *) | TagValue of { source: preg, dest: preg, isSigned: bool, opSize: opSize } (* Shift a value to remove the tag bit. The cache is used if this is untagging a value that has previously been tagged. *) | UntagValue of { source: preg, dest: preg, isSigned: bool, cache: preg option, opSize: opSize } (* This provides the LEA instruction which can be used for various sorts of arithmetic. The base register is optional in this case. *) | LoadEffectiveAddress of { base: preg option, offset: int, index: memoryIndex, dest: preg, opSize: opSize } (* Shift a word by an amount that can either be a constant or a register. *) | ShiftOperation of { shift: shiftType, resultReg: preg, operand: preg, shiftAmount: argument, ccRef: ccRef, opSize: opSize } (* Multiplication. We can use signed multiplication for both fixed precision and word (unsigned) multiplication. There are various forms of the instruction including a three-operand version. *) | Multiplication of { resultReg: preg, operand1: preg, operand2: argument, ccRef: ccRef, opSize: opSize } (* Division. This takes a register pair, always RDX:RAX, divides it by the operand register and puts the quotient in RAX and remainder in RDX. At the preg level we represent all of these by pRegs. The divisor can be either a register or a memory location. *) | Division of { isSigned: bool, dividend: preg, divisor: argument, quotient: preg, remainder: preg, opSize: opSize } (* Atomic exchange and addition. This is executed with a lock prefix and is used for atomic increment and decrement for mutexes. Before the operation the source contains an increment. After the operation the source contains the old value of the destination and the destination has been updated with its old value added to the increment. The destination is actually the word pointed at by "base". *) | AtomicExchangeAndAdd of { base: preg, source: preg } (* Create a "box" of a single-word "byte" cell and store the source into it. This can be implemented using AllocateMemoryOperation but the idea is to allow the transform layer to recognise when a value is being boxed and then unboxed and remove unnecessary allocation. *) | BoxValue of { boxKind: boxKind, source: preg, dest: preg, saveRegs: preg list } (* Compare two vectors of bytes and set the condition code on the result. In general vec1Addr and vec2Addr will be pointers inside memory cells so have to be untagged registers. *) | CompareByteVectors of { vec1Addr: preg, vec2Addr: preg, length: preg, ccRef: ccRef } (* Move a block of bytes (isByteMove true) or words (isByteMove false). The length is the number of items (bytes or words) to move. *) | BlockMove of { srcAddr: preg, destAddr: preg, length: preg, isByteMove: bool } (* Floating point comparison. *) | X87Compare of { arg1: preg, arg2: argument, isDouble: bool, ccRef: ccRef } (* Floating point comparison. *) | SSE2Compare of { arg1: preg, arg2: argument, isDouble: bool, ccRef: ccRef } (* The X87 FP unit does not generate condition codes directly. We have to load the cc into RAX and test it there. *) | X87FPGetCondition of { ccRef: ccRef, dest: preg } (* Binary floating point operations on the X87. *) | X87FPArith of { opc: fpOps, resultReg: preg, arg1: preg, arg2: argument, isDouble: bool } (* Floating point operations: negate and set sign positive. *) | X87FPUnaryOps of { fpOp: fpUnaryOps, dest: preg, source: preg } (* Load a fixed point value as a floating point value. *) | X87Float of { dest: preg, source: argument } (* Load a fixed point value as a floating point value. *) | SSE2Float of { dest: preg, source: argument } (* Binary floating point operations using SSE2 instructions. *) | SSE2FPUnary of { opc: sse2UnaryOps, resultReg: preg, source: argument } (* Binary floating point operations using SSE2 instructions. *) | SSE2FPBinary of { opc: sse2BinaryOps, resultReg: preg, arg1: preg, arg2: argument } (* Tag a 32-bit floating point value. This is tagged by shifting left 32-bits and then setting the bottom bit. This allows memory operands to be untagged simply by loading the high-order word. *) | TagFloat of { source: preg, dest: preg } (* Untag a 32-bit floating point value into a XMM register. If the source is in memory we just need to load the high-order word. *) | UntagFloat of { source: argument, dest: preg, cache: preg option } (* Get and set the control registers. These all have to work through memory but it's simpler to assume they work through registers. *) | GetSSE2ControlReg of { dest: preg } | SetSSE2ControlReg of { source: preg } | GetX87ControlReg of { dest: preg } | SetX87ControlReg of { source: preg } (* Convert a floating point value to an integer. *) | X87RealToInt of { source: preg, dest: preg } (* Convert a floating point value to an integer. *) | SSE2RealToInt of { source: argument, dest: preg, isDouble: bool, isTruncate: bool } (* Sign extend a 32-bit value to 64-bits. Not included in LoadArgument because that assumes that if we have the result in a register we can simply reuse the register. *) | SignExtend32To64 of { source: argument, dest: preg } (* Destinations at the end of a basic block. *) and controlFlow = (* Unconditional branch to a label - should be a merge point. *) Unconditional of int (* Conditional branch. Jumps to trueJump if the condional is false, falseJump if false. *) | Conditional of { ccRef: ccRef, condition: branchOps, trueJump: int, falseJump: int } (* Exit - the last instruction of the block is a return, raise or tailcall. *) | ExitCode (* Indexed case - this branches to one of a number of labels *) | IndexedBr of int list (* Set up a handler. This doesn't cause an immediate branch but the state at the start of the handler is the state at this point. *) | SetHandler of { handler: int, continue: int } (* Unconditional branch to a handler. If an exception is raised explicitly within the scope of a handler. *) | UnconditionalHandle of int (* Conditional branch to a handler. Occurs if there is a call to a function within the scope of a handler. It may jump to the handler. *) | ConditionalHandle of { handler: int, continue: int } and basicBlock = BasicBlock of { block: x86ICode list, flow: controlFlow } (* Return the successor blocks from a control flow. *) val successorBlocks: controlFlow -> int list val printICodeAbstract: basicBlock vector * (string -> unit) -> unit val indexRegister: memoryIndex -> preg option (* Destinations used in move. *) datatype destinations = RegDest of reg | StackDest of int structure Sharing: sig type genReg = genReg and argument = argument and memoryIndex = memoryIndex and x86ICode = x86ICode and branchOps = branchOps and reg = reg and preg = preg and destinations = destinations and controlFlow = controlFlow and basicBlock = basicBlock and stackLocn = stackLocn and regProperty = regProperty and callKinds = callKinds and arithOp = arithOp and shiftType = shiftType and fpOps = fpOps and fpUnaryOps = fpUnaryOps and sse2UnaryOps = sse2UnaryOps and sse2BinaryOps = sse2BinaryOps and ccRef = ccRef and opSize = opSize and closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86CodetreeToICode.ML b/mlsource/MLCompiler/CodeTree/X86Code/X86CodetreeToICode.ML index 1421e4d1..fdd51e09 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86CodetreeToICode.ML +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86CodetreeToICode.ML @@ -1,3955 +1,3975 @@ (* - Copyright David C. J. Matthews 2016-18 + Copyright David C. J. Matthews 2016-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 *) functor X86CodetreeToICode( structure BACKENDTREE: BackendIntermediateCodeSig structure ICODE: ICodeSig structure DEBUG: DEBUGSIG structure X86FOREIGN: FOREIGNCALLSIG structure ICODETRANSFORM: X86ICODETRANSFORMSIG structure CODE_ARRAY: CODEARRAYSIG sharing ICODE.Sharing = ICODETRANSFORM.Sharing = CODE_ARRAY.Sharing ): GENCODESIG = struct open BACKENDTREE open Address open ICODE open CODE_ARRAY exception InternalError = Misc.InternalError local val regs = case targetArch of Native32Bit => [eax, ebx] | Native64Bit => [eax, ebx, r8, r9, r10] | ObjectId32Bit => [eax, esi, r8, r9, r10] val fpResult = case targetArch of Native32Bit => FPReg fp0 | _ => XMMReg xmm0 val fpArgRegs = case targetArch of Native32Bit => [] | _ => [xmm0, xmm1, xmm2] in val generalArgRegs = List.map GenReg regs val floatingPtArgRegs = List.map XMMReg fpArgRegs fun resultReg GeneralType = GenReg eax | resultReg DoubleFloatType = fpResult | resultReg SingleFloatType = fpResult end (* tag a short constant *) fun tag c = 2 * c + 1 (* shift a short constant, but don't set tag bit *) fun semitag c = 2 * c (* Reverse a list and append the second. This is used a lot when converting between the reverse and forward list versions. e.g. codeToICode and codeToICodeRev *) fun revApp([], l) = l | revApp(hd :: tl, l) = revApp(tl, hd :: l) datatype blockStruct = BlockSimple of x86ICode | BlockExit of x86ICode | BlockLabel of int | BlockFlow of controlFlow | BlockBegin of { regArgs: (preg * reg) list, stackArgs: stackLocn list } | BlockRaiseAndHandle of x86ICode * int | BlockOptionalHandle of {call: x86ICode, handler: int, label: int } local open RunCall val F_mutable_bytes = Word.fromLargeWord(Word8.toLargeWord(Word8.orb (F_mutable, F_bytes))) fun makeRealConst l = let val r = allocateByteMemory(0wx8 div bytesPerWord, F_mutable_bytes) fun setBytes([], _) = () | setBytes(hd::tl, n) = (storeByte(r, n, hd); setBytes(tl, n+0wx1)) val () = setBytes(l, 0w0) val () = clearMutableBit r in r end in (* These are floating point constants used to change and mask the sign bit. *) val realSignBit: machineWord = makeRealConst [0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx80] and realAbsMask: machineWord = makeRealConst [0wxff, 0wxff, 0wxff, 0wxff, 0wxff, 0wxff, 0wxff, 0wx7f] and floatSignBit: machineWord = makeRealConst [0wx00, 0wx00, 0wx00, 0wx80, 0wx00, 0wx00, 0wx00, 0wx00] and floatAbsMask: machineWord = makeRealConst [0wxff, 0wxff, 0wxff, 0wx7f, 0wx00, 0wx00, 0wx00, 0wx00] end datatype commutative = Commutative | NonCommutative (* Check that a large-word constant looks right and get the value as a large int*) fun largeWordConstant value = if isShort value then raise InternalError "largeWordConstant: invalid" else let val addr = toAddress value in if length addr <> nativeWordSize div wordSize orelse flags addr <> F_bytes then raise InternalError "largeWordConstant: invalid" else (); LargeWord.toLargeInt(RunCall.unsafeCast addr) end fun codeFunctionToX86({body, localCount, name, argTypes, resultType=fnResultType, closure, ...}:bicLambdaForm, debugSwitches, resultClosure) = let (* Pseudo-registers are allocated sequentially and the properties added to the list. *) val pregCounter = ref 0 val pregPropList = ref [] fun newPReg() = let val regNo = !pregCounter before pregCounter := !pregCounter + 1 val () = pregPropList := RegPropGeneral :: !pregPropList in PReg regNo end and newUReg() = let val regNo = !pregCounter before pregCounter := !pregCounter + 1 val () = pregPropList := RegPropUntagged :: !pregPropList in PReg regNo end and newStackLoc size = let val regNo = !pregCounter before pregCounter := !pregCounter + 1 val () = pregPropList := RegPropStack size :: !pregPropList in StackLoc{size=size, rno=regNo} end and newMergeReg() = let val regNo = !pregCounter before pregCounter := !pregCounter + 1 val () = pregPropList := RegPropMultiple :: !pregPropList in PReg regNo end datatype locationValue = NoLocation | PregLocation of preg | ContainerLocation of { container: stackLocn, stackOffset: int } val locToPregArray = Array.array(localCount, NoLocation) val labelCounter = ref 1 (* Start at 1. Zero is used for the root. *) fun newLabel() = !labelCounter before labelCounter := !labelCounter + 1 val ccRefCounter = ref 0 fun newCCRef() = CcRef(!ccRefCounter) before ccRefCounter := !ccRefCounter + 1 fun constantAsArgument value = if isShort value then IntegerConstant(tag(Word.toLargeIntX(toShort value))) else AddressConstant value (* Create the branch condition from the test, isSigned and jumpOn values. (In)equality tests are the same for signed and unsigned values. *) local open BuiltIns in fun testAsBranch(TestEqual, _, true) = JE | testAsBranch(TestEqual, _, false) = JNE (* Signed tests *) | testAsBranch(TestLess, true, true) = JL | testAsBranch(TestLess, true, false) = JGE | testAsBranch(TestLessEqual, true, true) = JLE | testAsBranch(TestLessEqual, true, false) = JG | testAsBranch(TestGreater, true, true) = JG | testAsBranch(TestGreater, true, false) = JLE | testAsBranch(TestGreaterEqual, true, true) = JGE | testAsBranch(TestGreaterEqual, true, false) = JL (* Unsigned tests *) | testAsBranch(TestLess, false, true) = JB | testAsBranch(TestLess, false, false) = JNB | testAsBranch(TestLessEqual, false, true) = JNA | testAsBranch(TestLessEqual, false, false) = JA | testAsBranch(TestGreater, false, true) = JA | testAsBranch(TestGreater, false, false) = JNA | testAsBranch(TestGreaterEqual, false, true) = JNB | testAsBranch(TestGreaterEqual, false, false) = JB | testAsBranch(TestUnordered, _, _) = raise InternalError "TestUnordered" (* Switch the direction of a test if we turn c op x into x op c. *) fun leftRightTest TestEqual = TestEqual | leftRightTest TestLess = TestGreater | leftRightTest TestLessEqual = TestGreaterEqual | leftRightTest TestGreater = TestLess | leftRightTest TestGreaterEqual = TestLessEqual | leftRightTest TestUnordered = TestUnordered end (* Overflow check. This raises Overflow if the overflow bit is set in the cc. This generates a single block for the function unless there is a handler. As well as reducing the size of the code this also means that overflow checks are generally JO instructions to the end of the code. Since the default branch prediction is not to take forward jumps this should improve prefetching on the normal, non-overflow, path. *) fun checkOverflow ({currHandler=NONE, overflowBlock=ref(SOME overFlowLab), ...}) ccRef = (* It's already been set and there's no surrounding handler - use this. *) let val noOverflowLab = newLabel() in [ BlockFlow(Conditional{ ccRef=ccRef, condition=JO, trueJump=overFlowLab, falseJump=noOverflowLab }), BlockLabel noOverflowLab ] end | checkOverflow ({currHandler=NONE, overflowBlock, ...}) ccRef = let (* *) val overFlowLab = newLabel() and noOverflowLab = newLabel() val packetReg = newPReg() val () = overflowBlock := SOME overFlowLab in [ BlockFlow(Conditional{ ccRef=ccRef, condition=JO, trueJump=overFlowLab, falseJump=noOverflowLab }), BlockLabel overFlowLab, BlockSimple(LoadArgument{source=AddressConstant(toMachineWord(Overflow)), dest=packetReg, kind=movePolyWord}), BlockExit(RaiseExceptionPacket{packetReg=packetReg}), BlockLabel noOverflowLab ] end | checkOverflow ({currHandler=SOME h, ...}) ccRef = let val overFlowLab = newLabel() and noOverflowLab = newLabel() val packetReg = newPReg() in [ BlockFlow(Conditional{ ccRef=ccRef, condition=JO, trueJump=overFlowLab, falseJump=noOverflowLab }), BlockLabel overFlowLab, BlockSimple(LoadArgument{source=AddressConstant(toMachineWord(Overflow)), dest=packetReg, kind=movePolyWord}), BlockRaiseAndHandle(RaiseExceptionPacket{packetReg=packetReg}, h), BlockLabel noOverflowLab ] end fun setAndRestoreRounding (rndMode, doWithRounding) = let open IEEEReal val savedRnd = newUReg() and setRnd = newUReg() in case fpMode of FPModeX87 => [BlockSimple(GetX87ControlReg{dest=savedRnd})] @ (* Set the appropriate bits in the control word. *) (case rndMode of TO_NEAREST => (* The bits need to be zero - just mask them. *) [BlockSimple( ArithmeticFunction{oper=AND, resultReg=setRnd, operand1=savedRnd, operand2=IntegerConstant 0xf3ff, ccRef=newCCRef(), opSize=OpSize32})] | TO_NEGINF => let val wrk = newUReg() in (* Mask the bits and set to 01 *) [BlockSimple( ArithmeticFunction{oper=AND, resultReg=wrk, operand1=savedRnd, operand2=IntegerConstant 0xf3ff, ccRef=newCCRef(), opSize=OpSize32}), BlockSimple( ArithmeticFunction{oper=OR, resultReg=setRnd, operand1=savedRnd, operand2=IntegerConstant 0x400, ccRef=newCCRef(), opSize=OpSize32})] end | TO_POSINF => let val wrk = newUReg() in (* Mask the bits and set to 10 *) [BlockSimple( ArithmeticFunction{oper=AND, resultReg=wrk, operand1=savedRnd, operand2=IntegerConstant 0xf3ff, ccRef=newCCRef(), opSize=OpSize32}), BlockSimple( ArithmeticFunction{oper=OR, resultReg=setRnd, operand1=savedRnd, operand2=IntegerConstant 0x800, ccRef=newCCRef(), opSize=OpSize32})] end | TO_ZERO => (* The bits need to be one - just set them. *) [BlockSimple( ArithmeticFunction{oper=OR, resultReg=setRnd, operand1=savedRnd, operand2=IntegerConstant 0xc00, ccRef=newCCRef(), opSize=OpSize32})]) @ [BlockSimple(SetX87ControlReg{source=setRnd})] @ doWithRounding() @ (* Restore the original rounding. *) [BlockSimple(SetX87ControlReg{source=savedRnd})] | FPModeSSE2 => [BlockSimple(GetSSE2ControlReg{dest=savedRnd})] @ (* Set the appropriate bits in the control word. *) (case rndMode of TO_NEAREST => (* The bits need to be zero - just mask them. *) [BlockSimple( ArithmeticFunction{oper=AND, resultReg=setRnd, operand1=savedRnd, operand2=IntegerConstant 0xffff9fff, ccRef=newCCRef(), opSize=OpSize32})] | TO_NEGINF => let val wrk = newUReg() in (* Mask the bits and set to 01 *) [BlockSimple( ArithmeticFunction{oper=AND, resultReg=wrk, operand1=savedRnd, operand2=IntegerConstant 0xffff9fff, ccRef=newCCRef(), opSize=OpSize32}), BlockSimple( ArithmeticFunction{oper=OR, resultReg=setRnd, operand1=savedRnd, operand2=IntegerConstant 0x2000, ccRef=newCCRef(), opSize=OpSize32})] end | TO_POSINF => let val wrk = newUReg() in (* Mask the bits and set to 10 *) [BlockSimple( ArithmeticFunction{oper=AND, resultReg=wrk, operand1=savedRnd, operand2=IntegerConstant 0xffff9fff, ccRef=newCCRef(), opSize=OpSize32}), BlockSimple( ArithmeticFunction{oper=OR, resultReg=setRnd, operand1=savedRnd, operand2=IntegerConstant 0x4000, ccRef=newCCRef(), opSize=OpSize32})] end | TO_ZERO => (* The bits need to be one - just set them. *) [BlockSimple( ArithmeticFunction{oper=OR, resultReg=setRnd, operand1=savedRnd, operand2=IntegerConstant 0x6000, ccRef=newCCRef(), opSize=OpSize32})]) @ [BlockSimple(SetSSE2ControlReg{source=setRnd})] @ doWithRounding() @ [BlockSimple(SetSSE2ControlReg{source=savedRnd})] end (* Put a floating point value into a box or tag it so the value can be held in a general register. *) fun boxOrTagReal(srcReg, destReg, precision) = if precision = BuiltIns.PrecDouble orelse wordSize <> 0w8 then let open BuiltIns val boxFloat = case (fpMode, precision) of (FPModeX87, PrecDouble) => BoxX87Double | (FPModeX87, PrecSingle) => BoxX87Float | (FPModeSSE2, PrecDouble) => BoxSSE2Double | (FPModeSSE2, PrecSingle) => BoxSSE2Float in [BlockSimple(BoxValue{boxKind=boxFloat, source=srcReg, dest=destReg, saveRegs=[]})] end else [BlockSimple(TagFloat{source=srcReg, dest=destReg})] (* Indicate that the base address is actually an object index where appropriate. *) val memIndexOrObject = case targetArch of ObjectId32Bit => ObjectIndex | _ => NoMemIndex (* Generally we have an offset in words and no index register. *) fun wordOffsetAddress(offset, baseReg: preg): argument = MemoryLocation{offset=offset*Word.toInt wordSize, base=baseReg, index=memIndexOrObject, cache=NONE} (* The large-word operations all work on the value within the box pointed at by the register. We generate all large-word operations using this even where the X86 instruction requires a register. This allows the next level to optimise cases of cascaded instructions and avoid creating boxes for intermediate values. *) fun wordAt reg = wordOffsetAddress(0, reg) val returnAddressEntry = newStackLoc 1 datatype argLoc = ArgInReg of { realReg: reg, argReg: preg } | ArgOnStack of { stackOffset: int, stackReg: stackLocn } (* Pseudo-regs for the result, the closure and the args that were passed in real regs. *) val resultTarget = newPReg() val closureRegAddr = newPReg() (* Create a map for the arguments indicating their register or stack location. *) local (* Select the appropriate argument register depending on the argument type. *) fun argTypesToArgEntries([], _, _, _) = ([], [], [], []) | argTypesToArgEntries(DoubleFloatType :: tl, gRegs, fpReg :: fpRegs, n) = let val (argTypes, argCode, argRegs, stackArgs) = argTypesToArgEntries(tl, gRegs, fpRegs, n-1) val pRegArg = newPReg() and uRegArg = newUReg() in (ArgInReg{realReg=fpReg, argReg=pRegArg} :: argTypes, boxOrTagReal(uRegArg, pRegArg, BuiltIns.PrecDouble) @ argCode, (uRegArg, fpReg) :: argRegs, stackArgs) end | argTypesToArgEntries(SingleFloatType :: tl, gRegs, fpReg :: fpRegs, n) = let val (argTypes, argCode, argRegs, stackArgs) = argTypesToArgEntries(tl, gRegs, fpRegs, n-1) val pRegArg = newPReg() and uRegArg = newUReg() in (ArgInReg{realReg=fpReg, argReg=pRegArg} :: argTypes, boxOrTagReal(uRegArg, pRegArg, BuiltIns.PrecSingle) @ argCode, (uRegArg, fpReg) :: argRegs, stackArgs) end | argTypesToArgEntries(_ :: tl, gReg :: gRegs, fpRegs, n) = (* This deals with general arguments but also with extra floating point arguments. They are boxed as usual. *) let val (argTypes, argCode, argRegs, stackArgs) = argTypesToArgEntries(tl, gRegs, fpRegs, n-1) val argReg=newPReg() in (ArgInReg{realReg=gReg, argReg=argReg} :: argTypes, argCode, (argReg, gReg) :: argRegs, stackArgs) end | argTypesToArgEntries(_ :: tl, [], fpRegs, n) = let val (argTypes, argCode, argRegs, stackArgs) = argTypesToArgEntries(tl, [], fpRegs, n-1) val stackLoc = newStackLoc 1 in (ArgOnStack {stackOffset=n, stackReg = stackLoc } :: argTypes, argCode, argRegs, stackLoc :: stackArgs) end val (argEntries, argCode, argRegs, stackArguments) = argTypesToArgEntries(argTypes, generalArgRegs, floatingPtArgRegs, List.length argTypes) val clReg = case closure of [] => [] | _ => [(closureRegAddr, GenReg edx)] in val argumentVector = Vector.fromList argEntries (* Start code for the function. *) val beginInstructions = argCode @ [BlockBegin{regArgs=clReg @ argRegs, stackArgs=stackArguments @ [returnAddressEntry]}] (* The number of arguments on the stack. Needed in return instrs and tail calls. *) val currentStackArgs = List.length stackArguments end (* The return instruction. This can be added on to various tails but there is always one at the end anyway. *) fun returnInstruction({stackPtr, ...}, target, tailCode) = let val (returnCode, resReg) = case fnResultType of GeneralType => ([], target) | DoubleFloatType => let val resReg = newUReg() in ([BlockSimple(LoadArgument{source=wordAt target, dest=resReg, kind=MoveDouble})], resReg) end | SingleFloatType => let val resReg = newUReg() val unpack = if wordSize = 0w8 then BlockSimple(UntagFloat{source=RegisterArgument target, dest=resReg, cache=NONE}) else BlockSimple(LoadArgument{source=wordAt target, dest=resReg, kind=MoveFloat}) in ([unpack], resReg) end in BlockExit(ReturnResultFromFunction{resultReg=resReg, realReg=resultReg fnResultType, numStackArgs=currentStackArgs}) :: returnCode @ (if stackPtr <> 0 then BlockSimple(ResetStackPtr{numWords=stackPtr, preserveCC=false}) :: tailCode else tailCode) end (* This controls what codeAsArgument returns. Different instructions have different requirements. If an option is set to false the value is instead loaded into a new preg. "const32s" means that it will fit into 32-bits. Any constant satisfies that on X86/32 but on the X86/64 we don't allow addresses because we can't be sure whether they will fit or not. *) type allowedArgument = { anyConstant: bool, const32s: bool, memAddr: bool, existingPreg: bool } val allowInMemMove = (* We can move a 32-bit constant into memory but not a long constant. *) { anyConstant=false, const32s=true, memAddr=false, existingPreg=true } and allowInPReg = { anyConstant=false, const32s=false, memAddr=false, existingPreg=true } (* AllowDefer can be used to ensure that any side-effects are done before something else but otherwise we only evaluate afterwards. *) and allowDefer = { anyConstant=true, const32s=true, memAddr=true, existingPreg=true } datatype destination = SpecificPReg of preg | NoResult | Allowed of allowedArgument (* Context type. *) type context = { loopArgs: (preg list * int * int) option, stackPtr: int, currHandler: int option, overflowBlock: int option ref } (* If a preg has been provided, use that, otherwise generate a new one. *) fun asTarget(SpecificPReg preg) = preg | asTarget NoResult = newPReg() | asTarget(Allowed _) = newPReg() fun moveIfNotAllowed(NoResult, code, arg) = (code, arg, false) | moveIfNotAllowed(Allowed{anyConstant=true, ...}, code, arg as AddressConstant _) = (code, arg, false) | moveIfNotAllowed(Allowed{anyConstant=true, ...}, code, arg as IntegerConstant _) = (code, arg, false) | moveIfNotAllowed(dest as Allowed{const32s=true, ...}, code, arg as IntegerConstant value) = (* This is allowed if the value is within 32-bits *) if is32bit value then (code, arg, false) else moveToTarget(dest, code, arg) | moveIfNotAllowed(dest as Allowed{const32s=true, ...}, code, arg as AddressConstant _) = if targetArch = Native32Bit then (code, arg, false) (* We can store the address directly *) else moveToTarget(dest, code, arg) | moveIfNotAllowed(Allowed{existingPreg=true, ...}, code, arg as RegisterArgument(PReg _)) = (code, arg, false) | moveIfNotAllowed(Allowed{memAddr=true, ...}, code, arg as MemoryLocation _) = (code, arg, false) | moveIfNotAllowed(dest, code, arg) = moveToTarget(dest, code, arg) and moveToTarget(dest, code, arg) = let val target = asTarget dest val moveSize = case arg of AddressConstant _ => movePolyWord | MemoryLocation _ => movePolyWord | _ => moveNativeWord in (code @ [BlockSimple(LoadArgument{source=arg, dest=target, kind=moveSize})], RegisterArgument target, false) end (* Create a bool result from a test by returning true or false. *) fun makeBoolResultRev(condition, ccRef, target, testCode) = let val trueLab = newLabel() and falseLab = newLabel() and mergeLab = newLabel() val mergeReg = newMergeReg() in BlockSimple(LoadArgument{dest=target, source=RegisterArgument mergeReg, kind=Move32Bit}) :: BlockLabel mergeLab :: BlockFlow(Unconditional mergeLab) :: BlockSimple(LoadArgument{dest=mergeReg, source=IntegerConstant(tag 0), kind=Move32Bit}) :: BlockLabel falseLab :: BlockFlow(Unconditional mergeLab) :: BlockSimple(LoadArgument{dest=mergeReg, source=IntegerConstant(tag 1), kind=Move32Bit}) :: BlockLabel trueLab :: BlockFlow(Conditional{ ccRef=ccRef, condition=condition, trueJump=trueLab, falseJump=falseLab }) :: testCode end fun moveIfNotAllowedRev(NoResult, code, arg) = (code, arg, false) | moveIfNotAllowedRev(Allowed{anyConstant=true, ...}, code, arg as AddressConstant _) = (code, arg, false) | moveIfNotAllowedRev(Allowed{anyConstant=true, ...}, code, arg as IntegerConstant _) = (code, arg, false) | moveIfNotAllowedRev(dest as Allowed{const32s=true, ...}, code, arg as IntegerConstant value) = (* This is allowed if the value is within 32-bits *) if is32bit value then (code, arg, false) else moveToTargetRev(dest, code, arg) | moveIfNotAllowedRev(dest as Allowed{const32s=true, ...}, code, arg as AddressConstant _) = if targetArch = Native32Bit then (code, arg, false) else moveToTargetRev(dest, code, arg) | moveIfNotAllowedRev(Allowed{existingPreg=true, ...}, code, arg as RegisterArgument(PReg _)) = (code, arg, false) | moveIfNotAllowedRev(Allowed{memAddr=true, ...}, code, arg as MemoryLocation _) = (code, arg, false) | moveIfNotAllowedRev(dest, code, arg) = moveToTargetRev(dest, code, arg) and moveToTargetRev(dest, code, arg) = let val target = asTarget dest val moveSize = case arg of AddressConstant _ => movePolyWord | MemoryLocation _ => movePolyWord | _ => moveNativeWord in (BlockSimple(LoadArgument{source=arg, dest=target, kind=moveSize}) :: code, RegisterArgument target, false) end (* Use a move if there's no offset or index. We could use an add if there's no index. *) and loadAddress{base, offset=0, index=NoMemIndex, dest} = LoadArgument{source=RegisterArgument base, dest=dest, kind=movePolyWord} | loadAddress{base, offset, index, dest} = LoadEffectiveAddress{base=SOME base, offset=offset, dest=dest, index=index, opSize=nativeWordOpSize} and codeToICodeTarget(instr, context: context, isTail, target) = (* This is really for backwards compatibility. *) let val (code, _, _) = codeToICode(instr, context, isTail, SpecificPReg target) in code end and codeToPReg(instr, context) = let (* Many instructions require an argument in a register. If it's already in a register use that rather than creating a new one. *) val (code, result, _) = codeToICode(instr, context, false, Allowed allowInPReg) val preg = case result of RegisterArgument pr => pr | _ => raise InternalError "codeToPReg" in (code, preg) end and codeToPRegRev(instr, context, tailCode) = let (* Many instructions require an argument in a register. If it's already in a register use that rather than creating a new one. *) val (code, result, _) = codeToICodeRev(instr, context, false, Allowed allowInPReg, tailCode) val preg = case result of RegisterArgument pr => pr | _ => raise InternalError "codeToPRegRev" in (code, preg) end and codeToICode(instr, context, isTail, destination) = let val (code, dest, haveExited) = codeToICodeRev(instr, context, isTail, destination, []) in (List.rev code, dest, haveExited) end (* Main function to turn the codetree into ICode. Optimisation is generally left to later passes. This does detect tail recursion. This builds the result up in reverse order. There was an allocation hotspot in loadFields in the BICTuple case which was eliminated by building the list in reverse and then reversing the result. It seems better to build the list in reverse generally but for the moment there are too many special cases to do everything. *) and codeToICodeRev(BICNewenv (bindings, exp), context: context as {stackPtr=initialSp, ...} , isTail, destination, tailCode) = let (* Process a list of bindings. We need to accumulate the space used by any containers and reset the stack pointer at the end if necessary. *) fun doBindings([], context, tailCode) = (tailCode, context) | doBindings(BICDeclar{value=BICExtract(BICLoadLocal l), addr, ...} :: decs, context, tailCode) = let (* Giving a new name to an existing entry. This should have been removed at a higher level but it doesn't always seem to be. In particular we must treat this specially if it's a container. *) val original = Array.sub(locToPregArray, l) val () = Array.update(locToPregArray, addr, original) in doBindings(decs, context, tailCode) end | doBindings(BICDeclar{value, addr, ...} :: decs, context, tailCode) = let val (code, dest) = codeToPRegRev(value, context, tailCode) val () = Array.update(locToPregArray, addr, PregLocation dest) in doBindings(decs, context, code) end | doBindings(BICRecDecs [{lambda, addr, ...}] :: decs, context, tailCode) = (* We shouldn't have single entries in RecDecs but it seems to occur at the moment. *) let val dest = newPReg() val (code, _, _) = codeToICodeRev(BICLambda lambda, context, false, SpecificPReg dest, tailCode) val () = Array.update(locToPregArray, addr, PregLocation dest) in doBindings(decs, context, code) end | doBindings(BICRecDecs recDecs :: decs, context, tailCode) = let val destRegs = map (fn _ => newPReg()) recDecs (* First build the closures as mutable cells containing zeros. Set the entry in the address table to the register containing the address. *) fun makeClosure({lambda={closure, ...}, addr, ...}, dest, c) = let val () = Array.update(locToPregArray, addr, PregLocation dest) val sizeClosure = List.length closure + (if targetArch = ObjectId32Bit then 2 else 1) open Address fun clear n = if n = sizeClosure then [BlockSimple(AllocateMemoryOperation{size=sizeClosure, flags=if targetArch = ObjectId32Bit then Word8.orb(F_mutable, F_closure) else F_mutable, dest=dest, saveRegs=[]})] else (clear (n+1) @ [BlockSimple( StoreArgument{source=IntegerConstant(tag 0), base=dest, offset=n*Word.toInt wordSize, index=memIndexOrObject, kind=movePolyWord, isMutable=false})]) in c @ clear 0 @ [BlockSimple InitialisationComplete] end val allocClosures = ListPair.foldlEq makeClosure [] (recDecs, destRegs) fun setClosure({lambda as {closure, ...}, ...}, dest, l) = let val clResult = makeConstantClosure() val () = codeFunctionToX86(lambda, debugSwitches, clResult) (* Basically the same as tuple except we load the address of the closure we've made. *) fun loadFields([], _) = [] | loadFields(f :: rest, n) = let val (code, source, _) = codeToICode(BICExtract f, context, false, Allowed allowInMemMove) val storeValue = [BlockSimple(StoreArgument{ source=source, base=dest, offset=n*Word.toInt wordSize, index=memIndexOrObject, kind=movePolyWord, isMutable=false })] in code @ storeValue @ loadFields(rest, n+1) end val setCodeAddress = if targetArch = ObjectId32Bit then let (* We can't get the code address until run time. *) val codeReg = newUReg() val closureReg = newPReg() in map BlockSimple [ LoadArgument{ source=AddressConstant(toMachineWord clResult), dest=closureReg, kind=movePolyWord}, LoadArgument{ source=MemoryLocation{offset=0, base=closureReg, index=ObjectIndex, cache=NONE}, dest=codeReg, kind=Move64Bit}, StoreArgument{ source=RegisterArgument codeReg, offset=0, base=dest, index=ObjectIndex, kind=moveNativeWord, isMutable=false} ] end else let val codeAddr = codeAddressFromClosure clResult val (code, source, _) = moveIfNotAllowed(Allowed allowInMemMove, [], AddressConstant codeAddr) in code @ [BlockSimple( StoreArgument{ source=source, base=dest, offset=0, index=NoMemIndex, kind=movePolyWord, isMutable=false })] end val setFields = setCodeAddress @ loadFields(closure, if targetArch = ObjectId32Bit then 2 else 1) in l @ setFields @ [BlockSimple(LockMutable{addr=dest})] end val setClosures = ListPair.foldlEq setClosure [] (recDecs, destRegs) val code = List.rev(allocClosures @ setClosures) in doBindings(decs, context, code @ tailCode) end | doBindings(BICNullBinding exp :: decs, context, tailCode) = let val (code, _, _) = codeToICodeRev(exp, context, false, NoResult, tailCode) (* And discard result. *) in doBindings(decs, context, code) end | doBindings(BICDecContainer{ addr, size } :: decs, {loopArgs, stackPtr, currHandler, overflowBlock}, tailCode) = let val containerReg = newStackLoc size val () = Array.update(locToPregArray, addr, ContainerLocation{container=containerReg, stackOffset=stackPtr+size}) in doBindings(decs, {loopArgs=loopArgs, stackPtr=stackPtr+size, currHandler=currHandler, overflowBlock=overflowBlock}, BlockSimple(ReserveContainer{size=size, container=containerReg}) :: tailCode) end val (codeBindings, resContext as {stackPtr=finalSp, ...}) = doBindings(bindings, context, tailCode) (* If we have had a container we'll need to reset the stack *) in if initialSp <> finalSp then let val _ = finalSp >= initialSp orelse raise InternalError "codeToICode - stack ptr" val bodyReg = newPReg() and resultReg = asTarget destination val (codeExp, result, haveExited) = codeToICodeRev(exp, resContext, isTail, SpecificPReg bodyReg, codeBindings) val afterAdjustSp = if haveExited then codeExp else BlockSimple(LoadArgument{source=result, dest=resultReg, kind=movePolyWord}) :: BlockSimple(ResetStackPtr{numWords=finalSp-initialSp, preserveCC=false}) :: codeExp in (afterAdjustSp, RegisterArgument resultReg, haveExited) end else codeToICodeRev(exp, resContext, isTail, destination, codeBindings) end | codeToICodeRev(BICConstnt(value, _), _, _, destination, tailCode) = moveIfNotAllowedRev(destination, tailCode, constantAsArgument value) | codeToICodeRev(BICExtract(BICLoadLocal l), {stackPtr, ...}, _, destination, tailCode) = ( case Array.sub(locToPregArray, l) of NoLocation => raise InternalError "codeToICodeRev - local unset" | PregLocation preg => moveIfNotAllowedRev(destination, tailCode, RegisterArgument preg) | ContainerLocation{container, stackOffset} => (* This always returns a ContainerAddr whatever the "allowed". *) (tailCode, ContainerAddr{container=container, stackOffset=stackPtr-stackOffset}, false) ) | codeToICodeRev(BICExtract(BICLoadArgument a), {stackPtr, ...}, _, destination, tailCode) = ( case Vector.sub(argumentVector, a) of ArgInReg{argReg, ...} => (* It was originally in a register. It's now in a preg. *) moveIfNotAllowedRev(destination, tailCode, RegisterArgument argReg) | ArgOnStack{stackOffset, stackReg} => (* Pushed before call. *) let val target = asTarget destination in (BlockSimple(LoadArgument{ source=StackLocation{wordOffset=stackOffset+stackPtr, container=stackReg, field=0, cache=NONE}, dest=target, kind=moveNativeWord}) :: tailCode, RegisterArgument target, false) end ) | codeToICodeRev(BICExtract(BICLoadClosure c), _, _, destination, tailCode) = let (* Add the number of words for the code address. This is 1 in native but 2 in 32-in-64. *) val offset = case targetArch of ObjectId32Bit => c+2 | _ => c+1 in if c >= List.length closure then raise InternalError "BICExtract: closure" else (); (* N.B. We need to add one to the closure entry because zero is the code address. *) moveIfNotAllowedRev(destination, tailCode, wordOffsetAddress(offset, closureRegAddr)) end | codeToICodeRev(BICExtract BICLoadRecursive, _, _, destination, tailCode) = (* If the closure is empty we must use the constant. We can't guarantee that the caller will actually load the closure register if it knows the closure is empty. *) moveIfNotAllowedRev(destination, tailCode, case closure of [] => AddressConstant(closureAsAddress resultClosure) | _ => RegisterArgument closureRegAddr) | codeToICodeRev(BICField{base, offset}, context, _, destination, tailCode) = let val (codeBase, baseEntry, _) = codeToICodeRev(base, context, false, Allowed allowInPReg, tailCode) in (* This should not be used with a container. *) case baseEntry of RegisterArgument baseR => moveIfNotAllowedRev(destination, codeBase, wordOffsetAddress(offset, baseR)) | _ => raise InternalError "codeToICodeRev-BICField" end | codeToICodeRev(BICLoadContainer{base, offset}, context, _, destination, tailCode) = let val (codeBase, baseEntry, _) = codeToICodeRev(base, context, false, Allowed allowInPReg, tailCode) val multiplier = Word.toInt(nativeWordSize div wordSize) in (* If this is a local container we extract the field. *) case baseEntry of RegisterArgument baseR => moveIfNotAllowedRev(destination, codeBase, wordOffsetAddress(offset*multiplier, baseR)) | ContainerAddr{container, stackOffset} => let val target = asTarget destination val finalOffset = stackOffset+offset val _ = finalOffset >= 0 orelse raise InternalError "offset" in (BlockSimple(LoadArgument{ source=StackLocation{wordOffset=finalOffset, container=container, field=offset, cache=NONE}, dest=target, kind=movePolyWord}) :: tailCode, RegisterArgument target, false) end | _ => raise InternalError "codeToICodeRev-BICField" end | codeToICodeRev(BICEval{function, argList, resultType, ...}, context as { currHandler, ...}, isTail, destination, tailCode) = let val target = asTarget destination (* Create pregs for the closure and each argument. *) val clPReg = newPReg() (* If we have a constant closure we can go directly to the entry point. If the closure is a single word we don't need to load the closure register. *) val (functionCode, closureEntry, callKind) = case function of BICConstnt(addr, _) => let val addrAsAddr = toAddress addr (* If this is a closure we're still compiling we can't get the code address. However if this is directly recursive we can use the recursive convention. *) in if wordEq(closureAsAddress resultClosure, addr) then (tailCode, [], Recursive) else if flags addrAsAddr <> Address.F_words andalso flags addrAsAddr <> Address.F_closure then (BlockSimple(LoadArgument{source=AddressConstant addr, dest=clPReg, kind=movePolyWord}) :: tailCode, [(RegisterArgument clPReg, GenReg edx)], FullCall) else if targetArch = ObjectId32Bit then (* We can't actually load the code address here. *) let val addrLength = length addrAsAddr val _ = addrLength >= 0w1 orelse raise InternalError "BICEval address" val _ = flags addrAsAddr = Address.F_closure orelse raise InternalError "BICEval address not a closure" in if addrLength = 0w2 then (tailCode, [], ConstantCode addr) else (BlockSimple(LoadArgument{source=AddressConstant addr, dest=clPReg, kind=movePolyWord}) :: tailCode, [(RegisterArgument clPReg, GenReg edx)], ConstantCode addr) end else (* Native 32 or 64-bits. *) let val addrLength = length addrAsAddr val _ = addrLength >= 0w1 orelse raise InternalError "BICEval address" val codeAddr = loadWord(addrAsAddr, 0w0) val _ = isCode (toAddress codeAddr) orelse raise InternalError "BICEval address not code" in if addrLength = 0w1 then (tailCode, [], ConstantCode codeAddr) else (BlockSimple(LoadArgument{source=AddressConstant addr, dest=clPReg, kind=movePolyWord}) :: tailCode, [(RegisterArgument clPReg, GenReg edx)], ConstantCode codeAddr) end end | BICExtract BICLoadRecursive => ( (* If the closure is empty we don't need to load rdx *) case closure of [] => (tailCode, [], Recursive) | _ => (BlockSimple(LoadArgument {source=RegisterArgument closureRegAddr, dest=clPReg, kind=movePolyWord}) :: tailCode, [(RegisterArgument clPReg, GenReg edx)], Recursive) ) | function => (* General case. *) (#1 (codeToICodeRev(function, context, false, SpecificPReg clPReg, tailCode)), [(RegisterArgument clPReg, GenReg edx)], FullCall) (* Optimise arguments. We have to be careful with tail-recursive functions because they need to save any stack arguments that could be overwritten. This is complicated because we overwrite the stack before loading the register arguments. In some circumstances it could be safe but for the moment leave it. This should be safe in the new code-transform but not the old codeICode. Currently we don't allow memory arguments at all. There's the potential for problems later. Memory arguments could possibly lead to aliasing of the stack if the memory actually refers to a container on the stack. That would mess up the code that ensures that stack arguments are stored in the right order. *) (* We don't allow long constants in stack arguments to a tail-recursive call because we may use a memory move to set them. We also don't allow them in 32-in-64 because we can't push an address constant. *) val allowInStackArg = Allowed {anyConstant=not isTail andalso targetArch <> ObjectId32Bit, const32s=true, memAddr=false, existingPreg=not isTail } and allowInRegArg = Allowed {anyConstant=true, const32s=true, memAddr=false, existingPreg=not isTail } (* Load the first arguments into registers and the rest to the stack. *) fun loadArgs ([], _, _, tailCode) = (tailCode, [], []) | loadArgs ((arg, DoubleFloatType) :: args, gRegs, fpReg :: fpRegs, tailCode) = let (* Floating point register argument. *) val (c, r) = codeToPRegRev(arg, context, tailCode) val r1 = newUReg() val c1 = BlockSimple(LoadArgument{source=wordAt r, dest=r1, kind=MoveDouble}) :: c val (code, regArgs, stackArgs) = loadArgs(args, gRegs, fpRegs, c1) in (code, (RegisterArgument r1, fpReg) :: regArgs, stackArgs) end | loadArgs ((arg, SingleFloatType) :: args, gRegs, fpReg :: fpRegs, tailCode) = let (* Floating point register argument. *) val (c, r) = codeToPRegRev(arg, context, tailCode) val r1 = newUReg() val c1 = if wordSize = 0w8 then BlockSimple(UntagFloat{source=RegisterArgument r, dest=r1, cache=NONE}) :: c else BlockSimple(LoadArgument{source=wordAt r, dest=r1, kind=MoveFloat}) :: c val (code, regArgs, stackArgs) = loadArgs(args, gRegs, fpRegs, c1) in (code, (RegisterArgument r1, fpReg) :: regArgs, stackArgs) end | loadArgs ((arg, _) :: args, gReg::gRegs, fpRegs, tailCode) = let (* General register argument. *) val (c, r, _) = codeToICodeRev(arg, context, false, allowInRegArg, tailCode) val (code, regArgs, stackArgs) = loadArgs(args, gRegs, fpRegs, c) in (code, (r, gReg) :: regArgs, stackArgs) end | loadArgs ((arg, _) :: args, [], fpRegs, tailCode) = let (* Stack argument. *) val (c, r, _) = codeToICodeRev(arg, context, false, allowInStackArg, tailCode) val (code, regArgs, stackArgs) = loadArgs(args, [], fpRegs, c) in (code, regArgs, r :: stackArgs) end val (codeArgs, regArgs, stackArgs) = loadArgs(argList, generalArgRegs, floatingPtArgRegs, functionCode) (* If this is at the end of the function and the result types are the same we can use a tail-recursive call. *) val tailCall = isTail andalso resultType = fnResultType val callCode = if tailCall then let val {stackPtr, ...} = context (* The number of arguments currently on the stack. *) val currentStackArgCount = currentStackArgs val newStackArgCount = List.length stackArgs (* The offset of the first argument or the return address if there are no stack arguments. N.B. We actually have currentStackArgCount+1 items on the stack including the return address. Offsets can be negative. *) val stackOffset = stackPtr val firstArgumentAddr = currentStackArgCount fun makeStackArgs([], _) = [] | makeStackArgs(arg::args, offset) = {src=arg, stack=offset} :: makeStackArgs(args, offset-1) val stackArgs = makeStackArgs(stackArgs, firstArgumentAddr) (* The stack adjustment needed to compensate for any items that have been pushed and the differences in the number of arguments. May be positive or negative. This is also the destination address of the return address so when we enter the new function the return address will be the first item on the stack. *) val stackAdjust = firstArgumentAddr - newStackArgCount (* Add an entry for the return address to the stack arguments. *) val returnEntry = {src=StackLocation{wordOffset=stackPtr, container=returnAddressEntry, field=0, cache=NONE}, stack=stackAdjust} (* Because we're storing into the stack we may be overwriting values we want. If the source of any value is a stack location below the current stack pointer we load it except in the special case where the destination is the same as the source (which is often the case with the return address). *) local fun loadArgs [] = ([], []) | loadArgs (arg :: rest) = let val (loadCode, loadedArgs) = loadArgs rest in case arg of {src as StackLocation{wordOffset, ...}, stack} => if wordOffset = stack+stackOffset (* Same location *) orelse stack+stackOffset < 0 (* Storing above current top of stack *) orelse stackOffset+wordOffset > ~ stackAdjust (* Above the last argument *) then (loadCode, arg :: loadedArgs) else let val preg = newPReg() in (BlockSimple(LoadArgument{source=src, dest=preg, kind=moveNativeWord}) :: loadCode, {src=RegisterArgument preg, stack=stack} :: loadedArgs) end | _ => (loadCode, arg :: loadedArgs) end in val (loadStackArgs, loadedStackArgs) = loadArgs(returnEntry :: stackArgs) end in BlockExit(TailRecursiveCall{regArgs=closureEntry @ regArgs, stackArgs=loadedStackArgs, stackAdjust = stackAdjust, currStackSize=stackOffset, callKind=callKind, workReg=newPReg()}) :: loadStackArgs @ codeArgs end else let val (moveResult, resReg) = case resultType of GeneralType => ([], target) | DoubleFloatType => let val fpRegDest = newUReg() in (boxOrTagReal(fpRegDest, target, BuiltIns.PrecDouble), fpRegDest) end | SingleFloatType => let val fpRegDest = newUReg() in (boxOrTagReal(fpRegDest, target, BuiltIns.PrecSingle), fpRegDest) end val call = FunctionCall{regArgs=closureEntry @ regArgs, stackArgs=stackArgs, dest=resReg, realDest=resultReg resultType, callKind=callKind, saveRegs=[]} val callBlock = case currHandler of NONE => BlockSimple call :: codeArgs | SOME h => BlockOptionalHandle{call=call, handler=h, label=newLabel()} :: codeArgs in moveResult @ callBlock end in (callCode, RegisterArgument target, tailCall (* We've exited if this was a tail jump *)) end - | codeToICodeRev(BICGetThreadId, _, _, destination, tailCode) = + | codeToICodeRev(BICNullary{oper=BuiltIns.GetCurrentThreadId}, _, _, destination, tailCode) = (* Get the ID of the current thread. *) let val target = asTarget destination in (BlockSimple(LoadMemReg{offset=memRegThreadSelf, dest=target}) :: tailCode, RegisterArgument target, false) end + | codeToICodeRev(BICNullary{oper=BuiltIns.CheckRTSException}, { currHandler, ...}, _, _, tailCode) = + let + (* Raise an exception in ML if the last RTS call set the exception packet. *) + val haveException = newLabel() and noException = newLabel() + val ccRef = newCCRef() + val testReg = newPReg() + val raiseCode = RaiseExceptionPacket{packetReg=testReg} + val code = + BlockLabel noException :: + (case currHandler of + NONE => BlockExit raiseCode | SOME h => BlockRaiseAndHandle(raiseCode, h)) :: + BlockLabel haveException :: + BlockFlow(Conditional{ ccRef=ccRef, condition=JNE, trueJump=haveException, falseJump=noException }) :: + BlockSimple(CompareLiteral{arg1=RegisterArgument testReg, arg2=tag 0, opSize=polyWordOpSize, ccRef=ccRef}) :: + BlockSimple(LoadMemReg{offset=memRegExceptionPacket, dest=testReg}) :: + tailCode + in + (code, (* Unit result *) IntegerConstant(tag 0), false) + end + | codeToICodeRev(BICUnary instr, context, isTail, destination, tailCode) = codeToICodeUnaryRev(instr, context, isTail, destination, tailCode) | codeToICodeRev(BICBinary instr, context, isTail, destination, tailCode) = codeToICodeBinaryRev(instr, context, isTail, destination, tailCode) | codeToICodeRev(BICArbitrary{oper, shortCond, arg1, arg2, longCall}, context, _, destination, tailCode) = let val startLong = newLabel() and resultLabel = newLabel() val target = asTarget destination val condResult = newMergeReg() (* Overflow check - if there's an overflow jump to the long precision case. *) fun jumpOnOverflow ccRef = let val noOverFlow = newLabel() in [BlockFlow(Conditional{ ccRef=ccRef, condition=JO, trueJump=startLong, falseJump=noOverFlow }), BlockLabel noOverFlow] end val (longCode, _, _) = codeToICode(longCall, context, false, SpecificPReg condResult) (* We could use a tail jump here if this is a tail. *) val (code, dest, haveExited) = ( (* Test the tag bits and skip to the long case if either is clear. *) List.rev(codeConditionRev(shortCond, context, false, startLong, [])) @ (* Try evaluating as fixed precision and jump if we get an overflow. *) codeFixedPrecisionArith(oper, arg1, arg2, context, condResult, jumpOnOverflow) @ (* If we haven't had an overflow jump to the result. *) [BlockFlow(Unconditional resultLabel), (* If we need to use the full long-precision call we come here. *) BlockLabel startLong] @ longCode @ [BlockLabel resultLabel, BlockSimple(LoadArgument{source=RegisterArgument condResult, dest=target, kind=movePolyWord})], RegisterArgument target, false) in (revApp(code, tailCode), dest, haveExited) end | codeToICodeRev(BICAllocateWordMemory instr, context, isTail, destination, tailCode) = let val (code, dest, haveExited) = codeToICodeAllocate(instr, context, isTail, destination) in (revApp(code, tailCode), dest, haveExited) end | codeToICodeRev(BICLambda(lambda as { closure = [], ...}), _, _, destination, tailCode) = (* Empty closure - create a constant closure for any recursive calls. *) let val closure = makeConstantClosure() val () = codeFunctionToX86(lambda, debugSwitches, closure) (* Return the closure itself as the value. *) in moveIfNotAllowedRev(destination, tailCode, AddressConstant(closureAsAddress closure)) end | codeToICodeRev(BICLambda(lambda as { closure, ...}), context, isTail, destination, tailCode) = (* Non-empty closure. Ignore stack closure option at the moment. *) let val closureRef = makeConstantClosure() val () = codeFunctionToX86(lambda, debugSwitches, closureRef) in if targetArch = ObjectId32Bit then let val target = asTarget destination val memAddr = newPReg() fun loadFields([], n, tlCode) = let val codeReg = newUReg() val closureReg = newPReg() in (* The code address occupies the first native word but we need to extract it at run-time. We don't currently have a way to have 64-bit constants. *) BlockSimple( StoreArgument{ source=RegisterArgument codeReg, offset=0, base=memAddr, index=ObjectIndex, kind=moveNativeWord, isMutable=false}) :: BlockSimple(LoadArgument{ source=MemoryLocation{offset=0, base=closureReg, index=ObjectIndex, cache=NONE}, dest=codeReg, kind=Move64Bit}) :: BlockSimple(LoadArgument{ source=AddressConstant(toMachineWord closureRef), dest=closureReg, kind=movePolyWord}) :: BlockSimple(AllocateMemoryOperation{size=n, flags=F_closure, dest=memAddr, saveRegs=[]}) :: tlCode end | loadFields(f :: rest, n, tlCode) = let (* Defer the evaluation if possible. We may have a constant that we can't move directly but it's better to load it after the allocation otherwise we will have to push the register if we need to GC. *) val (code1, source1, _) = codeToICodeRev(BICExtract f, context, false, Allowed allowDefer, tlCode) val restAndAlloc = loadFields(rest, n+1, code1) val (code2, source, _) = moveIfNotAllowedRev(Allowed allowInMemMove, restAndAlloc, source1) val storeValue = BlockSimple(StoreArgument{ source=source, offset=n*Word.toInt wordSize, base=memAddr, index=ObjectIndex, kind=movePolyWord, isMutable=false}) in storeValue :: code2 end val code = BlockSimple InitialisationComplete :: BlockSimple(LoadArgument{source=RegisterArgument memAddr, dest=target, kind=movePolyWord}) :: loadFields(closure, 2, tailCode) in (code, RegisterArgument target, false) end (* Treat it as a tuple with the code as the first field. *) else codeToICodeRev(BICTuple(BICConstnt(codeAddressFromClosure closureRef, []) :: map BICExtract closure), context, isTail, destination, tailCode) end | codeToICodeRev(BICCond(test, thenPt, elsePt), context, isTail, NoResult, tailCode) = let (* If we don't want the result but are only evaluating for side-effects we may be able to optimise special cases. This was easier in the forward case but for now we don't bother and leave it to the lower levels. *) val startElse = newLabel() and skipElse = newLabel() val codeTest = codeConditionRev(test, context, false, startElse, tailCode) val (codeThen, _, _) = codeToICodeRev(thenPt, context, isTail, NoResult, codeTest) val (codeElse, _, _) = codeToICodeRev(elsePt, context, isTail, NoResult, BlockLabel startElse :: BlockFlow(Unconditional skipElse) :: codeThen) in (BlockLabel skipElse :: codeElse, (* Unit result *) IntegerConstant(tag 0), false) end | codeToICodeRev(BICCond(test, thenPt, elsePt), context, isTail, destination, tailCode) = let (* Because we may push the result onto the stack we have to create a new preg to hold the result and then copy that to the final result. *) (* If this is a tail each arm will exit separately and neither will return a result. *) val target = asTarget destination val condResult = newMergeReg() val thenTarget = if isTail then newPReg() else condResult val startElse = newLabel() val testCode = codeConditionRev(test, context, false, startElse, tailCode) (* Put the result in the target register. *) val (thenCode, _, thenExited) = codeToICodeRev(thenPt, context, isTail, SpecificPReg thenTarget, testCode) (* Add a jump round the else-part except that if this is a tail we return. The then-part could have exited e.g. with a raise or a loop. *) val (exitThen, thenLabel, elseTarget) = if thenExited then (thenCode, [], target (* Can use original target. *)) else if isTail then (returnInstruction(context, thenTarget, thenCode), [], newPReg()) else let val skipElse = newLabel() in (BlockFlow(Unconditional skipElse) :: thenCode, [BlockSimple(LoadArgument{source=RegisterArgument condResult, dest=target, kind=movePolyWord}), BlockLabel skipElse], condResult) end val (elseCode, _, elseExited) = codeToICodeRev(elsePt, context, isTail, SpecificPReg elseTarget, BlockLabel startElse :: exitThen) (* Add a return to the else-part if necessary so we will always exit on a tail. *) val exitElse = if isTail andalso not elseExited then returnInstruction(context, elseTarget, elseCode) else elseCode in (thenLabel @ exitElse, RegisterArgument target, isTail orelse thenExited andalso elseExited) end | codeToICodeRev(BICCase { cases, test, default, isExhaustive, firstIndex}, context, isTail, destination, tailCode) = let (* We have to create a new preg for the result in case we need to push it to the stack. *) val targetReg = newMergeReg() local val initialTestReg = newPReg() val (testCode, _, _) = codeToICodeRev(test, context, false, SpecificPReg initialTestReg, tailCode) (* Subtract the minimum value so the value we're testing is always in the range of (tagged) 0 to the maximum. It is possible to adjust the value when computing the index but that can lead to overflows during compilation if the minimum is very large or small. We can ignore overflow and allow values to wrap round. *) in val (testCode, testReg) = if firstIndex = 0w0 then (testCode, initialTestReg) else let val newTestReg = newPReg() val subtract = BlockSimple(ArithmeticFunction{oper=SUB, resultReg=newTestReg, operand1=initialTestReg, operand2=IntegerConstant(semitag(Word.toLargeInt firstIndex)), ccRef=newCCRef(), opSize=polyWordOpSize}) in (subtract :: testCode, newTestReg) end end val workReg = newPReg() (* Unless this is exhaustive we need to add a range check. *) val (rangeCheck, extraDefaults) = if isExhaustive then (testCode, []) else let val defLab1 = newLabel() val tReg1 = newPReg() val ccRef1 = newCCRef() (* Since we've subtracted any minimum we only have to check whether the value is greater (unsigned) than the maximum. *) val numberOfCases = LargeInt.fromInt(List.length cases) val continueLab = newLabel() val testCode2 = BlockLabel continueLab :: BlockFlow(Conditional{ccRef=ccRef1, condition=JNB, trueJump=defLab1, falseJump=continueLab}) :: BlockSimple(WordComparison{arg1=tReg1, arg2=IntegerConstant(tag numberOfCases), ccRef=ccRef1, opSize=polyWordOpSize}) :: BlockSimple(LoadArgument {source=RegisterArgument testReg, dest=tReg1, kind=movePolyWord}) :: testCode in (testCode2, [defLab1]) end (* Make a label for each item in the list. *) val codeLabels = map (fn _ => newLabel()) cases (* Create an exit label in case it's needed. *) val labelForExit = if isTail then ~1 (* Illegal label. *) else newLabel() (* Generate the code for each of the cases and the default. We need to put an unconditional branch after each to skip the other cases. *) fun codeCases (SOME c :: otherCases, startLabel :: otherLabels, tailCode) = let val caseTarget = if isTail then newPReg() else targetReg (* Put in the case with a jump to the end of the sequence. *) val (codeThisCase, _, caseExited) = codeToICodeRev(c, context, isTail, SpecificPReg caseTarget, BlockLabel startLabel :: tailCode) val exitThisCase = if caseExited then codeThisCase else if isTail then returnInstruction(context, caseTarget, codeThisCase) else BlockFlow(Unconditional labelForExit) :: codeThisCase in codeCases(otherCases, otherLabels, exitThisCase) end | codeCases(NONE :: otherCases, _ :: otherLabels, tailCode) = codeCases(otherCases, otherLabels, tailCode) | codeCases ([], [], tailCode) = let (* We need to add labels for all the gaps we filled and also for a "default" label for the indexed-case instruction itself as well as any range checks. *) fun addDefault (startLabel, NONE, l) = BlockLabel startLabel :: l | addDefault (_, SOME _, l) = l fun asForward l = BlockLabel l val dLabs = map asForward extraDefaults @ tailCode val defLabels = ListPair.foldlEq addDefault dLabs (codeLabels, cases) val defaultTarget = if isTail then newPReg() else targetReg val (defaultCode, _, defaultExited) = codeToICodeRev(default, context, isTail, SpecificPReg defaultTarget, defLabels) in (* Put in the default. Because this is the last we don't need to jump round it. However if this is a tail and we haven't exited we put in a return. That way the case will always have exited if this is a tail. *) if isTail andalso not defaultExited then returnInstruction(context, defaultTarget, defaultCode) else defaultCode end | codeCases _ = raise InternalError "codeCases: mismatch" val codedCases = codeCases(cases, codeLabels, BlockFlow(IndexedBr codeLabels) :: BlockSimple(IndexedCaseOperation{testReg=testReg, workReg=workReg}) :: rangeCheck) (* We can now copy to the target. If we need to push the result this load will be converted into a push. *) val target = asTarget destination val copyToTarget = if isTail then codedCases else BlockSimple(LoadArgument{source=RegisterArgument targetReg, dest=target, kind=movePolyWord}) :: BlockLabel labelForExit :: codedCases in (copyToTarget, RegisterArgument target, isTail (* We have always exited on a tail. *)) end | codeToICodeRev(BICBeginLoop {loop, arguments}, context as { stackPtr, currHandler, overflowBlock, ...}, isTail, destination, tailCode) = let val target = asTarget destination fun codeArgs ([], tailCode) = ([], tailCode) | codeArgs (({value, addr}, _) :: rest, tailCode) = let val pr = newPReg() val () = Array.update(locToPregArray, addr, PregLocation pr) val (code, _, _) = codeToICodeRev(value, context, false, SpecificPReg pr, tailCode) val (pregs, othercode) = codeArgs(rest, code) in (pr::pregs, othercode) end val (loopRegs, argCode) = codeArgs(arguments, tailCode) val loopLabel = newLabel() val (loopBody, _, loopExited) = codeToICodeRev(loop, {loopArgs=SOME (loopRegs, loopLabel, stackPtr), stackPtr=stackPtr, currHandler=currHandler, overflowBlock=overflowBlock }, isTail, SpecificPReg target, BlockLabel loopLabel :: BlockSimple BeginLoop :: argCode) in (loopBody, RegisterArgument target, loopExited) end | codeToICodeRev(BICLoop args, context as {loopArgs=SOME (loopRegs, loopLabel, loopSp), stackPtr, currHandler, ...}, _, destination, tailCode) = let val target = asTarget destination (* Registers to receive the evaluated arguments. We can't put the values into the loop variables yet because the values could depend on the current values of the loop variables. *) val argPRegs = map(fn _ => newPReg()) args val codeArgs = ListPair.foldlEq(fn ((arg, _), pr, l) => #1 (codeToICodeRev(arg, context, false, SpecificPReg pr, l))) tailCode (args, argPRegs) val jumpArgs = ListPair.mapEq(fn (s, l) => (RegisterArgument s, l)) (argPRegs, loopRegs) (* If we've allocated a container in the loop we have to remove it before jumping back. *) val stackReset = if loopSp = stackPtr then codeArgs else BlockSimple(ResetStackPtr{numWords=stackPtr-loopSp, preserveCC=false}) :: codeArgs val jumpLoop = JumpLoop{regArgs=jumpArgs, stackArgs=[], checkInterrupt=SOME[], workReg=NONE} (* "checkInterrupt" could result in a Interrupt exception so we treat this like a function call. *) val code = case currHandler of NONE => BlockFlow(Unconditional loopLabel) :: BlockSimple jumpLoop :: stackReset | SOME h => BlockOptionalHandle{call=jumpLoop, handler=h, label=loopLabel} :: stackReset in (code, RegisterArgument target, true) end | codeToICodeRev(BICLoop _, {loopArgs=NONE, ...}, _, _, _) = raise InternalError "BICLoop without BICBeginLoop" | codeToICodeRev(BICRaise exc, context as { currHandler, ...}, _, destination, tailCode) = let val packetReg = newPReg() val (code, _, _) = codeToICodeRev(exc, context, false, SpecificPReg packetReg, tailCode) val raiseCode = RaiseExceptionPacket{packetReg=packetReg} val block = case currHandler of NONE => BlockExit raiseCode | SOME h => BlockRaiseAndHandle(raiseCode, h) in (block :: code, RegisterArgument(asTarget destination), true (* Always exits *)) end | codeToICodeRev(BICHandle{exp, handler, exPacketAddr}, context as { stackPtr, loopArgs, overflowBlock, ... }, isTail, destination, tailCode) = let (* As with BICCond and BICCase we need to create a new register for the result in case we need to push it to the stack. *) val handleResult = newMergeReg() val handlerLab = newLabel() and startHandling = newLabel() val (bodyTarget, handlerTarget) = if isTail then (newPReg(), newPReg()) else (handleResult, handleResult) (* TODO: Even if we don't actually want a result we force one in here by using "asTarget". *) (* The expression cannot be treated as a tail because the handler has to be removed after. It may "exit" if it has raised an unconditional exception. If it has we mustn't generate a PopExceptionHandler because there won't be any result for resultReg. We need to add two words to the stack to account for the items pushed by PushExceptionHandler. We create an instruction to push the handler followed by a block fork to the start of the code and, potentially the handler, then a label to start the code that the handler is in effect for. *) val initialCode = BlockLabel startHandling :: BlockFlow(SetHandler{handler=handlerLab, continue=startHandling}) :: BlockSimple(PushExceptionHandler{workReg=newPReg()}) :: tailCode val (expCode, _, expExit) = codeToICodeRev(exp, {stackPtr=stackPtr+2, loopArgs=loopArgs, currHandler=SOME handlerLab, overflowBlock=overflowBlock}, false (* Not tail *), SpecificPReg bodyTarget, initialCode) (* If this is the tail we can replace the jump at the end of the handled code with returns. If the handler has exited we don't need a return there. Otherwise we need to add an unconditional jump to skip the handler. *) val (atExpEnd, skipExpLabel) = case (isTail, expExit) of (true, true) => (* Tail and exited. *) (expCode, NONE) | (true, false) => (* Tail and not exited. *) (returnInstruction(context, bodyTarget, BlockSimple(PopExceptionHandler{workReg=newPReg()}) :: expCode), NONE) | (false, true) => (* Not tail but exited. *) (expCode, NONE) | (false, false) => let val skipHandler = newLabel() in (BlockFlow(Unconditional skipHandler) :: BlockSimple(PopExceptionHandler{workReg=newPReg()}) :: expCode, SOME skipHandler) end (* Make a register to hold the exception packet and put eax into it. *) val packetAddr = newPReg() val () = Array.update(locToPregArray, exPacketAddr, PregLocation packetAddr) val (handleCode, _, handleExit) = codeToICodeRev(handler, context, isTail, SpecificPReg handlerTarget, BlockSimple(BeginHandler{workReg=newPReg(), packetReg=packetAddr}) :: BlockLabel handlerLab :: atExpEnd) val target = asTarget destination val afterHandler = case (isTail, handleExit) of (true, true) => (* Tail and exited. *) handleCode | (true, false) => (* Tail and not exited. *) returnInstruction(context, handlerTarget, handleCode) | (false, _) => (* Not tail. *) handleCode val addLabel = case skipExpLabel of SOME lab => BlockLabel lab:: afterHandler | NONE => afterHandler in (BlockSimple(LoadArgument{source=RegisterArgument handleResult, dest=target, kind=movePolyWord}) :: addLabel, RegisterArgument target, isTail) end | codeToICodeRev(BICTuple fields, context, _, destination, tailCode) = let (* TODO: This is a relic of the old fall-back code-generator. It required the result of a tuple to be at the top of the stack. It should be changed. *) val target = asTarget destination (* Actually we want this. *) val memAddr = newPReg() fun loadFields([], n, tlCode) = BlockSimple(AllocateMemoryOperation{size=n, flags=0w0, dest=memAddr, saveRegs=[]}) :: tlCode | loadFields(f :: rest, n, tlCode) = let (* Defer the evaluation if possible. We may have a constant that we can't move directly but it's better to load it after the allocation otherwise we will have to push the register if we need to GC. *) val (code1, source1, _) = codeToICodeRev(f, context, false, Allowed allowDefer, tlCode) val restAndAlloc = loadFields(rest, n+1, code1) val (code2, source, _) = moveIfNotAllowedRev(Allowed allowInMemMove, restAndAlloc, source1) val storeValue = BlockSimple(StoreArgument{ source=source, offset=n*Word.toInt wordSize, base=memAddr, index=memIndexOrObject, kind=movePolyWord, isMutable=false}) in storeValue :: code2 end val code = BlockSimple InitialisationComplete :: BlockSimple(LoadArgument{source=RegisterArgument memAddr, dest=target, kind=movePolyWord}) :: loadFields(fields, 0, tailCode) in (code, RegisterArgument target, false) end (* Copy the source tuple into the container. There are important special cases for both the source tuple and the container. If the source tuple is a BICTuple we have the fields and can store them without creating a tuple on the heap. If the destination is a local container we can store directly into the stack. *) | codeToICodeRev(BICSetContainer{container, tuple, filter}, context as {stackPtr, ...}, _, destination, tailCode) = let local fun createStore containerReg (source, destWord) = StoreArgument{source=source, offset=destWord*Word.toInt nativeWordSize, base=containerReg, index=NoMemIndex, kind=moveNativeWord, isMutable=false} in val findContainer = case container of BICExtract(BICLoadLocal l) => ( case Array.sub(locToPregArray, l) of ContainerLocation{container, stackOffset} => let fun storeToStack(source, destWord) = StoreToStack{source=source, container=container, field=destWord, stackOffset=stackPtr-stackOffset+destWord} in SOME storeToStack end | _ => NONE ) | _ => NONE val (codeContainer, storeInstr) = case findContainer of SOME storeToStack => (tailCode, storeToStack) | NONE => let val containerTarget = newPReg() val (codeContainer, _, _) = codeToICodeRev(container, context, false, SpecificPReg containerTarget, tailCode) in (codeContainer, createStore containerTarget) end end val filterLength = BoolVector.length filter val code = case tuple of BICTuple cl => let (* In theory it's possible that the tuple could contain fields that are not used but nevertheless need to be evaluated for their side-effects. Create all the fields and push to the stack. *) fun codeField(arg, (regs, tailCode)) = let val (c, r, _) = codeToICodeRev(arg, context, false, Allowed allowInMemMove, tailCode) in (r :: regs, c) end val (pregsRev, codeFields) = List.foldl codeField ([], codeContainer) cl val pregs = List.rev pregsRev fun copyField(srcReg, (sourceWord, destWord, tailCode)) = if sourceWord < filterLength andalso BoolVector.sub(filter, sourceWord) then (sourceWord+1, destWord+1, BlockSimple(storeInstr(srcReg, destWord)) :: tailCode) else (sourceWord+1, destWord, tailCode) val (_, _, resultCode) = List.foldl copyField (0, 0, codeFields) pregs in resultCode end | tuple => let (* Copy a heap tuple. It is possible that this is another container in which case we must load the fields directly. We mustn't load its address and then copy because loading the address would be the last reference and might cause the container to be reused prematurely. *) val findContainer = case tuple of BICExtract(BICLoadLocal l) => ( case Array.sub(locToPregArray, l) of ContainerLocation{container, stackOffset} => let fun getAddr sourceWord = StackLocation{wordOffset=stackPtr-stackOffset+sourceWord, container=container, field=sourceWord, cache=NONE} in SOME getAddr end | _ => NONE ) | _ => NONE val (codeTuple, loadField) = case findContainer of SOME getAddr => (codeContainer, getAddr) | NONE => let val tupleTarget = newPReg() val (codeTuple, _, _) = codeToICodeRev(tuple, context, false, SpecificPReg tupleTarget, codeContainer) fun loadField sourceWord = wordOffsetAddress(sourceWord, tupleTarget) in (codeTuple, loadField) end fun copyContainer(sourceWord, destWord, tailCode) = if sourceWord = filterLength then tailCode else if BoolVector.sub(filter, sourceWord) then let val loadReg = newPReg() val code = BlockSimple(storeInstr(RegisterArgument loadReg, destWord)) :: BlockSimple(LoadArgument{source=loadField sourceWord, dest=loadReg, kind=movePolyWord}) :: tailCode in copyContainer(sourceWord+1, destWord+1, code) end else copyContainer(sourceWord+1, destWord, tailCode) in copyContainer(0, 0, codeTuple) end in moveIfNotAllowedRev(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeRev(BICTagTest{test, tag=tagValue, ...}, context, _, destination, tailCode) = (* Check the "tag" word of a union (datatype). N.B. Not the same as testing the tag bit of a word. *) let val ccRef = newCCRef() val memOrReg = { anyConstant=false, const32s=false, memAddr=true, existingPreg=true } val (testCode, tagArg, _) = codeToICodeRev(test, context, false, Allowed memOrReg, tailCode) val target = asTarget destination in (makeBoolResultRev(JE, ccRef, target, (* Use CompareLiteral because the tag must fit in 32-bits. *) BlockSimple(CompareLiteral{arg1=tagArg, arg2=tag(Word.toLargeInt tagValue), opSize=polyWordOpSize, ccRef=ccRef}) :: testCode), RegisterArgument target, false) end | codeToICodeRev(BICLoadOperation instr, context, isTail, destination, tailCode) = let val (code, dest, haveExited) = codeToICodeLoad(instr, context, isTail, destination) in (revApp(code, tailCode), dest, haveExited) end | codeToICodeRev(BICStoreOperation instr, context, isTail, destination, tailCode) = let val (code, dest, haveExited) = codeToICodeStore(instr, context, isTail, destination) in (revApp(code, tailCode), dest, haveExited) end | codeToICodeRev(BICBlockOperation ({kind=BlockOpEqualByte, sourceLeft, destRight, length}), context, _, destination, tailCode) = let val vec1Reg = newUReg() and vec2Reg = newUReg() val ccRef = newCCRef() val (leftCode, leftUntag, {base=leftBase, offset=leftOffset, index=leftIndex, ...}) = codeAddressRev(sourceLeft, true, context, tailCode) val (rightCode, rightUntag, {base=rightBase, offset=rightOffset, index=rightIndex, ...}) = codeAddressRev(destRight, true, context, leftCode) val (lengthCode, lengthUntag, lengthArg) = codeAsUntaggedToRegRev(length, false (* unsigned *), context, rightCode) val target = asTarget destination val code = makeBoolResultRev(JE, ccRef, target, BlockSimple(CompareByteVectors{ vec1Addr=vec1Reg, vec2Addr=vec2Reg, length=lengthArg, ccRef=ccRef }) :: lengthUntag @ BlockSimple(loadAddress{base=rightBase, offset=rightOffset, index=rightIndex, dest=vec2Reg}) :: rightUntag @ BlockSimple(loadAddress{base=leftBase, offset=leftOffset, index=leftIndex, dest=vec1Reg}) :: leftUntag @ lengthCode) in (code, RegisterArgument target, false) end | codeToICodeRev(BICBlockOperation instr, context, isTail, destination, tailCode) = let val (code, dest, haveExited) = codeToICodeBlock(instr, context, isTail, destination) in (revApp(code, tailCode), dest, haveExited) end and codeToICodeUnaryRev({oper=BuiltIns.NotBoolean, arg1}, context, _, destination, tailCode) = let val target = asTarget destination val ccRef = newCCRef() val allow = Allowed {anyConstant=false, const32s=false, memAddr=true, existingPreg=true} val (argCode, testDest, _) = codeToICodeRev(arg1, context, false, allow, tailCode) in (* Test the argument and return a boolean result. If either the argument is a condition or the result is used in a test this will be better than using XOR. *) (makeBoolResultRev(JNE, ccRef, target, BlockSimple(CompareLiteral{arg1=testDest, arg2=tag 1, opSize=polyWordOpSize, ccRef=ccRef}) :: argCode), RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.IsTaggedValue, arg1}, context, _, destination, tailCode) = let val ccRef = newCCRef() val memOrReg = { anyConstant=false, const32s=false, memAddr=true, existingPreg=true } val (testCode, testResult, _) = codeToICodeRev(arg1, context, false, Allowed memOrReg, tailCode) (* Test the tag bit. This sets the zero bit if the value is untagged. *) val target = asTarget destination in (makeBoolResultRev(JNE, ccRef, target, BlockSimple(TestTagBit{arg=testResult, ccRef=ccRef}) :: testCode), RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.MemoryCellLength, arg1}, context, _, destination, tailCode) = let val target = asTarget destination val argReg1 = newUReg() and argReg2 = newUReg() and argReg3 = newUReg() (* These are untagged until the tag is put in. *) and ccRef1 = newCCRef() and ccRef2 = newCCRef() and ccRef3 = newCCRef() (* Get the length of a memory cell (heap object). We need to mask out the top byte containing the flags and to tag the result. The mask is 56 bits on 64-bit which won't fit in an inline constant. Since we have to shift it anyway we might as well do this by shifts. *) val (argCode, addrReg) = codeToPRegRev(arg1, context, tailCode) in (BlockSimple(ArithmeticFunction{oper=OR, resultReg=target, operand1=argReg3, operand2=IntegerConstant 1, ccRef=ccRef3, opSize=polyWordOpSize}) :: BlockSimple(ShiftOperation{shift=SHR, resultReg=argReg3, operand=argReg2, shiftAmount=IntegerConstant 7 (* 8-tagshift*), ccRef=ccRef2, opSize=polyWordOpSize }) :: BlockSimple(ShiftOperation{shift=SHL, resultReg=argReg2, operand=argReg1, shiftAmount=IntegerConstant 8, ccRef=ccRef1, opSize=polyWordOpSize }) :: BlockSimple(LoadArgument{source=wordOffsetAddress(~1, addrReg), dest=argReg1, kind=movePolyWord}) :: argCode, RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.MemoryCellFlags, arg1}, context, _, destination, tailCode) = let val target = asTarget destination val argReg1 = newUReg() val (argCode, addrReg) = codeToPRegRev(arg1, context, tailCode) in (BlockSimple(TagValue{ source=argReg1, dest=target, isSigned=false, opSize=OpSize32 }) :: BlockSimple(LoadArgument{source=MemoryLocation{offset= ~1, base=addrReg, index=memIndexOrObject, cache=NONE}, dest=argReg1, kind=MoveByte}) :: argCode, RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.ClearMutableFlag, arg1}, context, _, destination, tailCode) = let val (argCode, addrReg) = codeToPRegRev(arg1, context, tailCode) in moveIfNotAllowedRev(destination, BlockSimple(LockMutable{addr=addrReg}) :: argCode, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeUnaryRev({oper=BuiltIns.AtomicIncrement, arg1}, context, _, destination, tailCode) = let val target = asTarget destination val incrReg = newUReg() val (argCode, addrReg) = codeToPRegRev(arg1, context, tailCode) val code = (* We want the result to be the new value but we've returned the old value. *) BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=incrReg, operand2=IntegerConstant(semitag 1), ccRef=newCCRef(), opSize=polyWordOpSize}) :: BlockSimple(AtomicExchangeAndAdd{ base=addrReg, source=incrReg }) :: BlockSimple(LoadArgument{source=IntegerConstant(semitag 1), dest=incrReg, kind=movePolyWord}) :: argCode in (code, RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.AtomicDecrement, arg1}, context, _, destination, tailCode) = let val target = asTarget destination val incrReg = newUReg() val (argCode, addrReg) = codeToPRegRev(arg1, context, tailCode) val code = BlockSimple(ArithmeticFunction{oper=SUB, resultReg=target, operand1=incrReg, operand2=IntegerConstant(semitag 1), ccRef=newCCRef(), opSize=polyWordOpSize}) :: BlockSimple(AtomicExchangeAndAdd{ base=addrReg, source=incrReg }) :: BlockSimple(LoadArgument{source=IntegerConstant(semitag ~1), dest=incrReg, kind=movePolyWord}) :: argCode in (code, RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.AtomicReset, arg1}, context, _, destination, tailCode) = let (* This is needed only for the interpreted version where we have a single real mutex to interlock atomic increment and decrement. We have to use the same mutex to interlock clearing a mutex. On the X86 we use hardware locking and the hardware guarantees that an assignment of a word will be atomic. *) val (argCode, addrReg) = codeToPRegRev(arg1, context, tailCode) (* Store tagged 1 in the mutex. This is the unlocked value. *) val code = BlockSimple(StoreArgument{source=IntegerConstant(tag 1), base=addrReg, index=memIndexOrObject, offset=0, kind=movePolyWord, isMutable=true}) :: argCode in moveIfNotAllowedRev(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeUnaryRev({oper=BuiltIns.LongWordToTagged, arg1}, context, _, destination, tailCode) = let (* This is exactly the same as StringLengthWord at the moment. TODO: introduce a new ICode entry so that the next stage can optimise longword operations. *) val target = asTarget destination val argReg1 = newUReg() val (argCode, addrReg) = codeToPRegRev(arg1, context, tailCode) val code = BlockSimple(TagValue{ source=argReg1, dest=target, isSigned=false, opSize=polyWordOpSize }) :: BlockSimple(LoadArgument{source=wordAt addrReg, dest=argReg1, kind=movePolyWord}) :: argCode in (code, RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.SignedToLongWord, arg1}, context, _, destination, tailCode) = let val addrReg = newPReg() and untagArg = newUReg() val (argCode, argReg1) = codeToPRegRev(arg1, context, tailCode) val (signExtend, sxReg) = case targetArch of ObjectId32Bit => let val sReg = newUReg() in ([BlockSimple(SignExtend32To64{source=RegisterArgument argReg1, dest=sReg})], sReg) end | _ => ([], argReg1) val code = BlockSimple(BoxValue{boxKind=BoxLargeWord, source=untagArg, dest=addrReg, saveRegs=[]}) :: BlockSimple(UntagValue{source=sxReg, dest=untagArg, isSigned=true, cache=NONE, opSize=nativeWordOpSize}) :: signExtend @ argCode in moveIfNotAllowedRev(destination, code, RegisterArgument addrReg) end | codeToICodeUnaryRev({oper=BuiltIns.UnsignedToLongWord, arg1}, context, _, destination, tailCode) = let val addrReg = newPReg() and untagArg = newUReg() val (argCode, argReg1) = codeToPRegRev(arg1, context, tailCode) val code = BlockSimple(BoxValue{boxKind=BoxLargeWord, source=untagArg, dest=addrReg, saveRegs=[]}) :: (* We can just use a polyWord operation to untag the unsigned value. *) BlockSimple(UntagValue{source=argReg1, dest=untagArg, isSigned=false, cache=NONE, opSize=polyWordOpSize}) :: argCode in moveIfNotAllowedRev(destination, code, RegisterArgument addrReg) end | codeToICodeUnaryRev({oper=BuiltIns.RealNeg precision, arg1}, context, _, destination, tailCode) = let val target = asTarget destination val fpRegSrc = newUReg() and fpRegDest = newUReg() and sse2ConstReg = newUReg() (* The SSE2 code uses an SSE2 logical operation to flip the sign bit. This requires the values to be loaded into registers first because the logical operations require 128-bit operands. *) val (argCode, aReg1) = codeToPReg(arg1, context) (* Double precision values are always boxed and single precision values if they won't fit in a word. Otherwise we can using tagging. *) open BuiltIns val load = if precision = PrecDouble then BlockSimple(LoadArgument{source=wordAt aReg1, dest=fpRegSrc, kind=MoveDouble}) else if wordSize = 0w8 then BlockSimple(UntagFloat{source=RegisterArgument aReg1, dest=fpRegSrc, cache=NONE}) else BlockSimple(LoadArgument{source=wordAt aReg1, dest=fpRegSrc, kind=MoveFloat}) val code = case fpMode of FPModeX87 => [BlockSimple(X87FPUnaryOps{ fpOp=FCHS, dest=fpRegDest, source=fpRegSrc})] | FPModeSSE2 => let (* In single precision mode the sign bit is in the low 32-bits. There may be a better way to load it. *) val signBit = if precision = PrecDouble then realSignBit else floatSignBit in [BlockSimple(LoadArgument{source=AddressConstant signBit, dest=sse2ConstReg, kind=MoveDouble}), BlockSimple(SSE2FPBinary{opc=SSE2BXor, resultReg=fpRegDest, arg1=fpRegSrc, arg2=RegisterArgument sse2ConstReg})] end val result = boxOrTagReal(fpRegDest, target, precision) in (revApp(argCode @ load :: code @ result, tailCode), RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.RealAbs precision, arg1}, context, _, destination, tailCode) = let val target = asTarget destination val fpRegSrc = newUReg() and fpRegDest = newUReg() and sse2ConstReg = newUReg() val (argCode, aReg1) = codeToPReg(arg1, context) open BuiltIns val load = if precision = PrecDouble then BlockSimple(LoadArgument{source=wordAt aReg1, dest=fpRegSrc, kind=MoveDouble}) else if wordSize = 0w8 then BlockSimple(UntagFloat{source=RegisterArgument aReg1, dest=fpRegSrc, cache=NONE}) else BlockSimple(LoadArgument{source=wordAt aReg1, dest=fpRegSrc, kind=MoveFloat}) val code = case fpMode of FPModeX87 => [BlockSimple(X87FPUnaryOps{ fpOp=FABS, dest=fpRegDest, source=fpRegSrc})] | FPModeSSE2 => let val mask = if precision = PrecDouble then realAbsMask else floatAbsMask in [BlockSimple(LoadArgument{source=AddressConstant mask, dest=sse2ConstReg, kind=MoveDouble}), BlockSimple(SSE2FPBinary{opc=SSE2BAnd, resultReg=fpRegDest, arg1=fpRegSrc, arg2=RegisterArgument sse2ConstReg})] end val result = boxOrTagReal(fpRegDest, target, precision) in (revApp(argCode @ load :: code @ result, tailCode), RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.RealFixedInt precision, arg1}, context, _, destination, tailCode) = let val target = asTarget destination val untagReg = newUReg() and fpReg = newUReg() val (argCode, aReg1) = codeToPReg(arg1, context) val floatOp = case fpMode of FPModeX87 => X87Float | FPModeSSE2 => SSE2Float val boxFloat = case fpMode of FPModeX87 => BoxX87Double | FPModeSSE2 => BoxSSE2Double val _ = precision = BuiltIns.PrecDouble orelse raise InternalError "RealFixedInt - single" val code = argCode @ [BlockSimple(UntagValue{source=aReg1, dest=untagReg, isSigned=true, cache=NONE, opSize=polyWordOpSize}), BlockSimple(floatOp{ dest=fpReg, source=RegisterArgument untagReg}), BlockSimple(BoxValue{boxKind=boxFloat, source=fpReg, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.FloatToDouble, arg1}, context, _, destination, tailCode) = let (* Convert a single precision floating point value to double precision. *) val target = asTarget destination val fpReg = newUReg() and fpReg2 = newUReg() val (argCode, aReg1) = codeToPReg(arg1, context) (* MoveFloat always converts from single to double-precision. *) val unboxOrUntag = case (fpMode, wordSize) of (FPModeX87, _) => [BlockSimple(LoadArgument{source=wordAt aReg1, dest=fpReg2, kind=MoveFloat})] | (FPModeSSE2, 0w4) => [BlockSimple(LoadArgument{source=wordAt aReg1, dest=fpReg, kind=MoveFloat}), BlockSimple(SSE2FPUnary{opc=SSE2UFloatToDouble, resultReg=fpReg2, source=RegisterArgument fpReg})] | (FPModeSSE2, _) => [BlockSimple(UntagFloat{source=RegisterArgument aReg1, dest=fpReg, cache=NONE}), BlockSimple(SSE2FPUnary{opc=SSE2UFloatToDouble, resultReg=fpReg2, source=RegisterArgument fpReg})] val boxFloat = case fpMode of FPModeX87 => BoxX87Double | FPModeSSE2 => BoxSSE2Double val code = argCode @ unboxOrUntag @ [BlockSimple(BoxValue{boxKind=boxFloat, source=fpReg2, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.DoubleToFloat NONE, arg1}, context, _, destination, tailCode) = let (* Convert a double precision value to a single precision using the current rounding mode. This is simpler than setting the rounding mode and then restoring it. *) val target = asTarget destination val fpReg = newUReg() and fpReg2 = newUReg() val (argCode, aReg1) = codeToPReg(arg1, context) (* In 32-bit mode we need to box the float. In 64-bit mode we can tag it. *) val boxOrTag = case fpMode of FPModeX87 => [BlockSimple(BoxValue{boxKind=BoxX87Float, source=fpReg, dest=target, saveRegs=[]})] | FPModeSSE2 => BlockSimple(SSE2FPUnary{opc=SSE2UDoubleToFloat, resultReg=fpReg2, source=RegisterArgument fpReg}) :: boxOrTagReal(fpReg2, target, BuiltIns.PrecSingle) val code = argCode @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=fpReg, kind=MoveDouble})] @ boxOrTag in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.DoubleToFloat (SOME rndMode), arg1}, context, _, destination, tailCode) = let (* Convert a double precision value to a single precision. The rounding mode is passed in explicitly. *) val target = asTarget destination val fpReg = newUReg() and fpReg2 = newUReg() val (argCode, aReg1) = codeToPReg(arg1, context) (* In 32-bit mode we need to box the float. In 64-bit mode we can tag it. *) (* We need to save the rounding mode before we change it and restore it afterwards. *) open IEEEReal fun doConversion() = case fpMode of FPModeX87 => (* Convert the value using the appropriate rounding. *) [BlockSimple(BoxValue{boxKind=BoxX87Float, source=fpReg, dest=target, saveRegs=[]})] | FPModeSSE2 => BlockSimple(SSE2FPUnary{opc=SSE2UDoubleToFloat, resultReg=fpReg2, source=RegisterArgument fpReg}) :: boxOrTagReal(fpReg2, target, BuiltIns.PrecSingle) val code = argCode @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=fpReg, kind=MoveDouble})] @ setAndRestoreRounding(rndMode, doConversion) in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeUnaryRev({oper=BuiltIns.RealToInt(precision, rndMode), arg1}, context, _, destination, tailCode) = let val target = asTarget destination val chkOverflow = newCCRef() val convResult = newUReg() and wrkReg2 = newUReg() (* Convert a floating point value to an integer. We need to raise overflow if the result is out of range. We first convert the value to 32/64 bits then tag it. An overflow can happen either because the real number does not fit in 32/64 bits or if it is not a 31/63 bit value. Fortunately, if the first conversion fails the result is a value that causes an overflow when we try it shift it so the check for overflow only needs to happen there. There is an SSE2 instruction that implements truncation (round to zero) directly but in other cases we need to set the rounding mode. *) val doConvert = case (fpMode, precision) of (FPModeX87, _) => let val fpReg = newUReg() val (argCode, aReg) = codeToPReg(arg1, context) fun doConvert() = [BlockSimple(X87RealToInt{source=fpReg, dest=convResult })] in argCode @ [BlockSimple(LoadArgument{source=wordAt aReg, dest=fpReg, kind=MoveDouble})] @ setAndRestoreRounding(rndMode, doConvert) end | (FPModeSSE2, BuiltIns.PrecDouble) => let val (argCode, argReg) = codeToPReg(arg1, context) fun doConvert() = [BlockSimple( SSE2RealToInt{source=wordAt argReg, dest=convResult, isDouble=true, isTruncate = rndMode = IEEEReal.TO_ZERO }) ] in argCode @ ( case rndMode of IEEEReal.TO_ZERO => doConvert() | _ => setAndRestoreRounding(rndMode, doConvert)) end | (FPModeSSE2, BuiltIns.PrecSingle) => let val (argCode, aReg) = codeToPReg(arg1, context) val fpReg = newUReg() fun doConvert() = [BlockSimple( SSE2RealToInt{source=RegisterArgument fpReg, dest=convResult, isDouble=false, isTruncate = rndMode = IEEEReal.TO_ZERO })] in argCode @ [BlockSimple(UntagFloat{source=RegisterArgument aReg, dest=fpReg, cache=NONE})] @ ( case rndMode of IEEEReal.TO_ZERO => doConvert() | _ => setAndRestoreRounding(rndMode, doConvert) ) end val checkAndTag = BlockSimple(ShiftOperation{ shift=SHL, resultReg=wrkReg2, operand=convResult, shiftAmount=IntegerConstant 1, ccRef=chkOverflow, opSize=polyWordOpSize}) :: checkOverflow context chkOverflow @ [BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=wrkReg2, operand2=IntegerConstant 1, ccRef = newCCRef(), opSize=polyWordOpSize})] in (revApp(doConvert @ checkAndTag, tailCode), RegisterArgument target, false) end and codeToICodeBinaryRev({oper=BuiltIns.WordComparison{test, isSigned}, arg1, arg2=BICConstnt(arg2Value, _)}, context, _, destination, tailCode) = let (* Comparisons. Because this is also used for pointer equality and even for exception matching it is perfectly possible that the argument could be an address. *) val ccRef = newCCRef() val comparison = (* If the argument is a tagged value that will fit in 32-bits we can use the literal version. Use toLargeIntX here because the value will be sign-extended even if we're actually doing an unsigned comparison. *) if isShort arg2Value andalso is32bit(tag(Word.toLargeIntX(toShort arg2Value))) then let val allow = Allowed {anyConstant=false, const32s=false, memAddr=true, existingPreg=true} in (* We're often comparing with a character or a string length field that has to be untagged. In that case we can avoid loading it into a register and untagging it by doing the comparison directly. *) case arg1 of BICLoadOperation{kind=LoadStoreUntaggedUnsigned, address} => let val (codeBaseIndex, codeUntag, memLoc) = codeAddressRev(address, false, context, tailCode) val literal = Word.toLargeIntX(toShort arg2Value) in BlockSimple(CompareLiteral{arg1=MemoryLocation memLoc, arg2=literal, opSize=polyWordOpSize, ccRef=ccRef}) :: codeUntag @ codeBaseIndex end | BICLoadOperation{kind=LoadStoreMLByte _, address} => let val (codeBaseIndex, codeUntag, {base, index, offset, ...}) = codeAddressRev(address, true, context, tailCode) val _ = toShort arg2Value >= 0w0 andalso toShort arg2Value < 0w256 orelse raise InternalError "Compare byte not a byte" val literal = Word8.fromLargeWord(Word.toLargeWord(toShort arg2Value)) in BlockSimple(CompareByteMem{arg1={base=base, index=index, offset=offset}, arg2=literal, ccRef=ccRef}) :: codeUntag @ codeBaseIndex end | BICUnary({oper=BuiltIns.MemoryCellFlags, arg1}) => (* This occurs particularly in arbitrary precision comparisons. *) let val (baseCode, baseReg) = codeToPRegRev(arg1, context, tailCode) val _ = toShort arg2Value >= 0w0 andalso toShort arg2Value < 0w256 orelse raise InternalError "Compare memory cell not a byte" val literal = Word8.fromLargeWord(Word.toLargeWord(toShort arg2Value)) in BlockSimple(CompareByteMem{arg1={base=baseReg, index=memIndexOrObject, offset= ~1}, arg2=literal, ccRef=ccRef}) :: baseCode end | _ => let (* TODO: We could include rarer cases of tagging by looking at the code and seeing if it's a TagValue. *) val (testCode, testDest, _) = codeToICodeRev(arg1, context, false, allow, tailCode) val literal = tag(Word.toLargeIntX(toShort arg2Value)) in BlockSimple(CompareLiteral{arg1=testDest, arg2=literal, opSize=polyWordOpSize, ccRef=ccRef}) :: testCode end end else (* Addresses or larger values. We need to use a register comparison. *) let val (testCode, testReg) = codeToPRegRev(arg1, context, tailCode) val arg2Arg = constantAsArgument arg2Value in BlockSimple(WordComparison{arg1=testReg, arg2=arg2Arg, ccRef=ccRef, opSize=polyWordOpSize}) :: testCode end val target = asTarget destination in (makeBoolResultRev(testAsBranch(test, isSigned, true), ccRef, target, comparison), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordComparison{test, isSigned}, arg1=BICConstnt(arg1Value, _), arg2}, context, _, destination, tailCode) = let (* If we have the constant first we need to reverse the test so the first argument is a register. *) val ccRef = newCCRef() val comparison = if isShort arg1Value andalso is32bit(tag(Word.toLargeIntX(toShort arg1Value))) then let val allow = Allowed {anyConstant=false, const32s=false, memAddr=true, existingPreg=true} val (testCode, testDest, _) = codeToICodeRev(arg2, context, false, allow, tailCode) val literal = tag(Word.toLargeIntX(toShort arg1Value)) in BlockSimple(CompareLiteral{arg1=testDest, arg2=literal, opSize=polyWordOpSize, ccRef=ccRef}) :: testCode end else (* Addresses or larger values. We need to use a register comparison. *) let val (testCode, testReg) = codeToPRegRev(arg2, context, tailCode) val arg1Arg = constantAsArgument arg1Value in BlockSimple(WordComparison{arg1=testReg, arg2=arg1Arg, ccRef=ccRef, opSize=polyWordOpSize}) :: testCode end val target = asTarget destination in (makeBoolResultRev(testAsBranch(leftRightTest test, isSigned, true), ccRef, target, comparison), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordComparison {test, isSigned}, arg1, arg2}, context, _, destination, tailCode) = let val ccRef = newCCRef() val memOrReg = { anyConstant=false, const32s=false, memAddr=true, existingPreg=true } val (arg1Code, arg1Result, _) = codeToICodeRev(arg1, context, false, Allowed memOrReg, tailCode) val (arg2Code, arg2Result, _) = codeToICodeRev(arg2, context, false, Allowed memOrReg, arg1Code) val target = asTarget destination val code = case (arg1Result, arg2Result) of (RegisterArgument arg1Reg, arg2Result) => makeBoolResultRev(testAsBranch(test, isSigned, true), ccRef, target, BlockSimple(WordComparison{arg1=arg1Reg, arg2=arg2Result, ccRef=ccRef, opSize=polyWordOpSize}) :: arg2Code) | (arg1Result, RegisterArgument arg2Reg) => (* The second argument is in a register - switch the sense of the test. *) makeBoolResultRev(testAsBranch(leftRightTest test, isSigned, true), ccRef, target, BlockSimple(WordComparison{arg1=arg2Reg, arg2=arg1Result, ccRef=ccRef, opSize=polyWordOpSize}) :: arg2Code) | (arg1Result, arg2Result) => let (* Have to load an argument - pick the first. *) val arg1Reg = newPReg() in makeBoolResultRev(testAsBranch(test, isSigned, true), ccRef, target, BlockSimple(WordComparison{arg1=arg1Reg, arg2=arg2Result, ccRef=ccRef, opSize=polyWordOpSize}) :: BlockSimple(LoadArgument{source=arg1Result, dest=arg1Reg, kind=movePolyWord}) :: arg2Code) end in (code, RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.FixedPrecisionArith oper, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val code = codeFixedPrecisionArith(oper, arg1, arg2, context, target, checkOverflow context) in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithAdd, arg1, arg2=BICConstnt(value, _)}, context, _, destination, tailCode) = let val target = asTarget destination (* If the argument is a constant we can subtract the tag beforehand. N.B. it is possible to have type-incorrect values in dead code. i.e. code that will never be executed because of a run-time check. *) val constVal = if isShort value then semitag(Word.toLargeIntX(toShort value)) else 0 val (arg1Code, aReg1) = codeToPRegRev(arg1, context, tailCode) in (BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=aReg1, operand2=IntegerConstant constVal, ccRef = newCCRef(), opSize=polyWordOpSize}) :: arg1Code, RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithAdd, arg1=BICConstnt(value, _), arg2}, context, _, destination, tailCode) = let val target = asTarget destination (* If the argument is a constant we can subtract the tag beforehand. Check for short - see comment above. *) val constVal = if isShort value then semitag(Word.toLargeIntX(toShort value)) else 0 val (arg2Code, aReg2) = codeToPRegRev(arg2, context, tailCode) in (BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=aReg2, operand2=IntegerConstant constVal, ccRef = newCCRef(), opSize=polyWordOpSize}) :: arg2Code, RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithAdd, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) (* Use LEA to do the addition since we're not concerned with overflow. This is shorter than subtracting the tag and adding the values and also moves the result into the appropriate register. *) val code = arg1Code @ arg2Code @ [BlockSimple(LoadEffectiveAddress{base=SOME aReg1, offset= ~1, index=MemIndex1 aReg2, dest=target, opSize=polyWordOpSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithSub, arg1, arg2=BICConstnt(value, _)}, context, _, destination, tailCode) = let val target = asTarget destination (* If the argument is a constant we can subtract the tag beforehand. Check for short - see comment above. *) val constVal = if isShort value then semitag(Word.toLargeIntX(toShort value)) else 0 val (arg1Code, aReg1) = codeToPRegRev(arg1, context, tailCode) in (BlockSimple(ArithmeticFunction{oper=SUB, resultReg=target, operand1=aReg1, operand2=IntegerConstant constVal, ccRef=newCCRef(), opSize=polyWordOpSize}) :: arg1Code, RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithSub, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val aReg3 = newPReg() val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val code = arg1Code @ arg2Code @ (* Do the subtraction and add in the tag bit. This could be reordered if we have cascaded operations since we don't need to check for overflow. *) [BlockSimple(ArithmeticFunction{oper=SUB, resultReg=aReg3, operand1=aReg1, operand2=RegisterArgument aReg2, ccRef=newCCRef(), opSize=polyWordOpSize}), BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=aReg3, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithMult, arg1, arg2=BICConstnt(value, _)}, context, _, destination, tailCode) = codeMultiplyConstantWordRev(arg1, context, destination, if isShort value then toShort value else 0w0, tailCode) | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithMult, arg1=BICConstnt(value, _), arg2}, context, _, destination, tailCode) = codeMultiplyConstantWordRev(arg2, context, destination, if isShort value then toShort value else 0w0, tailCode) | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithMult, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val arg1Untagged = newUReg() and arg2Untagged = newUReg() and resUntagged = newUReg() val code = arg1Code @ arg2Code @ (* Shift one argument and subtract the tag from the other. It's possible this could be reordered if we have a value that is already untagged. *) [BlockSimple(UntagValue{source=aReg1, dest=arg1Untagged, isSigned=false, cache=NONE, opSize=polyWordOpSize}), BlockSimple(ArithmeticFunction{oper=SUB, resultReg=arg2Untagged, operand1=aReg2, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize}), BlockSimple(Multiplication{resultReg=resUntagged, operand1=arg1Untagged, operand2=RegisterArgument arg2Untagged, ccRef=newCCRef(), opSize=polyWordOpSize}), BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=resUntagged, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithDiv, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val arg1Untagged = newUReg() and arg2Untagged = newUReg() val quotient = newUReg() and remainder = newUReg() val code = arg1Code @ arg2Code @ (* Shift both of the arguments to remove the tags. We don't test for zero here - that's done explicitly. *) [BlockSimple(UntagValue{source=aReg1, dest=arg1Untagged, isSigned=false, cache=NONE, opSize=polyWordOpSize}), BlockSimple(UntagValue{source=aReg2, dest=arg2Untagged, isSigned=false, cache=NONE, opSize=polyWordOpSize}), BlockSimple(Division { isSigned = false, dividend=arg1Untagged, divisor=RegisterArgument arg2Untagged, quotient=quotient, remainder=remainder, opSize=polyWordOpSize }), BlockSimple(TagValue { source=quotient, dest=target, isSigned=false, opSize=polyWordOpSize })] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith BuiltIns.ArithMod, arg1, arg2}, context, _, destination, tailCode) = let (* Identical to Quot except that the result is the remainder. *) val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val arg1Untagged = newUReg() and arg2Untagged = newUReg() val quotient = newUReg() and remainder = newUReg() val code = arg1Code @ arg2Code @ (* Shift both of the arguments to remove the tags. *) [BlockSimple(UntagValue{source=aReg1, dest=arg1Untagged, isSigned=false, cache=NONE, opSize=polyWordOpSize}), BlockSimple(UntagValue{source=aReg2, dest=arg2Untagged, isSigned=false, cache=NONE, opSize=polyWordOpSize}), BlockSimple(Division { isSigned = false, dividend=arg1Untagged, divisor=RegisterArgument arg2Untagged, quotient=quotient, remainder=remainder, opSize=polyWordOpSize }), BlockSimple(TagValue { source=remainder, dest=target, isSigned=false, opSize=polyWordOpSize })] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordArith _, ...}, _, _, _, _) = raise InternalError "codeToICodeNonRev: WordArith - unimplemented operation" | codeToICodeBinaryRev({oper=BuiltIns.WordLogical logOp, arg1, arg2=BICConstnt(value, _)}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, arg1Reg) = codeToPReg(arg1, context) (* Use a semitagged value for XOR. This preserves the tag bit. Use toLargeIntX here because the operations will sign-extend 32-bit values. *) val constVal = if isShort value then (case logOp of BuiltIns.LogicalXor => semitag | _ => tag) (Word.toLargeIntX(toShort value)) else 0 val oper = case logOp of BuiltIns.LogicalOr => OR | BuiltIns.LogicalAnd => AND | BuiltIns.LogicalXor => XOR (* If we AND with a value that fits in 32-bits we can use a 32-bit operation. *) val opSize = if logOp = BuiltIns.LogicalAnd andalso constVal <= 0xffffffff andalso constVal >= 0 then OpSize32 else polyWordOpSize val code = arg1Code @ [BlockSimple(ArithmeticFunction{oper=oper, resultReg=target, operand1=arg1Reg, operand2=IntegerConstant constVal, ccRef=newCCRef(), opSize=opSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordLogical logOp, arg1=BICConstnt(value, _), arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg2Code, arg2Reg) = codeToPReg(arg2, context) (* Use a semitagged value for XOR. This preserves the tag bit. *) val constVal = if isShort value then (case logOp of BuiltIns.LogicalXor => semitag | _ => tag) (Word.toLargeIntX(toShort value)) else 0 val oper = case logOp of BuiltIns.LogicalOr => OR | BuiltIns.LogicalAnd => AND | BuiltIns.LogicalXor => XOR (* If we AND with a value that fits in 32-bits we can use a 32-bit operation. *) val opSize = if logOp = BuiltIns.LogicalAnd andalso constVal <= 0xffffffff andalso constVal >= 0 then OpSize32 else polyWordOpSize val code = arg2Code @ [BlockSimple(ArithmeticFunction{oper=oper, resultReg=target, operand1=arg2Reg, operand2=IntegerConstant constVal, ccRef=newCCRef(), opSize=opSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordLogical BuiltIns.LogicalOr, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, arg1Reg) = codeToPReg(arg1, context) val (arg2Code, arg2Reg) = codeToPReg(arg2, context) val code = arg1Code @ arg2Code @ (* Or-ing preserves the tag bit. *) [BlockSimple(ArithmeticFunction{oper=OR, resultReg=target, operand1=arg1Reg, operand2=RegisterArgument arg2Reg, ccRef=newCCRef(), opSize=polyWordOpSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordLogical BuiltIns.LogicalAnd, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, arg1Reg) = codeToPReg(arg1, context) val (arg2Code, arg2Reg) = codeToPReg(arg2, context) val code = arg1Code @ arg2Code @ (* Since they're both tagged the result will be tagged. *) [BlockSimple(ArithmeticFunction{oper=AND, resultReg=target, operand1=arg1Reg, operand2=RegisterArgument arg2Reg, ccRef=newCCRef(), opSize=polyWordOpSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordLogical BuiltIns.LogicalXor, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, arg1Reg) = codeToPReg(arg1, context) val (arg2Code, arg2Reg) = codeToPReg(arg2, context) val aReg3 = newPReg() val code = arg1Code @ arg2Code @ (* We need to restore the tag bit after the operation. *) [BlockSimple(ArithmeticFunction{oper=XOR, resultReg=aReg3, operand1=arg1Reg, operand2=RegisterArgument arg2Reg, ccRef=newCCRef(), opSize=polyWordOpSize}), BlockSimple(ArithmeticFunction{oper=OR, resultReg=target, operand1=aReg3, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.WordShift BuiltIns.ShiftLeft, arg1, arg2=BICConstnt(value, _)}, context, _, destination, tailCode) = (* Use the general case multiplication code. This will use a shift except for small values. It does detect special cases such as multiplication by 4 and 8 which can be implemented with LEA. *) codeMultiplyConstantWordRev(arg1, context, destination, if isShort value then Word.<<(0w1, toShort value) else 0w1, tailCode) | codeToICodeBinaryRev({oper=BuiltIns.WordShift shift, arg1, arg2}, context, _, destination, tailCode) = (* N.B. X86 shifts of greater than the word length mask the higher bits. That isn't what ML wants but that is dealt with at a higher level *) let open BuiltIns val target = asTarget destination (* Load the value into an untagged register. If this is a left shift we need to clear the tag bit. We don't need to do that for right shifts. *) val argRegUntagged = newUReg() val arg1Code = case arg1 of BICConstnt(value, _) => let (* Remove the tag bit. This isn't required for right shifts. *) val cnstntVal = if isShort value then semitag(Word.toLargeInt(toShort value)) else 1 in [BlockSimple(LoadArgument{source=IntegerConstant cnstntVal, dest=argRegUntagged, kind=movePolyWord})] end | _ => let val (arg1Code, arg1Reg) = codeToPReg(arg1, context) val removeTag = case shift of ShiftLeft => ArithmeticFunction{oper=SUB, resultReg=argRegUntagged, operand1=arg1Reg, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize} | _ => LoadArgument{source=RegisterArgument arg1Reg, dest=argRegUntagged, kind=movePolyWord} in arg1Code @ [BlockSimple removeTag] end (* The shift amount can usefully be a constant. *) val (arg2Code, untag2Code, arg2Arg) = codeAsUntaggedByte(arg2, false, context) val resRegUntagged = newUReg() val shiftOp = case shift of ShiftLeft => SHL | ShiftRightLogical => SHR | ShiftRightArithmetic => SAR val code = arg1Code @ arg2Code @ untag2Code @ [BlockSimple(ShiftOperation{ shift=shiftOp, resultReg=resRegUntagged, operand=argRegUntagged, shiftAmount=arg2Arg, ccRef=newCCRef(), opSize=polyWordOpSize }), (* Set the tag by ORing it in. This will work whether or not a right shift has shifted a 1 into this position. *) BlockSimple( ArithmeticFunction{oper=OR, resultReg=target, operand1=resRegUntagged, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.AllocateByteMemory, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val sizeReg = newPReg() and baseReg = newPReg() val sizeCode = codeToICodeTarget(arg1, context, false, sizeReg) val (flagsCode, flagUntag, flagArg) = codeAsUntaggedByte(arg2, false, context) val code =sizeCode @ flagsCode @ [BlockSimple(AllocateMemoryVariable{size=sizeReg, dest=baseReg, saveRegs=[]})] @ flagUntag @ [BlockSimple(StoreArgument{ source=flagArg, base=baseReg, offset= ~1, index=memIndexOrObject, kind=MoveByte, isMutable=false}), BlockSimple InitialisationComplete, BlockSimple(LoadArgument{ source=RegisterArgument baseReg, dest=target, kind=movePolyWord})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordComparison test, arg1, arg2}, context, _, destination, tailCode) = let val ccRef = newCCRef() val (arg1Code, arg1Reg) = codeToPRegRev(arg1, context, tailCode) (* In X64 we can extract the word from a constant and do the comparison directly. That can't be done in X86/32 because the value isn't tagged and might look like an address. The RTS scans for comparisons with inline constant addresses. *) val (arg2Code, arg2Operand) = if targetArch <> Native32Bit then (* Native 64-bit or 32-in-64. *) ( case arg2 of BICConstnt(value, _) => (arg1Code, IntegerConstant(largeWordConstant value)) | _ => let val (code, reg) = codeToPRegRev(arg2, context, arg1Code) in (code, wordAt reg) end ) else let val (code, reg) = codeToPRegRev(arg2, context, arg1Code) in (code, wordAt reg) end val argReg = newUReg() val target = asTarget destination val code = makeBoolResultRev(testAsBranch(test, false, true), ccRef, target, BlockSimple(WordComparison{arg1=argReg, arg2=arg2Operand, ccRef=ccRef, opSize=nativeWordOpSize}) :: BlockSimple(LoadArgument{source=wordAt arg1Reg, dest=argReg, kind=moveNativeWord}) :: arg2Code) in (code, RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith BuiltIns.ArithAdd, arg1, arg2=BICConstnt(value, _)}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val aReg3 = newUReg() val argReg = newUReg() val constantValue = largeWordConstant value val code =arg1Code @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=argReg, kind=moveNativeWord}), BlockSimple(ArithmeticFunction{oper=ADD, resultReg=aReg3, operand1=argReg, operand2=IntegerConstant constantValue, ccRef=newCCRef(), opSize=nativeWordOpSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith BuiltIns.ArithAdd, arg1=BICConstnt(value, _), arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg2Code, aReg2) = codeToPReg(arg2, context) val aReg3 = newUReg() val argReg = newUReg() val constantValue = largeWordConstant value val code = arg2Code @ [BlockSimple(LoadArgument{source=wordAt aReg2, dest=argReg, kind=moveNativeWord}), BlockSimple(ArithmeticFunction{oper=ADD, resultReg=aReg3, operand1=argReg, operand2=IntegerConstant constantValue, ccRef=newCCRef(), opSize=nativeWordOpSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith BuiltIns.ArithAdd, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val aReg3 = newUReg() val argReg = newUReg() val code = arg1Code @ arg2Code @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=argReg, kind=moveNativeWord}), BlockSimple(ArithmeticFunction{oper=ADD, resultReg=aReg3, operand1=argReg, operand2=wordAt aReg2, ccRef=newCCRef(), opSize=nativeWordOpSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith BuiltIns.ArithSub, arg1, arg2=BICConstnt(value, _)}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val aReg3 = newUReg() val argReg = newUReg() val constantValue = largeWordConstant value val code = arg1Code @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=argReg, kind=moveNativeWord}), BlockSimple(ArithmeticFunction{oper=SUB, resultReg=aReg3, operand1=argReg, operand2=IntegerConstant constantValue, ccRef=newCCRef(), opSize=nativeWordOpSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith BuiltIns.ArithSub, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val aReg3 = newUReg() val argReg = newUReg() val code = arg1Code @ arg2Code @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=argReg, kind=moveNativeWord}), BlockSimple(ArithmeticFunction{oper=SUB, resultReg=aReg3, operand1=argReg, operand2=wordAt aReg2, ccRef=newCCRef(), opSize=nativeWordOpSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith BuiltIns.ArithMult, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val resValue = newUReg() val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val argReg1 = newUReg() val code = arg1Code @ arg2Code @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=argReg1, kind=moveNativeWord}), BlockSimple(Multiplication{resultReg=resValue, operand1=argReg1, operand2=wordAt aReg2, ccRef=newCCRef(), opSize=nativeWordOpSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=resValue, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith BuiltIns.ArithDiv, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val quotient = newUReg() and remainder = newUReg() val dividendReg = newUReg() and divisorReg = newUReg() val code = arg1Code @ arg2Code @ (* We don't test for zero here - that's done explicitly. *) [BlockSimple(LoadArgument{source=wordAt aReg1, dest=dividendReg, kind=moveNativeWord}), BlockSimple(LoadArgument{source=wordAt aReg2, dest=divisorReg, kind=moveNativeWord}), BlockSimple(Division { isSigned = false, dividend=dividendReg, divisor=RegisterArgument divisorReg, quotient=quotient, remainder=remainder, opSize=nativeWordOpSize }), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=quotient, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith BuiltIns.ArithMod, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val quotient = newUReg() and remainder = newUReg() val dividendReg = newUReg() and divisorReg = newUReg() val code = arg1Code @ arg2Code @ (* We don't test for zero here - that's done explicitly. *) [BlockSimple(LoadArgument{source=wordAt aReg1, dest=dividendReg, kind=moveNativeWord}), BlockSimple(LoadArgument{source=wordAt aReg2, dest=divisorReg, kind=moveNativeWord}), BlockSimple(Division { isSigned = false, dividend=dividendReg, divisor=RegisterArgument divisorReg, quotient=quotient, remainder=remainder, opSize=nativeWordOpSize }), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=remainder, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordArith _, ...}, _, _, _, _) = raise InternalError "codeToICodeNonRev: LargeWordArith - unimplemented operation" | codeToICodeBinaryRev({oper=BuiltIns.LargeWordLogical logOp, arg1, arg2=BICConstnt(value, _)}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val aReg3 = newUReg() val argReg = newUReg() val constantValue = largeWordConstant value val oper = case logOp of BuiltIns.LogicalOr => OR | BuiltIns.LogicalAnd => AND | BuiltIns.LogicalXor => XOR (* If we AND with a value that fits in 32-bits we can use a 32-bit operation. *) val opSize = if logOp = BuiltIns.LogicalAnd andalso constantValue <= 0xffffffff andalso constantValue >= 0 then OpSize32 else nativeWordOpSize val code = arg1Code @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=argReg, kind=moveNativeWord}), BlockSimple(ArithmeticFunction{oper=oper, resultReg=aReg3, operand1=argReg, operand2=IntegerConstant constantValue, ccRef=newCCRef(), opSize=opSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordLogical logOp, arg1=BICConstnt(value, _), arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg2Code, aReg2) = codeToPReg(arg2, context) val aReg3 = newUReg() val argReg = newUReg() val constantValue = largeWordConstant value val oper = case logOp of BuiltIns.LogicalOr => OR | BuiltIns.LogicalAnd => AND | BuiltIns.LogicalXor => XOR (* If we AND with a value that fits in 32-bits we can use a 32-bit operation. *) val opSize = if logOp = BuiltIns.LogicalAnd andalso constantValue <= 0xffffffff andalso constantValue >= 0 then OpSize32 else nativeWordOpSize val code = arg2Code @ [BlockSimple(LoadArgument{source=wordAt aReg2, dest=argReg, kind=moveNativeWord}), BlockSimple(ArithmeticFunction{oper=oper, resultReg=aReg3, operand1=argReg, operand2=IntegerConstant constantValue, ccRef=newCCRef(), opSize=opSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordLogical logOp, arg1, arg2}, context, _, destination, tailCode) = let val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) val aReg3 = newUReg() val argReg = newUReg() val oper = case logOp of BuiltIns.LogicalOr => OR | BuiltIns.LogicalAnd => AND | BuiltIns.LogicalXor => XOR val code = arg1Code @ arg2Code @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=argReg, kind=moveNativeWord}), BlockSimple(ArithmeticFunction{oper=oper, resultReg=aReg3, operand1=argReg, operand2=wordAt aReg2, ccRef=newCCRef(), opSize=nativeWordOpSize}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.LargeWordShift shift, arg1, arg2}, context, _, destination, tailCode) = (* The shift is always a Word.word value i.e. tagged. There is a check at the higher level that the shift does not exceed 32/64 bits. *) let open BuiltIns val target = asTarget destination val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, untag2Code, arg2Arg) = codeAsUntaggedByte(arg2, false, context) val aReg3 = newUReg() val shiftOp = case shift of ShiftLeft => SHL | ShiftRightLogical => SHR | ShiftRightArithmetic => SAR val argReg = newUReg() val code = arg1Code @ arg2Code @ [BlockSimple(LoadArgument{source=wordAt aReg1, dest=argReg, kind=moveNativeWord})] @ untag2Code @ [BlockSimple(ShiftOperation{ shift=shiftOp, resultReg=aReg3, operand=argReg, shiftAmount=arg2Arg, ccRef=newCCRef(), opSize=nativeWordOpSize }), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=aReg3, dest=target, saveRegs=[]})] in (revApp(code, tailCode), RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.RealArith(fpOpPrec as (fpOp, fpPrec)), arg1, arg2}, context, _, destination, tailCode) = let open BuiltIns val commutative = case fpOp of ArithSub => NonCommutative | ArithDiv => NonCommutative | ArithAdd => Commutative | ArithMult => Commutative | _ => raise InternalError "codeToICodeNonRev: RealArith - unimplemented operation" val (argCodeRev, fpRegSrc, arg2Value) = codeFPBinaryArgsRev(arg1, arg2, fpPrec, commutative, context, []) val argCode = List.rev argCodeRev val target = asTarget destination val fpRegDest = newUReg() val arith = case fpMode of FPModeX87 => let val fpOp = case fpOp of ArithAdd => FADD | ArithSub => FSUB | ArithMult => FMUL | ArithDiv => FDIV | _ => raise InternalError "codeToICodeNonRev: RealArith - unimplemented operation" val isDouble = case fpPrec of PrecSingle => false | PrecDouble => true in [BlockSimple(X87FPArith{ opc=fpOp, resultReg=fpRegDest, arg1=fpRegSrc, arg2=arg2Value, isDouble=isDouble})] end | FPModeSSE2 => let val fpOp = case fpOpPrec of (ArithAdd, PrecSingle) => SSE2BAddSingle | (ArithSub, PrecSingle) => SSE2BSubSingle | (ArithMult, PrecSingle) => SSE2BMulSingle | (ArithDiv, PrecSingle) => SSE2BDivSingle | (ArithAdd, PrecDouble) => SSE2BAddDouble | (ArithSub, PrecDouble) => SSE2BSubDouble | (ArithMult, PrecDouble) => SSE2BMulDouble | (ArithDiv, PrecDouble) => SSE2BDivDouble | _ => raise InternalError "codeToICodeNonRev: RealArith - unimplemented operation" in [BlockSimple(SSE2FPBinary{ opc=fpOp, resultReg=fpRegDest, arg1=fpRegSrc, arg2=arg2Value})] end (* Box or tag the result. *) val result = boxOrTagReal(fpRegDest, target, fpPrec) in (revApp(argCode @ arith @ result, tailCode), RegisterArgument target, false) end (* Floating point comparison. This is complicated because we have different instruction sequences for SSE2 and X87. We also have to get the handling of unordered (NaN) values right. All the tests are treated as false if either argument is a NaN. To combine that test with the other tests we sometimes have to reverse the comparison. *) | codeToICodeBinaryRev({oper=BuiltIns.RealComparison(BuiltIns.TestEqual, precision), arg1, arg2}, context, _, destination, tailCode) = let (* Get the arguments. It's commutative. *) val (arg2Code, fpReg, arg2Val) = codeFPBinaryArgsRev(arg1, arg2, precision, Commutative, context, tailCode) val ccRef1 = newCCRef() and ccRef2 = newCCRef() val testReg1 = newUReg() and testReg2 = newUReg() and testReg3 = newUReg() (* If this is X87 we get the condition into RAX and test it there. If it is SSE2 we have to treat the unordered result (parity set) specially. *) val isDouble = precision = BuiltIns.PrecDouble val target = asTarget destination val code = case fpMode of FPModeX87 => makeBoolResultRev(JE, ccRef2, target, BlockSimple(ArithmeticFunction{ oper=XOR, resultReg=testReg3, operand1=testReg2, operand2=IntegerConstant 0x4000, ccRef=ccRef2, opSize=OpSize32 }) :: BlockSimple(ArithmeticFunction{ oper=AND, resultReg=testReg2, operand1=testReg1, operand2=IntegerConstant 0x4400, ccRef=newCCRef(), opSize=OpSize32 }) :: BlockSimple(X87FPGetCondition { ccRef=ccRef1, dest=testReg1 }) :: BlockSimple(X87Compare{arg1=fpReg, arg2=arg2Val, ccRef=ccRef1, isDouble = isDouble}) :: arg2Code) | FPModeSSE2 => let val noParityLabel = newLabel() val resultLabel = newLabel() val falseLabel = newLabel() val trueLabel = newLabel() val mergeReg = newMergeReg() in BlockSimple(LoadArgument{ source=RegisterArgument mergeReg, dest=target, kind=Move32Bit }) :: BlockLabel resultLabel :: BlockFlow(Unconditional resultLabel) :: (* Result is false if parity is set i.e. unordered or if unequal. *) BlockSimple(LoadArgument{ source=IntegerConstant(tag 0), dest=mergeReg, kind=Move32Bit }) :: BlockLabel falseLabel :: BlockFlow(Unconditional resultLabel) :: (* Result is true if it's ordered and equal. *) BlockSimple(LoadArgument{ source=IntegerConstant(tag 1), dest=mergeReg, kind=Move32Bit }) :: BlockLabel trueLabel :: (* Not unordered - test the equality *) BlockFlow(Conditional{ccRef=ccRef1, condition=JE, trueJump=trueLabel, falseJump=falseLabel}) :: BlockLabel noParityLabel :: (* Go to falseLabel if unordered and therefore not equal. *) BlockFlow(Conditional{ccRef=ccRef1, condition=JP, trueJump=falseLabel, falseJump=noParityLabel}) :: BlockSimple(SSE2Compare{arg1=fpReg, arg2=arg2Val, ccRef=ccRef1, isDouble = isDouble}) :: arg2Code end in (code, RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.RealComparison(BuiltIns.TestUnordered, precision), arg1, arg2}, context, _, destination, tailCode) = let (* The unordered test is really included because it is easy to implement and is the simplest way of implementing isNan. *) (* Get the arguments. It's commutative. *) val (arg2Code, fpReg, arg2Val) = codeFPBinaryArgsRev(arg1, arg2, precision, Commutative, context, tailCode) val ccRef1 = newCCRef() and ccRef2 = newCCRef() val testReg1 = newUReg() and testReg2 = newUReg() and testReg3 = newUReg() (* If this is X87 we get the condition into RAX and test it there. If it is SSE2 we have to treat the unordered result (parity set) specially. *) val isDouble = precision = BuiltIns.PrecDouble val target = asTarget destination val code = case fpMode of FPModeX87 => (* And with 0x4500. We have to use XOR rather than CMP to avoid having an untagged constant comparison. *) makeBoolResultRev(JE, ccRef2, target, BlockSimple(ArithmeticFunction{ oper=XOR, resultReg=testReg3, operand1=testReg2, operand2=IntegerConstant 0x4500, ccRef=ccRef2, opSize=OpSize32 }) :: BlockSimple(ArithmeticFunction{ oper=AND, resultReg=testReg2, operand1=testReg1, operand2=IntegerConstant 0x4500, ccRef=newCCRef(), opSize=OpSize32 }) :: BlockSimple(X87FPGetCondition { ccRef=ccRef1, dest=testReg1 }) :: BlockSimple(X87Compare{arg1=fpReg, arg2=arg2Val, ccRef=ccRef1, isDouble = isDouble}) :: arg2Code) | FPModeSSE2 => makeBoolResultRev(JP, ccRef1, target, BlockSimple(SSE2Compare{arg1=fpReg, arg2=arg2Val, ccRef=ccRef1, isDouble = isDouble}) :: arg2Code) in (code, RegisterArgument target, false) end | codeToICodeBinaryRev({oper=BuiltIns.RealComparison(comparison, precision), arg1, arg2}, context, _, destination, tailCode) = let (* Ordered comparisons are complicated because they are all defined to be false if either argument is a NaN. We have two different tests for a > b and a >= b and implement a < b and a <= b by changing the order of the arguments. *) val (arg1Code, arg1Value) = codeFPArgument(arg1, precision, context, tailCode) val (arg2Code, arg2Value) = codeFPArgument(arg2, precision, context, arg1Code) val (regArg, opArg, isGeq) = case comparison of BuiltIns.TestGreater => (arg1Value, arg2Value, false) | BuiltIns.TestLess => (arg2Value, arg1Value, false) (* Reversed: aa. *) | BuiltIns.TestGreaterEqual => (arg1Value, arg2Value, true) | BuiltIns.TestLessEqual => (arg2Value, arg1Value, true) (* Reversed: a<=b is b>=a. *) | _ => raise InternalError "RealComparison: unimplemented operation" (* Load the first operand into a register. *) val (fpReg, loadCode) = case regArg of RegisterArgument fpReg => (fpReg, arg2Code) | regArg => let val fpReg = newUReg() val moveOp = case precision of BuiltIns.PrecDouble => MoveDouble | BuiltIns.PrecSingle => MoveFloat in (fpReg, BlockSimple(LoadArgument{source=regArg, dest=fpReg, kind=moveOp}) :: arg2Code) end val isDouble = precision = BuiltIns.PrecDouble val target = asTarget destination val code = case fpMode of FPModeX87 => let val testReg1 = newUReg() and testReg2 = newUReg() val ccRef1 = newCCRef() and ccRef2 = newCCRef() val testBits = if isGeq then 0x500 else 0x4500 in makeBoolResultRev(JE, ccRef2, target, BlockSimple(ArithmeticFunction{ oper=AND, resultReg=testReg2, operand1=testReg1, operand2=IntegerConstant testBits, ccRef=ccRef2, opSize=OpSize32 }) :: BlockSimple(X87FPGetCondition { ccRef=ccRef1, dest=testReg1 }) :: BlockSimple(X87Compare{arg1=fpReg, arg2=opArg, ccRef=ccRef1, isDouble = isDouble}) :: loadCode) end | FPModeSSE2 => let val ccRef1 = newCCRef() val condition = if isGeq then JNB (* >=, <= *) else JA (* >, < *) in makeBoolResultRev(condition, ccRef1, target, BlockSimple(SSE2Compare{arg1=fpReg, arg2=opArg, ccRef=ccRef1, isDouble = isDouble}) :: loadCode) end in (code, RegisterArgument target, false) end (* Multiply tagged word by a constant. We're not concerned with overflow so it's possible to use various short cuts. *) and codeMultiplyConstantWordRev(arg, context, destination, multiplier, tailCode) = let val target = asTarget destination val (argCode, aReg) = codeToPReg(arg, context) val doMultiply = case multiplier of 0w0 => [BlockSimple(LoadArgument{source=IntegerConstant 1, dest=target, kind=movePolyWord})] | 0w1 => [BlockSimple(LoadArgument{source=RegisterArgument aReg, dest=target, kind=movePolyWord})] | 0w2 => [BlockSimple(LoadEffectiveAddress{base=SOME aReg, offset= ~1, index=MemIndex1 aReg, dest=target, opSize=polyWordOpSize})] | 0w3 => [BlockSimple(LoadEffectiveAddress{base=SOME aReg, offset= ~2, index=MemIndex2 aReg, dest=target, opSize=polyWordOpSize})] | 0w4 => [BlockSimple(LoadEffectiveAddress{base=NONE, offset= ~3, index=MemIndex4 aReg, dest=target, opSize=polyWordOpSize})] | 0w5 => [BlockSimple(LoadEffectiveAddress{base=SOME aReg, offset= ~4, index=MemIndex4 aReg, dest=target, opSize=polyWordOpSize})] | 0w8 => [BlockSimple(LoadEffectiveAddress{base=NONE, offset= ~7, index=MemIndex8 aReg, dest=target, opSize=polyWordOpSize})] | 0w9 => [BlockSimple(LoadEffectiveAddress{base=SOME aReg, offset= ~8, index=MemIndex8 aReg, dest=target, opSize=polyWordOpSize})] | _ => let val tReg = newUReg() val tagCorrection = Word.toLargeInt multiplier - 1 fun getPower2 n = let fun p2 (n, l) = if n = 0w1 then SOME l else if Word.andb(n, 0w1) = 0w1 then NONE else p2(Word.>>(n, 0w1), l+0w1) in if n = 0w0 then NONE else p2(n,0w0) end val multiply = case getPower2 multiplier of SOME power => (* Shift it including the tag. *) BlockSimple(ShiftOperation{ shift=SHL, resultReg=tReg, operand=aReg, shiftAmount=IntegerConstant(Word.toLargeInt power), ccRef=newCCRef(), opSize=polyWordOpSize }) | NONE => (* Multiply including the tag. *) BlockSimple(Multiplication{resultReg=tReg, operand1=aReg, operand2=IntegerConstant(Word.toLargeInt multiplier), ccRef=newCCRef(), opSize=polyWordOpSize}) in [multiply, BlockSimple(ArithmeticFunction{oper=SUB, resultReg=target, operand1=tReg, operand2=IntegerConstant tagCorrection, ccRef=newCCRef(), opSize=polyWordOpSize})] end in (revApp(argCode @ doMultiply, tailCode), RegisterArgument target, false) end and codeToICodeAllocate({numWords as BICConstnt(length, _), flags as BICConstnt(flagValue, _), initial}, context, _, destination) = (* Constant length and flags is used for ref. We could handle other cases. *) if isShort length andalso isShort flagValue andalso toShort length = 0w1 then let val target = asTarget destination (* Force a different register. *) val vecLength = Word.toInt(toShort length) val flagByte = Word8.fromLargeWord(Word.toLargeWord(toShort flagValue)) val memAddr = newPReg() and valueReg = newPReg() fun initialise n = BlockSimple(StoreArgument{ source=RegisterArgument valueReg, offset=n*Word.toInt wordSize, base=memAddr, index=memIndexOrObject, kind=movePolyWord, isMutable=false}) val code = codeToICodeTarget(initial, context, false, valueReg) @ [BlockSimple(AllocateMemoryOperation{size=vecLength, flags=flagByte, dest=memAddr, saveRegs=[]})] @ List.tabulate(vecLength, initialise) @ [BlockSimple InitialisationComplete, BlockSimple(LoadArgument{source=RegisterArgument memAddr, dest=target, kind=movePolyWord})] in (code, RegisterArgument target, false) end else (* If it's longer use the full run-time form. *) allocateMemoryVariable(numWords, flags, initial, context, destination) | codeToICodeAllocate({numWords, flags, initial}, context, _, destination) = allocateMemoryVariable(numWords, flags, initial, context, destination) and codeToICodeLoad({kind=LoadStoreMLWord _, address}, context, _, destination) = let val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeAddress(address, false, context) in (codeBaseIndex @ codeUntag @ [BlockSimple(LoadArgument {source=MemoryLocation memLoc, dest=target, kind=movePolyWord})], RegisterArgument target, false) end | codeToICodeLoad({kind=LoadStoreMLByte _, address}, context, _, destination) = let val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeAddress(address, true, context) val untaggedResReg = newUReg() in (codeBaseIndex @ codeUntag @ [BlockSimple(LoadArgument { source=MemoryLocation memLoc, dest=untaggedResReg, kind=MoveByte}), BlockSimple(TagValue {source=untaggedResReg, dest=target, isSigned=false, opSize=OpSize32})], RegisterArgument target, false) end | codeToICodeLoad({kind=LoadStoreC8, address}, context, _, destination) = let (* Load a byte from C memory. This is almost exactly the same as LoadStoreMLByte except that the base address is a LargeWord.word value. *) val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeCAddress(address, 0w1, context) val untaggedResReg = newUReg() in (codeBaseIndex @ codeUntag @ [BlockSimple(LoadArgument { source=MemoryLocation memLoc, dest=untaggedResReg, kind=MoveByte}), BlockSimple(TagValue {source=untaggedResReg, dest=target, isSigned=false, opSize=OpSize32})], RegisterArgument target, false) end | codeToICodeLoad({kind=LoadStoreC16, address}, context, _, destination) = let (* Load a 16-bit value from C memory. *) val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeCAddress(address, 0w2, context) val untaggedResReg = newUReg() in (codeBaseIndex @ codeUntag @ [BlockSimple(LoadArgument { source=MemoryLocation memLoc, dest=untaggedResReg, kind=Move16Bit}), BlockSimple(TagValue {source=untaggedResReg, dest=target, isSigned=false, opSize=OpSize32})], RegisterArgument target, false) end | codeToICodeLoad({kind=LoadStoreC32, address}, context, _, destination) = let (* Load a 32-bit value from C memory. If this is 64-bit mode we can tag it but if this is 32-bit mode we need to box it. *) val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeCAddress(address, 0w4, context) val untaggedResReg = newUReg() val boxTagCode = if targetArch = Native64Bit then BlockSimple(TagValue {source=untaggedResReg, dest=target, isSigned=false, opSize=OpSize64 (* It becomes 33 bits *)}) else BlockSimple(BoxValue{boxKind=BoxLargeWord, source=untaggedResReg, dest=target, saveRegs=[]}) in (codeBaseIndex @ codeUntag @ [BlockSimple(LoadArgument { source=MemoryLocation memLoc, dest=untaggedResReg, kind=Move32Bit}), boxTagCode], RegisterArgument target, false) end | codeToICodeLoad({kind=LoadStoreC64, address}, context, _, destination) = let (* Load a 64-bit value from C memory. This is only allowed in 64-bit mode. The result is a boxed value. *) val _ = targetArch <> Native32Bit orelse raise InternalError "codeToICodeNonRev: BICLoadOperation LoadStoreC64 in 32-bit" val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeCAddress(address, 0w8, context) val untaggedResReg = newUReg() in (codeBaseIndex @ codeUntag @ [BlockSimple(LoadArgument { source=MemoryLocation memLoc, dest=untaggedResReg, kind=Move64Bit}), BlockSimple(BoxValue{boxKind=BoxLargeWord, source=untaggedResReg, dest=target, saveRegs=[]})], RegisterArgument target, false) end | codeToICodeLoad({kind=LoadStoreCFloat, address}, context, _, destination) = let val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeCAddress(address, 0w4, context) val untaggedResReg = newUReg() val boxFloat = case fpMode of FPModeX87 => BoxX87Double | FPModeSSE2 => BoxSSE2Double (* We need to convert the float into a double. *) val loadArg = case fpMode of FPModeX87 => BlockSimple(LoadArgument { source=MemoryLocation memLoc, dest=untaggedResReg, kind=MoveFloat}) | FPModeSSE2 => BlockSimple(SSE2FPUnary { source=MemoryLocation memLoc, resultReg=untaggedResReg, opc=SSE2UFloatToDouble}) in (codeBaseIndex @ codeUntag @ [loadArg, BlockSimple(BoxValue{boxKind=boxFloat, source=untaggedResReg, dest=target, saveRegs=[]})], RegisterArgument target, false) end | codeToICodeLoad({kind=LoadStoreCDouble, address}, context, _, destination) = let val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeCAddress(address, 0w8, context) val untaggedResReg = newUReg() val boxFloat = case fpMode of FPModeX87 => BoxX87Double | FPModeSSE2 => BoxSSE2Double in (codeBaseIndex @ codeUntag @ [BlockSimple(LoadArgument { source=MemoryLocation memLoc, dest=untaggedResReg, kind=MoveDouble}), BlockSimple(BoxValue{boxKind=boxFloat, source=untaggedResReg, dest=target, saveRegs=[]})], RegisterArgument target, false) end | codeToICodeLoad({kind=LoadStoreUntaggedUnsigned, address}, context, _, destination) = let val target = asTarget destination val (codeBaseIndex, codeUntag, memLoc) = codeAddress(address, false, context) val untaggedResReg = newUReg() in (codeBaseIndex @ codeUntag @ [BlockSimple(LoadArgument { source=MemoryLocation memLoc, dest=untaggedResReg, kind=movePolyWord}), BlockSimple(TagValue {source=untaggedResReg, dest=target, isSigned=false, opSize=polyWordOpSize})], RegisterArgument target, false) end and codeToICodeStore({kind=LoadStoreMLWord _, address, value}, context, _, destination) = let val (sourceCode, source, _) = codeToICode(value, context, false, Allowed allowInMemMove) val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeAddress(address, false, context) val code = codeBaseIndex @ sourceCode @ codeUntag @ [BlockSimple(StoreArgument {source=source, base=base, offset=offset, index=index, kind=movePolyWord, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeStore({kind=LoadStoreMLByte _, address, value}, context, _, destination) = let val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeAddress(address, true, context) (* We have to untag the value to store. *) val (valueCode, untagValue, valueArg) = codeAsUntaggedByte(value, false, context) val code = codeBaseIndex @ valueCode @ untagValue @ codeUntag @ [BlockSimple(StoreArgument {source=valueArg, base=base, offset=offset, index=index, kind=MoveByte, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeStore({kind=LoadStoreC8, address, value}, context, _, destination) = let (* Store a byte to C memory. Almost exactly the same as LoadStoreMLByte. *) val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeCAddress(address, 0w1, context) val (valueCode, untagValue, valueArg) = codeAsUntaggedByte(value, false, context) val code = codeBaseIndex @ valueCode @ untagValue @ codeUntag @ [BlockSimple(StoreArgument {source=valueArg, base=base, offset=offset, index=index, kind=MoveByte, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeStore({kind=LoadStoreC16, address, value}, context, _, destination) = let (* Store a 16-bit value to C memory. *) val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeCAddress(address, 0w2, context) (* We don't currently implement 16-bit constant moves so this must always be in a reg. *) val (valueCode, untagValue, valueArg) = codeAsUntaggedToReg(value, false, context) val code = codeBaseIndex @ valueCode @ untagValue @ codeUntag @ [BlockSimple(StoreArgument {source=RegisterArgument valueArg, base=base, offset=offset, index=index, kind=Move16Bit, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeStore({kind=LoadStoreC32, address, value}, context, _, destination) = (* Store a 32-bit value. If this is 64-bit mode we untag it but if this is 32-bit mode we unbox it. *) let val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeCAddress(address, 0w4, context) val code = if targetArch = Native64Bit then let (* We don't currently implement 32-bit constant moves so this must always be in a reg. *) val (valueCode, untagValue, valueArg) = codeAsUntaggedToReg(value, false, context) in codeBaseIndex @ valueCode @ untagValue @ codeUntag @ [BlockSimple(StoreArgument {source=RegisterArgument valueArg, base=base, offset=offset, index=index, kind=Move32Bit, isMutable=true})] end else let val (valueCode, valueReg) = codeToPReg(value, context) val valueReg1 = newUReg() in codeBaseIndex @ valueCode @ BlockSimple(LoadArgument{source=wordAt valueReg, dest=valueReg1, kind=Move32Bit}) :: codeUntag @ [BlockSimple(StoreArgument {source=RegisterArgument valueReg1, base=base, offset=offset, index=index, kind=Move32Bit, isMutable=true})] end in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeStore({kind=LoadStoreC64, address, value}, context, _, destination) = let (* Store a 64-bit value. *) val _ = targetArch <> Native32Bit orelse raise InternalError "codeToICodeNonRev: BICStoreOperation LoadStoreC64 in 32-bit" val (valueCode, valueReg) = codeToPReg(value, context) val valueReg1 = newUReg() val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeCAddress(address, 0w8, context) val code = codeBaseIndex @ valueCode @ codeUntag @ [BlockSimple(LoadArgument{source=wordAt valueReg, dest=valueReg1, kind=Move64Bit}), BlockSimple(StoreArgument {source=RegisterArgument valueReg1, base=base, offset=offset, index=index, kind=Move64Bit, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeStore({kind=LoadStoreCFloat, address, value}, context, _, destination) = let val floatReg = newUReg() and float2Reg = newUReg() val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeCAddress(address, 0w4, context) val (valueCode, valueReg) = codeToPReg(value, context) (* If we're using an SSE2 reg we have to convert it from double to single precision. *) val (storeReg, cvtCode) = case fpMode of FPModeSSE2 => (float2Reg, [BlockSimple(SSE2FPUnary{opc=SSE2UDoubleToFloat, resultReg=float2Reg, source=RegisterArgument floatReg})]) | FPModeX87 => (floatReg, []) val code = codeBaseIndex @ valueCode @ codeUntag @ BlockSimple(LoadArgument{source=wordAt valueReg, dest=floatReg, kind=MoveDouble}) :: cvtCode @ [BlockSimple(StoreArgument {source=RegisterArgument storeReg, base=base, offset=offset, index=index, kind=MoveFloat, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeStore({kind=LoadStoreCDouble, address, value}, context, _, destination) = let val floatReg = newUReg() val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeCAddress(address, 0w8, context) val (valueCode, valueReg) = codeToPReg(value, context) val code = codeBaseIndex @ valueCode @ codeUntag @ [BlockSimple(LoadArgument{source=wordAt valueReg, dest=floatReg, kind=MoveDouble}), BlockSimple(StoreArgument {source=RegisterArgument floatReg, base=base, offset=offset, index=index, kind=MoveDouble, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | codeToICodeStore({kind=LoadStoreUntaggedUnsigned, address, value}, context, _, destination) = let (* We have to untag the value to store. *) val (codeBaseIndex, codeUntag, {base, offset, index, ...}) = codeAddress(address, false, context) (* See if it's a constant. This is frequently used to set the last word of a string to zero. *) (* We have to be a bit more careful on the X86. We use moves to store constants that can include addresses. To avoid problems we only use a move if the value is zero or odd and so looks like a tagged value. *) val storeAble = case value of BICConstnt(value, _) => if not(isShort value) then NONE else let val ival = Word.toLargeIntX(toShort value) in if targetArch = Native64Bit then if is32bit ival then SOME ival else NONE else if ival = 0 orelse ival mod 2 = 1 then SOME ival else NONE end | _ => NONE val (storeVal, valCode) = case storeAble of SOME value => (IntegerConstant value (* Leave untagged *), []) | NONE => let val valueReg = newPReg() and valueReg1 = newUReg() in (RegisterArgument valueReg1, codeToICodeTarget(value, context, false, valueReg) @ [BlockSimple(UntagValue{dest=valueReg1, source=valueReg, isSigned=false, cache=NONE, opSize=polyWordOpSize})]) end val code = codeBaseIndex @ valCode @ codeUntag @ [BlockSimple(StoreArgument {source=storeVal, base=base, offset=offset, index=index, kind=movePolyWord, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end and codeToICodeBlock({kind=BlockOpCompareByte, sourceLeft, destRight, length}, context, _, destination) = let (* This is effectively a big-endian comparison since we compare the bytes until we find an inequality. *) val target = asTarget destination val mergeResult = newMergeReg() val vec1Reg = newUReg() and vec2Reg = newUReg() val (leftCode, leftUntag, {base=leftBase, offset=leftOffset, index=leftIndex, ...}) = codeAddress(sourceLeft, true, context) val (rightCode, rightUntag, {base=rightBase, offset=rightOffset, index=rightIndex, ...}) = codeAddress(destRight, true, context) val ccRef = newCCRef() val labLess = newLabel() and labGreater = newLabel() and exitLab = newLabel() val labNotLess = newLabel() and labNotGreater = newLabel() val (lengthCode, lengthUntag, lengthArg) = codeAsUntaggedToReg(length, false (* unsigned *), context) val code = leftCode @ rightCode @ lengthCode @ leftUntag @ [BlockSimple(loadAddress{base=leftBase, offset=leftOffset, index=leftIndex, dest=vec1Reg})] @ rightUntag @ [BlockSimple(loadAddress{base=rightBase, offset=rightOffset, index=rightIndex, dest=vec2Reg})] @ lengthUntag @ [BlockSimple(CompareByteVectors{ vec1Addr=vec1Reg, vec2Addr=vec2Reg, length=lengthArg, ccRef=ccRef }), (* N.B. These are unsigned comparisons. *) BlockFlow(Conditional{ ccRef=ccRef, condition=JB, trueJump=labLess, falseJump=labNotLess }), BlockLabel labNotLess, BlockFlow(Conditional{ ccRef=ccRef, condition=JA, trueJump=labGreater, falseJump=labNotGreater }), BlockLabel labNotGreater, BlockSimple(LoadArgument{ source=IntegerConstant(tag 0), dest=mergeResult, kind=movePolyWord }), BlockFlow(Unconditional exitLab), BlockLabel labLess, BlockSimple(LoadArgument{ source=IntegerConstant(tag ~1), dest=mergeResult, kind=movePolyWord }), BlockFlow(Unconditional exitLab), BlockLabel labGreater, BlockSimple(LoadArgument{ source=IntegerConstant(tag 1), dest=mergeResult, kind=movePolyWord }), BlockLabel exitLab, BlockSimple(LoadArgument{ source=RegisterArgument mergeResult, dest=target, kind=movePolyWord })] in (code, RegisterArgument target, false) end | codeToICodeBlock({kind=BlockOpMove {isByteMove}, sourceLeft, destRight, length}, context, _, destination) = let (* Moves of 4 or 8 bytes can be done as word moves provided the alignment is correct. Although this will work for strings it is really to handle moves between SysWord and volatileRef in Foreign.Memory. Moves of 1, 2 or 3 bytes or words are converted into a sequence of byte or word moves. *) val isWordMove = case (isByteMove, length) of (true, BICConstnt(l, _)) => if not (isShort l) orelse (toShort l <> 0w4 andalso toShort l <> nativeWordSize) then NONE else let val leng = toShort l val moveKind = if toShort l = nativeWordSize then moveNativeWord else Move32Bit val isLeftAligned = case sourceLeft of {index=NONE, offset, ...} => offset mod leng = 0w0 | _ => false val isRightAligned = case destRight of {index=NONE, offset, ...} => offset mod leng = 0w0 | _ => false in if isLeftAligned andalso isRightAligned then SOME moveKind else NONE end | _ => NONE in case isWordMove of SOME moveKind => let val (leftCode, leftUntag, leftMem) = codeAddress(sourceLeft, isByteMove, context) val (rightCode, rightUntag, {base, offset, index, ...}) = codeAddress(destRight, isByteMove, context) val untaggedResReg = newUReg() val code = leftCode @ rightCode @ leftUntag @ rightUntag @ [BlockSimple(LoadArgument { source=MemoryLocation leftMem, dest=untaggedResReg, kind=moveKind}), BlockSimple(StoreArgument {source=RegisterArgument untaggedResReg, base=base, offset=offset, index=index, kind=moveKind, isMutable=true})] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end | _ => let val vec1Reg = newUReg() and vec2Reg = newUReg() val (leftCode, leftUntag, {base=leftBase, offset=leftOffset, index=leftIndex, ...}) = codeAddress(sourceLeft, isByteMove, context) val (rightCode, rightUntag, {base=rightBase, offset=rightOffset, index=rightIndex, ...}) = codeAddress(destRight, isByteMove, context) val (lengthCode, lengthUntag, lengthArg) = codeAsUntaggedToReg(length, false (* unsigned *), context) val code = leftCode @ rightCode @ lengthCode @ leftUntag @ [BlockSimple(loadAddress{base=leftBase, offset=leftOffset, index=leftIndex, dest=vec1Reg})] @ rightUntag @ [BlockSimple(loadAddress{base=rightBase, offset=rightOffset, index=rightIndex, dest=vec2Reg})] @ lengthUntag @ [BlockSimple(BlockMove{ srcAddr=vec1Reg, destAddr=vec2Reg, length=lengthArg, isByteMove=isByteMove })] in moveIfNotAllowed(destination, code, (* Unit result *) IntegerConstant(tag 0)) end end | codeToICodeBlock({kind=BlockOpEqualByte, ...}, _, _, _) = (* TODO: Move the code from codeToICodeRev. However, that is already reversed. *) raise InternalError "codeToICodeBlock - BlockOpEqualByte" (* Already done *) and codeConditionRev(condition, context, jumpOn, jumpLabel, tailCode) = (* General case. Load the value into a register and compare it with 1 (true) *) let val ccRef = newCCRef() val (testCode, testReg) = codeToPRegRev(condition, context, tailCode) val noJumpLabel = newLabel() in BlockLabel noJumpLabel :: BlockFlow(Conditional{ccRef=ccRef, condition=if jumpOn then JE else JNE, trueJump=jumpLabel, falseJump=noJumpLabel}) :: BlockSimple(CompareLiteral{arg1=RegisterArgument testReg, arg2=tag 1, opSize=OpSize32, ccRef=ccRef}) :: testCode end (* The fixed precision functions are also used for arbitrary precision but instead of raising Overflow we need to jump to the code that handles the long format. *) and codeFixedPrecisionArith(BuiltIns.ArithAdd, arg1, BICConstnt(value, _), context, target, onOverflow) = let val ccRef = newCCRef() (* If the argument is a constant we can subtract the tag beforehand. This should always be a tagged value if the type is correct. However it's possible for it not to be if we have an arbitrary precision value. There will be a run-time check that the value is short and so this code will never be executed. It will generally be edited out by the higher level be we can't rely on that. Because it's never executed we can just put in zero. *) val constVal = if isShort value then semitag(Word.toLargeIntX(toShort value)) else 0 val (arg1Code, aReg1) = codeToPReg(arg1, context) in arg1Code @ [BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=aReg1, operand2=IntegerConstant constVal, ccRef=ccRef, opSize=polyWordOpSize})] @ onOverflow ccRef end | codeFixedPrecisionArith(BuiltIns.ArithAdd, BICConstnt(value, _), arg2, context, target, onOverflow) = let val ccRef = newCCRef() (* If the argument is a constant we can subtract the tag beforehand. Check for short - see comment above. *) val constVal = if isShort value then semitag(Word.toLargeIntX(toShort value)) else 0 val (arg2Code, aReg2) = codeToPReg(arg2, context) in arg2Code @ [BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=aReg2, operand2=IntegerConstant constVal, ccRef=ccRef, opSize=polyWordOpSize})] @ onOverflow ccRef end | codeFixedPrecisionArith(BuiltIns.ArithAdd, arg1, arg2, context, target, onOverflow) = let val aReg3 = newPReg() and ccRef = newCCRef() val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) in arg1Code @ arg2Code @ (* Subtract the tag bit from the second argument, do the addition and check for overflow. *) (* TODO: We should really do the detagging in the transform phase. It can make a better choice of the argument if one of the arguments is already untagged or if we have a constant argument. *) [BlockSimple(ArithmeticFunction{oper=SUB, resultReg=aReg3, operand1=aReg1, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize}), BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=aReg3, operand2=RegisterArgument aReg2, ccRef=ccRef, opSize=polyWordOpSize})] @ onOverflow ccRef end (* Subtraction. We can handle the special case of the second argument being a constant but not the first. *) | codeFixedPrecisionArith(BuiltIns.ArithSub, arg1, BICConstnt(value, _), context, target, onOverflow) = let val ccRef = newCCRef() (* If the argument is a constant we can subtract the tag beforehand. Check for short - see comment above. *) val constVal = if isShort value then semitag(Word.toLargeIntX(toShort value)) else 0 val (arg1Code, aReg1) = codeToPReg(arg1, context) in arg1Code @ [BlockSimple(ArithmeticFunction{oper=SUB, resultReg=target, operand1=aReg1, operand2=IntegerConstant constVal, ccRef=ccRef, opSize=polyWordOpSize})] @ onOverflow ccRef end | codeFixedPrecisionArith(BuiltIns.ArithSub, arg1, arg2, context, target, onOverflow) = let val aReg3 = newPReg() val ccRef = newCCRef() val (arg1Code, aReg1) = codeToPReg(arg1, context) val (arg2Code, aReg2) = codeToPReg(arg2, context) in arg1Code @ arg2Code @ (* Do the subtraction, test for overflow and afterwards add in the tag bit. *) [BlockSimple(ArithmeticFunction{oper=SUB, resultReg=aReg3, operand1=aReg1, operand2=RegisterArgument aReg2, ccRef=ccRef, opSize=polyWordOpSize})] @ onOverflow ccRef @ [BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=aReg3, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize})] end | codeFixedPrecisionArith(BuiltIns.ArithMult, arg1, BICConstnt(value, _), context, target, onOverflow) = let val aReg = newPReg() and argUntagged = newUReg() and resUntagged = newUReg() val mulCC = newCCRef() (* Is it better to untag the constant or the register argument? *) val constVal = if isShort value then Word.toLargeIntX(toShort value) else 0 in codeToICodeTarget(arg1, context, false, aReg) @ [BlockSimple(ArithmeticFunction{oper=SUB, resultReg=argUntagged, operand1=aReg, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize}), BlockSimple(Multiplication{resultReg=resUntagged, operand1=argUntagged, operand2=IntegerConstant constVal, ccRef=mulCC, opSize=polyWordOpSize} )] @ onOverflow mulCC @ [BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=resUntagged, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize})] end | codeFixedPrecisionArith(BuiltIns.ArithMult, BICConstnt(value, _), arg2, context, target, onOverflow) = let val aReg = newPReg() and argUntagged = newUReg() and resUntagged = newUReg() val mulCC = newCCRef() (* Is it better to untag the constant or the register argument? *) val constVal = if isShort value then Word.toLargeIntX(toShort value) else 0 in codeToICodeTarget(arg2, context, false, aReg) @ [BlockSimple(ArithmeticFunction{oper=SUB, resultReg=argUntagged, operand1=aReg, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize}), BlockSimple(Multiplication{resultReg=resUntagged, operand1=argUntagged, operand2=IntegerConstant constVal, ccRef=mulCC, opSize=polyWordOpSize} )] @ onOverflow mulCC @ [BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=resUntagged, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize})] end | codeFixedPrecisionArith(BuiltIns.ArithMult, arg1, arg2, context, target, onOverflow) = let val aReg1 = newPReg() and aReg2 = newPReg() and arg1Untagged = newUReg() and arg2Untagged = newUReg() and resUntagged = newUReg() val mulCC = newCCRef() (* This is almost the same as the word operation except we use a signed shift and check for overflow. *) in codeToICodeTarget(arg1, context, false, aReg1) @ codeToICodeTarget(arg2, context, false, aReg2) @ (* Shift one argument and subtract the tag from the other. It's possible this could be reordered if we have a value that is already untagged. *) [BlockSimple(UntagValue{source=aReg1, dest=arg1Untagged, isSigned=true (* Signed shift here. *), cache=NONE, opSize=polyWordOpSize}), BlockSimple(ArithmeticFunction{oper=SUB, resultReg=arg2Untagged, operand1=aReg2, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize}), BlockSimple(Multiplication{resultReg=resUntagged, operand1=arg1Untagged, operand2=RegisterArgument arg2Untagged, ccRef=mulCC, opSize=polyWordOpSize} )] @ onOverflow mulCC @ [BlockSimple(ArithmeticFunction{oper=ADD, resultReg=target, operand1=resUntagged, operand2=IntegerConstant 1, ccRef=newCCRef(), opSize=polyWordOpSize})] end | codeFixedPrecisionArith(BuiltIns.ArithQuot, arg1, arg2, context, target, _) = let val aReg1 = newPReg() and aReg2 = newPReg() val arg1Untagged = newUReg() and arg2Untagged = newUReg() val quotient = newUReg() and remainder = newUReg() in codeToICodeTarget(arg1, context, false, aReg1) @ codeToICodeTarget(arg2, context, false, aReg2) @ (* Shift both of the arguments to remove the tags. We don't test for zero here - that's done explicitly. *) [BlockSimple(UntagValue{source=aReg1, dest=arg1Untagged, isSigned=true, cache=NONE, opSize=polyWordOpSize}), BlockSimple(UntagValue{source=aReg2, dest=arg2Untagged, isSigned=true, cache=NONE, opSize=polyWordOpSize}), BlockSimple(Division { isSigned = true, dividend=arg1Untagged, divisor=RegisterArgument arg2Untagged, quotient=quotient, remainder=remainder, opSize=polyWordOpSize }), BlockSimple(TagValue { source=quotient, dest=target, isSigned=true, opSize=polyWordOpSize})] end | codeFixedPrecisionArith(BuiltIns.ArithRem, arg1, arg2, context, target, _) = let (* Identical to Quot except that the result is the remainder. *) val aReg1 = newPReg() and aReg2 = newPReg() val arg1Untagged = newUReg() and arg2Untagged = newUReg() val quotient = newUReg() and remainder = newUReg() in codeToICodeTarget(arg1, context, false, aReg1) @ codeToICodeTarget(arg2, context, false, aReg2) @ (* Shift both of the arguments to remove the tags. *) [BlockSimple(UntagValue{source=aReg1, dest=arg1Untagged, isSigned=true, cache=NONE, opSize=polyWordOpSize}), BlockSimple(UntagValue{source=aReg2, dest=arg2Untagged, isSigned=true, cache=NONE, opSize=polyWordOpSize}), BlockSimple(Division { isSigned = true, dividend=arg1Untagged, divisor=RegisterArgument arg2Untagged, quotient=quotient, remainder=remainder, opSize=polyWordOpSize }), BlockSimple(TagValue { source=remainder, dest=target, isSigned=true, opSize=polyWordOpSize})] end | codeFixedPrecisionArith(_, _, _, _, _, _) = raise InternalError "codeToICode: FixedPrecisionArith - unimplemented operation" (* Generate code for floating point arguments where one of the arguments must be in a register. If the first argument is in a register use that, if the second is in a register and it's commutative use that otherwise load the first argument into a register. *) and codeFPBinaryArgsRev(arg1, arg2, precision, commutative, context, tailCode) = let val (arg1Code, arg1Value) = codeFPArgument(arg1, precision, context, tailCode) val (arg2Code, arg2Value) = codeFPArgument(arg2, precision, context, arg1Code) in case (arg1Value, arg2Value, commutative) of (RegisterArgument fpReg, _, _) => (arg2Code, fpReg, arg2Value) | (_, RegisterArgument fpReg, Commutative) => (arg2Code, fpReg, arg1Value) | (arg1Val, _, _) => let val fpReg = newUReg() val moveOp = case precision of BuiltIns.PrecDouble => MoveDouble | BuiltIns.PrecSingle => MoveFloat in (BlockSimple(LoadArgument{source=arg1Val, dest=fpReg, kind=moveOp}) :: arg2Code, fpReg, arg2Value) end end (* Generate code to evaluate a floating point argument. The aim of this code is to avoid the overhead of untagging a short-precision floating point value in memory. *) and codeFPArgument(BICConstnt(value, _), _, _, tailCode) = let val argVal = (* Single precision constants in 64-bit mode are represented by the value shifted left 32 bits. A word is shifted left one bit so the result is 0w31. *) if isShort value then IntegerConstant(Word.toLargeInt(Word.>>(toShort value, 0w31))) else AddressConstant value in (tailCode, argVal) end | codeFPArgument(arg, precision, context, tailCode) = ( case (precision, wordSize) of (BuiltIns.PrecSingle, 0w8) => (* If this is a single precision value and the word size is 8 the values are tagged. If it is memory we can load the value directly from the high-order word. *) let val memOrReg = { anyConstant=false, const32s=false, memAddr=true, existingPreg=true } val (code, result, _) = codeToICodeRev(arg, context, false, Allowed memOrReg, tailCode) in case result of RegisterArgument argReg => let val fpReg = newUReg() in (BlockSimple(UntagFloat{source=RegisterArgument argReg, dest=fpReg, cache=NONE}) :: code, RegisterArgument fpReg) end | MemoryLocation{offset, base, index, ...} => (code, MemoryLocation{offset=offset+4, base=base, index=index, cache=NONE}) | _ => raise InternalError "codeFPArgument" end | _ => (* Otherwise the value is boxed. *) let val (argCode, argReg) = codeToPRegRev(arg, context, tailCode) in (argCode, wordAt argReg) end ) (* Code an address. The index is optional. *) and codeAddressRev({base, index=SOME index, offset}, true (* byte move *), context, tailCode) = let (* Byte address with index. The index needs to be untagged. *) val indexReg1 = newUReg() val (codeBase, baseReg) = codeToPRegRev(base, context, tailCode) val (codeIndex, indexReg) = codeToPRegRev(index, context, codeBase) val untagCode = [BlockSimple(UntagValue{dest=indexReg1, source=indexReg, isSigned=false, cache=NONE, opSize=polyWordOpSize})] val (codeLoadAddr, realBase) = if targetArch = ObjectId32Bit then let val addrReg = newUReg() in ([BlockSimple(LoadEffectiveAddress{ base=SOME baseReg, offset=0, index=ObjectIndex, dest=addrReg, opSize=nativeWordOpSize})], addrReg) end else ([], baseReg) val memResult = {base=realBase, offset=Word.toInt offset, index=MemIndex1 indexReg1, cache=NONE} in (codeLoadAddr @ codeIndex, untagCode, memResult) end | codeAddressRev({base, index=SOME index, offset}, false (* word move *), context, tailCode) = let (* Word address with index. We can avoid untagging the index by adjusting the multiplier and offset *) val (codeBase, baseReg) = codeToPRegRev(base, context, tailCode) val (codeIndex, indexReg) = codeToPRegRev(index, context, codeBase) val (codeLoadAddr, realBase) = if targetArch = ObjectId32Bit then let val addrReg = newUReg() in ([BlockSimple(LoadEffectiveAddress{ base=SOME baseReg, offset=0, index=ObjectIndex, dest=addrReg, opSize=nativeWordOpSize})], addrReg) end else ([], baseReg) val memResult = if wordSize = 0w8 then {base=realBase, offset=Word.toInt offset-4, index=MemIndex4 indexReg, cache=NONE} else {base=realBase, offset=Word.toInt offset-2, index=MemIndex2 indexReg, cache=NONE} in (codeLoadAddr @ codeIndex, [], memResult) end | codeAddressRev({base, index=NONE, offset}, _, context, tailCode) = let val (codeBase, baseReg) = codeToPRegRev(base, context, tailCode) val memResult = {offset=Word.toInt offset, base=baseReg, index=memIndexOrObject, cache=NONE} in (codeBase, [], memResult) end and codeAddress(addr, isByte, context) = let val (code, untag, res) = codeAddressRev(addr, isByte, context, []) in (List.rev code, untag, res) end (* C-memory operations are slightly different. The base address is a LargeWord.word value. The index is a byte index so may have to be untagged. *) and codeCAddress({base, index=SOME index, offset}, 0w1, context) = let (* Byte address with index. The index needs to be untagged. *) val untaggedBaseReg = newUReg() and indexReg1 = newUReg() val (codeBase, baseReg) = codeToPReg(base, context) and (codeIndex, indexReg) = codeToPReg(index, context) val untagCode = [BlockSimple(LoadArgument{source=wordAt baseReg, dest=untaggedBaseReg, kind=moveNativeWord}), BlockSimple(UntagValue{dest=indexReg1, source=indexReg, isSigned=false, cache=NONE, opSize=polyWordOpSize})] val memResult = {base=untaggedBaseReg, offset=Word.toInt offset, index=MemIndex1 indexReg1, cache=NONE} in (codeBase @ codeIndex, untagCode, memResult) end | codeCAddress({base, index=SOME index, offset}, size, context) = let (* Non-byte address with index. By using an appropriate multiplier we can avoid having to untag the index. *) val untaggedBaseReg = newUReg() val (codeBase, baseReg) = codeToPReg(base, context) and (codeIndex, indexReg) = codeToPReg(index, context) val untagCode = [BlockSimple(LoadArgument{source=wordAt baseReg, dest=untaggedBaseReg, kind=moveNativeWord})] val memResult = case size of 0w2 => {base=untaggedBaseReg, offset=Word.toInt offset-1, index=MemIndex1 indexReg, cache=NONE} | 0w4 => {base=untaggedBaseReg, offset=Word.toInt offset-2, index=MemIndex2 indexReg, cache=NONE} | 0w8 => {base=untaggedBaseReg, offset=Word.toInt offset-4, index=MemIndex4 indexReg, cache=NONE} | _ => raise InternalError "codeCAddress: unknown size" in (codeBase @ codeIndex, untagCode, memResult) end | codeCAddress({base, index=NONE, offset}, _, context) = let val untaggedBaseReg = newUReg() val (codeBase, baseReg) = codeToPReg(base, context) val untagCode = [BlockSimple(LoadArgument{source=wordAt baseReg, dest=untaggedBaseReg, kind=moveNativeWord})] val memResult = {offset=Word.toInt offset, base=untaggedBaseReg, index=NoMemIndex, cache=NONE} in (codeBase, untagCode, memResult) end (* Return an untagged value. If we have a constant just return it. Otherwise return the code to evaluate the argument, the code to untag it and the reference to the untagged register. *) and codeAsUntaggedToRegRev(BICConstnt(value, _), isSigned, _, tailCode) = let (* Should always be short except for unreachable code. *) val untagReg = newUReg() val cval = if isShort value then toShort value else 0w0 val cArg = IntegerConstant(if isSigned then Word.toLargeIntX cval else Word.toLargeInt cval) (* Don't tag *) val untag = [BlockSimple(LoadArgument{source=cArg, dest=untagReg, kind=movePolyWord})] in (tailCode, untag, untagReg) (* Don't tag. *) end | codeAsUntaggedToRegRev(arg, isSigned, context, tailCode) = let val untagReg = newUReg() val (code, srcReg) = codeToPRegRev(arg, context, tailCode) val untag = [BlockSimple(UntagValue{source=srcReg, dest=untagReg, isSigned=isSigned, cache=NONE, opSize=polyWordOpSize})] in (code, untag, untagReg) end and codeAsUntaggedToReg(arg, isSigned, context) = let val (code, untag, untagReg) = codeAsUntaggedToRegRev(arg, isSigned, context, []) in (List.rev code, untag, untagReg) end (* Return the argument as an untagged value. We separate evaluating the argument from untagging because we may have to evaluate other arguments and that could involve a function call and we can't save the value to the stack after we've untagged it. Currently this is only used for byte values but we may have to be careful if we use it for word values on the X86. Moving an untagged value into a register might look like loading a constant address. *) and codeAsUntaggedByte(BICConstnt(value, _), isSigned, _) = let val cval = if isShort value then toShort value else 0w0 val cArg = IntegerConstant(if isSigned then Word.toLargeIntX cval else Word.toLargeInt cval) (* Don't tag *) in ([], [], cArg) end | codeAsUntaggedByte(arg, isSigned, context) = let val untagReg = newUReg() val (code, argReg) = codeToPReg(arg, context) val untag = [BlockSimple(UntagValue{source=argReg, dest=untagReg, isSigned=isSigned, cache=NONE, opSize=OpSize32})] in (code, untag, RegisterArgument untagReg) end (* Allocate memory. This is used both for true variable length cells and also for longer constant length cells. *) and allocateMemoryVariable(numWords, flags, initial, context, destination) = let val target = asTarget destination (* With the exception of flagReg all these registers are modified by the code. So, we have to copy the size value into a new register. *) val sizeReg = newPReg() and initReg = newPReg() val sizeReg2 = newPReg() val untagSizeReg = newUReg() and initAddrReg = newPReg() and allocReg = newPReg() val sizeCode = codeToICodeTarget(numWords, context, false, sizeReg) and (flagsCode, flagUntag, flagArg) = codeAsUntaggedByte(flags, false, context) (* We're better off deferring the initialiser if possible. If the value is a constant we don't have to save it. *) val (initCode, initResult, _) = codeToICode(initial, context, false, Allowed allowDefer) in (sizeCode @ flagsCode @ initCode @ [(* We need to copy the size here because AllocateMemoryVariable modifies the size in order to store the length word. This is unfortunate especially as we're going to untag it anyway. *) BlockSimple(LoadArgument{source=RegisterArgument sizeReg, dest=sizeReg2, kind=movePolyWord}), BlockSimple(AllocateMemoryVariable{size=sizeReg, dest=allocReg, saveRegs=[]})] @ flagUntag @ [BlockSimple(StoreArgument{ source=flagArg, base=allocReg, offset= ~1, index=memIndexOrObject, kind=MoveByte, isMutable=false}), (* We need to copy the address here because InitialiseMem modifies all its arguments. *) BlockSimple( if targetArch = ObjectId32Bit then LoadEffectiveAddress{ base=SOME allocReg, offset=0, index=ObjectIndex, dest=initAddrReg, opSize=nativeWordOpSize} else LoadArgument{source=RegisterArgument allocReg, dest=initAddrReg, kind=movePolyWord}), BlockSimple(UntagValue{source=sizeReg2, dest=untagSizeReg, isSigned=false, cache=NONE, opSize=polyWordOpSize}), BlockSimple(LoadArgument{source=initResult, dest=initReg, kind=movePolyWord}), BlockSimple(InitialiseMem{size=untagSizeReg, init=initReg, addr=initAddrReg}), BlockSimple InitialisationComplete, BlockSimple(LoadArgument{source=RegisterArgument allocReg, dest=target, kind=movePolyWord})], RegisterArgument target, false) end (*Turn the codetree structure into icode. *) val bodyContext = {loopArgs=NONE, stackPtr=0, currHandler=NONE, overflowBlock=ref NONE} val (bodyCode, _, bodyExited) = codeToICodeRev(body, bodyContext, true, SpecificPReg resultTarget, beginInstructions) val icode = if bodyExited then bodyCode else returnInstruction(bodyContext, resultTarget, bodyCode) (* Turn the icode list into basic blocks. The input list is in reverse so as part of this we reverse the list. *) local val resArray = Array.array(!labelCounter, BasicBlock{ block=[], flow=ExitCode }) fun createEntry (blockNo, block, flow) = Array.update(resArray, blockNo, BasicBlock{ block=block, flow=flow}) fun splitCode([], _, _) = (* End of code. We should have had a BeginFunction. *) raise InternalError "splitCode - no begin" | splitCode(BlockBegin args :: _, sinceLabel, flow) = (* Final instruction. Create the initial block and exit. *) createEntry(0, BeginFunction args ::sinceLabel, flow) | splitCode(BlockSimple instr :: rest, sinceLabel, flow) = splitCode(rest, instr :: sinceLabel, flow) | splitCode(BlockLabel label :: rest, sinceLabel, flow) = (* Label - finish this block and start another. *) ( createEntry(label, sinceLabel, flow); (* Default to a jump to this label. That is used if we have assumed a drop-through. *) splitCode(rest, [], Unconditional label) ) | splitCode(BlockExit instr :: rest, _, _) = splitCode(rest, [instr], ExitCode) | splitCode(BlockFlow flow :: rest, _, _) = splitCode(rest, [], flow) | splitCode(BlockRaiseAndHandle(instr, handler) :: rest, _, _) = splitCode(rest, [instr], UnconditionalHandle handler) | splitCode(BlockOptionalHandle{call, handler, label} :: rest, sinceLabel, flow) = let (* A function call within a handler. This could go to the handler but if there is no exception will go to the next instruction. Also includes JumpLoop since the stack check could result in an Interrupt exception. *) in createEntry(label, sinceLabel, flow); splitCode(rest, [call], ConditionalHandle{handler=handler, continue=label}) end in val () = splitCode(icode, [], ExitCode) val resultVector = Array.vector resArray end open ICODETRANSFORM val pregProperties = Vector.fromList(List.rev(! pregPropList)) in codeICodeFunctionToX86{blocks = resultVector, functionName = name, pregProps = pregProperties, ccCount= ! ccRefCounter, debugSwitches = debugSwitches, resultClosure = resultClosure} end fun gencodeLambda(lambda, debugSwitches, closure) = let open DEBUG Universal (*val debugSwitches = [tagInject Pretty.compilerOutputTag (Pretty.prettyPrint(print, 70)), tagInject assemblyCodeTag true] @ debugSwitches*) in codeFunctionToX86(lambda, debugSwitches, closure) end structure Foreign = X86FOREIGN structure Sharing = struct type backendIC = backendIC and bicLoadForm = bicLoadForm and argumentType = argumentType and closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml b/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml index f29cc207..bef85146 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml @@ -1,1190 +1,1100 @@ (* Copyright (c) 2016-19 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor X86FOREIGNCALL( structure X86CODE: X86CODESIG structure X86OPTIMISE: sig type operation type code type operations = operation list type closureRef (* Optimise and code-generate. *) val generateCode: {code: code, ops: operations, labelCount: int, resultClosure: closureRef} -> unit structure Sharing: sig type operation = operation type code = code type closureRef = closureRef end end structure DEBUG: DEBUGSIG structure CODE_ARRAY: CODEARRAYSIG sharing X86CODE.Sharing = X86OPTIMISE.Sharing = CODE_ARRAY.Sharing ): FOREIGNCALLSIG = struct open X86CODE open Address open CODE_ARRAY + + (* Unix X64. The first six arguments are in rdi, rsi, rdx, rcx, r8, r9. + The rest are on the stack. + Windows X64. The first four arguments are in rcx, rdx, r8 and r9. The rest are + on the stack. The caller must ensure the stack is aligned on 16-byte boundary + and must allocate 32-byte save area for the register args. + rbx, rbp, rdi, rsi, rsp, r12-r15 are saved by the called function. + X86/32. Arguments are pushed to the stack. + ebx, edi, esi, ebp and esp are saved by the called function. + We use esi to hold the argument data pointer and edi to save the ML stack pointer + Our ML conventions use eax, ebx for the first two arguments in X86/32, + rax, ebx, r8, r9, r10 for the first five arguments in X86/64 and + rax, rsi, r8, r9 and r10 for the first five arguments in X86/64-32 bit. + *) val memRegSize = 0 - + val (polyWordOpSize, nativeWordOpSize) = case targetArch of Native32Bit => (OpSize32, OpSize32) | Native64Bit => (OpSize64, OpSize64) | ObjectId32Bit => (OpSize32, OpSize64) (* Ebx/Rbx is used for the second argument on the native architectures but is replaced by esi on the object ID arch because ebx is used as the global base register. *) val mlArg2Reg = case targetArch of ObjectId32Bit => esi | _ => ebx exception InternalError = Misc.InternalError fun opSizeToMove OpSize32 = Move32 | opSizeToMove OpSize64 = Move64 val pushR = PushToStack o RegisterArg fun moveRR{source, output, opSize} = Move{source=RegisterArg source, destination=RegisterArg output, moveSize=opSizeToMove opSize} fun loadMemory(reg, base, offset, opSize) = Move{source=MemoryArg{base=base, offset=offset, index=NoIndex}, destination=RegisterArg reg, moveSize=opSizeToMove opSize} and storeMemory(reg, base, offset, opSize) = Move{source=RegisterArg reg, destination=MemoryArg {base=base, offset=offset, index=NoIndex}, moveSize=opSizeToMove opSize} val loadHeapMemory = case targetArch of ObjectId32Bit => ( fn (reg, base, offset, opSize) => Move{source=MemoryArg{base=ebx, offset=offset, index=Index4 base}, destination=RegisterArg reg, moveSize=opSizeToMove opSize} ) | _ => loadMemory fun loadAddress{source=(srcReg, 0), destination} = Move{source=RegisterArg srcReg, destination=RegisterArg destination, moveSize=opSizeToMove nativeWordOpSize} | loadAddress{source=(srcReg, srcOffset), destination} = LoadAddress{offset=srcOffset, base=SOME srcReg, index=NoIndex, output=destination, opSize=nativeWordOpSize } (* Sequence of operations to move memory. *) fun moveMemory{source, destination, length} = [ loadAddress{source=source, destination=rsi}, loadAddress{source=destination, destination=rdi}, Move{source=NonAddressConstArg(LargeInt.fromInt length), destination=RegisterArg rcx, moveSize=opSizeToMove nativeWordOpSize}, RepeatOperation MOVS8 ] fun createProfileObject _ (*functionName*) = let (* The profile object is a single mutable with the F_bytes bit set. *) open Address val profileObject = RunCall.allocateByteMemory(0w1, Word.fromLargeWord(Word8.toLargeWord(Word8.orb(F_mutable, F_bytes)))) fun clear 0w0 = () | clear i = (assignByte(profileObject, i-0w1, 0w0); clear (i-0w1)) val () = clear wordSize in toMachineWord profileObject end val makeEntryPoint: string -> machineWord = RunCall.rtsCallFull1 "PolyCreateEntryPointObject" datatype abi = X86_32 | X64Win | X64Unix local (* Get the ABI. On 64-bit Windows and Unix use different calling conventions. *) val getABICall: unit -> int = RunCall.rtsCallFast0 "PolyGetABI" in fun getABI() = case getABICall() of 0 => X86_32 | 1 => X64Unix | 2 => X64Win | n => raise InternalError ("Unknown ABI type " ^ Int.toString n) end - val noException = 1 + (* This is now the standard entry call code. *) + datatype fastArgs = FastArgFixed | FastArgDouble | FastArgFloat + - (* Full RTS call version. An extra argument is passed that contains the thread ID. - This allows the taskData object to be found which is needed if the code allocates - any ML memory or raises an exception. It also saves the stack and heap pointers - in case of a GC. *) - fun rtsCallFull (functionName, nArgs (* Not counting the thread ID *), debugSwitches) = + fun rtsCallFastGeneral (functionName, argFormats, (*resultFormat*) _, debugSwitches) = let val entryPointAddr = makeEntryPoint functionName (* Get the ABI. On 64-bit Windows and Unix use different calling conventions. *) val abi = getABI() - (* Branch to check for exception. *) - val exLabel = Label{labelNo=0} (* There's just one label in this function. *) - - (* Unix X64. The first six arguments are in rdi, rsi, rdx, rcx, r8, r9. - The rest are on the stack. - Windows X64. The first four arguments are in rcx, rdx, r8 and r9. The rest are - on the stack. The caller must ensure the stack is aligned on 16-byte boundary - and must allocate 32-byte save area for the register args. - rbx, rbp, rdi, rsi, rsp, r12-r15 are saved by the called function. - X86/32. Arguments are pushed to the stack. - ebx, edi, esi, ebp and esp are saved by the called function. - We use esi to hold the argument data pointer and edi to save the ML stack pointer - Our ML conventions use eax, ebx for the first two arguments in X86/32, - rax, ebx, r8, r9, r10 for the first five arguments in X86/64 and - rax, rsi, r8, r9 and r10 for the first five arguments in X86/64-32 bit. - *) - - (* Previously the ML stack pointer was saved in a callee-save register. This works - in almost all circumstances except when a call to the FFI code results in a callback - and the callback moves the ML stack. Instead the RTS callback handler adjusts the value - in memRegStackPtr and we reload the ML stack pointer from there. *) val entryPtrReg = if targetArch <> Native32Bit then r11 else ecx - val stackSpace = - case abi of - X64Unix => memRegSize - | X64Win => memRegSize + 32 (* Requires 32-byte save area. *) - | X86_32 => - let - (* GCC likes to keep the stack on a 16-byte alignment. *) - val argSpace = (nArgs+1)*4 - val align = argSpace mod 16 - in - (* Add sufficient space so that esp will be 16-byte aligned *) - if align = 0 - then memRegSize - else memRegSize + 16 - align - end + val nArgs = List.length argFormats + + local + (* Compute stack space. The actual number of args passed is nArgs+1. *) + val argSpace = + case abi of + X64Unix => Int.max(0, nArgs-6)*8 + | X64Win => Int.max(0, nArgs-4)*8 + | X86_32 => List.foldl(fn (FastArgDouble, n) => n+8 | (_, n) => n+4) 0 argFormats + val align = argSpace mod 16 + in + (* Add sufficient space so that esp will be 16-byte aligned after we + have pushed any arguments we need to push. *) + val stackSpace = + if align = 0 + then memRegSize + else memRegSize + 16 - align + end - (* The RTS functions expect the real address of the thread Id. *) - fun loadThreadId toReg = - if targetArch <> ObjectId32Bit - then [loadMemory(toReg, ebp, memRegThreadSelf, nativeWordOpSize)] - else [loadMemory(toReg, ebp, memRegThreadSelf, polyWordOpSize), - LoadAddress{output=toReg, offset=0, base=SOME ebx, index=Index4 toReg, opSize=nativeWordOpSize}] + (* The number of ML arguments passed on the stack. *) + val mlArgsOnStack = Int.max(case abi of X86_32 => nArgs - 2 | _ => nArgs - 5, 0) val code = [ Move{source=AddressConstArg entryPointAddr, destination=RegisterArg entryPtrReg, moveSize=opSizeToMove polyWordOpSize}, (* Load the entry point ref. *) loadHeapMemory(entryPtrReg, entryPtrReg, 0, nativeWordOpSize)(* Load its value. *) ] @ ( (* Save heap ptr. This is in r15 in X86/64 *) if targetArch <> Native32Bit then [storeMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize)] (* Save heap ptr *) else [] ) @ ( - if abi = X86_32 andalso nArgs >= 3 + if (case abi of X86_32 => nArgs >= 3 | _ => nArgs >= 6) then [moveRR{source=esp, output=edi, opSize=nativeWordOpSize}] (* Needed if we have to load from the stack. *) else [] ) @ - [ - (* Have to save the stack pointer to the arg structure in case we need to scan the stack for a GC. *) storeMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Save ML stack and switch to C stack. *) - loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize), (*moveRR{source=ebp, output=esp},*) (* Load the saved C stack pointer. *) + loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize), (* Set the stack pointer past the data on the stack. For Windows/64 add in a 32 byte save area *) ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt stackSpace), opSize=nativeWordOpSize} ] @ ( - case (abi, nArgs) of (* Set the argument registers. *) - (X64Unix, 0) => loadThreadId edi - | (X64Unix, 1) => moveRR{source=eax, output=esi, opSize=polyWordOpSize} :: loadThreadId edi - | (X64Unix, 2) => - moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} :: - moveRR{source=eax, output=esi, opSize=polyWordOpSize} :: loadThreadId edi - | (X64Unix, 3) => - moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} :: moveRR{source=eax, output=esi, opSize=polyWordOpSize} :: - moveRR{source=r8, output=ecx, opSize=polyWordOpSize} :: loadThreadId edi - | (X64Win, 0) => loadThreadId ecx - | (X64Win, 1) => moveRR{source=eax, output=edx, opSize=polyWordOpSize} :: loadThreadId ecx - | (X64Win, 2) => - moveRR{source=eax, output=edx, opSize=polyWordOpSize} :: - moveRR{source=mlArg2Reg, output=r8, opSize=polyWordOpSize} :: loadThreadId ecx - | (X64Win, 3) => - moveRR{source=eax, output=edx, opSize=polyWordOpSize} :: moveRR{source=r8, output=r9, opSize=polyWordOpSize} :: - moveRR{source=mlArg2Reg, output=r8, opSize=polyWordOpSize} :: loadThreadId ecx - | (X86_32, 0) => [ PushToStack(MemoryArg{base=ebp, offset=memRegThreadSelf, index=NoIndex}) ] - | (X86_32, 1) => [ pushR eax, PushToStack(MemoryArg{base=ebp, offset=memRegThreadSelf, index=NoIndex}) ] - | (X86_32, 2) => [ pushR mlArg2Reg, pushR eax, PushToStack(MemoryArg{base=ebp, offset=memRegThreadSelf, index=NoIndex}) ] - | (X86_32, 3) => - [ - (* We need to move an argument from the ML stack. *) - PushToStack(MemoryArg{base=edi, offset=4, index=NoIndex}), pushR mlArg2Reg, pushR eax, - PushToStack(MemoryArg{base=ebp, offset=memRegThreadSelf, index=NoIndex}) - ] - | _ => raise InternalError "rtsCall: Abi/argument count not implemented" + case abi of (* Set the argument registers. *) + X86_32 => + let + fun pushReg(reg, FastArgFixed) = [pushR reg] + | pushReg(reg, FastArgDouble) = + (* reg contains the address of the value. This must be unboxed onto the stack. *) + [ + FPLoadFromMemory{address={base=reg, offset=0, index=NoIndex}, precision=DoublePrecision}, + ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 8, opSize=nativeWordOpSize}, + FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=DoublePrecision, andPop=true } + ] + | pushReg(reg, FastArgFloat) = + (* reg contains the address of the value. This must be unboxed onto the stack. *) + [ + FPLoadFromMemory{address={base=reg, offset=0, index=NoIndex}, precision=SinglePrecision}, + ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 4, opSize=nativeWordOpSize}, + FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=SinglePrecision, andPop=true } + ] + + (* The stack arguments have to be copied first followed by the ebx and finally eax. *) + fun pushArgs (_, []) = [] + | pushArgs (_, [argType]) = pushReg(eax, argType) + | pushArgs (_, [arg2Type, arg1Type]) = pushReg(ebx, arg2Type) @ pushReg(eax, arg1Type) + | pushArgs (n, FastArgFixed :: argTypes) = + PushToStack(MemoryArg{base=edi, offset=(nArgs-n+1)* 4, index=NoIndex}) :: pushArgs(n-1, argTypes) + | pushArgs (n, argType :: argTypes) = + (* Use esi as a temporary register. *) + loadMemory(esi, edi, (nArgs-n+1)* 4, polyWordOpSize) :: pushReg(esi, argType) @ pushArgs(n-1, argTypes) + in + pushArgs(nArgs, List.rev argFormats) + end + + | X64Unix => + ( + if List.all (fn FastArgFixed => true | _ => false) argFormats + then + let + fun pushArgs 0 = [] + | pushArgs 1 = [moveRR{source=eax, output=edi, opSize=polyWordOpSize}] + | pushArgs 2 = moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize} :: pushArgs 1 + | pushArgs 3 = moveRR{source=r8, output=edx, opSize=polyWordOpSize} :: pushArgs 2 + | pushArgs 4 = moveRR{source=r9, output=ecx, opSize=polyWordOpSize} :: pushArgs 3 + | pushArgs 5 = + (* We have to move r8 into edx before we can move r10 into r8 *) + moveRR{source=r8, output=edx, opSize=polyWordOpSize} :: + moveRR{source=r9, output=ecx, opSize=polyWordOpSize} :: + moveRR{source=r10, output=r8, opSize=polyWordOpSize} :: pushArgs 2 + | pushArgs 6 = + (* We have to move r9 into edi before we can load r9 from the stack. *) + moveRR{source=r8, output=edx, opSize=polyWordOpSize} :: + moveRR{source=r9, output=ecx, opSize=polyWordOpSize} :: + loadMemory(r9, edi, 8, polyWordOpSize) :: + moveRR{source=r10, output=r8, opSize=polyWordOpSize} :: pushArgs 2 + | pushArgs _ = raise InternalError "rtsCall: Abi/argument count not implemented" + in + pushArgs nArgs + end + else case argFormats of + [] => [] + | [FastArgFixed] => [ moveRR{source=eax, output=edi, opSize=polyWordOpSize} ] + | [FastArgFixed, FastArgFixed] => + (* Since mlArgs2Reg is esi on 32-in-64 this is redundant. *) + [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize} ] + | [FastArgFixed, FastArgFixed, FastArgFixed] => + [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize}, + moveRR{source=r8, output=edx, opSize=polyWordOpSize} ] + | [FastArgFixed, FastArgFixed, FastArgFixed, FastArgFixed] => + [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize}, + moveRR{source=r8, output=edx, opSize=polyWordOpSize}, moveRR{source=r9, output=ecx, opSize=polyWordOpSize} ] + (* One "double" argument. The value needs to be unboxed. *) + | [FastArgDouble] => [] (* Already in xmm0 *) + (* X64 on both Windows and Unix take the first arg in xmm0 and the second in xmm1. They are already there. *) + | [FastArgDouble, FastArgDouble] => [] + | [FastArgDouble, FastArgFixed] => [ moveRR{source=eax, output=edi, opSize=nativeWordOpSize} ] + | [FastArgFloat] => [] (* Already in xmm0 *) + | [FastArgFloat, FastArgFloat] => [] (* Already in xmm0 and xmm1 *) + (* One float argument and one fixed. *) + | [FastArgFloat, FastArgFixed] => [moveRR{source=mlArg2Reg, output=edi, opSize=polyWordOpSize} ] + + | _ => raise InternalError "rtsCall: Abi/argument count not implemented" + + ) + + | X64Win => + ( + if List.all (fn FastArgFixed => true | _ => false) argFormats + then + let + fun pushArgs 0 = [] + | pushArgs 1 = [moveRR{source=eax, output=ecx, opSize=polyWordOpSize}] + | pushArgs 2 = moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} :: pushArgs 1 + | pushArgs 3 = (* Already in r8 *) pushArgs 2 + | pushArgs 4 = (* Already in r9, and r8 *) pushArgs 2 + | pushArgs 5 = pushR r10 :: pushArgs 2 + | pushArgs 6 = PushToStack(MemoryArg{base=edi, offset=8, index=NoIndex}) :: pushArgs 5 + | pushArgs _ = raise InternalError "rtsCall: Abi/argument count not implemented" + in + pushArgs nArgs + end + + else case argFormats of + [FastArgFixed] => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize} ] + | [FastArgFixed, FastArgFixed] => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} ] + | [FastArgFixed, FastArgFixed, FastArgFixed] => + [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} (* Arg3 is already in r8. *) ] + | [FastArgFixed, FastArgFixed, FastArgFixed, FastArgFixed] => + [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} (* Arg3 is already in r8 and arg4 in r9. *) ] + | [FastArgDouble] => [ (* Already in xmm0 *) ] + (* X64 on both Windows and Unix take the first arg in xmm0 and the second in xmm1. They are already there. *) + | [FastArgDouble, FastArgDouble] => [ ] + (* X64 on both Windows and Unix take the first arg in xmm0. On Unix the integer argument is treated + as the first argument and goes into edi. On Windows it's treated as the second and goes into edx. + N.B. It's also the first argument in ML so is in rax. *) + | [FastArgDouble, FastArgFixed] => [ moveRR{source=eax, output=edx, opSize=nativeWordOpSize} ] + | [FastArgFloat] => [] + | [FastArgFloat, FastArgFloat] => [] (* Already in xmm0 and xmm1 *) + | [FastArgFloat, FastArgFixed] => [moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize}] + + | _ => raise InternalError "rtsCall: Abi/argument count not implemented" + ) ) @ + (* For Windows/64 add in a 32 byte save area ater we've pushed any arguments. *) + (case abi of X64Win => [ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg 32, opSize=nativeWordOpSize}] | _ => []) @ [ CallAddress(RegisterArg entryPtrReg), (* Call the function *) loadMemory(esp, ebp, memRegStackPtr, nativeWordOpSize) (* Restore the ML stack pointer. *) ] @ ( if targetArch <> Native32Bit then [loadMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize) ] (* Copy back the heap ptr *) else [] ) @ [ - ArithMemConst{opc=CMP, address={offset=memRegExceptionPacket, base=ebp, index=NoIndex}, source=noException, opSize=polyWordOpSize}, - ConditionalBranch{test=JNE, label=exLabel}, - (* Remove any arguments that have been passed on the stack. *) - ReturnFromFunction(Int.max(case abi of X86_32 => nArgs-2 | _ => nArgs-5, 0)), - JumpLabel exLabel, (* else raise the exception *) - loadMemory(eax, ebp, memRegExceptionPacket, polyWordOpSize), - RaiseException { workReg=ecx } - ] - - val profileObject = createProfileObject functionName - val newCode = codeCreate (functionName, profileObject, debugSwitches) - val closure = makeConstantClosure() - val () = X86OPTIMISE.generateCode{code=newCode, labelCount=1(*One label.*), ops=code, resultClosure=closure} - in - closureAsAddress closure - end - - (* This is a quicker version but can only be used if the RTS entry does - not allocated ML memory, raise an exception or need to suspend the thread. *) - datatype fastArgs = FastArgFixed | FastArgDouble | FastArgFloat - - - fun rtsCallFastGeneral (functionName, argFormats, (*resultFormat*) _, debugSwitches) = - let - val entryPointAddr = makeEntryPoint functionName - - (* Get the ABI. On 64-bit Windows and Unix use different calling conventions. *) - val abi = getABI() - - val (entryPtrReg, saveMLStackPtrReg) = - if targetArch <> Native32Bit then (r11, r13) else (ecx, edi) - - val stackSpace = - case abi of - X64Unix => memRegSize - | X64Win => memRegSize + 32 (* Requires 32-byte save area. *) - | X86_32 => - let - (* GCC likes to keep the stack on a 16-byte alignment. *) - val argSpace = List.foldl(fn (FastArgDouble, n) => n+8 | (_, n) => n+4) 0 argFormats - val align = argSpace mod 16 - in - (* Add sufficient space so that esp will be 16-byte aligned *) - if align = 0 - then memRegSize - else memRegSize + 16 - align - end - - (* The number of ML arguments passed on the stack. *) - val mlArgsOnStack = - Int.max(case abi of X86_32 => List.length argFormats - 2 | _ => List.length argFormats - 5, 0) - - val code = - [ - Move{source=AddressConstArg entryPointAddr, destination=RegisterArg entryPtrReg, moveSize=opSizeToMove polyWordOpSize}, (* Load the entry point ref. *) - loadHeapMemory(entryPtrReg, entryPtrReg, 0, nativeWordOpSize),(* Load its value. *) - moveRR{source=esp, output=saveMLStackPtrReg, opSize=nativeWordOpSize}, (* Save ML stack and switch to C stack. *) - loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize), - (* Set the stack pointer past the data on the stack. For Windows/64 add in a 32 byte save area *) - ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt stackSpace), opSize=nativeWordOpSize} - ] @ - ( - case (abi, argFormats) of (* Set the argument registers. *) - (_, []) => [] - | (X64Unix, [FastArgFixed]) => [ moveRR{source=eax, output=edi, opSize=polyWordOpSize} ] - | (X64Unix, [FastArgFixed, FastArgFixed]) => - (* Since mlArgs2Reg is esi on 32-in-64 this is redundant. *) - [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize} ] - | (X64Unix, [FastArgFixed, FastArgFixed, FastArgFixed]) => - [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize}, - moveRR{source=r8, output=edx, opSize=polyWordOpSize} ] - | (X64Unix, [FastArgFixed, FastArgFixed, FastArgFixed, FastArgFixed]) => - [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize}, - moveRR{source=r8, output=edx, opSize=polyWordOpSize}, moveRR{source=r9, output=ecx, opSize=polyWordOpSize} ] - | (X64Win, [FastArgFixed]) => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize} ] - | (X64Win, [FastArgFixed, FastArgFixed]) => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} ] - | (X64Win, [FastArgFixed, FastArgFixed, FastArgFixed]) => - [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} (* Arg3 is already in r8. *) ] - | (X64Win, [FastArgFixed, FastArgFixed, FastArgFixed, FastArgFixed]) => - [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} (* Arg3 is already in r8 and arg4 in r9. *) ] - | (X86_32, [FastArgFixed]) => [ pushR eax ] - | (X86_32, [FastArgFixed, FastArgFixed]) => [ pushR mlArg2Reg, pushR eax ] - | (X86_32, [FastArgFixed, FastArgFixed, FastArgFixed]) => - [ - (* We need to move an argument from the ML stack. *) - loadMemory(edx, saveMLStackPtrReg, 4, polyWordOpSize), pushR edx, pushR mlArg2Reg, pushR eax - ] - | (X86_32, [FastArgFixed, FastArgFixed, FastArgFixed, FastArgFixed]) => - [ - (* We need to move an arguments from the ML stack. *) - loadMemory(edx, saveMLStackPtrReg, 4, polyWordOpSize), pushR edx, - loadMemory(edx, saveMLStackPtrReg, 8, polyWordOpSize), pushR edx, - pushR mlArg2Reg, pushR eax - ] - - (* One "double" argument. The value needs to be unboxed. *) - | (X86_32, [FastArgDouble]) => - (* eax contains the address of the value. This must be unboxed onto the stack. *) - [ - FPLoadFromMemory{address={base=eax, offset=0, index=NoIndex}, precision=DoublePrecision}, - ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 8, opSize=nativeWordOpSize}, - FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=DoublePrecision, andPop=true } - ] - - | (_, [FastArgDouble]) => [ (* Already in xmm0 *) ] - - | (X86_32, [FastArgDouble, FastArgDouble]) => - (* eax and ebx contain the addresses of the values. They must be unboxed onto the stack. *) - [ - FPLoadFromMemory{address={base=ebx, offset=0, index=NoIndex}, precision=DoublePrecision}, - ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 8, opSize=nativeWordOpSize}, - FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=DoublePrecision, andPop=true }, - FPLoadFromMemory{address={base=eax, offset=0, index=NoIndex}, precision=DoublePrecision}, - ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 8, opSize=nativeWordOpSize}, - FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=DoublePrecision, andPop=true } - ] - (* X64 on both Windows and Unix take the first arg in xmm0 and the second in xmm1. They are already there. *) - | (_, [FastArgDouble, FastArgDouble]) => [ ] - - (* X64 on both Windows and Unix take the first arg in xmm0. On Unix the integer argument is treated - as the first argument and goes into edi. On Windows it's treated as the second and goes into edx. - N.B. It's also the first argument in ML so is in rax. *) - | (X64Unix, [FastArgDouble, FastArgFixed]) => [ moveRR{source=eax, output=edi, opSize=nativeWordOpSize} ] - | (X64Win, [FastArgDouble, FastArgFixed]) => [ moveRR{source=eax, output=edx, opSize=nativeWordOpSize} ] - | (X86_32, [FastArgDouble, FastArgFixed]) => - (* ebx must be pushed to the stack but eax must be unboxed.. *) - [ - pushR ebx, - FPLoadFromMemory{address={base=eax, offset=0, index=NoIndex}, precision=DoublePrecision}, - ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 8, opSize=nativeWordOpSize}, - FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=DoublePrecision, andPop=true } - ] - - (* One "float" argument. The value needs to be untagged on X86/64 but unboxed on X86/32. *) - | (X86_32, [FastArgFloat]) => - (* eax contains the address of the value. This must be unboxed onto the stack. *) - [ - FPLoadFromMemory{address={base=eax, offset=0, index=NoIndex}, precision=SinglePrecision}, - ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 4, opSize=nativeWordOpSize}, - FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=SinglePrecision, andPop=true } - ] - | (_, [FastArgFloat]) => [] - - (* Two float arguments. Untag them on X86/64 but unbox on X86/32 *) - | (X86_32, [FastArgFloat, FastArgFloat]) => - (* eax and ebx contain the addresses of the values. They must be unboxed onto the stack. *) - [ - FPLoadFromMemory{address={base=ebx, offset=0, index=NoIndex}, precision=SinglePrecision}, - ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 4, opSize=nativeWordOpSize}, - FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=SinglePrecision, andPop=true }, - FPLoadFromMemory{address={base=eax, offset=0, index=NoIndex}, precision=SinglePrecision}, - ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 4, opSize=nativeWordOpSize}, - FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=SinglePrecision, andPop=true } - ] - | (_, [FastArgFloat, FastArgFloat]) => [] (* Already in xmm0 and xmm1 *) - - (* One float argument and one fixed. *) - | (X64Unix, [FastArgFloat, FastArgFixed]) => [moveRR{source=mlArg2Reg, output=edi, opSize=polyWordOpSize} ] - | (X64Win, [FastArgFloat, FastArgFixed]) => [moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize}] - | (X86_32, [FastArgFloat, FastArgFixed]) => - (* ebx must be pushed to the stack but eax must be unboxed.. *) - [ - pushR ebx, - FPLoadFromMemory{address={base=eax, offset=0, index=NoIndex}, precision=SinglePrecision}, - ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 4, opSize=nativeWordOpSize}, - FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=SinglePrecision, andPop=true } - ] - - | _ => raise InternalError "rtsCall: Abi/argument count not implemented" - ) @ - [ - CallAddress(RegisterArg entryPtrReg), (* Call the function *) - moveRR{source=saveMLStackPtrReg, output=esp, opSize=nativeWordOpSize}, (* Restore the ML stack pointer *) (* Since this is an ML function we need to remove any ML stack arguments. *) ReturnFromFunction mlArgsOnStack ] val profileObject = createProfileObject functionName val newCode = codeCreate (functionName, profileObject, debugSwitches) val closure = makeConstantClosure() val () = X86OPTIMISE.generateCode{code=newCode, labelCount=0, ops=code, resultClosure=closure} in closureAsAddress closure end fun rtsCallFast (functionName, nArgs, debugSwitches) = rtsCallFastGeneral (functionName, List.tabulate(nArgs, fn _ => FastArgFixed), FastArgFixed, debugSwitches) (* RTS call with one double-precision floating point argument and a floating point result. *) fun rtsCallFastRealtoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgDouble], FastArgDouble, debugSwitches) (* RTS call with two double-precision floating point arguments and a floating point result. *) fun rtsCallFastRealRealtoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgDouble, FastArgDouble], FastArgDouble, debugSwitches) (* RTS call with one double-precision floating point argument, one fixed point argument and a floating point result. *) fun rtsCallFastRealGeneraltoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgDouble, FastArgFixed], FastArgDouble, debugSwitches) (* RTS call with one general (i.e. ML word) argument and a floating point result. This is used only to convert arbitrary precision values to floats. *) fun rtsCallFastGeneraltoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFixed], FastArgDouble, debugSwitches) (* Operations on Real32.real values. *) fun rtsCallFastFloattoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFloat], FastArgFloat, debugSwitches) fun rtsCallFastFloatFloattoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFloat, FastArgFloat], FastArgFloat, debugSwitches) (* RTS call with one double-precision floating point argument, one fixed point argument and a floating point result. *) fun rtsCallFastFloatGeneraltoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFloat, FastArgFixed], FastArgFloat, debugSwitches) (* RTS call with one general (i.e. ML word) argument and a floating point result. This is used only to convert arbitrary precision values to floats. *) fun rtsCallFastGeneraltoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFixed], FastArgFloat, debugSwitches) datatype ffiABI = FFI_SYSV (* Unix 32 bit and Windows GCC 32-bit *) | FFI_STDCALL (* Windows 32-bit system ABI. Callee clears the stack. *) | FFI_MS_CDECL (* VS 32-bit. Same as SYSV except when returning a struct. Default on Windows including GCC in Mingw. *) | FFI_WIN64 (* Windows 64 bit *) | FFI_UNIX64 (* Unix 64 bit. libffi also implements this on X86/32. *) (* We don't include various other 32-bit Windows ABIs. *) local (* Get the current ABI list. N.B. Foreign.LibFFI.abiList is the ABIs on the platform we built the compiler on, not necessarily the one we're running on. *) val ffiGeneral = RunCall.rtsCallFull2 "PolyFFIGeneral" in fun getFFIAbi abi = let val abis: (string * Foreign.LibFFI.abi) list = ffiGeneral (50, ()) in case List.find (fn ("default", _) => false | (_, a) => a = abi) abis of SOME ("sysv", _) => FFI_SYSV | SOME ("stdcall", _) => FFI_STDCALL | SOME ("ms_cdecl", _) => FFI_MS_CDECL | SOME ("win64", _) => FFI_WIN64 | SOME ("unix64", _) => FFI_UNIX64 | _ => raise Foreign.Foreign "Unknown or unsupported ABI" end end fun alignUp(s, align) = Word.andb(s + align-0w1, ~ align) fun intAlignUp(s, align) = Word.toInt(alignUp(Word.fromInt s, align)) (* Build a foreign call function. The arguments are the abi, the list of argument types and the result type. The result is the code of the ML function that takes three arguments: the C function to call, the arguments as a vector of C values and the address of the memory for the result. *) fun call32Bits(abi, args, result) = let (* 32-bit arguments. These all go to the stack so we can simply push them. The arguments go on the stack in reverse order. *) fun loadArgs32([], stackOffset, argOffset, code, continue) = continue(stackOffset, argOffset, code) | loadArgs32(arg::args, stackOffset, argOffset, code, continue) = let val {size, align, typeCode, elements} = Foreign.LibFFI.extractFFItype arg val newArgOffset = alignUp(argOffset, align) val baseAddr = {base=mlArg2Reg, offset=Word.toInt newArgOffset, index=NoIndex} in if typeCode = Foreign.LibFFI.ffiTypeCodeUInt8 then (* Unsigned char. *) loadArgs32(args, stackOffset+4, newArgOffset+size, Move{source=MemoryArg baseAddr, destination=RegisterArg edx, moveSize=Move8 } :: PushToStack(RegisterArg edx) :: code, continue) else if typeCode = Foreign.LibFFI.ffiTypeCodeSInt8 then (* Signed char. *) loadArgs32(args, stackOffset+4, newArgOffset+size, Move{source=MemoryArg baseAddr, destination=RegisterArg edx, moveSize=Move8X32 } :: PushToStack(RegisterArg edx) :: code, continue) else if typeCode = Foreign.LibFFI.ffiTypeCodeUInt16 then (* Unsigned 16-bits. *) loadArgs32(args, stackOffset+4, newArgOffset+size, Move{source=MemoryArg baseAddr, destination=RegisterArg edx, moveSize=Move16 } :: PushToStack(RegisterArg edx) :: code, continue) else if typeCode = Foreign.LibFFI.ffiTypeCodeSInt16 then (* Signed 16-bits. *) loadArgs32(args, stackOffset+4, newArgOffset+size, Move{source=MemoryArg baseAddr, destination=RegisterArg edx, moveSize=Move16X32 } :: PushToStack(RegisterArg edx) :: code, continue) else if typeCode = Foreign.LibFFI.ffiTypeCodeUInt32 orelse typeCode = Foreign.LibFFI.ffiTypeCodeSInt32 orelse typeCode = Foreign.LibFFI.ffiTypeCodePointer orelse typeCode = Foreign.LibFFI.ffiTypeCodeFloat orelse typeCode = Foreign.LibFFI.ffiTypeCodeInt then (* 32-bits. *) loadArgs32(args, stackOffset+4, newArgOffset+size, PushToStack(MemoryArg baseAddr) :: code, continue) else if typeCode = Foreign.LibFFI.ffiTypeCodeDouble then (* Double: push the two words. High-order word first, then low-order. *) loadArgs32(args, stackOffset+8, newArgOffset+size, PushToStack(MemoryArg{base=mlArg2Reg, offset=Word.toInt newArgOffset+4, index=NoIndex}) :: PushToStack(MemoryArg{base=mlArg2Reg, offset=Word.toInt newArgOffset, index=NoIndex}) :: code, continue) else if typeCode = Foreign.LibFFI.ffiTypeCodeStruct (* structs passed as values are recursively unpacked. *) then loadArgs32(elements, stackOffset, newArgOffset (* Struct is aligned. *), code, fn (so, ao, code) => loadArgs32(args, so, ao, code, continue)) else if typeCode = Foreign.LibFFI.ffiTypeCodeVoid then raise Foreign.Foreign "Void cannot be used for a function argument" else (* Anything else? *) raise Foreign.Foreign "Unrecognised type for function argument" end val {typeCode, size, ...} = Foreign.LibFFI.extractFFItype result val resultMemory = {base=ecx, offset=0, index=NoIndex} (* Structures are passed by reference by storing the address of the result as the first argument except that in MS_CDECL (and STDCALL?) structures of size 1, 2, 4 and 8 are returned in EAX, and for 8, EDX. *) val (getResult, needResultAddress) = if typeCode = Foreign.LibFFI.ffiTypeCodeStruct andalso (abi = FFI_SYSV orelse (size <> 0w1 andalso size <> 0w2 andalso size <> 0w4 andalso size <> 0w8)) (* TODO: We have to get the address of the destination area. *) then ([], true) else if typeCode = Foreign.LibFFI.ffiTypeCodeVoid then ([], false) else (loadMemory(ecx, esp, 4, nativeWordOpSize) :: loadHeapMemory(ecx, ecx, 0, nativeWordOpSize) :: (if size = 0w1 then (* Single byte *) [Move{source=RegisterArg eax, destination=MemoryArg resultMemory, moveSize=Move8}] else if size = 0w2 then (* 16-bits *) [Move{source=RegisterArg eax, destination=MemoryArg resultMemory, moveSize=Move16}] else if typeCode = Foreign.LibFFI.ffiTypeCodeFloat then [FPStoreToMemory{address=resultMemory, precision=SinglePrecision, andPop=true }] else if size = 0w4 then [Move{source=RegisterArg eax, destination=MemoryArg resultMemory, moveSize=Move32}] else if typeCode = Foreign.LibFFI.ffiTypeCodeDouble then [FPStoreToMemory{address=resultMemory, precision=DoublePrecision, andPop=true }] else if size = 0w8 then [ Move{source=RegisterArg eax, destination=MemoryArg resultMemory, moveSize=Move32}, Move{source=RegisterArg edx, destination=MemoryArg {base=ecx, offset=4, index=NoIndex}, moveSize=Move32} ] else raise Foreign.Foreign "Unrecognised result type"), false) local (* Load the arguments. If we need to pass the return address for a struct that is the first arg. *) val (startStack, startCode) = if needResultAddress then (4, [PushToStack(MemoryArg{base=ecx, offset=0, index=NoIndex})]) else (0, []) in val (argCode, argStack) = loadArgs32(args, startStack, 0w0, startCode, fn (stackOffset, _, code) => (code, stackOffset)) end local val align = argStack mod 16 in (* Always align the stack. It's not always necessary on 32-bits but GCC prefers it. *) val preArgAlign = if align = 0 then 0 else 16-align end in ( (* If we're returning a struct we need the result address before we call. *) if needResultAddress then [loadMemory(ecx, esp, 4, nativeWordOpSize)] else [] ) @ [ (* Save the stack pointer. *) storeMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Save ML stack and switch to C stack. *) loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize) (* Load the saved C stack pointer. *) ] @ ( if preArgAlign = 0 then [] else [ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt preArgAlign), opSize=nativeWordOpSize}] ) @ ( (* The second argument is a SysWord containing the address of a malloced area of memory with the actual arguments in it. *) if null args then [] else [loadHeapMemory(mlArg2Reg, mlArg2Reg, 0, nativeWordOpSize)] ) @ argCode @ [ (* Call the function. We're discarding the value in rsp so no need to remove args. *) CallAddress(MemoryArg{base=eax, offset=0, index=NoIndex}), loadMemory(esp, ebp, memRegStackPtr, nativeWordOpSize) (* Restore the ML stack pointer. *) ] @ getResult @ (* Store the result in the destination. *) [ ReturnFromFunction 1 ] end (* Windows on X64. *) fun callWindows64Bits(args, result) = let val extraStackReg = r10 (* Not used for any arguments. *) fun loadWin64Args([], stackOffset, _, _, code, extraStack, preCode) = (code, stackOffset, preCode, extraStack) | loadWin64Args(arg::args, stackOffset, argOffset, regs, code, extraStack, preCode) = let val {size, align, typeCode, ...} = Foreign.LibFFI.extractFFItype arg val newArgOffset = alignUp(argOffset, align) val baseAddr = {base=mlArg2Reg, offset=Word.toInt newArgOffset, index=NoIndex} val workReg = rcx (* rcx: the last to be loaded. *) (* Integer arguments. *) fun loadIntArg moveOp = case regs of (areg, _) :: regs' => loadWin64Args(args, stackOffset, newArgOffset+size, regs', Move{source=MemoryArg baseAddr, destination=RegisterArg areg, moveSize=moveOp } :: code, extraStack, preCode) | [] => loadWin64Args(args, stackOffset+8, newArgOffset+size, [], if size = 0w8 then PushToStack(MemoryArg baseAddr) :: code else (* Need to load it into a register first. *) Move{source=MemoryArg baseAddr, destination=RegisterArg workReg, moveSize=moveOp } :: PushToStack(RegisterArg workReg) :: code, extraStack, preCode) in (* Structs of 1, 2, 4 and 8 bytes are passed as the corresponding int. It may not be necessary to sign-extend 1, 2 or 4-byte values. 2, 4 or 8-byte structs may not be aligned onto the appropriate boundary but it should still work. *) case size of 0w1 => if typeCode = Foreign.LibFFI.ffiTypeCodeSInt8 then (* Signed char. *) loadIntArg Move8X64 else (* Unsigned char or single byte struct *) loadIntArg Move8 | 0w2 => if typeCode = Foreign.LibFFI.ffiTypeCodeSInt16 then (* Signed 16-bits. *) loadIntArg Move16X64 else (* Unsigned 16-bits. *) loadIntArg Move16 | 0w4 => if typeCode = Foreign.LibFFI.ffiTypeCodeFloat then ( case regs of (_, fpReg) :: regs' => loadWin64Args(args, stackOffset, newArgOffset+size, regs', XMMArith{opc=SSE2MoveFloat, source=MemoryArg baseAddr, output=fpReg } :: code, extraStack, preCode) | [] => loadWin64Args(args, stackOffset+8, newArgOffset+size, [], Move{source=MemoryArg baseAddr, destination=RegisterArg workReg, moveSize=Move32 } :: PushToStack(RegisterArg workReg) :: code, extraStack, preCode) ) else if typeCode = Foreign.LibFFI.ffiTypeCodeSInt32 orelse typeCode = Foreign.LibFFI.ffiTypeCodeInt then (* Signed 32-bits. *) loadIntArg Move32X64 else (* Unsigned 32-bits. *) loadIntArg Move32 | 0w8 => if typeCode = Foreign.LibFFI.ffiTypeCodeDouble then ( case regs of (_, fpReg) :: regs' => loadWin64Args(args, stackOffset, newArgOffset+size, regs', XMMArith{opc=SSE2MoveDouble, source=MemoryArg baseAddr, output=fpReg } :: code, extraStack, preCode) | [] => loadWin64Args(args, stackOffset+8, newArgOffset+size, [], Move{source=MemoryArg baseAddr, destination=RegisterArg workReg, moveSize=Move64 } :: PushToStack(RegisterArg workReg) :: code, extraStack, preCode) ) else (* 64-bits. *) loadIntArg Move64 | _ => if typeCode <> Foreign.LibFFI.ffiTypeCodeStruct then raise Foreign.Foreign "Unrecognised type for function argument" else let (* Structures of other sizes are passed by reference. They are first copied into new areas on the stack. This ensures that the called function can update the structure without changing the original values. *) val newExtra = intAlignUp(extraStack + Word.toInt size, 0w16) val newPreCode = moveMemory{source=(mlArg2Reg, Word.toInt newArgOffset), destination=(extraStackReg, extraStack), length=Word.toInt size} @ preCode in case regs of (areg, _) :: regs' => loadWin64Args(args, stackOffset, newArgOffset+size, regs', loadAddress{source=(extraStackReg, extraStack), destination=areg} :: code, newExtra, newPreCode) | [] => loadWin64Args(args, stackOffset+8, newArgOffset+size, [], loadAddress{source=(extraStackReg, extraStack), destination=workReg} :: PushToStack(RegisterArg workReg) :: code, newExtra, newPreCode) end end val {typeCode, size, ...} = Foreign.LibFFI.extractFFItype result val resultAreaPtr = r12 (* Saved value of r8 - This is callee save. *) val resultMemory = {base=resultAreaPtr, offset=0, index=NoIndex} fun storeIntValue moveOp = ([Move{source=RegisterArg eax, destination=MemoryArg resultMemory, moveSize=moveOp}], false) and storeFloatValue precision = ([XMMStoreToMemory{toStore=xmm0, address=resultMemory, precision=precision}], false) val (getResult, passStructAddress) = if typeCode = Foreign.LibFFI.ffiTypeCodeVoid then ([], false) else if size = 0w1 (* Includes structs *) then (* Single byte *) storeIntValue Move8 else if size = 0w2 then (* 16-bits *) storeIntValue Move16 else if typeCode = Foreign.LibFFI.ffiTypeCodeFloat then storeFloatValue SinglePrecision else if size = 0w4 then storeIntValue Move32 else if typeCode = Foreign.LibFFI.ffiTypeCodeDouble then storeFloatValue DoublePrecision else if size = 0w8 then storeIntValue Move64 else if typeCode = Foreign.LibFFI.ffiTypeCodeStruct then ([], true) else raise Foreign.Foreign "Unrecognised result type" val win64ArgRegs = [ (rcx, xmm0), (rdx, xmm1), (r8, xmm2), (r9, xmm3) ] (* argCode is the code to load and push the arguments. argStack is the amount of stack space the arguments will take. It's only used to ensure that the stack is aligned onto a 16-byte boundary. preArgCode is any code that is needed to copy the arguments before they are actually loaded. Because it is done before the argument registers are loaded it can use rcx, rdi and rsi. extraStack is local stack space needed. It is usually zero but if it is non-zero it must be a multiple of 16 bytes. The address of this area is loaded into r10 before preArgCode is called. *) val (argCode, argStack, preArgCode, extraStack) = if passStructAddress then (* The address of the result structure goes in the first argument register: rcx *) loadWin64Args(args, 0, 0w0, tl win64ArgRegs, [moveRR{source=resultAreaPtr, output=rcx, opSize=nativeWordOpSize}], 0, []) else loadWin64Args(args, 0, 0w0, win64ArgRegs, [], 0, []) local val align = argStack mod 16 in (* Always align the stack. *) val preArgAlign = if align = 0 then 0 else 16-align end in (* Save heap ptr. Needed in case we have a callback. *) [storeMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize)] @ ( (* Put the destination address into a callee save resgister. We have to put the C address in there now because an ML address wouldn't be updated by a possible GC in a callback. *) if #typeCode(Foreign.LibFFI.extractFFItype result) <> Foreign.LibFFI.ffiTypeCodeVoid then [loadHeapMemory(resultAreaPtr, r8, 0, nativeWordOpSize)] else [] ) @ [ (* Save the stack pointer. *) storeMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Save ML stack and switch to C stack. *) loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize) (* Load the saved C stack pointer. *) ] @ ( if extraStack = 0 then [] else [ ArithToGenReg{opc=SUB, output=rsp, source=NonAddressConstArg(LargeInt.fromInt extraStack), opSize=nativeWordOpSize}, Move{source=RegisterArg rsp, destination=RegisterArg extraStackReg, moveSize=Move64} ] ) @ ( if preArgAlign = 0 then [] else [ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt preArgAlign), opSize=nativeWordOpSize}] ) @ ( (* The second argument is a SysWord containing the address of a malloced area of memory with the actual arguments in it. *) if null args then [] else [loadHeapMemory(mlArg2Reg, mlArg2Reg, 0, nativeWordOpSize)] ) @ preArgCode @ argCode @ [ (* Reserve a 32-byte area after the arguments. This is specific to the Windows ABI. *) ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt 32), opSize=nativeWordOpSize}, let (* The entry point is in a SysWord.word value in RAX. *) val entryPoint = case targetArch of ObjectId32Bit => MemoryArg{base=ebx, offset=0, index=Index4 eax} | _ => MemoryArg{base=eax, offset=0, index=NoIndex} in (* Call the function. We're discarding the value in rsp so no need to remove args. *) CallAddress entryPoint end, loadMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Restore the ML stack pointer. *) (* Reload the heap pointer. If we've called back to ML this could well have changed. *) loadMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize) ] @ (* Store the result in the destination. *) getResult @ [ReturnFromFunction 0 ] end (* callWindows64Bits *) local (* The rules for passing structs in SysV on X86/64 are complicated but most of the special cases don't apply. We don't support floating point larger than 8 bytes, packed structures or C++ constructors. It then reduces to the following: Structures of up to 8 bytes are passed in a single register and of 8-16 bytes in two registers. Larger structures are passed on the stack. The question is whether to use general registers or SSE2 registers. Each 8 byte chunk is considered independently after any internal structs have been unwrapped. Each chunk will consist of either a single 8-byte value (i.e.. a pointer, int64_t or a double) or one or more smaller values and possibly some padding. An SSE2 register is used if the value is a double, two floats or a single float and padding. Otherwise it must have at least one shorter int-like type (e.g. int, char, short etc) in which case a general register is used. That applies even if it also contains a float. If, having selected the kind of registers to be used, there are not enough for the whole struct it is passed on the stack. We don't really need this for simple arguments but it's easier to consider them all together. *) datatype argClass = ArgInMemory | ArgInRegs of { firstInSSE: bool, secondInSSE: bool } fun classifyArg arg = let val {size, ...} = Foreign.LibFFI.extractFFItype arg (* Unwrap the struct and any internal structs. *) fun getFields([], _) = [] | getFields(field::fields, offset) = let val {size, align, typeCode, elements, ...} = Foreign.LibFFI.extractFFItype field val alignedOffset = alignUp(offset, align) (* Align this even if it's a sub-struct *) in if typeCode = Foreign.LibFFI.ffiTypeCodeVoid then raise Foreign.Foreign "Void cannot be used for a function argument" else if typeCode = Foreign.LibFFI.ffiTypeCodeStruct then getFields(elements, alignedOffset) @ getFields(fields, alignedOffset+size) else (typeCode, alignedOffset) :: getFields(fields, alignedOffset+size) end val isSSE = List.all (fn (tc, _) => tc = Foreign.LibFFI.ffiTypeCodeFloat orelse tc = Foreign.LibFFI.ffiTypeCodeDouble) in if size > 0w16 then ArgInMemory else let val fieldsAndOffsets = getFields([arg], 0w0) in if size <= 0w8 (* Only the first register will be used. *) then ArgInRegs{firstInSSE=isSSE fieldsAndOffsets, secondInSSE=false} else let val (first8Bytes, second8Bytes) = List.partition (fn (_, off) => off <= 0w8) fieldsAndOffsets in ArgInRegs{firstInSSE=isSSE first8Bytes, secondInSSE=isSSE second8Bytes} end end end in fun callUnix64Bits(args, result) = let val argWorkReg = r10 (* Not used for any arguments. *) val resultAreaPtr = r12 (* Saved value of r8 - This is callee save. *) fun loadSysV64Args([], stackOffset, _, _, _, code, preCode) = (code, stackOffset, preCode) | loadSysV64Args(arg::args, stackOffset, argOffset, gRegs, fpRegs, code, preCode) = let val {size, align, typeCode, ...} = Foreign.LibFFI.extractFFItype arg (* Load a value into a register. Normally the size will be 1, 2, 4 or 8 bytes and this will just involve a simple load. Structs, though, can be of any size up to 8 bytes. *) fun loadRegister(reg, offset, size) = let (* We don't necessarily have to sign-extend. There's a comment in libffi that suggests that LVM expects it even though the SysV ABI doesn't require it. *) val moveOp = if size = 0w8 then Move64 else if typeCode = Foreign.LibFFI.ffiTypeCodeSInt32 orelse typeCode = Foreign.LibFFI.ffiTypeCodeInt then Move32X64 else if size >= 0w4 then Move32 else if typeCode = Foreign.LibFFI.ffiTypeCodeSInt16 then Move16X64 else if size >= 0w2 then Move16 else if typeCode = Foreign.LibFFI.ffiTypeCodeSInt8 then Move8X64 else Move8 in [Move{source=MemoryArg{base=mlArg2Reg, offset=Word.toInt offset, index=NoIndex}, destination=RegisterArg reg, moveSize=moveOp}] end @ ( if size = 0w6 orelse size = 0w7 then [ Move{source=MemoryArg{base=mlArg2Reg, offset=Word.toInt offset + 4, index=NoIndex}, destination=RegisterArg argWorkReg, moveSize=Move16}, ShiftConstant{ shiftType=SHL, output=argWorkReg, shift=0w32, opSize=OpSize64 }, ArithToGenReg{ opc=OR, output=reg, source=RegisterArg argWorkReg, opSize=OpSize64 } ] else [] ) @ ( if size = 0w3 orelse size = 0w5 orelse size = 0w7 then [ Move{source=MemoryArg{base=mlArg2Reg, offset=Word.toInt offset + Word.toInt(size-0w1), index=NoIndex}, destination=RegisterArg argWorkReg, moveSize=Move8}, ShiftConstant{ shiftType=SHL, output=argWorkReg, shift=Word8.fromLargeWord(Word.toLargeWord((size-0w1)*0w8)), opSize=OpSize64 }, ArithToGenReg{ opc=OR, output=reg, source=RegisterArg argWorkReg, opSize=OpSize64 } ] else [] ) val newArgOffset = alignUp(argOffset, align) val word1Addr = {base=mlArg2Reg, offset=Word.toInt newArgOffset, index=NoIndex} val word2Addr = {base=mlArg2Reg, offset=Word.toInt newArgOffset + 8, index=NoIndex} in case (classifyArg arg, size > 0w8, gRegs, fpRegs) of (* 8 bytes or smaller - single general reg. This is the usual case. *) (ArgInRegs{firstInSSE=false, ...}, false, gReg :: gRegs', fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', loadRegister(gReg, newArgOffset, size) @ code, preCode) (* 8 bytes or smaller - single SSE reg. Usual case for real arguments. *) | (ArgInRegs{firstInSSE=true, ...}, false, gRegs', fpReg :: fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', XMMArith{opc=if size = 0w4 then SSE2MoveFloat else SSE2MoveDouble, source=MemoryArg word1Addr, output=fpReg } :: code, preCode) (* 9-16 bytes - both values in general regs. *) | (ArgInRegs{firstInSSE=false, secondInSSE=false}, true, gReg1 :: gReg2 :: gRegs', fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', Move{source=MemoryArg word1Addr, destination=RegisterArg gReg1, moveSize=Move64} :: loadRegister(gReg2, newArgOffset+0w8, size-0w8) @ code, preCode) (* 9-16 bytes - first in general, second in SSE. *) | (ArgInRegs{firstInSSE=false, secondInSSE=true}, true, gReg :: gRegs', fpReg :: fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', Move{source=MemoryArg word1Addr, destination=RegisterArg gReg, moveSize=Move64} :: XMMArith{opc=if size = 0w12 then SSE2MoveFloat else SSE2MoveDouble, source=MemoryArg word2Addr, output=fpReg } :: code, preCode) (* 9-16 bytes - first in SSE, second in general. *) | (ArgInRegs{firstInSSE=true, secondInSSE=false}, true, gReg :: gRegs', fpReg :: fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', XMMArith{opc=SSE2MoveDouble, source=MemoryArg word1Addr, output=fpReg } :: loadRegister(gReg, newArgOffset+0w8, size-0w8) @ code, preCode) | (* 9-16 bytes - both values in SSE regs. *) (ArgInRegs{firstInSSE=true, secondInSSE=true}, true, gRegs', fpReg1 :: fpReg2 :: fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', XMMArith{opc=SSE2MoveDouble, source=MemoryArg word1Addr, output=fpReg1 } :: XMMArith{opc=if size = 0w12 then SSE2MoveFloat else SSE2MoveDouble, source=MemoryArg word2Addr, output=fpReg2 } :: code, preCode) | (_, _, gRegs', fpRegs') => (* Either larger than 16 bytes or we've run out of the right kind of registers. *) (* Move the argument in the preCode. It's possible a large struct could be the first argument and if we left it until the end RDI and RSI would already have been loaded. *) let val space = intAlignUp(Word.toInt size, 0w8) in loadSysV64Args(args, stackOffset+space, newArgOffset+size, gRegs', fpRegs', code, ArithToGenReg{opc=SUB, output=rsp, source=NonAddressConstArg(LargeInt.fromInt space), opSize=nativeWordOpSize} :: moveMemory{source=(mlArg2Reg, Word.toInt newArgOffset), destination=(rsp, 0), length=Word.toInt size} @ preCode) end end (* The rules for returning structs are similar to those for parameters. *) local (* Store a result register into the result area. In almost all cases this is very simple: the only complication is with structs of odd sizes. *) fun storeResult(reg, offset, size) = let val moveOp = if size = 0w8 then Move64 else if size >= 0w4 then Move32 else if size >= 0w2 then Move16 else Move8 in [Move{source=RegisterArg reg, destination=MemoryArg {base=ecx, offset=offset, index=NoIndex}, moveSize=moveOp}] end @ ( if size = 0w6 orelse size = 0w7 then [ ShiftConstant{ shiftType=SHR, output=reg, shift=0w32, opSize=OpSize64 }, Move{source=RegisterArg reg, destination=MemoryArg {base=ecx, offset=offset+4, index=NoIndex}, moveSize=Move16} ] else [] ) @ ( if size = 0w3 orelse size = 0w5 orelse size = 0w7 then [ ShiftConstant{ shiftType=SHR, output=reg, shift=Word8.fromLargeWord(Word.toLargeWord((size-0w1)*0w8)), opSize=OpSize64 }, Move{source=RegisterArg reg, destination=MemoryArg {base=ecx, offset=offset+Word.toInt(size-0w1), index=NoIndex}, moveSize=Move8} ] else [] ) val {size, typeCode, ...} = Foreign.LibFFI.extractFFItype result in val (getResult, passArgAddress) = if typeCode = Foreign.LibFFI.ffiTypeCodeVoid then ([], false) else case (classifyArg result, size > 0w8) of (* 8 bytes or smaller - returned in RAX - Normal case for int-like results. *) (ArgInRegs{firstInSSE=false, ...}, false) => (storeResult(rax, 0, size), false) (* 8 bytes or smaller - returned in XMM0 - Normal case for real results. *) | (ArgInRegs{firstInSSE=true, ...}, false) => ([XMMStoreToMemory{toStore=xmm0, address={base=rcx, offset=0, index=NoIndex}, precision=if size = 0w4 then SinglePrecision else DoublePrecision}], false) (* 9-16 bytes - returned in RAX/RDX. *) | (ArgInRegs{firstInSSE=false, secondInSSE=false}, true) => (storeResult(rax, 0, 0w8) @ storeResult(rdx, 0, size-0w8), false) (* 9-16 bytes - first in RAX, second in XMM0. *) | (ArgInRegs{firstInSSE=false, secondInSSE=true}, true) => (XMMStoreToMemory{toStore=xmm0, address={base=rcx, offset=8, index=NoIndex}, precision=if size = 0w12 then SinglePrecision else DoublePrecision} :: storeResult(rax, 0, 0w8), false) (* 9-16 bytes - first in XMM0, second in RAX. *) | (ArgInRegs{firstInSSE=true, secondInSSE=false}, true) => (XMMStoreToMemory{toStore=xmm0, address={base=rcx, offset=0, index=NoIndex}, precision=DoublePrecision} :: storeResult(rax, 8, size-0w8), false) (* 9-16 bytes - both values in SSE regs.*) | (ArgInRegs{firstInSSE=true, secondInSSE=true}, true) => ([XMMStoreToMemory{toStore=xmm0, address={base=rcx, offset=0, index=NoIndex}, precision=DoublePrecision}, XMMStoreToMemory{toStore=xmm1, address={base=rcx, offset=8, index=NoIndex}, precision=if size = 0w12 then SinglePrecision else DoublePrecision}], false) | _ => ([], true) (* Have to pass the address of the area in memory *) end val sysVGenRegs = [rdi, rsi, rdx, rcx, r8, r9] and sysVFPRegs = [xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7] val (argCode, argStack, preArgCode) = if passArgAddress (* If we have to pass the address of the result struct it goes in rdi. *) then loadSysV64Args(args, 0, 0w0, tl sysVGenRegs, sysVFPRegs, [moveRR{source=resultAreaPtr, output=rdi, opSize=nativeWordOpSize}], []) else loadSysV64Args(args, 0, 0w0, sysVGenRegs, sysVFPRegs, [], []) local val align = argStack mod 16 in (* Always align the stack. *) val preArgAlign = if align = 0 then 0 else 16-align end in (* Save heap ptr. Needed in case we have a callback. *) [storeMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize)] @ ( (* Put the destination address into a callee save resgister. We have to put the C address in there now because an ML address wouldn't be updated by a possible GC in a callback. *) if #typeCode(Foreign.LibFFI.extractFFItype result) <> Foreign.LibFFI.ffiTypeCodeVoid then [loadHeapMemory(resultAreaPtr, r8, 0, nativeWordOpSize)] else [] ) @ [ (* Save the stack pointer. *) storeMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Save ML stack and switch to C stack. *) loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize) (* Load the saved C stack pointer. *) ] @ ( if preArgAlign = 0 then [] else [ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt preArgAlign), opSize=nativeWordOpSize}] ) @ ( (* The second argument is a SysWord containing the address of a malloced area of memory with the actual arguments in it. *) if null args then [] else [loadHeapMemory(mlArg2Reg, mlArg2Reg, 0, nativeWordOpSize)] ) @ preArgCode @ argCode @ [ let (* The entry point is in a SysWord.word value in RAX. *) val entryPoint = case targetArch of ObjectId32Bit => MemoryArg{base=ebx, offset=0, index=Index4 eax} | _ => MemoryArg{base=eax, offset=0, index=NoIndex} in (* Call the function. We're discarding the value in rsp so no need to remove args. *) CallAddress entryPoint end, loadMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Restore the ML stack pointer. *) (* Reload the heap pointer. If we've called back to ML this could well have changed. *) loadMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize) ] @ (* Store the result in the destination. *) getResult @ [ ReturnFromFunction 0 ] end (* callUnix64Bits *) end fun foreignCall(abivalue: Foreign.LibFFI.abi, args: Foreign.LibFFI.ffiType list, result: Foreign.LibFFI.ffiType): Address.machineWord = let val abi = getFFIAbi abivalue val code = case abi of FFI_UNIX64 => callUnix64Bits(args, result) | FFI_WIN64 => callWindows64Bits(args, result) | _ => call32Bits(abi, args, result) val functionName = "foreignCall" val debugSwitches = [Universal.tagInject Pretty.compilerOutputTag (Pretty.prettyPrint(print, 70)), Universal.tagInject DEBUG.assemblyCodeTag true] val profileObject = createProfileObject functionName val newCode = codeCreate (functionName, profileObject, debugSwitches) val closure = makeConstantClosure() val () = X86OPTIMISE.generateCode{code=newCode, labelCount=0, ops=code, resultClosure=closure} in closureAsAddress closure end (* Build a callback function. The arguments are the abi, the list of argument types and the result type. The result is an ML function that takes an ML function, f, as its argument, registers it as a callback and returns the C function as its result. When the C function is called the arguments are copied into temporary memory and the vector passed to f along with the address of the memory for the result. "f" stores the result in it when it returns and the result is then passed back as the result of the callback. *) fun buildCallBack(abivalue: Foreign.LibFFI.abi, args: Foreign.LibFFI.ffiType list, result: Foreign.LibFFI.ffiType): Address.machineWord = let val abi = getFFIAbi abivalue in raise Fail "TODO: foreignCall" end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeToX86Code.ML b/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeToX86Code.ML index b7e9d821..d5ea923d 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeToX86Code.ML +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeToX86Code.ML @@ -1,2115 +1,2110 @@ (* Copyright David C. J. Matthews 2016-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 *) functor X86ICodeToX86Code( structure X86CODE: X86CODESIG structure X86OPTIMISE: sig type operation type code type operations = operation list type closureRef val generateCode: {code: code, ops: operations, labelCount: int, resultClosure: closureRef } -> unit structure Sharing: sig type operation = operation type code = code type closureRef = closureRef end end structure DEBUG: DEBUGSIG structure ICODE: ICodeSig structure IDENTIFY: X86IDENTIFYREFSSIG structure INTSET: INTSETSIG structure PRETTY: PRETTYSIG structure STRONGLY: sig val stronglyConnectedComponents: {nodeAddress: 'a -> int, arcs: 'a -> int list } -> 'a list -> 'a list list end sharing X86CODE.Sharing = ICODE.Sharing = X86OPTIMISE.Sharing = IDENTIFY.Sharing = INTSET ): X86ICODEGENERATESIG = struct open IDENTIFY open ICODE open X86CODE open Address exception InternalError = Misc.InternalError fun asGenReg(GenReg r) = r | asGenReg _ = raise InternalError "asGenReg" and asFPReg(FPReg r) = r | asFPReg _ = raise InternalError "asFPReg" and asXMMReg(XMMReg r) = r | asXMMReg _ = raise InternalError "asXMMReg" (* tag a short constant *) fun tag c = 2 * c + 1 local val regs = case targetArch of Native32Bit => [edi, esi, edx, ecx, ebx, eax] | Native64Bit => [r14, r13, r12, r11, r10, r9, r8, edi, esi, edx, ecx, ebx, eax] | ObjectId32Bit => [r14, r13, r12, r11, r10, r9, r8, edi, esi, edx, ecx, eax] in val generalRegisters = List.map GenReg regs end fun opSizeToMove OpSize32 = Move32 | opSizeToMove OpSize64 = Move64 fun icodeToX86Code{blocks, functionName, stackRequired, debugSwitches, allocatedRegisters, resultClosure, ...} = let fun argAsGenReg(RegisterArg(GenReg r)) = r | argAsGenReg _ = raise InternalError "argAsGenReg" fun sourceAsGenRegOrMem(RegisterArg(GenReg r)) = RegisterArg r | sourceAsGenRegOrMem(MemoryArg{offset, base=baseReg, index}) = MemoryArg{base=baseReg, offset=offset, index=index} | sourceAsGenRegOrMem(NonAddressConstArg v) = NonAddressConstArg v | sourceAsGenRegOrMem(AddressConstArg v) = AddressConstArg v | sourceAsGenRegOrMem _ = raise InternalError "sourceAsGenRegOrMem" and sourceAsXMMRegOrMem(RegisterArg(XMMReg r)) = RegisterArg r | sourceAsXMMRegOrMem(MemoryArg{offset, base=baseReg, index}) = MemoryArg{base=baseReg, offset=offset, index=index} | sourceAsXMMRegOrMem(NonAddressConstArg v) = NonAddressConstArg v | sourceAsXMMRegOrMem(AddressConstArg v) = AddressConstArg v | sourceAsXMMRegOrMem _ = raise InternalError "sourceAsGenRegOrMem" (* Moves and loads. *) fun llLoadArgument({ source, dest=GenReg destReg, kind=Move64Bit}, code) = Move { source=sourceAsGenRegOrMem source, destination=RegisterArg destReg, moveSize=Move64 } :: code | llLoadArgument({ source=MemoryArg mLoc, dest=GenReg destReg, kind=MoveByte}, code) = (* Load from memory. *) Move{moveSize=Move8, source=MemoryArg mLoc, destination=RegisterArg destReg} :: code | llLoadArgument({ source=MemoryArg mLoc, dest=GenReg destReg, kind=Move16Bit}, code) = (* Load from memory. *) Move{moveSize=Move16, source=MemoryArg mLoc, destination=RegisterArg destReg} :: code | llLoadArgument({ source, dest=GenReg destReg, kind=Move32Bit}, code) = (* Load from memory. *) Move { source=sourceAsGenRegOrMem source, destination=RegisterArg destReg, moveSize=Move32 } :: code (* Load a floating point value. *) | llLoadArgument({source=MemoryArg{offset, base=baseReg, index}, dest=FPReg fpReg, kind=MoveDouble}, code) = moveToOutputFP(fpReg, FPLoadFromMemory{ address={base=baseReg, offset=offset, index=index}, precision=DoublePrecision } :: code) | llLoadArgument({source=AddressConstArg addrConst, dest=FPReg fpReg, kind=MoveDouble}, code) = moveToOutputFP(fpReg, FPLoadFromConst{ constant= addrConst, precision=DoublePrecision } :: code) | llLoadArgument({source=RegisterArg(FPReg fpSrc), dest=FPReg fpDest, kind=MoveDouble}, code) = (* Moving from one FP reg to another. Even if we are moving from FP0 we still do a load because FPStoreToFPReg adds one to the register number to account for one value on the stack. *) moveToOutputFP(fpDest, FPLoadFromFPReg{source=fpSrc, lastRef=false} :: code) (* Load or move from an XMM reg. *) | llLoadArgument({source, dest=XMMReg xmmRegReg, kind=MoveDouble}, code) = XMMArith { opc= SSE2MoveDouble, source=sourceAsXMMRegOrMem source, output=xmmRegReg } :: code (* Load a floating point value. *) | llLoadArgument({source=MemoryArg{offset, base=baseReg, index}, dest=FPReg fpReg, kind=MoveFloat}, code) = moveToOutputFP(fpReg, FPLoadFromMemory{ address={ base=baseReg, offset=offset, index=index }, precision=SinglePrecision } :: code) | llLoadArgument({source=AddressConstArg addrConst, dest=FPReg fpReg, kind=MoveFloat}, code) = moveToOutputFP(fpReg, FPLoadFromConst{ constant= addrConst, precision=SinglePrecision } :: code) (* Load or move from an XMM reg. *) | llLoadArgument({source, dest=XMMReg xmmRegReg, kind=MoveFloat}, code) = XMMArith { opc= SSE2MoveFloat, source=sourceAsXMMRegOrMem source, output=xmmRegReg } :: code (* Any other combinations are not allowed. *) | llLoadArgument _ = raise InternalError "codeGenICode: LoadArgument" (* Unless the destination is FP0 we need to store and pop. *) and moveToOutputFP(fpDest, code) = if fpDest = fp0 then code else FPStoreToFPReg{output=fpDest, andPop=true} :: code (* Store to memory *) fun llStoreArgument{ source=RegisterArg(GenReg sourceReg), base, offset, index, kind=Move64Bit} = Move{source=RegisterArg sourceReg, destination=MemoryArg {base=base, offset=offset, index=index}, moveSize=opSizeToMove OpSize64} | llStoreArgument{ source=RegisterArg(GenReg sourceReg), base, offset, index, kind=MoveByte} = Move{moveSize=Move8, source=RegisterArg sourceReg, destination=MemoryArg {base=base, offset=offset, index=index}} | llStoreArgument{ source=RegisterArg(GenReg sourceReg), base, offset, index, kind=Move16Bit} = Move{moveSize=Move16, source=RegisterArg sourceReg, destination=MemoryArg {base=base, offset=offset, index=index}} | llStoreArgument{ source=RegisterArg(GenReg sourceReg), base, offset, index, kind=Move32Bit} = Move{source=RegisterArg sourceReg, destination=MemoryArg {base=base, offset=offset, index=index}, moveSize=opSizeToMove OpSize32} (* Store a short constant to memory *) | llStoreArgument{ source=NonAddressConstArg srcValue, base, offset, index, kind=Move64Bit} = Move{source=NonAddressConstArg srcValue, destination=MemoryArg {base=base, offset=offset, index=index}, moveSize=Move64} | llStoreArgument{ source=NonAddressConstArg srcValue, base, offset, index, kind=Move32Bit} = Move{source=NonAddressConstArg srcValue, destination=MemoryArg {base=base, offset=offset, index=index}, moveSize=Move32} | llStoreArgument{ source=NonAddressConstArg srcValue, base, offset, index, kind=MoveByte} = Move{moveSize=Move8, source=NonAddressConstArg srcValue, destination=MemoryArg{base=base, offset=offset, index=index}} (* Store a long constant to memory *) | llStoreArgument{ source=AddressConstArg srcValue, base, offset, index, kind} = ( (* This Move must be of a polyWord size. *) case (kind, polyWordOpSize) of (Move64Bit, OpSize64) => () | (Move32Bit, OpSize32) => () | _ => raise InternalError "Move of AddressConstArg"; Move{moveSize=opSizeToMove polyWordOpSize, source=AddressConstArg srcValue, destination=MemoryArg {base=base, offset=offset, index=index}} ) (* Store a floating point value. *) | llStoreArgument{source=RegisterArg(FPReg fpReg), offset, base=baseReg, index, kind=MoveDouble} = let val _ = fpReg = fp0 orelse raise InternalError "llStoreArgument: Store FPReg <> fp0" in FPStoreToMemory{ address={ base=baseReg, offset=offset, index=index}, precision=DoublePrecision, andPop=true } end | llStoreArgument{source=RegisterArg(XMMReg xmmRegReg), offset, base=baseReg, index, kind=MoveDouble} = XMMStoreToMemory { toStore=xmmRegReg, address={base=baseReg, offset=offset, index=index}, precision=DoublePrecision } (* Store a floating point value. *) | llStoreArgument{source=RegisterArg(FPReg fpReg), offset, base=baseReg, index, kind=MoveFloat} = let val _ = fpReg = fp0 orelse raise InternalError "llStoreArgument: Store FPReg <> fp0" in FPStoreToMemory{address={ base=baseReg, offset=offset, index=index}, precision=SinglePrecision, andPop=true } end | llStoreArgument{source=RegisterArg(XMMReg xmmRegReg), offset, base=baseReg, index, kind=MoveFloat} = XMMStoreToMemory { toStore=xmmRegReg, address={base=baseReg, offset=offset, index=index}, precision=SinglePrecision } | llStoreArgument _ = raise InternalError "llStoreArgument: StoreArgument" val numBlocks = Vector.length blocks fun getAllocatedReg r = Vector.sub(allocatedRegisters, r) val getAllocatedGenReg = asGenReg o getAllocatedReg and getAllocatedFPReg = asFPReg o getAllocatedReg and getAllocatedXMMReg = asXMMReg o getAllocatedReg fun codeExtIndex NoMemIndex = NoIndex | codeExtIndex(MemIndex1(PReg r)) = Index1(getAllocatedGenReg r) | codeExtIndex(MemIndex2(PReg r)) = Index2(getAllocatedGenReg r) | codeExtIndex(MemIndex4(PReg r)) = Index4(getAllocatedGenReg r) | codeExtIndex(MemIndex8(PReg r)) = Index8(getAllocatedGenReg r) | codeExtIndex ObjectIndex = raise InternalError "codeExtIndex: ObjectIndex" local fun codeExtArgument getReg (RegisterArgument(PReg r)) = RegisterArg(getReg r) | codeExtArgument _ (AddressConstant m) = AddressConstArg m | codeExtArgument _ (IntegerConstant i) = NonAddressConstArg i | codeExtArgument _ (MemoryLocation{base=PReg bReg, offset, index=ObjectIndex, cache=NONE}) = MemoryArg{base=ebx, index=Index4(getAllocatedGenReg bReg), offset=offset} | codeExtArgument _ (MemoryLocation{base=PReg bReg, offset, index, cache=NONE}) = MemoryArg{base=getAllocatedGenReg bReg, offset=offset, index=codeExtIndex index} | codeExtArgument getReg (MemoryLocation{cache=SOME(PReg r), ...}) = RegisterArg(getReg r) | codeExtArgument _ (StackLocation{wordOffset, cache=NONE, ...}) = MemoryArg{base=esp, offset=wordOffset*Word.toInt nativeWordSize, index=NoIndex} | codeExtArgument getReg (StackLocation{cache=SOME(PReg r), ...}) = RegisterArg(getReg r) | codeExtArgument _ (ContainerAddr _) = raise InternalError "codeExtArgument - ContainerAddr" in val codeExtArgument = codeExtArgument getAllocatedReg and codeExtArgumentAsGenReg = codeExtArgument getAllocatedGenReg and codeExtArgumentAsFPReg = codeExtArgument getAllocatedFPReg and codeExtArgumentAsXMMReg = codeExtArgument getAllocatedXMMReg end fun codeCallKind Recursive = NonAddressConstArg 0 (* Jump to the start *) | codeCallKind (ConstantCode v) = AddressConstArg v | codeCallKind FullCall = ( case targetArch of ObjectId32Bit => MemoryArg{base=ebx, index=Index4 edx, offset=0} | _ => MemoryArg{base=edx, index=NoIndex, offset=0} ) (* Move unless the registers are the same. *) fun moveIfNecessary({src, dst, kind}, code) = if src = dst then code else llLoadArgument({source=RegisterArg src, dest=dst, kind=kind}, code) fun opSizeToIMove OpSize64 = Move64Bit | opSizeToIMove OpSize32 = Move32Bit datatype llsource = StackSource of int | OtherSource of reg regOrMemoryArg fun sourceToX86Code(OtherSource r) = r | sourceToX86Code(StackSource wordOffset) = MemoryArg{base=esp, offset=wordOffset*Word.toInt nativeWordSize, index=NoIndex} local fun indexRegister NoIndex = NONE | indexRegister (Index1 r) = SOME r | indexRegister (Index2 r) = SOME r | indexRegister (Index4 r) = SOME r | indexRegister (Index8 r) = SOME r (* The registers are numbered from 0. Choose values that don't conflict with the stack addresses. *) fun regNo r = ~1 - nReg r type node = {src: llsource, dst: destinations } fun nodeAddress({dst=RegDest r, ...}: node) = regNo r | nodeAddress({dst=StackDest a, ...}) = a fun arcs({src=StackSource wordOffset, ...}: node) = [wordOffset] | arcs{src=OtherSource(RegisterArg r), ...} = [regNo r] | arcs{src=OtherSource(MemoryArg{base, index, ...}), ...} = (case indexRegister index of NONE => [regNo(GenReg base)] | SOME r => [regNo(GenReg base), regNo(GenReg r)]) | arcs _ = [] in val stronglyConnected = STRONGLY.stronglyConnectedComponents { nodeAddress=nodeAddress, arcs=arcs } end (* This is a general function for moving values into registers or to the stack where it is possible that the source values might also be in use as destinations. The stack is used for destinations only for tail recursive calls. *) fun moveMultipleValues(moves, workReg: reg option, code) = let val _ = if List.exists(fn {dst=StackDest _, ...} => true | _ => false) moves andalso not(isSome workReg) then raise InternalError "no work reg" else () fun moveValues ([], code) = code (* We're done. *) | moveValues (arguments, code) = let (* stronglyConnectedComponents does two things. It detects loops where it's not possible to move items without breaking the loop but more importantly it orders the dependencies so that if there are no loops we can load the source and store it in the destination knowing that we won't overwrite anything we might later need. *) val ordered = stronglyConnected arguments fun isFPReg(GenReg _) = false | isFPReg(XMMReg _) = true | isFPReg(FPReg _) = true fun moveEachValue ([], code) = code | moveEachValue ([{dst=RegDest reg, src as OtherSource(RegisterArg r)}] :: rest, code) = (* Source and dest are both regs - only move if they're different. *) if r = reg then moveEachValue(rest, code) else moveEachValue(rest, llLoadArgument({source=sourceToX86Code src, dest=reg, kind=if isFPReg reg then MoveDouble else moveNativeWord}, code)) | moveEachValue ([{dst=RegDest reg, src}] :: rest, code) = (* Load from store or a constant. Have to use movePolyWord if it's an address constant. *) moveEachValue(rest, llLoadArgument({source=sourceToX86Code src, dest=reg, kind=movePolyWord}, code)) | moveEachValue ([{dst=StackDest _, src=OtherSource(MemoryArg _ )}] :: _, _) = raise InternalError "moveEachValue - MemoryArgument" | moveEachValue ([{dst=StackDest addr, src as StackSource wordOffset}] :: rest, code) = (* Copy a stack location - needs a load and store unless the address is the same. *) if addr = wordOffset then moveEachValue(rest, code) else let val workReg = valOf workReg in moveEachValue(rest, llStoreArgument{source=RegisterArg workReg, base=esp, index=NoIndex, offset = addr*Word.toInt nativeWordSize, kind=moveNativeWord} :: llLoadArgument({source=sourceToX86Code src, dest=workReg, kind=moveNativeWord}, code)) end | moveEachValue ([{dst=StackDest addr, src}] :: rest, code) = (* Store from a register or a constant. *) moveEachValue(rest, llStoreArgument{ source=sourceToX86Code src, base=esp, index=NoIndex, offset = addr*Word.toInt nativeWordSize, kind=moveNativeWord} :: code) | moveEachValue((cycle as first :: _ :: _) :: rest, code) = (* We have a cycle. *) let (* We need to exchange some of the arguments. Doing an exchange here will set the destination with the correct source. However we have to process every subsequent entry with the swapped registers. That may well mean that one of those entries becomes trivial. Using XCHG means that we can move N registers in N-1 exchanges. We also need to rerun stronglyConnectedComponents on at least the rest of this cycle. It's easiest to flatten the rest and do everything. *) (* Try to find either a register-register move or a register-stack move. If not use the first. If there's a stack-register move there will also be a register-stack so we don't need to look for both. *) val {dst=selectDst, src=selectSrc} = case List.find(fn {src=OtherSource(RegisterArg _), dst=RegDest _} => true | _ => false) cycle of SOME found => found | _ => ( case List.find(fn {dst=RegDest _, ...} => true | _ => false) cycle of SOME found => found | NONE => first ) (* This includes this entry but after the swap we'll eliminate it. *) val flattened = List.foldl(fn (a, b) => a @ b) [] (cycle :: rest) val destAsSource = case selectDst of RegDest reg => OtherSource(RegisterArg reg) | StackDest s => StackSource s (* Source is not an equality type. We can't currently handle the situation where the source is a memory location. *) fun match(OtherSource(RegisterArg r1), OtherSource(RegisterArg r2)) = r1 = r2 | match(StackSource s1, StackSource s2) = s1 = s2 | match(OtherSource(MemoryArg _), _) = raise InternalError "moveEachValue: cycle" | match _ = false fun swapSources{src, dst} = if match(src, selectSrc) then {src=destAsSource, dst=dst} else if match(src, destAsSource) then {src=selectSrc, dst=dst} else {src=src, dst=dst} (* Try to use register to register exchange if we can. A register-to-memory exchange involves a bus lock and we'd like to avoid that. *) val exchangeCode = case (selectDst, selectSrc) of (RegDest(GenReg regA), OtherSource(RegisterArg(GenReg regB))) => XChng { reg=regA, arg=RegisterArg regB, opSize=nativeWordOpSize } :: code | (RegDest(XMMReg regA), OtherSource(RegisterArg(XMMReg regB))) => (* This is the only case where we can have a cycle with SSE2 regs. There are various ways of doing it but XORs are probably the easiest. *) XMMArith{opc=SSE2Xor, source=RegisterArg regA, output=regB} :: XMMArith{opc=SSE2Xor, source=RegisterArg regB, output=regA} :: XMMArith{opc=SSE2Xor, source=RegisterArg regA, output=regB} :: code | (RegDest _, OtherSource(RegisterArg _)) => raise InternalError "moveEachValue: invalid register combination" | (RegDest regA, src as StackSource addr) => let val workReg = valOf workReg in llStoreArgument{source=RegisterArg workReg, base=esp, index=NoIndex, offset = addr*Word.toInt nativeWordSize, kind=moveNativeWord} :: XChng { reg=asGenReg regA, arg=RegisterArg(asGenReg workReg), opSize=nativeWordOpSize } :: llLoadArgument({source=sourceToX86Code src, dest=workReg, kind=moveNativeWord}, code) end | (StackDest addr, OtherSource(RegisterArg regA)) => let (* This doesn't actually occur because we always find the case above. *) val workReg = valOf workReg in llStoreArgument{source=RegisterArg workReg, base=esp, index=NoIndex, offset = addr*Word.toInt nativeWordSize, kind=moveNativeWord} :: XChng { reg=asGenReg regA, arg=RegisterArg (asGenReg workReg), opSize=nativeWordOpSize } :: llLoadArgument({ source=MemoryArg{base=esp, offset=addr*Word.toInt nativeWordSize, index=NoIndex}, dest=workReg, kind=moveNativeWord}, code) end | (StackDest addr1, StackSource addr2) => let val workReg = valOf workReg (* This can still happen if we have argument registers that need to be loaded from stack locations and those argument registers happen to contain the values to be stored into those stack locations. e.g. ebx => S8; eax => S7; S8 => eax; S7 => eax. Eliminating the registers results in a cycle. It may be possible to avoid this by excluding the argument registers (eax; ebx; r8; r9; r10) from holding values in the area to be overwritten. *) in llStoreArgument{source=RegisterArg workReg, base=esp, index=NoIndex, offset = addr1*Word.toInt nativeWordSize, kind=moveNativeWord} :: XChng { reg=asGenReg workReg, arg=MemoryArg{base=esp, offset=addr2*Word.toInt nativeWordSize, index=NoIndex}, opSize=nativeWordOpSize } :: llLoadArgument({ source=MemoryArg{base=esp, offset=addr1*Word.toInt nativeWordSize, index=NoIndex}, dest=workReg, kind=moveNativeWord}, code) end | _ => raise InternalError "moveEachValue: cycle" in moveValues(List.map swapSources flattened, exchangeCode) end | moveEachValue(([]) :: _, _) = (* This should not happen - avoid warning. *) raise InternalError "moveEachValue - empty set" in moveEachValue(ordered, code) end in moveValues(moves, code) end (* Where we have multiple specific registers as either source or destination there is the potential that a destination register if currently in use as a source. *) fun moveMultipleRegisters(regPairList, code) = let val regPairsAsDests = List.map(fn {src, dst} => {src=OtherSource(RegisterArg src), dst=RegDest dst}) regPairList in moveMultipleValues(regPairsAsDests, NONE, code) end val outputLabelCount = ref 0 val blockToLabelMap = Array.array(numBlocks, ~1) fun makeLabel() = Label{labelNo = ! outputLabelCount} before outputLabelCount := !outputLabelCount + 1 fun getBlockLabel blockNo = case Array.sub(blockToLabelMap, blockNo) of ~1 => let val label as Label{labelNo} = makeLabel() val () = Array.update(blockToLabelMap, blockNo, labelNo) in label end | n => Label{labelNo=n} (* The profile object is a single mutable with the F_bytes bit set. *) local val v = RunCall.allocateByteMemory(0w1, Word.fromLargeWord(Word8.toLargeWord(Word8.orb(F_mutable, F_bytes)))) fun clear 0w0 = () | clear i = (assignByte(v, i-0w1, 0w0); clear (i-0w1)) val () = clear wordSize in val profileObject = toMachineWord v end (* Switch to indicate if we want to trace where live data has been allocated. *) val addAllocatingFunction = DEBUG.getParameter DEBUG.profileAllocationTag debugSwitches = 1 fun llAllocateMemoryOperation ({ size, flags, dest, saveRegs}, code) = let val toReg = asGenReg dest val preserve = saveRegs (* Allocate memory. N.B. Instructions are in reverse order. *) fun allocStore{size, flags, output, preserve} = if targetArch = Native64Bit andalso flags <> 0w0 then [Move{moveSize=Move8, source=NonAddressConstArg(Word8.toLargeInt flags), destination=MemoryArg {offset= ~1, base=output, index=NoIndex}}, Move{source=NonAddressConstArg(LargeInt.fromInt size), destination=MemoryArg {offset= ~ (Word.toInt wordSize), base=output, index=NoIndex}, moveSize=opSizeToMove polyWordOpSize}, AllocStore{size=size, output=output, saveRegs=preserve}] else let val lengthWord = IntInf.orb(IntInf.fromInt size, IntInf.<<(Word8.toLargeInt flags, 0w24)) in [Move{source=NonAddressConstArg lengthWord, destination=MemoryArg {offset= ~ (Word.toInt wordSize), base=output, index=NoIndex}, moveSize=opSizeToMove polyWordOpSize}, AllocStore{size=size, output=output, saveRegs=preserve}] end val allocCode = (* If we need to add the profile object *) if addAllocatingFunction then allocStore {size=size+1, flags=Word8.orb(flags, Address.F_profile), output=toReg, preserve=preserve} @ [Move{moveSize=opSizeToMove polyWordOpSize, source=AddressConstArg profileObject, destination=MemoryArg {base=toReg, offset=size*Word.toInt wordSize, index=NoIndex}}] else allocStore {size=size, flags=flags, output=toReg, preserve=preserve} (* Convert to an object index if necessary. *) val convertToObjId = if targetArch = ObjectId32Bit then [ ShiftConstant{ shiftType=SHR, output=toReg, shift=0w2, opSize=OpSize64 }, ArithToGenReg{ opc=SUB, output=toReg, source=RegisterArg ebx, opSize=nativeWordOpSize } ] else [] in convertToObjId @ allocCode @ code end (* Check the stack limit "register". This is used both at the start of a function for genuine stack checking but also in a loop to check for an interrupt. We need to save the registers even across an interrupt because it can be used if another thread wants a GC. *) fun testRegAndTrap(reg, entryPt, saveRegs) = let (* Normally we won't have a stack overflow so we will skip the check. *) val skipCheckLab = makeLabel() in (* Need it in reverse order. *) [ JumpLabel skipCheckLab, CallRTS{rtsEntry=entryPt, saveRegs=saveRegs}, ConditionalBranch{test=JNB, label=skipCheckLab}, ArithToGenReg{ opc=CMP, output=reg, source=MemoryArg{offset=memRegStackLimit, base=ebp, index=NoIndex}, opSize=nativeWordOpSize } ] end local val numRegisters = Vector.length allocatedRegisters val uses = Array.array(numRegisters, false) fun used(PReg r) = Array.update(uses, r, true) fun isUsed(PReg r) = Array.sub(uses, r) (* Set the registers used by the sources. This differs from getInstructionState in that we don't set the base register of a memory location to "used" if we can use the cache. *) fun argUses(RegisterArgument rarg) = used rarg | argUses(MemoryLocation { cache=SOME cr, ...}) = used cr | argUses(MemoryLocation { base, index, cache=NONE, ...}) = (used base; indexUses index) | argUses(StackLocation { cache=SOME rarg, ...}) = used rarg | argUses _ = () and indexUses NoMemIndex = () | indexUses(MemIndex1 arg) = used arg | indexUses(MemIndex2 arg) = used arg | indexUses(MemIndex4 arg) = used arg | indexUses(MemIndex8 arg) = used arg | indexUses ObjectIndex = () (* LoadArgument, TagValue, CopyToCache, UntagValue and BoxValue are eliminated if their destination is not used. In that case their source are not used either. *) fun instructionUses(LoadArgument { source, dest, ...}) = if isUsed dest then argUses source else () | instructionUses(StoreArgument{ source, base, index, ...}) = (argUses source; used base; indexUses index) | instructionUses(LoadMemReg _) = () | instructionUses(BeginFunction _) = () | instructionUses(FunctionCall{regArgs, stackArgs, ...}) = (List.app(argUses o #1) regArgs; List.app argUses stackArgs) | instructionUses(TailRecursiveCall{regArgs, stackArgs, ...}) = (List.app(argUses o #1) regArgs; List.app(argUses o #src) stackArgs) | instructionUses(AllocateMemoryOperation _) = () | instructionUses(AllocateMemoryVariable{size, ...}) = used size | instructionUses(InitialiseMem{size, addr, init}) = (used size; used addr; used init) | instructionUses(InitialisationComplete) = () | instructionUses(BeginLoop) = () | instructionUses(JumpLoop{regArgs, stackArgs, ...}) = (List.app(argUses o #1) regArgs; List.app(argUses o #1) stackArgs) | instructionUses(RaiseExceptionPacket{packetReg}) = used packetReg | instructionUses(ReserveContainer _) = () | instructionUses(IndexedCaseOperation{testReg, ...}) = used testReg | instructionUses(LockMutable{addr}) = used addr | instructionUses(WordComparison{arg1, arg2, ...}) = (used arg1; argUses arg2) | instructionUses(CompareLiteral{arg1, ...}) = argUses arg1 | instructionUses(CompareByteMem{arg1={base, index, ...}, ...}) = (used base; indexUses index) | instructionUses(PushExceptionHandler _) = () | instructionUses(PopExceptionHandler _) = () | instructionUses(BeginHandler _) = () | instructionUses(ReturnResultFromFunction{resultReg, ...}) = used resultReg | instructionUses(ArithmeticFunction{operand1, operand2, ...}) = (used operand1; argUses operand2) | instructionUses(TestTagBit{arg, ...}) = argUses arg | instructionUses(PushValue {arg, ...}) = argUses arg | instructionUses(CopyToCache{source, dest, ...}) = if isUsed dest then used source else () | instructionUses(ResetStackPtr _) = () | instructionUses(StoreToStack {source, ...}) = argUses source | instructionUses(TagValue{source, dest, ...}) = if isUsed dest then used source else () | instructionUses(UntagValue{dest, cache=SOME cacheR, ...}) = if isUsed dest then used cacheR else () | instructionUses(UntagValue{source, dest, cache=NONE, ...}) = if isUsed dest then used source else () | instructionUses(LoadEffectiveAddress{base, index, ...}) = (case base of SOME bReg => used bReg | NONE => (); indexUses index) | instructionUses(ShiftOperation{operand, shiftAmount, ...}) = (used operand; argUses shiftAmount) | instructionUses(Multiplication{operand1, operand2, ...}) = (used operand1; argUses operand2) | instructionUses(Division{dividend, divisor, ...}) = (used dividend; argUses divisor) | instructionUses(AtomicExchangeAndAdd{base, source}) = (used base; used source) | instructionUses(BoxValue{source, dest, ...}) = if isUsed dest then used source else () | instructionUses(CompareByteVectors{vec1Addr, vec2Addr, length, ...}) = (used vec1Addr; used vec2Addr; used length) | instructionUses(BlockMove{srcAddr, destAddr, length, ...}) = (used srcAddr; used destAddr; used length) | instructionUses(X87Compare{arg1, arg2, ...}) = (used arg1; argUses arg2) | instructionUses(SSE2Compare{arg1, arg2, ...}) = (used arg1; argUses arg2) | instructionUses(X87FPGetCondition _) = () | instructionUses(X87FPArith{arg1, arg2, ...}) = (used arg1; argUses arg2) | instructionUses(X87FPUnaryOps{source, ...}) = used source | instructionUses(X87Float{source, ...}) = argUses source | instructionUses(SSE2Float{source, ...}) = argUses source | instructionUses(SSE2FPUnary{source, ...}) = argUses source | instructionUses(SSE2FPBinary{arg1, arg2, ...}) = (used arg1; argUses arg2) | instructionUses(TagFloat{source, dest, ...}) = if isUsed dest then used source else () | instructionUses(UntagFloat{dest, cache=SOME cacheR, ...}) = if isUsed dest then used cacheR else () | instructionUses(UntagFloat{source, dest, cache=NONE, ...}) = if isUsed dest then argUses source else () | instructionUses(GetSSE2ControlReg _) = () | instructionUses(SetSSE2ControlReg{source}) = used source | instructionUses(GetX87ControlReg _) = () | instructionUses(SetX87ControlReg{source}) = used source | instructionUses(X87RealToInt{source, ...}) = used source | instructionUses(SSE2RealToInt{source, ...}) = argUses source | instructionUses(SignExtend32To64{source, dest}) = if isUsed dest then argUses source else () (* Depth-first scan. *) val visited = Array.array(numBlocks, false) fun processBlocks blockNo = if Array.sub(visited, blockNo) then () (* Done or currently being done. *) else let val () = Array.update(visited, blockNo, true) val ExtendedBasicBlock { flow, block,...} = Vector.sub(blocks, blockNo) val () = (* Process the dependencies first. *) case flow of ExitCode => () | Unconditional m => processBlocks m | Conditional {trueJump, falseJump, ...} => (processBlocks trueJump; processBlocks falseJump) | IndexedBr cases => List.app processBlocks cases | SetHandler{ handler, continue } => (processBlocks handler; processBlocks continue) | UnconditionalHandle _ => () | ConditionalHandle { continue, ...} => processBlocks continue (* Now this block. *) in List.foldr(fn ({instr, ...}, ()) => instructionUses instr) () block end in val () = processBlocks 0 val isUsed = isUsed end (* Return the register part of a cached item. *) fun decache(StackLocation{cache=SOME r, ...}) = RegisterArgument r | decache(MemoryLocation{cache=SOME r, ...}) = RegisterArgument r | decache arg = arg (* Only get the registers that are actually used. *) val getSaveRegs = List.mapPartial(fn (reg as PReg r) => if isUsed reg then SOME(getAllocatedGenReg r) else NONE) fun codeExtended _ ({instr=LoadArgument{source, dest as PReg dreg, kind}, ...}, code) = if not (isUsed dest) then code else let val realDestReg = getAllocatedReg dreg in case source of RegisterArgument(PReg sreg) => (* Register to register move. Try to use the same register for the source as the destination to eliminate the instruction. *) (* If the source is the same as the destination we don't need to do anything. *) moveIfNecessary({src=getAllocatedReg sreg, dst=realDestReg, kind=kind}, code) | MemoryLocation{cache=SOME(PReg sreg), ...} => (* This is also a register to register move but because the original load is from memory it could be a byte or short precision value. *) let val moveKind = case kind of Move64Bit => Move64Bit | MoveByte => Move32Bit | Move16Bit => Move32Bit | Move32Bit => Move32Bit | MoveFloat => MoveFloat | MoveDouble => MoveDouble in moveIfNecessary({src=getAllocatedReg sreg, dst=realDestReg, kind=moveKind}, code) end (* TODO: Isn't this covered by codeExtArgument? It looks like it was added in the 32-in-64 changes. *) | StackLocation{cache=SOME(PReg sreg), ...} => moveIfNecessary({src=getAllocatedReg sreg, dst=realDestReg, kind=kind}, code) | source => (* Loads of constants or from an address. *) llLoadArgument({source=codeExtArgument source, dest=realDestReg, kind=kind}, code) end | codeExtended _ ({instr=StoreArgument{ source, base=PReg bReg, offset, index, kind, ... }, ...}, code) = let val (baseReg, indexVal) = case index of ObjectIndex => (ebx, Index4(getAllocatedGenReg bReg)) | _ => (getAllocatedGenReg bReg, codeExtIndex index) in case (decache source, kind) of (RegisterArgument(PReg sReg), MoveByte) => if targetArch <> Native32Bit then llStoreArgument{ source=codeExtArgument source, base=baseReg, offset=offset, index=indexVal, kind=MoveByte} :: code else (* This is complicated on X86/32. We can't use edi or esi for the store registers. Instead we reserve ecx (see special case in "identify") and use that if we have to. *) let val realStoreReg = getAllocatedReg sReg val (moveCode, storeReg) = if realStoreReg = GenReg edi orelse realStoreReg = GenReg esi then (moveIfNecessary({src=realStoreReg, dst=GenReg ecx, kind=moveNativeWord}, code), GenReg ecx) else (code, realStoreReg) in llStoreArgument{ source=RegisterArg storeReg, base=baseReg, offset=offset, index=indexVal, kind=MoveByte} :: moveCode end | _ => llStoreArgument{ source=codeExtArgument source, base=baseReg, offset=offset, index=indexVal, kind=kind} :: code end | codeExtended _ ({instr=LoadMemReg { offset, dest=PReg pr}, ...}, code) = (* Load from the "memory registers" pointed at by ebp. *) (* Currently only used to load the thread Id which is a Poly word. *) llLoadArgument({source=MemoryArg{base=ebp, offset=offset, index=NoIndex}, dest=getAllocatedReg pr, kind=movePolyWord}, code) | codeExtended _ ({instr=BeginFunction{regArgs, ...}, ...}, code) = let val minStackCheck = 20 val saveRegs = List.mapPartial(fn (_, GenReg r) => SOME r | _ => NONE) regArgs val preludeCode = if stackRequired >= minStackCheck then let (* Compute the necessary amount in edi and compare that. *) val stackByteAdjust = ~ (Word.toInt nativeWordSize) * stackRequired val testEdiCode = testRegAndTrap (edi, StackOverflowCallEx, saveRegs) in (* N.B. In reverse order. *) testEdiCode @ [LoadAddress{output=edi, base=SOME esp, index=NoIndex, offset=stackByteAdjust, opSize=nativeWordOpSize}] end else testRegAndTrap (esp, StackOverflowCall, saveRegs) val usedRegs = List.filter (isUsed o #1) regArgs fun mkPair(PReg pr, rr) = {src=rr,dst=getAllocatedReg pr} val regPairs = List.map mkPair usedRegs in moveMultipleRegisters(regPairs, preludeCode @ code) end | codeExtended _ ({instr=TailRecursiveCall{callKind, regArgs=oRegArgs, stackArgs=oStackArgs, stackAdjust, currStackSize, workReg=PReg wReg}, ...}, code) = let val regArgs = List.map (fn (arg, reg) => (decache arg, reg)) oRegArgs and stackArgs = List.map(fn {src, stack } => {src=decache src, stack=stack}) oStackArgs val workReg = getAllocatedReg wReg (* We must leave stack entries as stack entries for the moment. *) fun codeArg(StackLocation{wordOffset, cache=NONE, ...}) = StackSource wordOffset | codeArg arg = OtherSource(codeExtArgument arg) val extStackArgs = map (fn {stack, src} => {dst=StackDest(stack+currStackSize), src=codeArg src}) stackArgs val extRegArgs = map (fn (a, r) => {src=codeArg a, dst=RegDest r}) regArgs (* Tail recursive calls are complicated because we generally have to overwrite the existing stack. That means storing the arguments in the right order to avoid overwriting a value that we are using for a different argument. *) fun codeTailCall(arguments: {dst: destinations, src: llsource} list, stackAdjust, code) = if stackAdjust < 0 then let (* If the function we're calling takes more arguments on the stack than the current function we will have to extend the stack. Do that by pushing the argument whose offset is at -1. Then adjust all the offsets and repeat. *) val {src=argM1, ...} = valOf(List.find(fn {dst=StackDest ~1, ...} => true | _ => false) arguments) fun renumberArgs [] = [] | renumberArgs ({dst=StackDest ~1, ...} :: args) = renumberArgs args (* Remove the one we've done. *) | renumberArgs ({dst, src} :: args) = let val newDest = case dst of StackDest d => StackDest(d+1) | regDest => regDest val newSrc = case src of StackSource wordOffset => StackSource(wordOffset+1) | other => other in {dst=newDest, src=newSrc} :: renumberArgs args end in codeTailCall(renumberArgs arguments, stackAdjust+1, PushToStack(sourceAsGenRegOrMem(sourceToX86Code argM1)) :: code) end else let val loadArgs = moveMultipleValues(arguments, SOME workReg, code) in if stackAdjust = 0 then loadArgs else ResetStack{numWords=stackAdjust, preserveCC=false} :: loadArgs end in JumpAddress(codeCallKind callKind) :: codeTailCall(extStackArgs @ extRegArgs, stackAdjust+currStackSize, code) end | codeExtended _ ({instr=FunctionCall{callKind, regArgs=oRegArgs, stackArgs=oStackArgs, dest=PReg dReg, realDest, saveRegs}, ...}, code) = let val regArgs = List.map (fn (arg, reg) => (decache arg, reg)) oRegArgs and stackArgs = List.map decache oStackArgs val destReg = getAllocatedReg dReg fun pushStackArgs ([], _, code) = code | pushStackArgs (ContainerAddr {stackOffset, ...} ::args, argNum, code) = let val adjustedAddr = stackOffset+argNum (* If there is an offset relative to rsp we need to add this in. *) val addOffset = if adjustedAddr = 0 then [] else [ArithMemConst{opc=ADD, address={offset=0, base=esp, index=NoIndex}, source=LargeInt.fromInt(adjustedAddr*Word.toInt nativeWordSize), opSize=nativeWordOpSize}] in pushStackArgs(args, argNum+1, addOffset @ PushToStack(RegisterArg esp) :: code) end | pushStackArgs (StackLocation {wordOffset, container, field, ...} ::args, argNum, code) = let (* Have to adjust the offsets of stack arguments. *) val adjusted = StackLocation{wordOffset=wordOffset+argNum, container=container, field=field+argNum, cache=NONE} in pushStackArgs(args, argNum+1, PushToStack(codeExtArgumentAsGenReg adjusted) :: code) end | pushStackArgs (arg::args, argNum, code) = pushStackArgs(args, argNum+1, PushToStack(codeExtArgumentAsGenReg arg) :: code) val pushedArgs = pushStackArgs(stackArgs, 0, code (* Initial code *)) (* We have to adjust any stack offset to account for the arguments we've pushed. *) val numStackArgs = List.length stackArgs (* We don't currently allow the arguments to be memory locations and instead force them into registers. That may be simpler especially if we can get the values directly into the required register. *) fun getRegArgs(RegisterArgument(PReg pr), reg) = SOME{dst=reg, src=getAllocatedReg pr} | getRegArgs(StackLocation {cache=SOME(PReg pr), ...}, reg) = SOME{dst=reg, src=getAllocatedReg pr} | getRegArgs(MemoryLocation _, _) = raise InternalError "FunctionCall - MemoryLocation" | getRegArgs _ = NONE val loadRegArgs = moveMultipleRegisters(List.mapPartial getRegArgs regArgs, pushedArgs) (* These are all items we can load without requiring a source register. That includes loading from the stack. *) fun getConstArgs((AddressConstant m, reg), code) = llLoadArgument({source=AddressConstArg m, dest=reg, kind=movePolyWord}, code) | getConstArgs((IntegerConstant i, reg), code) = llLoadArgument({source=NonAddressConstArg i, dest=reg, kind=movePolyWord}, code) | getConstArgs((StackLocation { cache=SOME _, ...}, _), code) = code | getConstArgs((StackLocation { wordOffset, ...}, reg), code) = llLoadArgument({source=MemoryArg{offset=(wordOffset+numStackArgs)*Word.toInt nativeWordSize, base=esp, index=NoIndex}, dest=reg, kind=moveNativeWord}, code) | getConstArgs((ContainerAddr {stackOffset, ...}, reg), code) = if stackOffset+numStackArgs = 0 then llLoadArgument({source=RegisterArg(GenReg esp), dest=reg, kind=moveNativeWord}, code) else LoadAddress{ output=asGenReg reg, offset=(stackOffset+numStackArgs)*Word.toInt nativeWordSize, base=SOME esp, index=NoIndex, opSize=nativeWordOpSize } :: code | getConstArgs((RegisterArgument _, _), code) = code | getConstArgs((MemoryLocation _, _), code) = code val loadConstArgs = List.foldl getConstArgs loadRegArgs regArgs (* Push the registers before the call and pop them afterwards. *) fun makeSaves([], code) = CallAddress(codeCallKind callKind) :: code | makeSaves(PReg reg::regs, code) = let val areg = getAllocatedGenReg reg val _ = areg = eax andalso raise InternalError "codeExtended: eax in save regs" val _ = if List.exists(fn (_, r) => r = GenReg areg) regArgs then raise InternalError "codeExtended: arg reg in save regs" else () in PopR areg :: makeSaves(regs, PushToStack(RegisterArg areg) :: code) end in moveIfNecessary({dst=destReg, src=realDest, kind=case realDest of GenReg _ => moveNativeWord | _ => MoveDouble}, makeSaves(saveRegs, loadConstArgs)) end | codeExtended _ ({instr=AllocateMemoryOperation{ size, flags, dest=PReg dReg, saveRegs}, ...}, code) = let val preserve = getSaveRegs saveRegs in llAllocateMemoryOperation({ size=size, flags=flags, dest=getAllocatedReg dReg, saveRegs=preserve}, code) end | codeExtended _ ({instr=AllocateMemoryVariable{size=PReg size, dest=PReg dest, saveRegs}, ...}, code) = let (* Simple case - no initialiser. *) val saveRegs = getSaveRegs saveRegs val sReg = getAllocatedGenReg size and dReg = getAllocatedGenReg dest val _ = sReg <> dReg orelse raise InternalError "codeGenICode-AllocateMemoryVariable" val allocCode = [ (* Store it as the length field. *) Move{source=RegisterArg sReg, moveSize=opSizeToMove polyWordOpSize, destination=MemoryArg {base=dReg, offset= ~ (Word.toInt wordSize), index=NoIndex}}, (* Untag the length *) ShiftConstant{ shiftType=SHR, output=sReg, shift=0w1, opSize=polyWordOpSize}, (* Allocate the memory *) AllocStoreVariable{ size=sReg, output=dReg, saveRegs=saveRegs} ] (* Convert to an object index if necessary. *) val convertToObjId = if targetArch = ObjectId32Bit then [ ShiftConstant{ shiftType=SHR, output=dReg, shift=0w2, opSize=OpSize64 }, ArithToGenReg{ opc=SUB, output=dReg, source=RegisterArg ebx, opSize=nativeWordOpSize } ] else [] in convertToObjId @ allocCode @ code end | codeExtended _ ({instr=InitialiseMem{size=PReg sReg, addr=PReg aReg, init=PReg iReg}, ...}, code) = (* We are going to use rep stosl/q to set the memory. That requires the length to be in ecx, the initialiser to be in eax and the destination to be edi. *) RepeatOperation (if polyWordOpSize = OpSize64 then STOS64 else STOS32):: moveIfNecessary({src=getAllocatedReg iReg, dst=GenReg eax, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg aReg, dst=GenReg edi, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg sReg, dst=GenReg ecx, kind=moveNativeWord}, code))) | codeExtended _ ({instr=InitialisationComplete, ...}, code) = StoreInitialised :: code | codeExtended _ ({instr=BeginLoop, ...}, code) = code | codeExtended _ ({instr=JumpLoop{regArgs, stackArgs, checkInterrupt, workReg}, ...}, code) = let val workReg = Option.map (fn PReg r => getAllocatedReg r) workReg (* TODO: Make the sources and destinations "friends". *) (* We must leave stack entries as stack entries for the moment as with TailCall. *) fun codeArg(StackLocation{wordOffset, ...}) = StackSource wordOffset | codeArg arg = OtherSource(codeExtArgument arg) val extStackArgs = map (fn (src, stack, _) => {dst=StackDest stack, src=codeArg src}) stackArgs val extRegArgs = map (fn (a, PReg r) => {src=codeArg a, dst=RegDest(getAllocatedReg r)}) regArgs val checkCode = case checkInterrupt of NONE => [] | SOME saveRegs => testRegAndTrap (esp, StackOverflowCall, getSaveRegs saveRegs) in checkCode @ moveMultipleValues(extStackArgs @ extRegArgs, workReg, code) end | codeExtended _ ({instr=RaiseExceptionPacket{ packetReg=PReg preg }, ...}, code) = - let - (* The argument must be put into rax. *) - val _ = getAllocatedGenReg preg = eax orelse raise InternalError "codeExtended: RaiseExceptionPacket" - in (* We need a work register here. It can be any register other than eax since we don't preserve registers across calls. *) - RaiseException { workReg=ecx } :: code - end + RaiseException { workReg=ecx } :: moveIfNecessary({src=getAllocatedReg preg, dst=GenReg eax, kind=moveNativeWord}, code) | codeExtended _ ({instr=ReserveContainer{size, ...}, ...}, code) = (* The memory must be cleared in case we have a GC. *) List.tabulate(size, fn _ => PushToStack(NonAddressConstArg(tag 0))) @ code | codeExtended {flow} ({instr=IndexedCaseOperation{testReg=PReg tReg, workReg=PReg wReg}, ...}, code) = let val testReg = getAllocatedReg tReg val workReg = getAllocatedReg wReg val _ = testReg <> workReg orelse raise InternalError "IndexedCaseOperation - same registers" val rReg = asGenReg testReg and wReg = asGenReg workReg val _ = rReg <> wReg orelse raise InternalError "IndexedCaseOperation - same registers" (* This should only be within a block with an IndexedBr flow type. *) val cases = case flow of IndexedBr cases => cases | _ => raise InternalError "codeGenICode: IndexedCaseOperation" val caseLabels = map getBlockLabel cases val startJumpTable = makeLabel() (* Compute the jump address. The index is a tagged integer so it is already multiplied by 2. We need to multiply by four to get the correct size. Subtract off the shifted tag. *) val jumpSize = ref JumpSize8 in JumpTable{cases=caseLabels, jumpSize=jumpSize} :: JumpLabel startJumpTable :: JumpAddress(RegisterArg wReg) :: IndexedJumpCalc{ addrReg=wReg, indexReg=rReg, jumpSize=jumpSize } :: LoadLabelAddress{label=startJumpTable, output=wReg} :: code end | codeExtended _ ({instr=LockMutable{addr=PReg pr}, ...}, code) = let val (bReg, index) = if targetArch = ObjectId32Bit then (ebx, Index4(asGenReg(getAllocatedReg pr))) else (asGenReg(getAllocatedReg pr), NoIndex) in (* Mask off the mutable bit. *) ArithByteMemConst{opc=AND, address={base=bReg, offset= ~1, index=index}, source=0wxff - F_mutable} :: code end | codeExtended _ ({instr=WordComparison{ arg1=PReg pr, arg2, opSize, ... }, ...}, code) = ArithToGenReg {opc=CMP, output=asGenReg(getAllocatedReg pr), source=codeExtArgumentAsGenReg arg2, opSize=opSize} :: code | codeExtended _ ({instr=CompareLiteral{ arg1, arg2, opSize, ... }, ...}, code) = ( case decache arg1 of (* N.B. We MUST decache since we're assuming that the base reg is not used. *) RegisterArgument(PReg pr) => ArithToGenReg {opc=CMP, output=asGenReg(getAllocatedReg pr), source=NonAddressConstArg arg2, opSize=opSize} :: code | MemoryLocation{base=PReg br, offset, index=ObjectIndex, ...} => ArithMemConst{ opc=CMP, address={offset=offset, base=ebx, index=Index4(asGenReg(getAllocatedReg br))}, source=arg2, opSize=opSize } :: code | MemoryLocation{base=PReg br, index, offset, ...} => ArithMemConst{ opc=CMP, address={offset=offset, base=asGenReg(getAllocatedReg br), index=codeExtIndex index}, source=arg2, opSize=opSize } :: code | StackLocation{wordOffset, ...} => ArithMemConst{ opc=CMP, address={offset=wordOffset*Word.toInt nativeWordSize, base=esp, index=NoIndex}, source=arg2, opSize=opSize } :: code | _ => raise InternalError "CompareLiteral" ) | codeExtended _ ({instr=CompareByteMem{ arg1={base=PReg br, offset, index}, arg2, ... }, ...}, code) = let val (bReg, index) = case index of ObjectIndex => (ebx, Index4(asGenReg(getAllocatedReg br))) | _ => (asGenReg(getAllocatedReg br), codeExtIndex index) in ArithByteMemConst{ opc=CMP, address={offset=offset, base=bReg, index=index}, source=arg2 } :: code end (* Set up an exception handler. *) | codeExtended {flow} ({instr=PushExceptionHandler{workReg=PReg hReg}, ...}, code) = let (* Set up an exception handler. *) val workReg=getAllocatedReg hReg (* Although we're pushing this to the stack we need to use LEA on the X86/64 and some arithmetic on the X86/32. We need a work reg for that. *) val handleReg = asGenReg workReg (* This should only be within a block with a SetHandler flow type. *) val handleLabel = case flow of SetHandler{ handler, ...} => handler | _ => raise InternalError "codeGenICode: PushExceptionHandler" val labelRef = getBlockLabel handleLabel (* Set up the handler by pushing the old handler to the stack, pushing the entry point and setting the handler address to the current stack pointer. *) in ( Move{source=RegisterArg esp, destination=MemoryArg {offset=memRegHandlerRegister, base=ebp, index=NoIndex}, moveSize=opSizeToMove nativeWordOpSize} :: PushToStack(RegisterArg handleReg) :: LoadLabelAddress{ label=labelRef, output=handleReg} :: PushToStack(MemoryArg{base=ebp, offset=memRegHandlerRegister, index=NoIndex}) :: code) end (* Pop an exception handler at the end of a handled section. Executed if no exception has been raised. This removes items from the stack. *) | codeExtended _ ({instr=PopExceptionHandler{workReg=PReg wReg, ...}, ...}, code) = let val workReg = getAllocatedReg wReg val wReg = asGenReg workReg in (* The stack pointer has been adjusted to just above the two words that were stored in PushExceptionHandler. *) ( Move{source=RegisterArg wReg, destination=MemoryArg {offset=memRegHandlerRegister, base=ebp, index=NoIndex}, moveSize=opSizeToMove nativeWordOpSize} :: PopR wReg :: ResetStack{numWords=1, preserveCC=false} :: code) end (* Start of a handler. Sets the address associated with PushExceptionHandler and provides a register for the packet.*) | codeExtended _ ({instr=BeginHandler{packetReg=PReg pReg, workReg=PReg wReg}, ...}, code) = let (* The exception packet is in rax. *) val realPktReg = getAllocatedReg pReg val realWorkreg = getAllocatedGenReg wReg (* The code here is almost the same as PopExceptionHandler. The only real difference is that PopExceptionHandler needs to pass the result of executing the handled code which could be in any register. This code needs to transmit the exception packet and that is always in rax. *) val beginHandleCode = Move{source=RegisterArg realWorkreg, destination=MemoryArg {offset=memRegHandlerRegister, base=ebp, index=NoIndex}, moveSize=opSizeToMove nativeWordOpSize} :: PopR realWorkreg :: ResetStack{numWords=1, preserveCC=false} :: Move{ source=MemoryArg{base=ebp, offset=memRegHandlerRegister, index=NoIndex}, destination=RegisterArg esp, moveSize=opSizeToMove nativeWordOpSize } :: code in moveIfNecessary({src=GenReg eax, dst=realPktReg, kind=moveNativeWord }, beginHandleCode) end | codeExtended _ ({instr=ReturnResultFromFunction { resultReg=PReg resReg, realReg, numStackArgs }, ...}, code) = let val resultReg = getAllocatedReg resReg (* If for some reason it's not in the right register we have to move it there. *) in ReturnFromFunction numStackArgs :: moveIfNecessary({src=resultReg, dst=realReg, kind=moveNativeWord}, code) end | codeExtended _ ({instr=ArithmeticFunction{oper=SUB, resultReg=PReg resReg, operand1=PReg op1Reg, operand2, opSize, ...}, ...}, code) = (* Subtraction - this is special because it can only be done one way round. The first argument must be in a register. *) let val realDestReg = getAllocatedReg resReg val realOp1Reg = getAllocatedReg op1Reg in ArithToGenReg { opc=SUB, output=asGenReg realDestReg, source=codeExtArgumentAsGenReg operand2, opSize=opSize } :: moveIfNecessary({src=realOp1Reg, dst=realDestReg, kind=opSizeToIMove opSize}, code) end | codeExtended _ ({instr=ArithmeticFunction{oper, resultReg=PReg resReg, operand1=PReg op1Reg, operand2, opSize, ...}, ...}, code) = ( case decache operand2 of RegisterArgument(PReg op2Reg) => (* Arithmetic operation with both arguments as registers. These operations are all symmetric so we can try to put either argument into the result reg and then do the operation on the other arg. *) let val realDestReg = getAllocatedGenReg resReg val realOp1Reg = getAllocatedGenReg op1Reg and realOp2Reg = getAllocatedGenReg op2Reg val (operandReg, moveInstr) = if realOp1Reg = realDestReg then (realOp2Reg, code) else if realOp2Reg = realDestReg then (realOp1Reg, code) else (realOp2Reg, Move{source=RegisterArg realOp1Reg, destination=RegisterArg realDestReg, moveSize=opSizeToMove opSize} :: code) in ArithToGenReg { opc=oper, output=realDestReg, source=RegisterArg operandReg, opSize=opSize } :: moveInstr end | operand2 => (* Arithmetic operation with the first argument in a register and the second a constant or memory location. *) let val realDestReg = getAllocatedReg resReg val realOp1Reg = getAllocatedReg op1Reg val op2Arg = codeExtArgumentAsGenReg operand2 (* If we couldn't put it in the result register we have to copy it there. *) in ArithToGenReg { opc=oper, output=asGenReg realDestReg, source=op2Arg, opSize=opSize } :: moveIfNecessary({src=realOp1Reg, dst=realDestReg, kind=opSizeToIMove opSize}, code) end ) | codeExtended _ ({instr=TestTagBit{arg, ...}, ...}, code) = TestByteBits{arg=codeExtArgumentAsGenReg arg, bits=0w1} :: code | codeExtended _ ({instr=PushValue {arg, ...}, ...}, code) = PushToStack(codeExtArgumentAsGenReg arg) :: code | codeExtended _ ({instr=CopyToCache{source=PReg sreg, dest as PReg dreg, kind}, ...}, code) = if not (isUsed dest) then code else let val realDestReg = getAllocatedReg dreg (* Get the source register using the current destination as a preference. *) val realSrcReg = getAllocatedReg sreg in (* If the source is the same as the destination we don't need to do anything. *) moveIfNecessary({src=realSrcReg, dst=realDestReg, kind=kind}, code) end | codeExtended _ ({instr=ResetStackPtr {numWords, preserveCC}, ...}, code) = ( numWords >= 0 orelse raise InternalError "codeGenICode: ResetStackPtr - negative offset"; ResetStack{numWords=numWords, preserveCC=preserveCC} :: code ) | codeExtended _ ({instr=StoreToStack{ source, stackOffset, ... }, ...}, code) = llStoreArgument{ source=codeExtArgument source, base=esp, offset=stackOffset*Word.toInt nativeWordSize, index=NoIndex, kind=moveNativeWord} :: code | codeExtended _ ({instr=TagValue{source=PReg srcReg, dest as PReg dReg, opSize, ...}, ...}, code) = if not (isUsed dest) then code else let val regResult = asGenReg(getAllocatedReg dReg) val realSReg = asGenReg(getAllocatedReg srcReg) in (* N.B. Using LEA with a base register and an index multiplier of 1 is shorter than using no base register and a multiplier of two. *) (* TODO: If the value we're tagging is a byte or a 16-bit value we can use OpSize32 and possibly save the Rex byte. *) LoadAddress{ output=regResult, offset=1, base=SOME realSReg, index=Index1 realSReg, opSize=opSize } :: code end | codeExtended _ ({instr=UntagValue{dest as PReg dReg, cache=SOME(PReg cacheReg), opSize, ...}, ...}, code) = if not (isUsed dest) then code else moveIfNecessary({src=getAllocatedReg cacheReg, dst=getAllocatedReg dReg, kind=opSizeToIMove opSize}, code) | codeExtended _ ({instr=UntagValue{source=PReg sReg, dest as PReg dReg, isSigned, opSize, ...}, ...}, code) = if not (isUsed dest) then code else let val regResult = getAllocatedReg dReg val realSReg = getAllocatedReg sReg in (* For most cases we're going to be using a 32-bit word if this is 32-in-64. The exception is when converting a word to a signed large-word. *) ShiftConstant{ shiftType=if isSigned then SAR else SHR, output=asGenReg regResult, shift=0w1, opSize=opSize } :: moveIfNecessary({src=realSReg, dst=regResult, kind=opSizeToIMove opSize}, code) end | codeExtended _ ({instr=LoadEffectiveAddress{base, offset, index=ObjectIndex, dest=PReg dReg, opSize}, ...}, code) = let val destReg = asGenReg(getAllocatedReg dReg) val bReg = case base of SOME(PReg br) => asGenReg(getAllocatedReg br) | NONE => raise InternalError "LoadEffectiveAddress - ObjectIndex but no base" in LoadAddress{ output=destReg, offset=offset, base=SOME ebx, index=Index4 bReg, opSize=opSize } :: code end | codeExtended _ ({instr=LoadEffectiveAddress{base, offset, index, dest=PReg dReg, opSize}, ...}, code) = let val destReg = asGenReg(getAllocatedReg dReg) val bReg = case base of SOME(PReg br) => SOME(asGenReg(getAllocatedReg br)) | NONE => NONE val indexR = codeExtIndex index in LoadAddress{ output=destReg, offset=offset, base=bReg, index=indexR, opSize=opSize } :: code end | codeExtended _ ({instr=ShiftOperation{shift, resultReg=PReg resReg, operand=PReg operReg, shiftAmount=IntegerConstant i, opSize, ...}, ...}, code) = let val realDestReg = getAllocatedReg resReg val realOpReg = getAllocatedReg operReg in ShiftConstant{ shiftType=shift, output=asGenReg realDestReg, shift=Word8.fromLargeInt i, opSize=opSize } :: moveIfNecessary({src=realOpReg, dst=realDestReg, kind=opSizeToIMove opSize}, code) end | codeExtended _ ({instr=ShiftOperation{shift, resultReg=PReg resReg, operand=PReg operReg, shiftAmount=RegisterArgument(PReg shiftReg), opSize, ...}, ...}, code) = let val realDestReg = getAllocatedReg resReg val realShiftReg = getAllocatedReg shiftReg val realOpReg = getAllocatedReg operReg (* We want the shift in ecx. We may not have got it there but the register should be free. The shift is masked to 5 or 6 bits so we have to check for larger shift values at a higher level.*) in ShiftVariable{ shiftType=shift, output=asGenReg realDestReg, opSize=opSize } :: moveIfNecessary({src=realOpReg, dst=realDestReg, kind=opSizeToIMove opSize}, moveIfNecessary({src=realShiftReg, dst=GenReg ecx, kind=Move32Bit (* < 64*)}, code)) end | codeExtended _ ({instr=ShiftOperation _, ...}, _) = raise InternalError "codeExtended - ShiftOperation" | codeExtended _ ({instr= Multiplication{resultReg=PReg resReg, operand1=PReg op1Reg, operand2, opSize, ...}, ...}, code) = ( case decache operand2 of RegisterArgument(PReg op2Reg) => let (* Treat exactly the same as ArithmeticFunction. *) val realDestReg = getAllocatedGenReg resReg val realOp1Reg = getAllocatedGenReg op1Reg and realOp2Reg = getAllocatedGenReg op2Reg val (operandReg, moveInstr) = if realOp1Reg = realDestReg then (realOp2Reg, code) else if realOp2Reg = realDestReg then (realOp1Reg, code) else (realOp2Reg, Move{source=RegisterArg realOp1Reg, destination=RegisterArg realDestReg, moveSize=opSizeToMove opSize} :: code) in MultiplyR { source=RegisterArg operandReg, output=realDestReg, opSize=opSize } :: moveInstr end | operand2 => (* Multiply operation with the first argument in a register and the second a constant or memory location. *) let val realDestReg = getAllocatedReg resReg val realOp1Reg = getAllocatedReg op1Reg val op2Arg = codeExtArgumentAsGenReg operand2 in MultiplyR { output=asGenReg realDestReg, source=op2Arg, opSize=opSize } :: moveIfNecessary({src=realOp1Reg, dst=realDestReg, kind=opSizeToIMove opSize}, code) end ) | codeExtended _ ({instr=Division{isSigned, dividend=PReg regDivid, divisor, quotient=PReg regQuot, remainder=PReg regRem, opSize}, ...}, code) = let (* TODO: This currently only supports the dividend in a register. LargeWord division will generally load the argument from a box so we could support a memory argument for that case. Word and integer values will always have to be detagged. *) (* Division is specific as to the registers. The dividend must be eax, quotient is eax and the remainder is edx. *) val realDiviReg = getAllocatedReg regDivid val realQuotReg = getAllocatedReg regQuot val realRemReg = getAllocatedReg regRem val divisorArg = codeExtArgument divisor val divisorReg = argAsGenReg divisorArg val _ = divisorReg <> eax andalso divisorReg <> edx orelse raise InternalError "codeGenICode: Division" (* rdx needs to be set to the high order part of the dividend. For signed division that means sign-extending rdx, for unsigned division we clear it. We only need a 32-bit clear since the top 32-bits are cleared anyway. *) val setRDX = if isSigned then SignExtendForDivide opSize else ArithToGenReg{ opc=XOR, output=edx, source=RegisterArg edx, opSize=OpSize32 } in (* We may need to move one or more of the registers although normally that won't be necessary. Almost certainly only either the remainder or the quotient will actually be used. *) moveMultipleRegisters([{src=GenReg eax, dst=realQuotReg}, {src=GenReg edx, dst=realRemReg}], DivideAccR {arg=divisorReg, isSigned=isSigned, opSize=opSize} :: setRDX :: moveIfNecessary({src=realDiviReg, dst=GenReg eax, kind=opSizeToIMove opSize}, code)) end | codeExtended _ ({instr=AtomicExchangeAndAdd{base=PReg bReg, source=PReg sReg}, ...}, code) = let val baseReg = asGenReg (getAllocatedReg bReg) and outReg = asGenReg (getAllocatedReg sReg) val address = if targetArch = ObjectId32Bit then {base=ebx, index=Index4 baseReg, offset=0} else {base=baseReg, index=NoIndex, offset=0} in AtomicXAdd{address=address, output=outReg, opSize=polyWordOpSize} :: code end | codeExtended _ ({instr=BoxValue{boxKind, source=PReg sReg, dest as PReg dReg, saveRegs}, ...}, code) = if not (isUsed dest) then code else let val preserve = getSaveRegs saveRegs val (srcReg, boxSize, moveKind) = case boxKind of BoxLargeWord => (getAllocatedReg sReg, Word.toInt(nativeWordSize div wordSize), moveNativeWord) | BoxX87Double => (getAllocatedReg sReg, Word.toInt(0w8 div wordSize), MoveDouble) | BoxX87Float => (getAllocatedReg sReg, Word.toInt(0w4 div wordSize), MoveFloat) | BoxSSE2Double => (getAllocatedReg sReg, Word.toInt(0w8 div wordSize), MoveDouble) | BoxSSE2Float => (getAllocatedReg sReg, Word.toInt(0w4 div wordSize), MoveFloat) val dstReg = getAllocatedReg dReg val (bReg, index) = if targetArch = ObjectId32Bit then (ebx, Index4(asGenReg dstReg)) else (asGenReg dstReg, NoIndex) in StoreInitialised :: llStoreArgument{ source=RegisterArg srcReg, offset=0, base=bReg, index=index, kind=moveKind} :: llAllocateMemoryOperation({ size=boxSize, flags=0wx1, dest=dstReg, saveRegs=preserve}, code) end | codeExtended _ ({instr=CompareByteVectors{vec1Addr=PReg v1Reg, vec2Addr=PReg v2Reg, length=PReg lReg, ...}, ...}, code) = (* There's a complication here. CompareByteVectors generates REPE CMPSB to compare the vectors but the condition code is only set if CMPSB is executed at least once. If the value in RCX/ECX is zero it will never be executed and the condition code will be unchanged. We want the result to be "equal" in that case so we need to ensure that is the case. It's quite possible that the condition code has just been set by shifting RCX/ECX to remove the tag in which case it will have set "equal" if the value was zero. We use CMP R/ECX,R/ECX which is two bytes in 32-bit. If we knew the length was non-zero (e.g. a constant) we could avoid this. *) RepeatOperation CMPS8 :: ArithToGenReg {opc=CMP, output=ecx, source=RegisterArg ecx, opSize=OpSize32} :: moveIfNecessary({src=getAllocatedReg v1Reg, dst=GenReg esi, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg v2Reg, dst=GenReg edi, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg lReg, dst=GenReg ecx, kind=moveNativeWord}, code))) | codeExtended _ ({instr=BlockMove{srcAddr=PReg sReg, destAddr=PReg dReg, length=PReg lReg, isByteMove}, ...}, code) = (* We may need to move these into the appropriate registers. They have been reserved but it's still possible the values could be in something else. *) RepeatOperation(if isByteMove then MOVS8 else if polyWordOpSize = OpSize64 then MOVS64 else MOVS32) :: moveIfNecessary({src=getAllocatedReg sReg, dst=GenReg esi, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg dReg, dst=GenReg edi, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg lReg, dst=GenReg ecx, kind=moveNativeWord}, code))) | codeExtended _ ({instr=X87Compare{arg1=PReg argReg, arg2, isDouble, ...}, ...}, code) = let val fpReg = getAllocatedFPReg argReg val _ = fpReg = fp0 orelse raise InternalError "codeGenICode: CompareFloatingPt not fp0" (* This currently pops the value. *) val precision = if isDouble then DoublePrecision else SinglePrecision in case codeExtArgumentAsFPReg arg2 of RegisterArg fpReg2 => FPArithR{opc=FCOMP, source=fpReg2} :: code | MemoryArg{offset, base=baseReg, index=NoIndex} => FPArithMemory{opc=FCOMP, base=baseReg, offset=offset, precision=precision} :: code | AddressConstArg const => FPArithConst{opc=FCOMP, source = const, precision=precision} :: code | _ => raise InternalError "codeGenICode: CompareFloatingPt: TODO" end | codeExtended _ ({instr=SSE2Compare{arg1=PReg argReg, arg2, isDouble, ...}, ...}, code) = let val xmmReg = getAllocatedXMMReg argReg val arg2Code = codeExtArgumentAsXMMReg arg2 in XMMArith { opc= if isDouble then SSE2CompDouble else SSE2CompSingle, output=xmmReg, source=arg2Code} :: code end | codeExtended _ ({instr=X87FPGetCondition{dest=PReg dReg, ...}, ...}, code) = moveIfNecessary({src=GenReg eax, dst=getAllocatedReg dReg, kind=Move32Bit}, FPStatusToEAX :: code) | codeExtended _ ({instr=X87FPArith{opc, resultReg=PReg resReg, arg1=PReg op1Reg, arg2, isDouble}, ...}, code) = let val realDestReg = getAllocatedFPReg resReg val realOp1Reg = getAllocatedFPReg op1Reg val _ = realDestReg = fp0 orelse raise InternalError "codeGenICode: FloatingPointArith not fp0" val _ = realOp1Reg = fp0 orelse raise InternalError "codeGenICode: FloatingPointArith not fp0" val op2Arg = codeExtArgumentAsFPReg arg2 val precision = if isDouble then DoublePrecision else SinglePrecision in case op2Arg of MemoryArg{offset, base=baseReg, index=NoIndex} => FPArithMemory{opc=opc, base=baseReg, offset=offset, precision=precision} :: code | AddressConstArg const => FPArithConst{opc=opc, source = const, precision=precision} :: code | _ => raise InternalError "codeGenICode: X87FPArith: TODO" end | codeExtended _ ({instr=X87FPUnaryOps{fpOp, dest=PReg resReg, source=PReg op1Reg}, ...}, code) = let val realDestReg = getAllocatedFPReg resReg val realOp1Reg = getAllocatedFPReg op1Reg val _ = realDestReg = fp0 orelse raise InternalError "codeGenICode: X87FPUnaryOps not fp0" val _ = realOp1Reg = fp0 orelse raise InternalError "codeGenICode: X87FPUnaryOps not fp0" in FPUnary fpOp :: code end | codeExtended _ ({instr=X87Float{dest=PReg resReg, source}, ...}, code) = let val intSource = codeExtArgumentAsGenReg source val fpReg = getAllocatedFPReg resReg val _ = fpReg = fp0 orelse raise InternalError "codeGenICode: FloatFixedInt not fp0" in (* This is complicated. The integer value has to be in memory not in a register so we have to push it to the stack and then make sure it is popped afterwards. Because it is untagged it is unsafe to leave it. *) ResetStack{numWords=1, preserveCC=false} :: FPLoadInt{ base=esp, offset=0, opSize=polyWordOpSize } :: PushToStack intSource :: code end | codeExtended _ ({instr=SSE2Float{dest=PReg resReg, source}, ...}, code) = let val xmmResReg = getAllocatedXMMReg resReg val srcReg = case codeExtArgumentAsGenReg source of RegisterArg srcReg => srcReg | _ => raise InternalError "FloatFixedInt: not reg" in XMMConvertFromInt{ output=xmmResReg, source=srcReg, opSize=polyWordOpSize} :: code end | codeExtended _ ({instr=SSE2FPUnary{opc, resultReg=PReg resReg, source}, ...}, code) = let val realDestReg = getAllocatedXMMReg resReg val opArg = codeExtArgumentAsXMMReg source val sse2Op = case opc of SSE2UDoubleToFloat => SSE2DoubleToFloat | SSE2UFloatToDouble => SSE2FloatToDouble in XMMArith{ opc=sse2Op, output=realDestReg, source=opArg} :: code end | codeExtended _ ({instr=SSE2FPBinary{opc, resultReg=PReg resReg, arg1=PReg op1Reg, arg2}, ...}, code) = let val realDestReg = getAllocatedXMMReg resReg val realOp1Reg = getAllocatedXMMReg op1Reg val op2Arg = codeExtArgumentAsXMMReg arg2 (* xorpd and andpd require 128-bit arguments with 128-bit alignment. *) val _ = case (opc, op2Arg) of (SSE2BXor, RegisterArg _) => () | (SSE2BXor, _) => raise InternalError "codeGenICode - SSE2Xor not in register" | (SSE2BAnd, RegisterArg _) => () | (SSE2BAnd, _) => raise InternalError "codeGenICode - SSE2And not in register" | _ => () val doMove = if realDestReg = realOp1Reg then code else XMMArith { opc=SSE2MoveDouble, source=RegisterArg realOp1Reg, output=realDestReg } :: code val sse2Op = case opc of SSE2BAddDouble => SSE2AddDouble | SSE2BSubDouble => SSE2SubDouble | SSE2BMulDouble => SSE2MulDouble | SSE2BDivDouble => SSE2DivDouble | SSE2BAddSingle => SSE2AddSingle | SSE2BSubSingle => SSE2SubSingle | SSE2BMulSingle => SSE2MulSingle | SSE2BDivSingle => SSE2DivSingle | SSE2BXor => SSE2Xor | SSE2BAnd => SSE2And in XMMArith{ opc=sse2Op, output=realDestReg, source=op2Arg} :: doMove end | codeExtended _ ({instr=TagFloat{source=PReg srcReg, dest as PReg dReg, ...}, ...}, code) = if not (isUsed dest) then code else let val _ = targetArch = Native64Bit orelse raise InternalError "TagFloat: not 64-bit" (* Copy the value from an XMM reg into a general reg and tag it. *) val regResult = asGenReg(getAllocatedReg dReg) val realSReg = getAllocatedXMMReg srcReg in ArithToGenReg { opc=ADD, output=regResult, source=NonAddressConstArg 1, opSize=polyWordOpSize } :: ShiftConstant{ shiftType=SHL, output=regResult, shift=0w32, opSize=OpSize64} :: MoveXMMRegToGenReg { source = realSReg, output = regResult } :: code end | codeExtended _ ({instr=UntagFloat{dest as PReg dReg, cache=SOME(PReg cacheReg), ...}, ...}, code) = if not (isUsed dest) then code else moveIfNecessary({src=getAllocatedReg cacheReg, dst=getAllocatedReg dReg, kind=MoveFloat}, code) | codeExtended _ ({instr=UntagFloat{source, dest as PReg dReg, ...}, ...}, code) = if not (isUsed dest) then code else let val regResult = getAllocatedXMMReg dReg in case codeExtArgumentAsGenReg source of RegisterArg realSReg => XMMShiftRight{ output=regResult, shift=0w4 (* Bytes - not bits *) } :: MoveGenRegToXMMReg {source=realSReg, output=regResult} :: code | MemoryArg{base, offset, index} => (* If the value is in memory we can just load the high order word. *) XMMArith { opc=SSE2MoveFloat, source=MemoryArg{base=base, offset=offset+4, index=index}, output=regResult } :: code | NonAddressConstArg ic => (* Shift down and then load from the non-constant area. *) XMMArith { opc=SSE2MoveFloat, source=NonAddressConstArg(IntInf.~>>(ic, 0w32)), output=regResult } :: code | _ => raise InternalError "UntagFloat - not register or memory" end | codeExtended _ ({instr=GetSSE2ControlReg{dest=PReg dReg}, ...}, code) = let (* This has to work through memory. Reserve one word on the stack, get the MXCSR register into it and pop it to the register. *) val regResult = getAllocatedGenReg dReg in PopR regResult :: XMMStoreCSR{base=esp, offset=0, index=NoIndex } :: PushToStack(NonAddressConstArg 0) :: code end | codeExtended _ ({instr=SetSSE2ControlReg{source=PReg sReg}, ...}, code) = let (* This has to work through memory. Push the register to the stack, store the value into the control register and remove it from the stack. *) val sourceReg = getAllocatedGenReg sReg in ResetStack{ numWords=1, preserveCC=false } :: XMMLoadCSR{base=esp, offset=0, index=NoIndex } :: PushToStack(RegisterArg sourceReg) :: code end | codeExtended _ ({instr=GetX87ControlReg{dest=PReg dReg}, ...}, code) = let (* This has to work through memory. Reserve one word on the stack, get the X87 control register into it and pop it to the register. *) val regResult = getAllocatedGenReg dReg in PopR regResult :: FPStoreCtrlWord{base=esp, offset=0, index=NoIndex } :: PushToStack(NonAddressConstArg 0) :: code end | codeExtended _ ({instr=SetX87ControlReg{source=PReg sReg}, ...}, code) = let (* This has to work through memory. Push the register to the stack, store the value into the control register and remove it from the stack. *) val sourceReg = getAllocatedGenReg sReg in ResetStack{ numWords=1, preserveCC=false } :: FPLoadCtrlWord{base=esp, offset=0, index=NoIndex } :: PushToStack(RegisterArg sourceReg) :: code end | codeExtended _ ({instr=X87RealToInt{source=PReg sReg, dest=PReg dReg}, ...}, code) = let (* This has to work through memory. Reserve one word on the stack, convert the value into it and pop it to the register. *) val regResult = getAllocatedGenReg dReg val fpReg = getAllocatedFPReg sReg val _ = fpReg = fp0 orelse raise InternalError "codeGenICode: CompareFloatingPt not fp0" (* This currently pops the value. *) in PopR regResult :: FPStoreInt{base=esp, offset=0, index=NoIndex } :: PushToStack(NonAddressConstArg 0) :: code end | codeExtended _ ({instr=SSE2RealToInt{source, dest=PReg dReg, isDouble, isTruncate}, ...}, code) = let (* The source is either an XMM register or memory. *) val regResult = getAllocatedGenReg dReg val opArg = codeExtArgumentAsXMMReg source in XMMStoreInt { source=opArg, precision=if isDouble then DoublePrecision else SinglePrecision, output = regResult, isTruncate=isTruncate } :: code end | codeExtended _ ({instr=SignExtend32To64{source, dest=PReg dReg}, ...}, code) = let val regResult = getAllocatedGenReg dReg val opArg = codeExtArgumentAsGenReg source in Move{moveSize=Move32X64, source=opArg, destination=RegisterArg regResult } :: code end val newCode = codeCreate (functionName, profileObject, debugSwitches) local (* processed - set to true when a block has been processed. *) val processed = Array.array(numBlocks, false) fun haveProcessed n = Array.sub(processed, n) (* Find the blocks that reference this one. This isn't essential but allows us to try to generate blocks in the order of the control flow. This in turn may allow us to use short branches rather than long ones. *) val labelRefs = Array.array(numBlocks, []) datatype flowCode = FlowCodeSimple of int | FlowCodeCMove of {code: operation list, trueJump: int, falseJump: int} (* Process this recursively to set the references. If we have unreachable blocks, perhaps because they've been merged, we don't want to include them in the reference counting. This shouldn't happen now that IdentifyReferences removes unreferenced blocks. *) fun setReferences fromLabel toLabel = case Array.sub(labelRefs, toLabel) of [] => (* Not yet visited at all. *) let val ExtendedBasicBlock{ flow, ...} = Vector.sub(blocks, toLabel) val refs = case flow of ExitCode => [] | Unconditional lab => [lab] | Conditional{trueJump, falseJump, ... } => [trueJump, falseJump] | IndexedBr labs => labs | SetHandler { handler, continue } => [handler, continue] | UnconditionalHandle _ => [] | ConditionalHandle { continue, ...} => [continue] val () = if fromLabel >= 0 then Array.update(labelRefs, toLabel, [fromLabel]) else () in List.app (setReferences toLabel) refs end | refs => (* We've visiting this at least once. Just add us to the list. *) Array.update(labelRefs, toLabel, fromLabel :: refs) val _ = setReferences 0 0 (* Process the blocks. We keep the "stack" explicit rather than using recursion because this allows us to select both arms of a conditional branch sooner. *) fun genCode(toDo, lastFlow, code) = case List.filter (not o haveProcessed) toDo of [] => let (* There's nothing left to do. We may need to add a final branch to the end. *) val finalBranch = case lastFlow of ExitCode => [] | IndexedBr _ => [] | Unconditional dest => [UncondBranch(getBlockLabel dest)] | Conditional { condition, trueJump, falseJump, ...} => [ UncondBranch(getBlockLabel falseJump), ConditionalBranch{test=condition, label=getBlockLabel trueJump} ] | SetHandler { continue, ...} => [UncondBranch(getBlockLabel continue)] | UnconditionalHandle _ => [] | ConditionalHandle { continue, ...} => [UncondBranch(getBlockLabel continue)] in finalBranch @ code (* Done. *) end | stillToDo as head :: _ => let local (* Check the references. If all the sources that lead up to this have already been we won't have any backward jumps. *) fun available dest = List.all haveProcessed (Array.sub(labelRefs, dest)) val continuation = case lastFlow of ExitCode => NONE | IndexedBr _ => NONE (* We could put the last branch in here. *) | Unconditional dest => if not (haveProcessed dest) andalso available dest then SOME(FlowCodeSimple dest) else NONE | Conditional {trueJump, falseJump, condition, ...} => let (* Can we replace this with a SETCC or CMOV? If both arms simply set a register to a value and either return or jump to the same location we can use a SETCC or a CMOV. *) val ExtendedBasicBlock { flow=tFlow, block=tBlock, ...} = Vector.sub(blocks, trueJump) and ExtendedBasicBlock { flow=fFlow, block=fBlock, ...} = Vector.sub(blocks, falseJump) fun cmoveOrSetcc{condition, output, tSource=IntegerConstant trueValue, fSource=IntegerConstant falseValue, kind, code} = let (* Could use SETCC. Only if we can use LEA for multiplication. The result must be tagged so we will always have a multiplier. *) val (multiplier, fValue, testCondition) = if trueValue >= falseValue then (trueValue-falseValue, falseValue, condition) else (falseValue-trueValue, trueValue, invertTest condition) val destReg = asGenReg output in if not (targetArch = Native32Bit andalso (destReg=esi orelse destReg=edi)) (* We can't use Setcc with esi or edi on native 32-bit. *) andalso (multiplier = 2 orelse multiplier = 4 orelse multiplier = 8) (* We're using LEA so can only be multiplying by 2, 4 or 8. *) andalso is32bit fValue (* and we're going to put this in the offset *) then let val effectiveOpSize = (* We can generally use 32-bit LEA except if the result is negative. *) if kind = Move32Bit orelse fValue >= 0 andalso fValue+multiplier <= 0x7fffffff then OpSize32 else OpSize64 val (index, base) = case multiplier of 2 => (Index1 destReg, SOME destReg) | 4 => (Index4 destReg, NONE) | 8 => (Index8 destReg, NONE) | _ => (NoIndex, NONE) (* Try to put the instruction to zero the register before any compare. We can do it provided the register we're going to zero isn't used in the comparison. *) fun checkArg(RegisterArg r) = r <> destReg | checkArg(MemoryArg mem) = checkMem mem | checkArg _ = true and checkMem{base, index=NoIndex, ...} = base <> destReg | checkMem{base, index=Index1 index, ...} = base <> destReg andalso index <> destReg | checkMem{base, index=Index2 index, ...} = base <> destReg andalso index <> destReg | checkMem{base, index=Index4 index, ...} = base <> destReg andalso index <> destReg | checkMem{base, index=Index8 index, ...} = base <> destReg andalso index <> destReg val zeroReg = ArithToGenReg { opc=XOR, output=destReg, source=RegisterArg destReg, opSize=OpSize32 } fun addXOR [] = NONE | addXOR ((instr as ResetStack _) :: tl) = (* If we can add the XOR before the ResetStack do so. *) Option.map(fn code => instr :: code) (addXOR tl) | addXOR ((instr as ArithToGenReg{output, source, ...}) :: tl) = if output <> destReg andalso checkArg source then SOME(instr :: zeroReg :: tl) else NONE | addXOR ((instr as ArithMemConst{address, ...}) :: tl) = if checkMem address then SOME(instr :: zeroReg :: tl) else NONE | addXOR ((instr as ArithByteMemConst{address, ...}) :: tl) = if checkMem address then SOME(instr :: zeroReg :: tl) else NONE | addXOR ((instr as XMMArith{source=MemoryArg mem, ...}) :: tl) = if checkMem mem then SOME(instr :: zeroReg :: tl) else NONE | addXOR ((instr as XMMArith _) :: tl) = SOME(instr :: zeroReg :: tl) | addXOR ((instr as TestByteBits{arg, ...}) :: tl) = if checkArg arg then SOME(instr :: zeroReg :: tl) else NONE | addXOR ((instr as RepeatOperation CMPS8) :: tl) = (* This uses edi, esi and ecx implicitly *) if destReg <> esi andalso destReg <> edi andalso destReg <> ecx then SOME(instr :: zeroReg :: tl) else NONE (* This seems to be just a conditional jump as a result of testing the condition code twice in Real.== *) | addXOR _ = NONE (* If we can't put the XOR before the instruction we need to either zero it using a move which won't affect the CC or we use MOVZB to extend the byte value to 32/64 bits. *) val loadAddr = LoadAddress{output=destReg, offset=Int.fromLarge fValue, base=base, index=index, opSize=effectiveOpSize} and setCond = SetCondition{output=destReg, test=testCondition} val code = case addXOR code of SOME withXOR => loadAddr :: setCond :: withXOR | NONE => loadAddr :: (* We've already check that we're not using esi/edi on native 32-bits. *) Move{destination=RegisterArg destReg, source=RegisterArg destReg, moveSize=Move8} :: setCond :: code in SOME code end else NONE end (* If either value is a memory location it isn't safe to load it. The base address may not be valid if the condition does not hold. *) | cmoveOrSetcc{tSource=MemoryLocation _, ...} = NONE | cmoveOrSetcc{fSource=MemoryLocation _, ...} = NONE | cmoveOrSetcc{condition, output, tSource, fSource, kind, code} = if targetArch = Native32Bit then NONE (* CMov doesn't work for constants. *) else let val output = asGenReg output val codeTrue = codeExtArgumentAsGenReg tSource and codeFalse = codeExtArgumentAsGenReg fSource val opSize = case kind of Move32Bit => OpSize32 | Move64Bit => OpSize64 | _ => raise InternalError "move size" (* One argument has to be loaded into a register first and the other is conditionally moved. *) val loadFalseCmoveTrue = if (case codeFalse of RegisterArg regFalse => regFalse = output | _ => false) then true (* The false value is already in the right register. *) else if (case codeTrue of RegisterArg regTrue => regTrue = output | _ => false) then false (* The true value is in the right register - have to reverse. *) else if (case codeTrue of NonAddressConstArg _ => true | _ => false) then false (* The true value is a short constant. If we use a CMOV we will have to put that in the non-constant area and use a PC-relative reference. Try to avoid it. *) else true fun cmov{codeLoad, codeMove, condition} = let val load = case codeLoad of RegisterArg regLoad => moveIfNecessary({src=GenReg regLoad, dst=GenReg output, kind=opSizeToIMove opSize}, code) | codeLoad => Move{source=codeLoad, destination=RegisterArg output, moveSize=opSizeToMove opSize} :: code in CondMove{test=condition, output=output, source=codeMove, opSize=opSize} :: load end in if loadFalseCmoveTrue then SOME(cmov{codeLoad=codeFalse, codeMove=codeTrue, condition=condition}) else SOME(cmov{codeLoad=codeTrue, codeMove=codeFalse, condition=invertTest condition}) end val isPossSetCCOrCmov = if not (haveProcessed trueJump) andalso available trueJump andalso not (haveProcessed falseJump) andalso available falseJump then case (tFlow, fFlow, tBlock, fBlock) of (ExitCode, ExitCode, [{instr=LoadArgument{dest=PReg tReg, source=tSource, kind=kindT}, ...}, {instr=ReturnResultFromFunction{resultReg=PReg resReg, realReg, numStackArgs, ...}, ...}], [{instr=LoadArgument{dest=PReg fReg, source=fSource, kind=kindF}, ...}, {instr=ReturnResultFromFunction _, ...}]) => (* The real register for the two sides should both be rax. *) let val realTReg = getAllocatedReg tReg and realFReg = getAllocatedReg fReg in if realTReg = realFReg andalso kindT = kindF andalso (kindT = Move32Bit orelse kindT = Move64Bit) then ( case cmoveOrSetcc{condition=condition, output=realTReg, tSource=tSource, fSource=fSource, kind=kindT, code=code} of SOME code => let val resultReg = getAllocatedReg resReg val code = ReturnFromFunction numStackArgs :: moveIfNecessary({src=resultReg, dst=realReg, kind=moveNativeWord}, code) in SOME{code=code, trueJump=trueJump, falseJump=falseJump} end | NONE => NONE ) else NONE end | (Unconditional tDest, Unconditional fDest, [{instr=LoadArgument{dest=PReg tReg, source=tSource, kind=kindT}, ...}], [{instr=LoadArgument{dest=PReg fReg, source=fSource, kind=kindF}, ...}]) => let val realTReg = getAllocatedReg tReg and realFReg = getAllocatedReg fReg in if tDest = fDest andalso realTReg = realFReg andalso kindT = kindF andalso (kindT = Move32Bit orelse kindT = Move64Bit) then ( case cmoveOrSetcc{condition=condition, output=realTReg, tSource=tSource, fSource=fSource, kind=kindT, code=code} of SOME code => SOME{code=code, trueJump=trueJump, falseJump=falseJump} | NONE => NONE ) else NONE end | _ => NONE else NONE in case isPossSetCCOrCmov of NONE => (* We can usually choose either destination and in nearly all cases it won't matter. The default branch is not to take forward jumps so if there is reason to believe that one branch is more likely we should follow that branch now and leave the other. If we have JO/JNO we assume that overflow is unusual. If one branch raises an exception we assume that that is unusual. *) let val (first, second) = case (condition, Vector.sub(blocks, falseJump)) of (JNO, _) => (trueJump, falseJump) | (_, ExtendedBasicBlock{ flow=ExitCode, block, ...}) => if List.exists(fn{instr=RaiseExceptionPacket _, ...} => true | _ => false) block then (trueJump, falseJump) else (falseJump, trueJump) | _ => (falseJump, trueJump) in if not (haveProcessed first) andalso available first then SOME(FlowCodeSimple first) else if not (haveProcessed second) andalso available second then SOME(FlowCodeSimple second) else NONE end | SOME args => SOME(FlowCodeCMove args) end | SetHandler { continue, ... } => (* We want the continuation if possible. We'll need a branch round the handler so that won't help. *) if not (haveProcessed continue) andalso available continue then SOME(FlowCodeSimple continue) else NONE | UnconditionalHandle _ => NONE | ConditionalHandle _ => NONE in (* First choice - continue the existing block. Second choice - the first item whose sources have all been processed. Third choice - something from the list. *) val picked = case continuation of SOME c => c | NONE => case List.find available stillToDo of SOME c => FlowCodeSimple c | NONE => FlowCodeSimple head end in case picked of FlowCodeSimple picked => let val () = Array.update(processed, picked, true) (* Code to terminate the previous block. *) val startCode = case lastFlow of ExitCode => [] | IndexedBr _ => [] | UnconditionalHandle _ => [] | Unconditional dest => if dest = picked then [] else [UncondBranch(getBlockLabel dest)] | ConditionalHandle { continue, ...} => if continue = picked then [] else [UncondBranch(getBlockLabel continue)] | SetHandler { continue, ... } => if continue = picked then [] else [UncondBranch(getBlockLabel continue)] | Conditional { condition, trueJump, falseJump, ...} => if picked = falseJump (* Usual case. *) then [ConditionalBranch{test=condition, label=getBlockLabel trueJump}] else if picked = trueJump then (* We have a jump to the true condition. Invert the jump. This is more than an optimisation. Because this immediately precedes the true block we're not going to generate a label. *) [ConditionalBranch{test=invertTest condition, label=getBlockLabel falseJump}] else [ UncondBranch(getBlockLabel falseJump), ConditionalBranch{test=condition, label=getBlockLabel trueJump} ] (* Code-generate the body with the code we've done so far at the end. Add a label at the start if necessary. *) local (* If the previous block dropped through to this and this was the only reference then we don't need a label. *) fun onlyJumpingHere (lab: int) = if lab <> picked then false else case Array.sub(labelRefs, picked) of [singleton] => singleton = lab | _ => false val noLabel = case lastFlow of ExitCode => picked = 0 (* Unless this was the first block. *) | Unconditional dest => onlyJumpingHere dest | Conditional { trueJump, falseJump, ...} => onlyJumpingHere trueJump orelse onlyJumpingHere falseJump | IndexedBr _ => false | SetHandler _ => false | UnconditionalHandle _ => false | ConditionalHandle { continue, ...} => onlyJumpingHere continue in val startLabel = if noLabel then [] else [JumpLabel(getBlockLabel picked)] end val ExtendedBasicBlock { flow, block, ...} = Vector.sub(blocks, picked) local fun genCodeBlock(instr, code) = codeExtended {flow=flow} (instr, code) in val bodyCode = List.foldl genCodeBlock (startLabel @ startCode @ code) block end val addSet = case flow of ExitCode => [] | IndexedBr cases => cases | Unconditional dest => [dest] | Conditional {trueJump, falseJump, ...} => [falseJump, trueJump] | SetHandler { handler, continue } => [handler, continue] | UnconditionalHandle _ => [] | ConditionalHandle { continue, ...} => [continue] in genCode(addSet @ stillToDo, flow, bodyCode) end | FlowCodeCMove{code, trueJump, falseJump} => let (* We've generated a conditional move and possibly a return. If the trueJump and falseJump are only ever referenced from this block they're done, otherwise we still need to do them. *) val _ = case Array.sub(labelRefs, trueJump) of [_] => Array.update(processed, trueJump, true) | _ => () val _ = case Array.sub(labelRefs, falseJump) of [_] => Array.update(processed, falseJump, true) | _ => () val ExtendedBasicBlock { flow, ...} = Vector.sub(blocks, trueJump) val addSet = case flow of ExitCode => [] | Unconditional dest => [dest] | _ => raise InternalError "FlowCodeCMove" in genCode(addSet @ stillToDo, flow, code) end end in val ops = genCode([0], ExitCode, []) end in X86OPTIMISE.generateCode{code=newCode, ops=List.rev ops, labelCount= !outputLabelCount, resultClosure=resultClosure} end val nGenRegs = List.length generalRegisters structure Sharing = struct type intSet = intSet and extendedBasicBlock = extendedBasicBlock and regProperty = regProperty and reg = reg and closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/FOREIGNCALLSIG.sml b/mlsource/MLCompiler/FOREIGNCALLSIG.sml index 77dff560..b5b2062a 100644 --- a/mlsource/MLCompiler/FOREIGNCALLSIG.sml +++ b/mlsource/MLCompiler/FOREIGNCALLSIG.sml @@ -1,33 +1,32 @@ (* Copyright (c) 2016, 2018-19 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) signature FOREIGNCALLSIG = sig - val rtsCallFull: string * int * Universal.universal list -> Address.machineWord val rtsCallFast: string * int * Universal.universal list -> Address.machineWord val rtsCallFastRealtoReal: string * Universal.universal list -> Address.machineWord val rtsCallFastRealRealtoReal: string * Universal.universal list -> Address.machineWord val rtsCallFastGeneraltoReal: string * Universal.universal list -> Address.machineWord val rtsCallFastRealGeneraltoReal: string * Universal.universal list -> Address.machineWord val rtsCallFastFloattoFloat: string * Universal.universal list -> Address.machineWord val rtsCallFastFloatFloattoFloat: string * Universal.universal list -> Address.machineWord val rtsCallFastGeneraltoFloat: string * Universal.universal list -> Address.machineWord val rtsCallFastFloatGeneraltoFloat: string * Universal.universal list -> Address.machineWord val foreignCall: Foreign.LibFFI.abi * Foreign.LibFFI.ffiType list * Foreign.LibFFI.ffiType -> Address.machineWord val buildCallBack: Foreign.LibFFI.abi * Foreign.LibFFI.ffiType list * Foreign.LibFFI.ffiType -> Address.machineWord end; diff --git a/mlsource/MLCompiler/INITIALISE_.ML b/mlsource/MLCompiler/INITIALISE_.ML index dd7a552f..f3b7e8fe 100644 --- a/mlsource/MLCompiler/INITIALISE_.ML +++ b/mlsource/MLCompiler/INITIALISE_.ML @@ -1,1953 +1,1999 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited Updated David C.J. Matthews 2008-9, 2012, 2013, 2015-19 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Title: Initialise ML Global Declarations. Author: Dave Matthews,Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) functor INITIALISE_ ( structure LEX: LEXSIG structure TYPETREE : TYPETREESIG structure STRUCTVALS : STRUCTVALSIG structure VALUEOPS : VALUEOPSSIG structure CODETREE : CODETREESIG structure EXPORTTREE: EXPORTTREESIG structure DATATYPEREP: DATATYPEREPSIG structure TYPEIDCODE: TYPEIDCODESIG structure MAKE: MAKESIG structure ADDRESS : AddressSig structure DEBUG: DEBUGSIG structure DEBUGGER : DEBUGGERSIG structure PRETTY : PRETTYSIG structure PRINTTABLE: PRINTTABLESIG structure MISC : sig val unescapeString : string -> string exception Conversion of string; (* string to int conversion failure *) end structure VERSION: sig val compilerVersion: string val versionNumber: int end structure UNIVERSALTABLE: sig type universal = Universal.universal type univTable type 'a tag = 'a Universal.tag val univLookup: univTable * 'a tag * string -> 'a option val fold: (string * universal * 'a -> 'a) -> 'a -> univTable -> 'a end sharing STRUCTVALS.Sharing = VALUEOPS.Sharing = TYPETREE.Sharing = EXPORTTREE.Sharing = PRETTY.Sharing = CODETREE.Sharing = MAKE.Sharing = ADDRESS = DATATYPEREP.Sharing = TYPEIDCODE.Sharing = DEBUGGER.Sharing = LEX.Sharing = PRINTTABLE.Sharing sharing STRUCTVALS.Sharing = VALUEOPS.Sharing = TYPETREE.Sharing = EXPORTTREE.Sharing = PRETTY.Sharing = CODETREE.Sharing = MAKE.Sharing = ADDRESS = DATATYPEREP.Sharing = TYPEIDCODE.Sharing = DEBUGGER.Sharing = LEX.Sharing = PRINTTABLE.Sharing = UNIVERSALTABLE ) : sig type gEnv val initGlobalEnv : {globalTable : gEnv, intIsArbitraryPrecision: bool } -> unit end = struct open STRUCTVALS; open TYPETREE open VALUEOPS; open CODETREE; open ADDRESS; open MAKE; open MISC; open EXPORTTREE open DATATYPEREP val intInfType = mkTypeConstruction ("int", intInfConstr, [], []) and realType = mkTypeConstruction ("real", realConstr, [], []) and charType = mkTypeConstruction ("char", charConstr, [], []) and wordType = mkTypeConstruction ("word", wordConstr, [], []) val declInBasis = [DeclaredAt inBasis] fun applyList _ [] = () | applyList f (h :: t) = (f h : unit; applyList f t); fun initGlobalEnv{globalTable : gEnv, intIsArbitraryPrecision: bool } = let val Env globalEnv = MAKE.gEnvAsEnv globalTable val enterGlobalValue = #enterVal globalEnv; val enterGlobalType = #enterType globalEnv; (* Some routines to help make the types. *) local (* careful - STRUCTVALS.intType differs from TYPETREE.intType *) open TYPETREE; in (* Make some type variables *) fun makeEqTV () = mkTypeVar (generalisable, true, false, false) fun makeTV () = mkTypeVar (generalisable, false, false, false) fun makePrintTV() = mkTypeVar (generalisable, false, false, true) fun makeTypeVariable() = makeTv {value=emptyType, level=generalisable, equality=false, nonunifiable=false, printable=false} (* Make some functions *) infixr 5 ->> fun a ->> b = mkFunctionType (a, b); infix 7 **; fun a ** b = mkProductType [a, b]; (* Type identifiers for the types of the declarations. *) val Int = if intIsArbitraryPrecision then intInfType else fixedIntType val String = stringType; val Bool = boolType; val Unit = unitType; val Char = charType; val Word = wordType; val Real = realType val Exn = exnType val mkTypeConstruction = mkTypeConstruction; val () = setPreferredInt(if intIsArbitraryPrecision then intInfConstr else fixedIntConstr) end; fun makePolymorphic(tvs, c) = let open TYPEIDCODE val tvs = List.filter(fn TypeVar tv => not justForEqualityTypes orelse tvEquality tv | _ => false) tvs in if null tvs then c else mkInlproc(c, List.length tvs, "", [], 0) end (* Function to make a type identifier with a pretty printer that just prints "?". None of the types are equality types so the equality function is empty. *) local fun monotypePrinter _ = PRETTY.PrettyString "?" in fun defaultEqAndPrintCode () = let open TypeValue val code = createTypeValue{ eqCode = CodeZero, printCode = mkConst (toMachineWord (ref monotypePrinter)), boxedCode = boxedEither (* Assume this for the moment *), sizeCode = singleWord } in Global (genCode(code, [], 0) ()) end end fun makeTypeAbbreviation(name, fullName, typeVars, typeResult, locations) = makeTypeConstructor( name, typeVars, makeTypeFunction(basisDescription fullName, (typeVars, typeResult)), locations) (* Make an opaque type and add it to an environment. *) fun makeAndDeclareOpaqueType(typeName, fullName, env) = let val typeconstr = makeTypeConstructor(typeName, [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription fullName), declInBasis); in #enterType env (typeName, TypeConstrSet(typeconstr, [])); mkTypeConstruction (typeName, typeconstr, [], declInBasis) end; (* List of something *) fun List (base : types) : types = mkTypeConstruction ("list", tsConstr listConstr, [base], declInBasis); (* ref something *) fun Ref (base : types) : types = mkTypeConstruction ("ref", refConstr, [base], declInBasis); fun Option (base : types) : types = mkTypeConstruction ("option", tsConstr optionConstr, [base], declInBasis); (* Type-dependent functions. *) fun mkSpecialFun (name:string, typeof:types, opn: typeDependent) : values = makeOverloaded (name, typeof, opn); (* Overloaded functions. *) fun mkOverloaded (name:string) (typeof: types) : values = mkSpecialFun(name, typeof, TypeDep) (* Make a structure. Returns the table as an environment so that entries can be added to the structure. *) fun makeStructure(parentEnv, name) = let val str as Struct{signat=Signatures{tab, ...}, ...} = makeEmptyGlobal name val () = #enterStruct parentEnv (name, str) val Env env = makeEnv tab in env end val () = enterGlobalType ("unit", TypeConstrSet(unitConstr, [])); local val falseCons = mkGconstr ("false", Bool, createNullaryConstructor(EnumForm{tag=0w0, maxTag=0w1}, [], "false"), true, 2, declInBasis) val trueCons = mkGconstr ("true", Bool, createNullaryConstructor(EnumForm{tag=0w1, maxTag=0w1}, [], "true"), true, 2, declInBasis) val boolEnv = makeStructure(globalEnv, "Bool") (* Bool structure *) val notFn = mkGvar("not", Bool ->> Bool, mkUnaryFn BuiltIns.NotBoolean, declInBasis) in val () = #enterType boolEnv ("bool", TypeConstrSet(boolConstr, [trueCons, falseCons])) val () = #enterVal boolEnv ("true", trueCons) val () = #enterVal boolEnv ("false", falseCons) val () = #enterVal boolEnv ("not", notFn) end; val () = enterGlobalType ("int", TypeConstrSet(if intIsArbitraryPrecision then intInfConstr else fixedIntConstr, [])) val () = enterGlobalType ("char", TypeConstrSet(charConstr, [])) val () = enterGlobalType ("string", TypeConstrSet(stringConstr, [])) val () = enterGlobalType ("real", TypeConstrSet(realConstr, [])) val () = (* Enter :: and nil. *) List.app(fn(tv as Value{name, ...}) => enterGlobalValue(name, tv)) (tsConstructors listConstr) val () = enterGlobalType ("list", listConstr); val () = (* Enter NONE and SOME. *) List.app(fn(tv as Value{name, ...}) => enterGlobalValue(name, tv)) (tsConstructors optionConstr) val () = enterGlobalType ("option", optionConstr); local val refCons = let val a = mkTypeVar(generalisable, false, false, false) in mkGconstr ("ref", a ->> Ref a, createUnaryConstructor(RefForm, [a], "ref"), false, 1, declInBasis) end in val () = enterGlobalType ("ref", TypeConstrSet(refConstr, [refCons])); val () = enterGlobalValue ("ref", refCons); end local open BuiltIns fun monoTypePrinter _ = PRETTY.PrettyString "?" val idCode = let open TypeValue val equalLongWordFn = mkInlproc( mkBinary(LargeWordComparison TestEqual, mkLoadArgument 0, mkLoadArgument 1), 2, "EqualLargeWord()", [], 0) val code = createTypeValue{ eqCode=equalLongWordFn, printCode=mkConst (toMachineWord (ref monoTypePrinter)), boxedCode = boxedNever, sizeCode = singleWord } in Global (genCode(code, [], 0) ()) end in val largeWordType = makeTypeConstructor("word", [], makeFreeId(0, idCode, true, basisDescription "LargeWord.word"), declInBasis) val LargeWord = mkTypeConstruction ("LargeWord.word", largeWordType, [], declInBasis) end val () = enterGlobalType ("exn", TypeConstrSet(exnConstr, [])); val () = enterGlobalType ("word", TypeConstrSet(wordConstr, [])); val runCallEnv = makeStructure(globalEnv, "RunCall") fun enterRunCall (name : string, entry : codetree, typ : types) : unit = let val value = mkGvar (name, typ, entry, declInBasis); in #enterVal runCallEnv (name, value) end local (* unsafeCast. Can be used to convert any value to any type. *) val a = makeTV () val b = makeTV () val unsafeCastEntry = mkInlproc (mkLoadArgument 0 (* just the parameter *), 1, "unsafeCast(1)", [], 0) in val () = enterRunCall ("unsafeCast", makePolymorphic([a, b], unsafeCastEntry), a ->> b) end local val a = makeTV() and b = makeTV() open BuiltIns in (* isShort - test if a value is tagged rather than being an address. *) val () = enterRunCall ("isShort", makePolymorphic([a], mkUnaryFn IsTaggedValue), a ->> Bool) (* pointer equality *) val () = enterRunCall ("pointerEq", makePolymorphic([a], mkBinaryFn(WordComparison{test=TestEqual, isSigned=false})), a ** a ->> Bool) (* load a word. The index is in words and is always zero or positive. *) val () = enterRunCall ("loadWord", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLWord{isImmutable=false})), a ** Word ->> b) (* Load a word from an immutable. *) val () = enterRunCall ("loadWordFromImmutable", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLWord{isImmutable=true})), a ** Word ->> b) (* load a byte. The index is in bytes and is always zero or positive. Probably the result should be a Word8.word value or a char. *) val () = enterRunCall ("loadByte", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLByte{isImmutable=false})), a ** Word ->> b) (* Load a byte from an immutable. *) val () = enterRunCall ("loadByteFromImmutable", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLByte{isImmutable=true})), a ** Word ->> b) (* Get the length of a heap cell. *) val () = enterRunCall ("memoryCellLength", makePolymorphic([a], mkUnaryFn MemoryCellLength), a ->> Word) (* Return the flags. Perhaps this could return a Word8.word value instead of a word. *) val () = enterRunCall ("memoryCellFlags", makePolymorphic([a], mkUnaryFn MemoryCellFlags), a ->> Word) (* Return the number of bytes per word. This is a constant since we have separate pre-built compilers for 32-bit and 64-bit. N.B. The byte order is not a constant since we only have a single pre-built compiler for little-endian and big-endian interpreted code. *) val () = enterRunCall ("bytesPerWord", mkConst(toMachineWord wordSize), Word) (* Store a word *) val () = enterRunCall ("storeWord", makePolymorphic([a, b], mkStoreOperationFn(LoadStoreMLWord{isImmutable=false})), mkProductType[a, Word, b] ->> Unit) (* Store a byte *) val () = enterRunCall ("storeByte", makePolymorphic([a, b], mkStoreOperationFn(LoadStoreMLByte{isImmutable=false})), mkProductType[a, Word, b] ->> Unit) (* Lock a mutable cell. *) val () = enterRunCall ("clearMutableBit", makePolymorphic([a], mkUnaryFn ClearMutableFlag), a ->> Unit) (* Allocate a byte cell. The second argument is the flags byte. It might be better if this were a Word8.word value. *) val () = enterRunCall ("allocateByteMemory", makePolymorphic([a], mkBinaryFn AllocateByteMemory), Word ** Word ->> a) (* Allocate a word cell. *) val () = enterRunCall ("allocateWordMemory", makePolymorphic([a, b], mkAllocateWordMemoryFn), mkProductType[Word, Word, a] ->> b) (* Byte vector operations. *) val () = enterRunCall ("byteVectorEqual", makePolymorphic([a], mkBlockOperationFn BlockOpEqualByte), mkProductType[a, a, Word, Word, Word] ->> Bool) val () = enterRunCall ("byteVectorCompare", makePolymorphic([a], mkBlockOperationFn BlockOpCompareByte), mkProductType[a, a, Word, Word, Word] ->> Int) (* Block moves. *) val () = enterRunCall ("moveBytes", makePolymorphic([a], mkBlockOperationFn (BlockOpMove{isByteMove=true})), mkProductType[a, a, Word, Word, Word] ->> Unit) val () = enterRunCall ("moveWords", makePolymorphic([a], mkBlockOperationFn (BlockOpMove{isByteMove=false})), mkProductType[a, a, Word, Word, Word] ->> Unit) (* Untagged loads and stores. *) val () = enterRunCall ("loadUntagged", mkLoadOperationFn LoadStoreUntaggedUnsigned, String ** Word ->> Word) val () = enterRunCall ("storeUntagged", mkStoreOperationFn LoadStoreUntaggedUnsigned, mkProductType[String, Word, Word] ->> Unit) end local val debugOpts = [] (* Place to add debugging if necessary. *) (* [tagInject Pretty.compilerOutputTag (Pretty.prettyPrint(print, 70)), tagInject assemblyCodeTag true] *) fun makeCall rtsCall n entryName = rtsCall (entryName, n, debugOpts) val makeFastCall = makeCall CODETREE.Foreign.rtsCallFast - and makeFullCall = makeCall CODETREE.Foreign.rtsCallFull (* We need to wrap this so that the arguments are passed in registers. *) fun makeRunCallTupled (argTypes, resultType, callN) : codetree = let val width = List.length argTypes val name = "rtsCall" ^ Int.toString width; local val f = mkLoadClosure 0 (* first item from enclosing scope *) val tuple = mkLoadArgument 0 (* the inner parameter *) val args = case argTypes of [singleType] => [(tuple, singleType)] | argTypes => let val argVals = List.tabulate(width, fn n => mkInd (n, tuple)) in ListPair.zipEq(argVals, argTypes) end in val innerBody = mkCall (f, args, resultType) end local (* The closure contains the address of the RTS call. *) val f = mkEval(mkConst callN, [mkLoadArgument 0]) val innerLambda = mkInlproc (innerBody, 1, name ^ "(1)", [mkLoadLocal 0], 0) in val outerBody = mkEnv([mkDec (0, f)], innerLambda) end val outerLambda = mkInlproc (outerBody, 1, name, [], 1) in outerLambda end + (* "Full" calls pass the thread Id as the first parameter. *) + fun makeRunCallTupledFull (argTypes, resultType) = + let + val width = List.length argTypes + val callN = toMachineWord(makeFastCall(width + 1)) + val name = "rtsCall" ^ Int.toString width; + + local + val f = mkLoadClosure 0 (* first item from enclosing scope *) + val tuple = mkLoadArgument 0 (* the inner parameter *) + val args = + case argTypes of + [singleType] => [(tuple, singleType)] + | argTypes => + let + val argVals = List.tabulate(width, fn n => mkInd (n, tuple)) + in + ListPair.zipEq(argVals, argTypes) + end + in + val innerBody = + mkEnv( + [ + mkDec(0, mkCall (f, (getCurrentThreadId, GeneralType) :: args, resultType)), + mkNullDec checkRTSException + ], mkLoadLocal 0) + end + + local + (* The closure contains the address of the RTS call. *) + val f = mkEval(mkConst callN, [mkLoadArgument 0]) (* This creates the actual call. *) + val innerLambda = mkInlproc (innerBody, 1, name ^ "(1)", [mkLoadLocal 0], 1) + in + val outerBody = mkEnv([mkDec (0, f)], innerLambda) + end + + val outerLambda = mkInlproc (outerBody, 1, name, [], 1) + in + outerLambda + end + local val a = makeTV () and b = makeTV () fun makeInlCode(makeCall, name) = let val call1 = toMachineWord(makeCall 1) val body = mkEval(mkConst call1, [mkLoadArgument 0]) val proc = mkInlproc (body, 1, name, [], 0) in makePolymorphic([a, b], proc) end in - val rtsCallFull1Entry = makeInlCode(makeFullCall, "rtsCallFull1") - and rtsCallFast1Entry = makeInlCode(makeFastCall, "rtsCallFast1") + val rtsCallFast1Entry = makeInlCode(makeFastCall, "rtsCallFast1") end local val a = makeTV () and b = makeTV () and c = makeTV () and d = makeTV () and e = makeTV () + and f = makeTV () fun makeRtsCall(n, makeCall) = makeRunCallTupled(List.tabulate(n, fn _ => GeneralType), GeneralType, toMachineWord(makeCall n)) + fun makeFullRtsCall n = makeRunCallTupledFull(List.tabulate(n, fn _ => GeneralType), GeneralType) in - val rtsCallFull0Entry = makePolymorphic([a], makeRtsCall(0, makeFullCall)) + val rtsCallFull0Entry = makePolymorphic([a], makeFullRtsCall 0) and rtsCallFast0Entry = makePolymorphic([a], makeRtsCall(0, makeFastCall)) val rtsCall0Type = String ->> Unit ->> a val rtsCall1Type = String ->> a ->> b - - val rtsCallFull2Entry = makePolymorphic([a, b, c], makeRtsCall(2, makeFullCall)) + val rtsCallFull1Entry = makePolymorphic([a, b], makeFullRtsCall 1) + val rtsCallFull2Entry = makePolymorphic([a, b, c], makeFullRtsCall 2) and rtsCallFast2Entry = makePolymorphic([a, b, c], makeRtsCall(2, makeFastCall)) val rtsCall2Type = String ->> TYPETREE.mkProductType [a,b] ->> c - val rtsCallFull3Entry = makePolymorphic([a, b, c, d], makeRtsCall(3, makeFullCall)) + val rtsCallFull3Entry = makePolymorphic([a, b, c, d], makeFullRtsCall 3) val rtsCallFast3Entry = makePolymorphic([a, b, c, d], makeRtsCall(3, makeFastCall)) val rtsCall3Type = String ->> TYPETREE.mkProductType [a,b,c] ->> d + val rtsCallFull4Entry = makePolymorphic([a, b, c, d, e], makeFullRtsCall 4) val rtsCallFast4Entry = makePolymorphic([a, b, c, d, e], makeRtsCall(4, makeFastCall)) val rtsCall4Type = String ->> TYPETREE.mkProductType [a,b,c,d] ->> e + val rtsCallFull5Entry = makePolymorphic([a, b, c, d, e, f], makeFullRtsCall 5) + val rtsCall5Type = String ->> TYPETREE.mkProductType [a,b,c,d,e] ->> f end in val () = enterRunCall ("rtsCallFull0", rtsCallFull0Entry, rtsCall0Type) val () = enterRunCall ("rtsCallFast0", rtsCallFast0Entry, rtsCall0Type) val () = enterRunCall ("rtsCallFull1", rtsCallFull1Entry, rtsCall1Type) val () = enterRunCall ("rtsCallFast1", rtsCallFast1Entry, rtsCall1Type) val () = enterRunCall ("rtsCallFull2", rtsCallFull2Entry, rtsCall2Type) val () = enterRunCall ("rtsCallFast2", rtsCallFast2Entry, rtsCall2Type) val () = enterRunCall ("rtsCallFull3", rtsCallFull3Entry, rtsCall3Type) val () = enterRunCall ("rtsCallFast3", rtsCallFast3Entry, rtsCall3Type) val () = enterRunCall ("rtsCallFast4", rtsCallFast4Entry, rtsCall4Type) + val () = enterRunCall ("rtsCallFull4", rtsCallFull4Entry, rtsCall4Type) + val () = enterRunCall ("rtsCallFull5", rtsCallFull5Entry, rtsCall5Type) val makeRunCallTupled = makeRunCallTupled (* Needed for reals. *) end local (* Create nullary exception. *) fun makeException0(name, id) = let val exc = Value{ name = name, typeOf = TYPETREE.exnType, access = Global(mkConst(toMachineWord id)), class = Exception, locations = declInBasis, references = NONE, instanceTypes=NONE } in #enterVal runCallEnv (name, exc) end (* Create exception with parameter. *) and makeException1(name, id, exType) = let val exc = Value{ name = name, typeOf = exType ->> TYPETREE.exnType, access = Global(mkConst(toMachineWord id)), class = Exception, locations = declInBasis, references = NONE, instanceTypes=NONE } in #enterVal runCallEnv (name, exc) end (* Exception numbers. Most of these are hard-coded in the RTS. *) val EXC_interrupt = 1 val EXC_syserr = 2 val EXC_size = 4 val EXC_overflow = 5 val EXC_divide = 7 val EXC_conversion = 8 val EXC_XWindows = 10 val EXC_subscript = 11 val EXC_thread = 12 val EXC_foreign = 23 val EXC_Bind = 100 (* In Match compiler. *) val EXC_Match = 101 val EXC_Fail = 103 in val () = List.app makeException0 [ ("Interrupt", EXC_interrupt), ("Size", EXC_size), ("Bind", EXC_Bind), ("Div", EXC_divide), ("Match", EXC_Match), ("Overflow", EXC_overflow), ("Subscript", EXC_subscript) ] val () = List.app makeException1 [ ("Fail", EXC_Fail, String), ("Conversion", EXC_conversion, String), ("XWindows", EXC_XWindows, String), ("Foreign", EXC_foreign, String), ("Thread", EXC_thread, String), ("SysErr", EXC_syserr, String ** Option LargeWord) ] end local val arg0 = mkLoadArgument 0 local val callForeignCall = mkEval(mkConst (toMachineWord CODETREE.Foreign.foreignCall), [arg0]) val innerBody = mkEval(mkLoadClosure 0, [mkInd(0, arg0), mkInd(1, arg0), mkInd(2, arg0)]) val outerBody = mkEnv([mkDec(0, callForeignCall)], mkInlproc(innerBody, 1, "foreignCall(1)(1)", [mkLoadLocal 0], 0)) in val foreignCallEntry = mkInlproc(outerBody, 1, "foreignCall(1)", [], 1) end val buildCallBackEntry = mkConst (toMachineWord CODETREE.Foreign.buildCallBack) val abiType = Int and ffiType = LargeWord val foreignCallType = mkProductType[abiType, List ffiType, ffiType] ->> mkProductType[LargeWord, LargeWord, LargeWord] ->> Unit val buildCallBackType = mkProductType[abiType, List ffiType, ffiType] ->> (mkProductType[LargeWord, LargeWord] ->> Unit) ->> LargeWord in val () = enterRunCall ("foreignCall", foreignCallEntry, foreignCallType) val () = enterRunCall ("buildCallBack", buildCallBackEntry, buildCallBackType) end (* Standard Basis structures for basic types. These contain the definitions of the basic types and operations on them. The structures are extended in the basis library and overloaded functions are extracted from them. *) local val largeIntEnv = makeStructure(globalEnv, "LargeInt") (* The comparison operations take two arbitrary precision ints and a general "compare" function that returns a fixed precision int. *) val compareType = mkProductType[intInfType, intInfType, intInfType ** intInfType ->> fixedIntType] ->> Bool val arithType = mkProductType[intInfType, intInfType, intInfType ** intInfType ->> intInfType] ->> intInfType fun enterArbitrary(name, oper, typ) = let val value = mkGvar (name, typ, mkArbitraryFn oper, declInBasis) in #enterVal largeIntEnv (name, value) end in val () = #enterType largeIntEnv ("int", TypeConstrSet(intInfConstr, [])) (* These functions are used internally. *) val () = enterArbitrary("less", ArbCompare BuiltIns.TestLess, compareType) val () = enterArbitrary("greater", ArbCompare BuiltIns.TestGreater, compareType) val () = enterArbitrary("lessEq", ArbCompare BuiltIns.TestLessEqual, compareType) val () = enterArbitrary("greaterEq", ArbCompare BuiltIns.TestGreaterEqual, compareType) val () = enterArbitrary("add", ArbArith BuiltIns.ArithAdd, arithType) val () = enterArbitrary("subtract", ArbArith BuiltIns.ArithSub, arithType) val () = enterArbitrary("multiply", ArbArith BuiltIns.ArithMult, arithType) end local val fixedIntEnv = makeStructure(globalEnv, "FixedInt") open BuiltIns fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal fixedIntEnv (name, value) end val compareType = fixedIntType ** fixedIntType ->> Bool and binaryType = fixedIntType ** fixedIntType ->> fixedIntType fun enterComparison(name, test) = enterBinary(name, WordComparison{test=test, isSigned=true}, compareType) and enterBinaryOp(name, oper) = enterBinary(name, FixedPrecisionArith oper, binaryType) in val () = #enterType fixedIntEnv ("int", TypeConstrSet(fixedIntConstr, [])) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("quot", ArithQuot) val () = enterBinaryOp("rem", ArithRem) end local open BuiltIns val largeWordEnv = makeStructure(globalEnv, "LargeWord") fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal largeWordEnv (name, value) end val compareType = LargeWord ** LargeWord ->> Bool and binaryType = LargeWord ** LargeWord ->> LargeWord and shiftType = LargeWord ** Word ->> LargeWord (* The shift amount is a Word. *) fun enterComparison(name, test) = enterBinary(name, LargeWordComparison test, compareType) and enterBinaryOp(name, oper) = enterBinary(name, LargeWordArith oper, binaryType) and enterBinaryLogical(name, oper) = enterBinary(name, LargeWordLogical oper, binaryType) and enterBinaryShift(name, oper) = enterBinary(name, LargeWordShift oper, shiftType) in val () = #enterType largeWordEnv ("word", TypeConstrSet(largeWordType, [])) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("div", ArithDiv) val () = enterBinaryOp("mod", ArithMod) val () = enterBinaryLogical("orb", LogicalOr) val () = enterBinaryLogical("andb", LogicalAnd) val () = enterBinaryLogical("xorb", LogicalXor) val () = enterBinaryShift("<<", ShiftLeft) val () = enterBinaryShift(">>", ShiftRightLogical) val () = enterBinaryShift("~>>", ShiftRightArithmetic) val LargeWord = LargeWord end local val wordStructEnv = makeStructure(globalEnv, "Word") open BuiltIns fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal wordStructEnv (name, value) end val compareType = Word ** Word ->> Bool and binaryType = Word ** Word ->> Word fun enterComparison(name, test) = enterBinary(name, WordComparison{test=test, isSigned=false}, compareType) and enterBinaryOp(name, oper) = enterBinary(name, WordArith oper, binaryType) and enterBinaryLogical(name, oper) = enterBinary(name, WordLogical oper, binaryType) and enterBinaryShift(name, oper) = enterBinary(name, WordShift oper, binaryType) val toLargeWordFn = mkGvar ("toLargeWord", Word ->> LargeWord, mkUnaryFn UnsignedToLongWord, declInBasis) and toLargeWordXFn = mkGvar ("toLargeWordX", Word ->> LargeWord, mkUnaryFn SignedToLongWord, declInBasis) and fromLargeWordFn = mkGvar ("fromLargeWord", LargeWord ->> Word, mkUnaryFn LongWordToTagged, declInBasis) in val () = #enterType wordStructEnv ("word", TypeConstrSet(wordConstr, [])) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("div", ArithDiv) val () = enterBinaryOp("mod", ArithMod) val () = enterBinaryLogical("orb", LogicalOr) val () = enterBinaryLogical("andb", LogicalAnd) val () = enterBinaryLogical("xorb", LogicalXor) val () = enterBinaryShift("<<", ShiftLeft) val () = enterBinaryShift(">>", ShiftRightLogical) val () = enterBinaryShift("~>>", ShiftRightArithmetic) val () = #enterVal wordStructEnv ("toLargeWord", toLargeWordFn) val () = #enterVal wordStructEnv ("toLargeWordX", toLargeWordXFn) val () = #enterVal wordStructEnv ("fromLargeWord", fromLargeWordFn) end local val charEnv = makeStructure(globalEnv, "Char") open BuiltIns (* Comparison functions are the same as Word. *) fun enterComparison(name, test) = let val typ = Char ** Char ->> Bool val entry = mkBinaryFn(WordComparison{test=test, isSigned=false}) val value = mkGvar (name, typ, entry, declInBasis) in #enterVal charEnv (name, value) end in val () = #enterType charEnv ("char", TypeConstrSet(charConstr, [])) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) end local val stringEnv = makeStructure(globalEnv, "String") in val () = #enterType stringEnv ("string", TypeConstrSet(stringConstr, [])) end local val realEnv = makeStructure(globalEnv, "Real") (* These are only used in Real so are included here rather than in RunCall. rtsCallFastRealtoReal is used for functions such as sqrt. rtsCallFastGeneraltoReal is used for Real.fromLargeInt. *) val debugOpts = [] (* Place to add debugging if necessary. *) fun makeFastRealRealCall entryName = CODETREE.Foreign.rtsCallFastRealtoReal (entryName, debugOpts) and makeFastRealRealRealCall entryName = CODETREE.Foreign.rtsCallFastRealRealtoReal (entryName, debugOpts) and makeFastIntInfRealCall entryName = CODETREE.Foreign.rtsCallFastGeneraltoReal (entryName, debugOpts) and makeFastRealGeneralRealCall entryName = CODETREE.Foreign.rtsCallFastRealGeneraltoReal (entryName, debugOpts) val rtsCallFastR_REntry = makeRunCallTupled([DoubleFloatType], DoubleFloatType, toMachineWord makeFastRealRealCall) (* This needs to be tupled. *) val rtsCallFastRR_REntry = makeRunCallTupled([DoubleFloatType, DoubleFloatType], DoubleFloatType, toMachineWord makeFastRealRealRealCall) and rtsCallFastRI_REntry = makeRunCallTupled([DoubleFloatType, GeneralType], DoubleFloatType, toMachineWord makeFastRealGeneralRealCall) val rtsCallFastI_REntry = makeRunCallTupled([GeneralType], DoubleFloatType, toMachineWord makeFastIntInfRealCall) val rtsCallFastF_F = mkGvar ("rtsCallFastR_R", String ->> Real ->> Real, rtsCallFastR_REntry, declInBasis) val rtsCallFastFF_F = mkGvar ("rtsCallFastRR_R", String ->> Real ** Real ->> Real, rtsCallFastRR_REntry, declInBasis) val rtsCallFastFG_F = mkGvar ("rtsCallFastRI_R", String ->> Real ** Int ->> Real, rtsCallFastRI_REntry, declInBasis) val rtsCallFastG_F = mkGvar ("rtsCallFastI_R", String ->> intInfType ->> Real, rtsCallFastI_REntry, declInBasis) fun enterUnary(name, oper, typ) = let val value = mkGvar (name, typ, mkUnaryFn oper, declInBasis) in #enterVal realEnv (name, value) end fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal realEnv (name, value) end val compareType = Real ** Real ->> Bool and binaryType = Real ** Real ->> Real and unaryType = Real ->> Real and realToFixType = Real ->> fixedIntType open BuiltIns IEEEReal fun enterComparison(name, test) = enterBinary(name, RealComparison(test, PrecDouble), compareType) and enterBinaryOp(name, oper) = enterBinary(name, RealArith(oper, PrecDouble), binaryType) in val () = #enterType realEnv ("real", TypeConstrSet(realConstr, [])) val () = #enterVal realEnv ("rtsCallFastR_R", rtsCallFastF_F) val () = #enterVal realEnv ("rtsCallFastRR_R", rtsCallFastFF_F) val () = #enterVal realEnv ("rtsCallFastRI_R", rtsCallFastFG_F) val () = #enterVal realEnv ("rtsCallFastI_R", rtsCallFastG_F) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterComparison("==", TestEqual) (* real is not an eqtype. *) (* Included unordered mainly because it's easy to implement isNan. *) val () = enterComparison("unordered", TestUnordered) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("/", ArithDiv) val () = enterUnary("~", RealNeg PrecDouble, unaryType) val () = enterUnary("abs", RealAbs PrecDouble, unaryType) val () = enterUnary("fromFixedInt", RealFixedInt PrecDouble, fixedIntType ->> Real) val () = enterUnary("truncFix", RealToInt(PrecDouble, TO_ZERO), realToFixType) val () = enterUnary("roundFix", RealToInt(PrecDouble, TO_NEAREST), realToFixType) val () = enterUnary("ceilFix", RealToInt(PrecDouble, TO_POSINF), realToFixType) val () = enterUnary("floorFix", RealToInt(PrecDouble, TO_NEGINF), realToFixType) end local val real32Env = makeStructure(globalEnv, "Real32") val floatType = mkTypeConstruction ("real", floatConstr, [], []) val Float = floatType val debugOpts = [] (* Place to add debugging if necessary. *) fun makeFastFloatFloatCall entryName = CODETREE.Foreign.rtsCallFastFloattoFloat (entryName, debugOpts) and makeFastFloatFloatFloatCall entryName = CODETREE.Foreign.rtsCallFastFloatFloattoFloat (entryName, debugOpts) and makeFastIntInfFloatCall entryName = CODETREE.Foreign.rtsCallFastGeneraltoFloat (entryName, debugOpts) and makeFastFloatGeneralFloatCall entryName = CODETREE.Foreign.rtsCallFastFloatGeneraltoFloat (entryName, debugOpts) val rtsCallFastR_REntry = makeRunCallTupled([SingleFloatType], SingleFloatType, toMachineWord makeFastFloatFloatCall) (* This needs to be tupled. *) val rtsCallFastRR_REntry = makeRunCallTupled([SingleFloatType, SingleFloatType], SingleFloatType, toMachineWord makeFastFloatFloatFloatCall) and rtsCallFastRI_REntry = makeRunCallTupled([SingleFloatType, GeneralType], SingleFloatType, toMachineWord makeFastFloatGeneralFloatCall) val rtsCallFastI_REntry = makeRunCallTupled([GeneralType], SingleFloatType, toMachineWord makeFastIntInfFloatCall) val rtsCallFastF_F = mkGvar ("rtsCallFastF_F", String ->> Float ->> Float, rtsCallFastR_REntry, declInBasis) val rtsCallFastFF_F = mkGvar ("rtsCallFastFF_F", String ->> Float ** Float ->> Float, rtsCallFastRR_REntry, declInBasis) val rtsCallFastFG_F = mkGvar ("rtsCallFastFI_F", String ->> Float ** Int ->> Float, rtsCallFastRI_REntry, declInBasis) val rtsCallFastG_F = mkGvar ("rtsCallFastI_F", String ->> intInfType ->> Float, rtsCallFastI_REntry, declInBasis) fun enterUnary(name, oper, typ) = let val value = mkGvar (name, typ, mkUnaryFn oper, declInBasis) in #enterVal real32Env (name, value) end fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal real32Env (name, value) end val compareType = Float ** Float ->> Bool and binaryType = Float ** Float ->> Float and unaryType = Float ->> Float and floatToFixType = Float ->> fixedIntType open BuiltIns IEEEReal fun enterComparison(name, test) = enterBinary(name, RealComparison(test, PrecSingle), compareType) and enterBinaryOp(name, oper) = enterBinary(name, RealArith(oper, PrecSingle), binaryType) in val () = #enterType real32Env ("real", TypeConstrSet(floatConstr, [])) val () = enterUnary("toLarge", BuiltIns.FloatToDouble, floatType ->> Real) (* Conversion with the current rounding mode. *) and () = enterUnary("fromReal", BuiltIns.DoubleToFloat NONE, Real ->> floatType) (* There are various versions of this function for each of the rounding modes. *) and () = enterUnary("fromRealRound", BuiltIns.DoubleToFloat (SOME IEEEReal.TO_NEAREST), Real ->> floatType) and () = enterUnary("fromRealTrunc", BuiltIns.DoubleToFloat (SOME IEEEReal.TO_ZERO), Real ->> floatType) and () = enterUnary("fromRealCeil", BuiltIns.DoubleToFloat (SOME IEEEReal.TO_POSINF), Real ->> floatType) and () = enterUnary("fromRealFloor", BuiltIns.DoubleToFloat (SOME IEEEReal.TO_NEGINF), Real ->> floatType) val () = #enterVal real32Env ("rtsCallFastR_R", rtsCallFastF_F) val () = #enterVal real32Env ("rtsCallFastRR_R", rtsCallFastFF_F) val () = #enterVal real32Env ("rtsCallFastRI_R", rtsCallFastFG_F) val () = #enterVal real32Env ("rtsCallFastI_R", rtsCallFastG_F) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterComparison("==", TestEqual) (* Real32.real is not an eqtype. *) val () = enterComparison("unordered", TestUnordered) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("/", ArithDiv) val () = enterUnary("~", RealNeg PrecSingle, unaryType) val () = enterUnary("abs", RealAbs PrecSingle, unaryType) val () = enterUnary("truncFix", RealToInt(PrecSingle, TO_ZERO), floatToFixType) val () = enterUnary("roundFix", RealToInt(PrecSingle, TO_NEAREST), floatToFixType) val () = enterUnary("ceilFix", RealToInt(PrecSingle, TO_POSINF), floatToFixType) val () = enterUnary("floorFix", RealToInt(PrecSingle, TO_NEGINF), floatToFixType) end val bootstrapEnv = makeStructure(globalEnv, "Bootstrap") fun enterBootstrap (name : string, entry : codetree, typ : types) : unit = let val value = mkGvar (name, typ, entry, declInBasis) in #enterVal bootstrapEnv (name, value) end local val threadEnv = makeStructure(globalEnv, "Thread") open TypeValue fun monoTypePrinter _ = PRETTY.PrettyString "?" val code = createTypeValue{ eqCode=equalWordFn, printCode=mkConst (toMachineWord (ref monoTypePrinter)), boxedCode=boxedAlways, sizeCode=singleWord } (* Thread.thread type. This is an equality type with pointer equality. *) val threadConstr= makeTypeConstructor ( "thread", [], makeFreeId(0, Global (genCode(code, [], 0) ()), true, basisDescription "thread"), [DeclaredAt inBasis]) val threadType = mkTypeConstruction ("thread", threadConstr, [], []); val selfFunction = mkGvar ("self", Unit ->> threadType, getCurrentThreadIdFn, declInBasis) val atIncrFunction = mkGvar("atomicIncr", Ref Word ->> Word, mkUnaryFn BuiltIns.AtomicIncrement, declInBasis) val atDecrFunction = mkGvar("atomicDecr", Ref Word ->> Word, mkUnaryFn BuiltIns.AtomicDecrement, declInBasis) val atResetFunction = mkGvar("atomicReset", Ref Word ->> Unit, mkUnaryFn BuiltIns.AtomicReset, declInBasis) in val () = #enterType threadEnv ("thread", TypeConstrSet(threadConstr, [])) val () = #enterVal threadEnv ("self", selfFunction) val () = #enterVal threadEnv ("atomicIncr", atIncrFunction) val () = #enterVal threadEnv ("atomicDecr", atDecrFunction) val () = #enterVal threadEnv ("atomicReset", atResetFunction) end local val fmemEnv = makeStructure(globalEnv, "ForeignMemory") val a = makeTV() (* We don't have Word8.word or Word32.word at this point so the easiest way to deal with this is to make them polymorphic. *) val get8Function = mkGvar("get8", LargeWord ** Word ->> a, makePolymorphic([a], mkLoadOperationFn LoadStoreC8), declInBasis) val get16Function = mkGvar("get16", LargeWord ** Word ->> Word, mkLoadOperationFn LoadStoreC16, declInBasis) val get32Function = mkGvar("get32", LargeWord ** Word ->> a, makePolymorphic([a], mkLoadOperationFn LoadStoreC32), declInBasis) val get64Function = mkGvar("get64", LargeWord ** Word ->> LargeWord, mkLoadOperationFn LoadStoreC64, declInBasis) val getFloatFunction = mkGvar("getFloat", LargeWord ** Word ->> Real, mkLoadOperationFn LoadStoreCFloat, declInBasis) val getDoubleFunction = mkGvar("getDouble", LargeWord ** Word ->> Real, mkLoadOperationFn LoadStoreCDouble, declInBasis) val set8Function = mkGvar("set8", mkProductType[LargeWord, Word, a] ->> Unit, makePolymorphic([a], mkStoreOperationFn LoadStoreC8), declInBasis) val set16Function = mkGvar("set16", mkProductType[LargeWord, Word, Word] ->> Unit, mkStoreOperationFn LoadStoreC16, declInBasis) val set32Function = mkGvar("set32", mkProductType[LargeWord, Word, a] ->> Unit, makePolymorphic([a], mkStoreOperationFn LoadStoreC32), declInBasis) val set64Function = mkGvar("set64", mkProductType[LargeWord, Word, LargeWord] ->> Unit, mkStoreOperationFn LoadStoreC64, declInBasis) val setFloatFunction = mkGvar("setFloat", mkProductType[LargeWord, Word, Real] ->> Unit, mkStoreOperationFn LoadStoreCFloat, declInBasis) val setDoubleFunction = mkGvar("setDouble", mkProductType[LargeWord, Word, Real] ->> Unit, mkStoreOperationFn LoadStoreCDouble, declInBasis) in val () = #enterVal fmemEnv ("get8", get8Function) val () = #enterVal fmemEnv ("get16", get16Function) val () = #enterVal fmemEnv ("get32", get32Function) val () = #enterVal fmemEnv ("get64", get64Function) val () = #enterVal fmemEnv ("getFloat", getFloatFunction) val () = #enterVal fmemEnv ("getDouble", getDoubleFunction) val () = #enterVal fmemEnv ("set8", set8Function) val () = #enterVal fmemEnv ("set16", set16Function) val () = #enterVal fmemEnv ("set32", set32Function) val () = #enterVal fmemEnv ("set64", set64Function) val () = #enterVal fmemEnv ("setFloat", setFloatFunction) val () = #enterVal fmemEnv ("setDouble", setDoubleFunction) end local fun addVal (name : string, value : 'a, typ : types) : unit = enterBootstrap (name, mkConst (toMachineWord value), typ) (* These are only used during the bootstrap phase. Replacements are installed once the appropriate modules of the basis library are compiled. *) fun intOfString s = let val radix = if String.size s >= 3 andalso String.substring(s, 0, 2) = "0x" orelse String.size s >= 4 andalso String.substring(s, 0, 3) = "~0x" then StringCvt.HEX else StringCvt.DEC in case StringCvt.scanString (Int.scan radix) s of NONE => raise Conversion "Invalid integer constant" | SOME res => res end fun wordOfString s = let val radix = if String.size s > 2 andalso String.sub(s, 2) = #"x" then StringCvt.HEX else StringCvt.DEC in case StringCvt.scanString (Word.scan radix) s of NONE => raise Conversion "Invalid word constant" | SOME res => res end open PRINTTABLE val convstringCode = genCode(mkConst(toMachineWord unescapeString), [], 0) () val convintCode = genCode(mkConst(toMachineWord intOfString), [], 0) () val convwordCode = genCode(mkConst(toMachineWord wordOfString), [], 0) () in (* Conversion overloads used to be set by the ML bootstrap code. It's simpler to do that here but to maintain compatibility with the 5.6 compiler we need to define these. Once we've rebuilt the compiler this can be removed along with the code that uses it. *) val () = addVal ("convStringName", "convString": string, String) val () = addVal ("convInt", intOfString : string -> int, String ->> intInfType) val () = addVal ("convWord", wordOfString : string -> word, String ->> Word) (* Convert a string, recognising and converting the escape codes. *) val () = addVal ("convString", unescapeString: string -> string, String ->> String) (* Flag to indicate which version of Int to compile *) val () = addVal ("intIsArbitraryPrecision", intIsArbitraryPrecision, Bool) (* Install the overloads now. *) val () = addOverload("convString", stringConstr, convstringCode) val () = addOverload("convInt", fixedIntConstr, convintCode) val () = addOverload("convInt", intInfConstr, convintCode) val () = addOverload("convWord", wordConstr, convwordCode) end (* The only reason we have vector here is to get equality right. We need vector to be an equality type and to have a specific equality function. *) local fun polyTypePrinter _ _ = PRETTY.PrettyString "?" (* The equality function takes the base equality type as an argument. The inner function takes two arguments which are the two vectors to compare, checks the lengths and if they're equal applies the base equality to each field. *) val eqCode = mkInlproc( mkProc( mkEnv([ (* Length of the items. *) mkDec(0, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 0)), mkDec(1, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 1)), mkMutualDecs[(2, (* Loop function. *) mkProc( mkIf( (* Finished? *) mkEqualWord(mkLoadClosure 0, mkLoadArgument 0), CodeTrue, (* Yes, all equal. *) mkIf( mkEval( TypeValue.extractEquality(mkLoadClosure 2), (* Base equality fn *) [ mkLoadOperation(LoadStoreMLWord{isImmutable=true}, mkLoadClosure 3, mkLoadArgument 0), mkLoadOperation(LoadStoreMLWord{isImmutable=true}, mkLoadClosure 4, mkLoadArgument 0) ]), mkEval(mkLoadClosure 1, (* Recursive call with index+1. *) [ mkBinary(BuiltIns.WordArith BuiltIns.ArithAdd, mkLoadArgument 0, mkConst(toMachineWord 1)) ]), CodeFalse (* Not equal elements - result false *) ) ), 1, "vector-loop", [mkLoadLocal 0 (* Length *), mkLoadLocal 2 (* Loop function *), mkLoadClosure 0 (* Base equality function *), mkLoadArgument 0 (* Vector 0 *), mkLoadArgument 1 (* Vector 1 *)], 0))] ], mkIf( (* Test the lengths. *) mkEqualWord(mkLoadLocal 0, mkLoadLocal 1), (* Equal - test the contents. *) mkEval(mkLoadLocal 2, [CodeZero]), CodeFalse (* Not same length- result false *) ) ), 2, "vector-eq", [mkLoadArgument 0], 3), 1, "vector-eq()", [], 0) val idCode = (* Polytype *) let open TypeValue val code = createTypeValue{ eqCode=eqCode, printCode=mkConst (toMachineWord (ref polyTypePrinter)), boxedCode=mkInlproc(boxedAlways, 1, "boxed-vector", [], 0), sizeCode=mkInlproc(singleWord, 1, "size-vector", [], 0)} in Global (genCode(code, [], 0) ()) end in val vectorType = makeTypeConstructor("vector", [makeTypeVariable()], makeFreeId(1, idCode, true, basisDescription "vector"), declInBasis) val () = enterGlobalType ("vector", TypeConstrSet(vectorType, [])) end (* We also need a type with byte-wise equality. *) local fun monoTypePrinter _ = PRETTY.PrettyString "?" (* This is a monotype equality function that takes two byte vectors and compares them byte-by-byte for equality. Because they are vectors of bytes it's unsafe to load the whole words which could look like addresses if the bottom bit happens to be zero. *) val eqCode = mkProc( mkEnv([ (* Length of the items. *) mkDec(0, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 0)), mkDec(1, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 1)) ], mkIf( (* Test the lengths. *) mkEqualWord(mkLoadLocal 0, mkLoadLocal 1), (* Equal - test the contents. *) mkEnv([ (* ByteVecEqual takes a byte length so we have to multiply by the number of bytes per word. *) mkDec(2, mkBinary(BuiltIns.WordArith BuiltIns.ArithMult, mkConst(toMachineWord RunCall.bytesPerWord), mkLoadLocal 0)) ], mkBlockOperation{kind=BlockOpEqualByte, leftBase=mkLoadArgument 0, rightBase=mkLoadArgument 1, leftIndex=CodeZero, rightIndex=CodeZero, length=mkLoadLocal 2}), CodeFalse (* Not same length- result false *) ) ), 2, "byteVector-eq", [], 3) val idCode = (* Polytype *) let open TypeValue val code = createTypeValue{ eqCode=eqCode, printCode=mkConst (toMachineWord (ref monoTypePrinter)), boxedCode=boxedAlways, sizeCode=singleWord} in Global (genCode(code, [], 0) ()) end in val byteVectorType = makeTypeConstructor("byteVector", [], makeFreeId(0, idCode, true, basisDescription "byteVector"), declInBasis) val () = #enterType bootstrapEnv ("byteVector", TypeConstrSet(byteVectorType, [])) end (* We also need array and Array2.array to be passed through here so that they have the special property of being eqtypes even if their argument is not. "array" is defined to be in the global environment. *) val () = enterGlobalType ("array", TypeConstrSet(arrayConstr, [])) val () = #enterType bootstrapEnv ("array", TypeConstrSet(array2Constr, [])) val () = #enterType bootstrapEnv ("byteArray", TypeConstrSet(byteArrayConstr, [])) (* "=', '<>', PolyML.print etc are type-specific function which appear to be polymorphic. The compiler recognises these and treats them specially. For (in)equality that means generating type-specific versions of the equality operations; for print etc that means printing in a type-specific way. They can become true polymorphic functions and lose their type-specificity. For (in)equality that means defaulting to structure equality which is normal and expected behaviour. For print etc that means losing the ability to print and just printing "?" so it's important to avoid that happening. "open" treats type-specific functions specially and retains the type-specificity. That's important to allow the prelude code to expand the PolyML structure. *) local val eqType = let val a = makeEqTV () in a ** a ->> Bool end val eqVal = mkSpecialFun("=", eqType, Equal) in val () = enterGlobalValue ("=", eqVal) end local val neqType = let val a = makeEqTV () in a ** a ->> Bool end val neqVal = mkSpecialFun("<>", neqType, NotEqual) in val () = enterGlobalValue ("<>", neqVal) end val polyMLEnv = makeStructure(globalEnv, "PolyML") val enterPolyMLVal = #enterVal polyMLEnv local (* This version of the environment must match that used in the NameSpace structure. *) open TYPETREE (* Create a new structure for them. *) val nameSpaceEnv = makeStructure(polyMLEnv, "NameSpace") (* Substructures. *) val valuesEnv = makeStructure(nameSpaceEnv, "Values") and typesEnv = makeStructure(nameSpaceEnv, "TypeConstrs") and fixesEnv = makeStructure(nameSpaceEnv, "Infixes") and structsEnv = makeStructure(nameSpaceEnv, "Structures") and sigsEnv = makeStructure(nameSpaceEnv, "Signatures") and functsEnv = makeStructure(nameSpaceEnv, "Functors") (* Types for the basic values. These are opaque. *) val valueVal = makeAndDeclareOpaqueType("value", "PolyML.NameSpace.Values.value", valuesEnv) (* Representation of the type of a value. *) val Types = makeAndDeclareOpaqueType("typeExpression", "PolyML.NameSpace.Values.typeExpression", valuesEnv) val typeVal = makeAndDeclareOpaqueType("typeConstr", "PolyML.NameSpace.TypeConstrs.typeConstr", typesEnv) val fixityVal = makeAndDeclareOpaqueType("fixity", "PolyML.NameSpace.Infixes.fixity", fixesEnv) val signatureVal = makeAndDeclareOpaqueType("signatureVal", "PolyML.NameSpace.Signatures.signatureVal", sigsEnv) val structureVal = makeAndDeclareOpaqueType("structureVal", "PolyML.NameSpace.Structures.structureVal", structsEnv) val functorVal = makeAndDeclareOpaqueType("functorVal", "PolyML.NameSpace.Functors.functorVal", functsEnv) (* nameSpace type. Labelled record. *) fun createFields(name, vType): { name: string, typeof: types} list = let val enterFun = String ** vType ->> Unit val lookupFun = String ->> Option vType val allFun = Unit ->> List (String ** vType) in [mkLabelEntry("enter" ^ name, enterFun), mkLabelEntry("lookup" ^ name, lookupFun), mkLabelEntry("all" ^ name, allFun)] end (* We have to use the same names as we use in the env type because we're passing "env" values through the bootstrap. *) val valTypes = [("Val", valueVal), ("Type", typeVal), ("Fix", fixityVal), ("Struct", structureVal), ("Sig", signatureVal), ("Funct", functorVal)] val fields = List.foldl (fn (p,l) => createFields p @ l) [] valTypes val recordType = makeTypeAbbreviation("nameSpace", "PolyML.NameSpace.nameSpace", [], mkLabelled(sortLabels fields, true), declInBasis); val () = #enterType nameSpaceEnv ("nameSpace", TypeConstrSet(recordType, [])); (* The result type of the compiler includes valueVal etc. *) val resultFields = List.map TYPETREE.mkLabelEntry [("values", List(String ** valueVal)), ("fixes", List(String ** fixityVal)), ("types", List(String ** typeVal)), ("structures", List(String ** structureVal)), ("signatures", List(String ** signatureVal)), ("functors", List(String ** functorVal))] in val nameSpaceType = mkTypeConstruction ("nameSpace", recordType, [], declInBasis) val execResult = mkLabelled(sortLabels resultFields, true) type execResult = { fixes: (string * fixStatus) list, values: (string * values) list, structures: (string * structVals) list, signatures: (string * signatures) list, functors: (string * functors) list, types: (string * typeConstrSet) list } val valueVal = valueVal val typeVal = typeVal val fixityVal = fixityVal val signatureVal = signatureVal val structureVal = structureVal val functorVal = functorVal val Types = Types val valuesEnv = valuesEnv and typesEnv = typesEnv and fixesEnv = fixesEnv and structsEnv = structsEnv and sigsEnv = sigsEnv and functsEnv = functsEnv end local val typeconstr = locationConstr val () = #enterType polyMLEnv ("location", typeconstr); in val Location = mkTypeConstruction ("location", tsConstr typeconstr, [], declInBasis) end (* Interface to the debugger. *) local open TYPETREE val debuggerEnv = makeStructure(polyMLEnv, "DebuggerInterface") (* Make these opaque at this level. *) val locationPropList = makeAndDeclareOpaqueType("locationPropList", "PolyML.DebuggerInterface.locationPropList", debuggerEnv) val typeId = makeAndDeclareOpaqueType("typeId", "PolyML.DebuggerInterface.typeId", debuggerEnv) val machineWordType = makeAndDeclareOpaqueType("machineWord", "PolyML.DebuggerInterface.machineWord", debuggerEnv) (* For long term security keep these as different from global types and sigs. Values in the static environment need to be copied before they are global. *) val localType = makeAndDeclareOpaqueType("localType", "PolyML.DebuggerInterface.localType", debuggerEnv) val localTypeConstr = makeAndDeclareOpaqueType("localTypeConstr", "PolyML.DebuggerInterface.localTypeConstr", debuggerEnv) val localSig = makeAndDeclareOpaqueType("localSig", "PolyML.DebuggerInterface.localSig", debuggerEnv) open DEBUGGER (* Entries in the static list. This type is only used within the implementation of DebuggerInterface in the basis library and does not appear in the final signature. *) val environEntryConstr = makeTypeConstructor("environEntry", [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription "PolyML.DebuggerInterface.environEntry"), declInBasis) val environEntryType = mkTypeConstruction ("environEntry", environEntryConstr, [], declInBasis) val constrs = (* Order is significant. *) [ ("EnvEndFunction", mkProductType[String, Location, localType]), ("EnvException", mkProductType[String, localType, locationPropList]), ("EnvStartFunction", mkProductType[String, Location, localType]), ("EnvStructure", mkProductType[String, localSig, locationPropList]), ("EnvTConstr", String ** localTypeConstr), ("EnvTypeid", typeId ** typeId), ("EnvVConstr", mkProductType[String, localType, Bool, Int, locationPropList]), ("EnvValue", mkProductType[String, localType, locationPropList]) ] (* This representation must match the representation defined in DEBUGGER_.sml. *) val numConstrs = List.length constrs val {constrs=constrReps, ...} = chooseConstrRepr(constrs, []) val constructors = ListPair.map (fn ((s,t), code) => mkGconstr(s, t ->> environEntryType, code, false, numConstrs, declInBasis)) (constrs, constrReps) val () = List.app (fn c => #enterVal debuggerEnv(valName c, c)) constructors (* Put these constructors onto the type. *) val () = #enterType debuggerEnv ("environEntry", TypeConstrSet(environEntryConstr, constructors)) (* Debug state type. *) val debugStateConstr = makeTypeAbbreviation("debugState", "PolyML.DebuggerInterface.debugState", [], mkProductType[List environEntryType, List machineWordType, Location], declInBasis) val () = #enterType debuggerEnv ("debugState", TypeConstrSet(debugStateConstr, [])) val debugStateType = mkTypeConstruction ("debugState", debugStateConstr, [], declInBasis) in val () = applyList (fn (name, v, t) => #enterVal debuggerEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("makeValue", toMachineWord(makeValue: debugState -> string * types * locationProp list * machineWord -> values), debugStateType ->> mkProductType[String, localType, locationPropList, machineWordType] ->> valueVal), ("makeException", toMachineWord(makeException: debugState -> string * types * locationProp list * machineWord -> values), debugStateType ->> mkProductType[String, localType, locationPropList, machineWordType] ->> valueVal), ("makeConstructor", toMachineWord(makeConstructor: debugState -> string * types * bool * int * locationProp list * machineWord -> values), debugStateType ->> mkProductType[String, localType, Bool, Int, locationPropList, machineWordType] ->> valueVal), ("makeAnonymousValue", toMachineWord(makeAnonymousValue: debugState -> types * machineWord -> values), debugStateType ->> mkProductType[localType, machineWordType] ->> valueVal), ("makeStructure", toMachineWord(makeStructure: debugState -> string * signatures * locationProp list * machineWord -> structVals), debugStateType ->> mkProductType[String, localSig, locationPropList, machineWordType] ->> structureVal), ("makeTypeConstr", toMachineWord(makeTypeConstr: debugState -> typeConstrSet -> typeConstrSet), debugStateType ->> localTypeConstr ->> typeVal), ("unitValue", toMachineWord(mkGvar("", unitType, CodeZero, []): values), valueVal), (* Used as a default *) ("setOnEntry", toMachineWord(setOnEntry: (string * PolyML.location -> unit) option -> unit), Option (String ** Location ->> Unit) ->> Unit), ("setOnExit", toMachineWord(setOnExit: (string * PolyML.location -> unit) option -> unit), Option (String ** Location ->> Unit) ->> Unit), ("setOnExitException", toMachineWord(setOnExitException: (string * PolyML.location -> exn -> unit) option -> unit), Option (String ** Location ->> Exn ->> Unit) ->> Unit), ("setOnBreakPoint", toMachineWord(setOnBreakPoint: (PolyML.location * bool ref -> unit) option -> unit), Option (Location ** Ref Bool ->> Unit) ->> Unit) ] end local val typeconstr = contextConstr in val () = #enterType polyMLEnv ("context", typeconstr); val () = List.app(fn(tv as Value{name, ...}) => #enterVal polyMLEnv(name, tv)) (tsConstructors typeconstr) end local val typeconstr = prettyConstr in val () = #enterType polyMLEnv ("pretty", typeconstr); val () = List.app(fn(tv as Value{name, ...}) => #enterVal polyMLEnv(name, tv)) (tsConstructors typeconstr) val PrettyType = mkTypeConstruction ("pretty", tsConstr typeconstr, [], declInBasis) end local val printType = let val a = makePrintTV () in a ->> a end; val printVal = mkSpecialFun("print", printType, Print); in val () = enterPolyMLVal ("print", printVal); end; local val makeStringType = let val a = makePrintTV () in a ->> String end; val makeStringVal = mkSpecialFun("makestring", makeStringType, MakeString); in val () = enterPolyMLVal ("makestring", makeStringVal); end; local val prettyType = let val a = makePrintTV () in a ** fixedIntType ->> PrettyType end; val prettyVal = mkSpecialFun("prettyRepresentation", prettyType, GetPretty); in val () = enterPolyMLVal ("prettyRepresentation", prettyVal); end; local (* addPrettyPrinter is the new function to install a pretty printer. *) val a = makeTV () val b = makeTV () val addPrettyType = (TYPETREE.fixedIntType ->> b ->> a ->> PrettyType) ->> Unit; val addPrettyVal = mkSpecialFun("addPrettyPrinter", addPrettyType, AddPretty); in val () = enterPolyMLVal ("addPrettyPrinter", addPrettyVal); end; (* This goes in RunCall since it's only for the basis library. *) local val addOverloadType = let val a = makeTV () and b = makeTV () in (a ->> b) ->> String ->> Unit end; val addOverloadVal = mkSpecialFun("addOverload", addOverloadType, AddOverload); in val () = #enterVal runCallEnv ("addOverload", addOverloadVal); end local (* Add a function to switch the default integer type. *) fun setType isArbitrary = setPreferredInt(if isArbitrary then intInfConstr else fixedIntConstr) in val () = #enterVal runCallEnv ("setDefaultIntTypeArbitrary", mkGvar ("setDefaultIntTypeArbitrary", Bool ->> Unit, mkConst (toMachineWord setType), declInBasis)) end local val sourceLocVal = mkSpecialFun("sourceLocation", Unit ->> Location, GetLocation); in val () = enterPolyMLVal ("sourceLocation", sourceLocVal); end; local (* This is used as one of the arguments to the compiler function. *) open TYPETREE val uniStructEnv = makeStructure(bootstrapEnv, "Universal") fun enterUniversal (name : string, entry : codetree, typ : types) : unit = let val value = mkGvar (name, typ, entry, declInBasis); in #enterVal uniStructEnv (name, value) end; local fun polyTypePrinter _ _ = PRETTY.PrettyString "?" open TypeValue val idCode = let val code = createTypeValue{ eqCode=CodeZero, (* Not an equality type *) printCode=mkConst (toMachineWord (ref polyTypePrinter)), boxedCode=mkInlproc(boxedEither(* Assume worst case *), 1, "boxed-tag", [], 0), sizeCode=mkInlproc(singleWord, 1, "size-tag", [], 0)} in Global (genCode(code, [], 0) ()) end in (* type 'a tag *) val tagConstr = makeTypeConstructor("tag", [makeTypeVariable()], makeFreeId(1, idCode, false, basisDescription "tag"), declInBasis); val () = #enterType uniStructEnv ("tag", TypeConstrSet(tagConstr, [])) end (* type universal *) val univConstr = makeTypeConstructor("universal", [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription "universal"), declInBasis); val () = #enterType uniStructEnv ("universal", TypeConstrSet(univConstr, [])); fun Tag base = mkTypeConstruction ("tag", tagConstr, [base], declInBasis) val Universal = mkTypeConstruction ("universal", univConstr, [], declInBasis) val a = makeTV() (* val tagInject : 'a tag -> 'a -> universal *) val injectType = Tag a ->> a ->> Universal val () = enterUniversal ("tagInject", makePolymorphic([a], mkConst (toMachineWord (Universal.tagInject: 'a Universal.tag -> 'a -> Universal.universal))), injectType) (* We don't actually need tagIs and tagProject since this is only used for the compiler. Universal is redefined in the basis library. *) val projectType = Tag a ->> Universal ->> a val () = enterUniversal ("tagProject", makePolymorphic([a], mkConst (toMachineWord(Universal.tagProject: 'a Universal.tag -> Universal.universal -> 'a))), projectType) val testType = Tag a ->> Universal ->> Bool val () = enterUniversal ("tagIs", makePolymorphic([a], mkConst (toMachineWord(Universal.tagIs: 'a Universal.tag -> Universal.universal -> bool))), testType) in val Tag = Tag and Universal = Universal end local open TYPETREE (* Parsetree properties datatype. *) val propConstr = makeTypeConstructor("ptProperties", [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription "PolyML.ptProperties"), declInBasis); val PtProperties = mkTypeConstruction ("ptProperties", propConstr, [], declInBasis) (* Parsetree type. *) val parseTreeConstr = makeTypeAbbreviation("parseTree", "PolyML.parseTree", [], Location ** List PtProperties, declInBasis); val ParseTree = mkTypeConstruction ("parseTree", parseTreeConstr, [], declInBasis) val () = #enterType polyMLEnv ("parseTree", TypeConstrSet(parseTreeConstr, [])); val constrs = (* Order is significant. *) [ ("PTbreakPoint", Ref Bool), ("PTcompletions", List String), ("PTdeclaredAt", Location), ("PTdefId", fixedIntType), ("PTfirstChild", Unit ->> ParseTree), ("PTnextSibling", Unit ->> ParseTree), ("PTopenedAt", Location), ("PTparent", Unit ->> ParseTree), ("PTpreviousSibling", Unit ->> ParseTree), ("PTprint", fixedIntType ->> PrettyType), ("PTreferences", Bool ** List Location), ("PTrefId", fixedIntType), ("PTstructureAt", Location), ("PTtype", Types) ]; (* This representation must match the representation defined in ExportTree.sml. *) val numConstrs = List.length constrs val {constrs=constrReps, ...} = chooseConstrRepr(constrs, []) val constructors = ListPair.map (fn ((s,t), code) => mkGconstr(s, t ->> PtProperties, code, false, numConstrs, declInBasis)) (constrs, constrReps) val () = List.app (fn c => #enterVal polyMLEnv(valName c, c)) constructors (* Put these constructors onto the type. *) val () = #enterType polyMLEnv ("ptProperties", TypeConstrSet(propConstr, constructors)); in val ParseTree = ParseTree and PtProperties = PtProperties end local open TYPETREE val compilerType : types = mkProductType[nameSpaceType, Unit ->> Option Char, List Universal] ->> mkProductType[Option ParseTree, Option (Unit ->> execResult)] type compilerType = nameSpace * (unit -> char option) * Universal.universal list -> exportTree option * (unit->execResult) option in val () = enterBootstrap ("use", mkConst (toMachineWord ((useIntoEnv globalTable []): string -> unit)), String ->> Unit) val () = enterBootstrap ("useWithParms", mkConst (toMachineWord ((useIntoEnv globalTable): Universal.universal list -> string -> unit)), List Universal ->> String ->> Unit) val () = enterPolyMLVal("compiler", mkGvar ("compiler", compilerType, mkConst (toMachineWord (compiler: compilerType)), declInBasis)); val () = enterBootstrap("globalSpace", mkConst (toMachineWord(gEnvAsNameSpace globalTable: nameSpace)), nameSpaceType) end; local val ty = TYPETREE.mkOverloadSet[] val addType = ty ** ty ->> ty; val negType = ty ->> ty; val cmpType = ty ** ty ->> Bool; in val () = enterGlobalValue ("+", mkOverloaded "+" addType); val () = enterGlobalValue ("-", mkOverloaded "-" addType); val () = enterGlobalValue ("*", mkOverloaded "*" addType); val () = enterGlobalValue ("~", mkOverloaded "~" negType); val () = enterGlobalValue ("abs", mkOverloaded "abs" negType); val () = enterGlobalValue (">=", mkOverloaded ">=" cmpType); val () = enterGlobalValue ("<=", mkOverloaded "<=" cmpType); val () = enterGlobalValue (">", mkOverloaded ">" cmpType); val () = enterGlobalValue ("<", mkOverloaded "<" cmpType); (* The following overloads are added in ML97 *) val () = enterGlobalValue ("div", mkOverloaded "div" addType); val () = enterGlobalValue ("mod", mkOverloaded "mod" addType); val () = enterGlobalValue ("/", mkOverloaded "/" addType); end; local open DEBUG; local open TYPETREE val fields = [ mkLabelEntry("location", Location), mkLabelEntry("hard", Bool), mkLabelEntry("message", PrettyType), mkLabelEntry("context", Option PrettyType) ] in val errorMessageProcType = mkLabelled(sortLabels fields, true) ->> Unit type errorMessageProcType = { location: location, hard: bool, message: pretty, context: pretty option } -> unit end local open TYPETREE val optNav = Option(Unit->>ParseTree) val fields = [ mkLabelEntry("parent", optNav), mkLabelEntry("next", optNav), mkLabelEntry("previous", optNav) ] in val navigationType = mkLabelled(sortLabels fields, true) type navigationType = { parent: (unit->exportTree) option, next: (unit->exportTree) option, previous: (unit->exportTree) option } end type 'a tag = 'a Universal.tag in val () = applyList (fn (name, v, t) => enterBootstrap(name, mkConst v, t)) [ ("compilerVersion", toMachineWord (VERSION.compilerVersion: string), String), ("compilerVersionNumber", toMachineWord (VERSION.versionNumber: int), Int), ("lineNumberTag", toMachineWord (lineNumberTag : (unit->FixedInt.int) tag), Tag (Unit->>fixedIntType)), ("offsetTag", toMachineWord (offsetTag: (unit->FixedInt.int) tag), Tag (Unit->>fixedIntType)), ("fileNameTag", toMachineWord (fileNameTag: string tag), Tag String), ("bindingCounterTag", toMachineWord (bindingCounterTag: (unit->FixedInt.int) tag), Tag (Unit->>fixedIntType)), ("maxInlineSizeTag", toMachineWord (maxInlineSizeTag: FixedInt.int tag), Tag fixedIntType), ("assemblyCodeTag", toMachineWord (assemblyCodeTag: bool tag), Tag Bool), ("parsetreeTag", toMachineWord (parsetreeTag: bool tag), Tag Bool), ("codetreeTag", toMachineWord (codetreeTag: bool tag), Tag Bool), ("icodeTag", toMachineWord (icodeTag: bool tag), Tag Bool), ("lowlevelOptimiseTag", toMachineWord (lowlevelOptimiseTag: bool tag), Tag Bool), ("codetreeAfterOptTag", toMachineWord (codetreeAfterOptTag: bool tag), Tag Bool), ("inlineFunctorsTag", toMachineWord (inlineFunctorsTag: bool tag), Tag Bool), ("debugTag", toMachineWord (debugTag: bool tag), Tag Bool), ("printDepthFunTag", toMachineWord (DEBUG.printDepthFunTag: (unit->FixedInt.int) tag), Tag (Unit->>fixedIntType)), ("errorDepthTag", toMachineWord (DEBUG.errorDepthTag: FixedInt.int tag), Tag fixedIntType), ("lineLengthTag", toMachineWord (DEBUG.lineLengthTag: FixedInt.int tag), Tag fixedIntType), ("profileAllocationTag", toMachineWord (DEBUG.profileAllocationTag: FixedInt.int tag), Tag fixedIntType), ("printOutputTag", toMachineWord (PRETTY.printOutputTag: (pretty->unit) tag), Tag (PrettyType->>Unit)) , ("compilerOutputTag", toMachineWord (PRETTY.compilerOutputTag: (pretty->unit) tag), Tag (PrettyType->>Unit)), ("errorMessageProcTag", toMachineWord (LEX.errorMessageProcTag: errorMessageProcType tag), Tag errorMessageProcType), ("rootTreeTag", toMachineWord (EXPORTTREE.rootTreeTag: navigation tag), Tag navigationType), ("reportUnreferencedIdsTag", toMachineWord (reportUnreferencedIdsTag: bool tag), Tag Bool), ("reportExhaustiveHandlersTag", toMachineWord (reportExhaustiveHandlersTag: bool tag), Tag Bool), ("narrowOverloadFlexRecordTag", toMachineWord (narrowOverloadFlexRecordTag: bool tag), Tag Bool), ("createPrintFunctionsTag", toMachineWord (createPrintFunctionsTag: bool tag), Tag Bool), ("reportDiscardedValuesTag", toMachineWord (reportDiscardedValuesTag: FixedInt.int tag), Tag fixedIntType) ] end; (* PolyML.CodeTree structure. This exports the CodeTree structure into the ML space. *) local open CODETREE val codetreeEnv = makeStructure(polyMLEnv, "CodeTree") fun createType typeName = makeAndDeclareOpaqueType(typeName, "PolyML.CodeTree." ^ typeName, codetreeEnv) val CodeTree = createType "codetree" and MachineWord = createType "machineWord" and CodeBinding = createType "codeBinding" (* For the moment export these only for the general argument and result types. *) fun simpleFn (code, nArgs, name, closure, nLocals) = mkFunction{body=code, argTypes=List.tabulate(nArgs, fn _ => GeneralType), resultType=GeneralType, name=name, closure=closure, numLocals=nLocals} and simpleInlineFn (code, nArgs, name, closure, nLocals) = mkInlineFunction{body=code, argTypes=List.tabulate(nArgs, fn _ => GeneralType), resultType=GeneralType, name=name, closure=closure, numLocals=nLocals} and simpleCall(func, args) = mkCall(func, List.map (fn c => (c, GeneralType)) args, GeneralType) in val CodeTree = CodeTree val () = applyList (fn (name, v, t) => #enterVal codetreeEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("pretty", toMachineWord (CODETREE.pretty: codetree -> pretty), CodeTree ->> PrettyType), ("mkConstant", toMachineWord(mkConst: machineWord -> codetree), MachineWord ->> CodeTree), ("genCode", toMachineWord (genCode: codetree * Universal.universal list * int -> (unit->codetree)), mkProductType[CodeTree, List Universal, Int] ->> (Unit ->> CodeTree)), ("evalue", toMachineWord (evalue: codetree -> machineWord option), CodeTree ->> Option MachineWord), ("mkFunction", toMachineWord (simpleFn: codetree * int * string * codetree list * int -> codetree), mkProductType[CodeTree, Int, String, List CodeTree, Int] ->> CodeTree), ("mkInlineFunction", toMachineWord (simpleInlineFn: codetree * int * string * codetree list * int -> codetree), mkProductType[CodeTree, Int, String, List CodeTree, Int] ->> CodeTree), ("mkCall", toMachineWord (simpleCall: codetree * codetree list -> codetree), CodeTree ** List CodeTree ->> CodeTree), ("mkLoadLocal", toMachineWord (mkLoadLocal: int -> codetree), Int ->> CodeTree), ("mkLoadArgument", toMachineWord (mkLoadArgument: int -> codetree), Int ->> CodeTree), ("mkLoadClosure", toMachineWord (mkLoadClosure: int -> codetree), Int ->> CodeTree), ("mkDec", toMachineWord (mkDec: int * codetree -> codeBinding), Int ** CodeTree ->> CodeBinding), ("mkInd", toMachineWord (mkInd: int * codetree -> codetree), Int ** CodeTree ->> CodeTree), ("mkIf", toMachineWord (mkIf: codetree * codetree * codetree -> codetree), mkProductType[CodeTree, CodeTree, CodeTree] ->> CodeTree), ("mkWhile", toMachineWord (mkWhile: codetree * codetree -> codetree), CodeTree ** CodeTree ->> CodeTree), ("mkLoop", toMachineWord (mkLoop: codetree list -> codetree), List CodeTree ->> CodeTree), ("mkBeginLoop", toMachineWord (mkBeginLoop: codetree * (int * codetree) list -> codetree), CodeTree ** List(Int ** CodeTree) ->> CodeTree), ("mkEnv", toMachineWord (mkEnv: codeBinding list * codetree -> codetree), List CodeBinding ** CodeTree ->> CodeTree), ("mkMutualDecs", toMachineWord (mkMutualDecs: (int * codetree) list -> codeBinding), List(Int ** CodeTree) ->> CodeBinding), ("mkTuple", toMachineWord (mkTuple: codetree list -> codetree), List CodeTree ->> CodeTree), ("mkRaise", toMachineWord (mkRaise: codetree -> codetree), CodeTree ->> CodeTree), ("mkHandle", toMachineWord (mkHandle: codetree * codetree * int -> codetree), mkProductType[CodeTree, CodeTree, Int] ->> CodeTree), ("mkNullDec", toMachineWord (mkNullDec: codetree -> codeBinding), CodeTree ->> CodeBinding) ] end local (* Finish off the NameSpace structure now we have types such as pretty. *) open TYPETREE (* The exported versions expect full name spaces as arguments. Because we convert the exported versions to machineWord and give them types as data structures the compiler can't actually check that the type we give matched the internal type. *) fun makeTypeEnv NONE = { lookupType = fn _ => NONE, lookupStruct = fn _ => NONE } | makeTypeEnv(SOME(nameSpace: nameSpace)): printTypeEnv = { lookupType = fn s => case #lookupType nameSpace s of NONE => NONE | SOME t => SOME(t, NONE), lookupStruct = fn s => case #lookupStruct nameSpace s of NONE => NONE | SOME t => SOME(t, NONE) } local (* Values substructure. This also has operations related to type expressions. *) fun codeForValue (Value{access = Global code, class = ValBound, ...}) = code | codeForValue _ = raise Fail "Not a global value" and exportedDisplayTypeExp(ty, depth, nameSpace: nameSpace option) = TYPETREE.display(ty, depth, makeTypeEnv nameSpace) and exportedDisplayValues(valu, depth, nameSpace: nameSpace option) = displayValues(valu, depth, makeTypeEnv nameSpace) and propsForValue (Value {locations, typeOf, ...}) = PTtype typeOf :: mapLocationProps locations fun isConstructor (Value{class = Exception, ...}) = true | isConstructor (Value{class = Constructor _, ...}) = true | isConstructor _ = false fun isException (Value{class = Exception, ...}) = true | isException _ = false in val () = applyList (fn (name, v, t) => #enterVal valuesEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord (valName: values -> string), valueVal ->> String), ("print", toMachineWord (printValues: values * FixedInt.int -> pretty), mkProductType[valueVal, fixedIntType] ->> PrettyType), ("printWithType", toMachineWord (exportedDisplayValues: values * FixedInt.int * nameSpace option -> pretty), mkProductType[valueVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("printType", toMachineWord(exportedDisplayTypeExp: types * FixedInt.int * nameSpace option -> pretty), mkProductType[Types, fixedIntType, Option nameSpaceType] ->> PrettyType), ("typeof", toMachineWord (valTypeOf: values -> types), valueVal ->> Types), ("code", toMachineWord (codeForValue: values -> codetree), valueVal ->> CodeTree), ("properties", toMachineWord (propsForValue: values ->ptProperties list), valueVal ->> List PtProperties), ("isConstructor", toMachineWord(isConstructor: values -> bool), valueVal ->> Bool), ("isException", toMachineWord(isException: values -> bool), valueVal ->> Bool) ] end local (* TypeConstrs substructure. *) fun exportedDisplayTypeConstr(tyCons, depth, nameSpace: nameSpace option) = TYPETREE.displayTypeConstrs(tyCons, depth, makeTypeEnv nameSpace) and propsForTypeConstr (TypeConstrSet(TypeConstrs {locations, ...}, _)) = mapLocationProps locations and nameForType (TypeConstrSet(TypeConstrs{name, ...}, _)) = name in val () = applyList (fn (name, v, t) => #enterVal typesEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForType: typeConstrSet -> string), typeVal ->> String), ("print", toMachineWord (exportedDisplayTypeConstr: typeConstrSet * FixedInt.int * nameSpace option -> pretty), mkProductType[typeVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("properties", toMachineWord (propsForTypeConstr: typeConstrSet ->ptProperties list), typeVal ->> List PtProperties) ] end local (* Structures substructure *) fun exportedDisplayStructs(str, depth, nameSpace: nameSpace option) = displayStructures(str, depth, makeTypeEnv nameSpace) and codeForStruct (Struct{access = Global code, ...}) = code | codeForStruct _ = raise Fail "Not a global structure" and propsForStruct (Struct {locations, ...}) = mapLocationProps locations and nameForStruct (Struct{name, ...}) = name fun nameSpaceForStruct(baseStruct as Struct{signat=Signatures { tab, ...}, ...}): nameSpace = let open UNIVERSALTABLE fun lookupVal s = case univLookup (tab, valueVar, s) of NONE => NONE | SOME v => SOME(makeSelectedValue(v, baseStruct)) and lookupType s = case univLookup (tab, typeConstrVar, s) of NONE => NONE | SOME t => SOME(makeSelectedType(t, baseStruct)) and lookupStruct s = case univLookup (tab, structVar, s) of NONE => NONE | SOME s => SOME(makeSelectedStructure(s, baseStruct)) local fun extractItems t tab = UNIVERSALTABLE.fold (fn (s, u, l) => if Universal.tagIs t u then (s, Universal.tagProject t u) :: l else l ) [] tab in fun allValues() = map(fn (s, v) => (s, makeSelectedValue(v, baseStruct))) (extractItems valueVar tab) and allTypes() = map(fn (s, t) => (s, makeSelectedType(t, baseStruct))) (extractItems typeConstrVar tab) and allStructs() = map(fn (s, v) => (s, makeSelectedStructure(v, baseStruct))) (extractItems structVar tab) end fun enterFunction _ = raise Fail "updating a structure is not possible." (* Raise an exception for any attempt to enter a new value. Return empty for the classes that can't exist in a structure. *) in { lookupVal = lookupVal, lookupType = lookupType, lookupStruct = lookupStruct, lookupFix = fn _ => NONE, lookupSig = fn _ => NONE, lookupFunct = fn _ => NONE, enterVal = enterFunction, enterType = enterFunction, enterFix = enterFunction, enterStruct = enterFunction, enterSig = enterFunction, enterFunct = enterFunction, allVal = allValues, allType = allTypes, allStruct = allStructs, allFix = fn () => [], allSig = fn () => [], allFunct = fn () => [] } end in val () = applyList (fn (name, v, t) => #enterVal structsEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForStruct: structVals -> string), structureVal ->> String), ("print", toMachineWord (exportedDisplayStructs: structVals * FixedInt.int * nameSpace option -> pretty), mkProductType[structureVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("code", toMachineWord (codeForStruct: structVals -> codetree), structureVal ->> CodeTree), ("properties", toMachineWord (propsForStruct: structVals ->ptProperties list), structureVal ->> List PtProperties), ("contents", toMachineWord(nameSpaceForStruct: structVals -> nameSpace), structureVal ->> nameSpaceType) ] end local (* Signatures substructure *) fun exportedDisplaySigs(sign, depth, nameSpace: nameSpace option) = displaySignatures(sign, depth, makeTypeEnv nameSpace) and propsForSig (Signatures {locations, ...}) = mapLocationProps locations and nameForSig (Signatures{name, ...}) = name in val () = applyList (fn (name, v, t) => #enterVal sigsEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForSig: signatures -> string), signatureVal ->> String), ("print", toMachineWord (exportedDisplaySigs: signatures * FixedInt.int * nameSpace option -> pretty), mkProductType[signatureVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("properties", toMachineWord (propsForSig: signatures ->ptProperties list), signatureVal ->> List PtProperties) ] end local (* Functors substructure *) fun exportedDisplayFunctors(funct, depth, nameSpace: nameSpace option) = displayFunctors(funct, depth, makeTypeEnv nameSpace) and codeForFunct (Functor{access = Global code, ...}) = code | codeForFunct _ = raise Fail "Not a global functor" and propsForFunctor (Functor {locations, ...}) = mapLocationProps locations and nameForFunctor (Functor{name, ...}) = name in val () = applyList (fn (name, v, t) => #enterVal functsEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForFunctor: functors -> string), functorVal ->> String), ("print", toMachineWord (exportedDisplayFunctors: functors * FixedInt.int * nameSpace option -> pretty), mkProductType[functorVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("code", toMachineWord (codeForFunct: functors -> codetree), functorVal ->> CodeTree), ("properties", toMachineWord (propsForFunctor: functors ->ptProperties list), functorVal ->> List PtProperties) ] end local (* Infixes substructure *) fun nameForFix(FixStatus(s, _)) = s in val () = applyList (fn (name, v, t) => #enterVal fixesEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForFix: fixStatus -> string), fixityVal ->> String), ("print", toMachineWord (displayFixStatus: fixStatus -> pretty), fixityVal ->> PrettyType) ] end in end in () end (* initGlobalEnv *); end; diff --git a/mlsource/extra/Win/Base.sml b/mlsource/extra/Win/Base.sml index 14863208..d426bdb5 100644 --- a/mlsource/extra/Win/Base.sml +++ b/mlsource/extra/Win/Base.sml @@ -1,1023 +1,1015 @@ (* Copyright (c) 2001, 2015 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* This contains various types and other values which are needed in various modules. All the exported types are contained in other structures. *) structure Base: sig val winCall0: Foreign.symbol -> unit -> 'a Foreign.conversion -> unit -> 'a val winCall1: Foreign.symbol -> 'a Foreign.conversion -> 'b Foreign.conversion -> 'a -> 'b val winCall2: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion -> 'c Foreign.conversion -> 'a * 'b -> 'c val winCall3: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion -> 'd Foreign.conversion -> 'a * 'b * 'c -> 'd val winCall4: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion -> 'e Foreign.conversion -> 'a * 'b * 'c * 'd -> 'e val winCall5: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion -> 'f Foreign.conversion -> 'a * 'b * 'c * 'd * 'e -> 'f val winCall6: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion -> 'g Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f -> 'g val winCall7: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion * 'g Foreign.conversion -> 'h Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g -> 'h val winCall8: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion -> 'i Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h -> 'i val winCall9: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion -> 'j Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i -> 'j val winCall10: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion * 'j Foreign.conversion -> 'k Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j -> 'k val winCall11: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion * 'j Foreign.conversion * 'k Foreign.conversion -> 'l Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k -> 'l val winCall12: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion * 'j Foreign.conversion * 'k Foreign.conversion * 'l Foreign.conversion -> 'm Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l -> 'm val winCall13: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion * 'j Foreign.conversion * 'k Foreign.conversion * 'l Foreign.conversion * 'm Foreign.conversion -> 'n Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm -> 'n val winCall14: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion * 'j Foreign.conversion * 'k Foreign.conversion * 'l Foreign.conversion * 'm Foreign.conversion * 'n Foreign.conversion -> 'o Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm * 'n -> 'o val winAbi: Foreign.LibFFI.abi val kernel: string -> Foreign.symbol and user: string -> Foreign.symbol and commdlg: string -> Foreign.symbol and gdi: string -> Foreign.symbol and shell: string -> Foreign.symbol and comctl: string -> Foreign.symbol val cSIZE_T: int Foreign.conversion and cLPARAM: int Foreign.conversion and cLONG_PTR: int Foreign.conversion and cULONG_PTR: int Foreign.conversion and cINT_PTR: int Foreign.conversion and cUINT_PTR: int Foreign.conversion and cDWORD: int Foreign.conversion and cWORD: int Foreign.conversion and cDWORD_PTR: int Foreign.conversion and cUINT_PTRw: SysWord.word Foreign.conversion val cUint8w: Word8.word Foreign.conversion and cUint16w: Word.word Foreign.conversion and cUint32w: Word32.word Foreign.conversion and cUintw: Word32.word Foreign.conversion and cUlongw: Word32.word Foreign.conversion val cDWORDw: Word32.word Foreign.conversion and cWORDw: Word.word Foreign.conversion val cBool: bool Foreign.conversion val successState: string -> unit Foreign.conversion val cPOSINT: string -> int Foreign.conversion type POINT = { x: int, y: int } val cPoint: POINT Foreign.conversion type RECT = { left: int, top: int, right: int, bottom: int } val cRect: RECT Foreign.conversion type SIZE = { cx: int, cy: int } val cSize: SIZE Foreign.conversion eqtype 'a HANDLE val hNull: 'a HANDLE val isHNull: 'a HANDLE -> bool val handleOfVoidStar: Foreign.Memory.voidStar -> 'a HANDLE and voidStarOfHandle: 'a HANDLE -> Foreign.Memory.voidStar eqtype HMENU and HDC and HWND and HINSTANCE and HGDIOBJ and HDROP and HRSRC and HUPDATE val cHGDIOBJ: HGDIOBJ Foreign.conversion and cHDROP: HDROP Foreign.conversion and cHMENU: HMENU Foreign.conversion and cHINSTANCE: HINSTANCE Foreign.conversion and cHDC: HDC Foreign.conversion and cHWND: HWND Foreign.conversion val cHMENUOPT: HMENU option Foreign.conversion and cHGDIOBJOPT: HGDIOBJ option Foreign.conversion and cHWNDOPT: HWND option Foreign.conversion and cHRSRC: HRSRC Foreign.conversion and cHUPDATE: HUPDATE Foreign.conversion val hgdiObjNull:HGDIOBJ and isHgdiObjNull: HGDIOBJ -> bool and hdcNull: HDC and isHdcNull: HDC -> bool and hmenuNull: HMENU and isHmenuNull: HMENU -> bool and hinstanceNull: HINSTANCE and isHinstanceNull: HINSTANCE -> bool and hwndNull: HWND type HPALETTE = HGDIOBJ and HFONT = HGDIOBJ and HPEN = HGDIOBJ and HBITMAP = HGDIOBJ and HRGN = HGDIOBJ and HBRUSH = HGDIOBJ and HENHMETAFILE = HGDIOBJ and HMETAFILE = HGDIOBJ val cHPALETTE: HPALETTE Foreign.conversion and cHFONT: HFONT Foreign.conversion and cHPEN: HPEN Foreign.conversion and cHBITMAP: HBITMAP Foreign.conversion and cHRGN: HRGN Foreign.conversion and cHBRUSH: HBRUSH Foreign.conversion and cHENHMETAFILE: HENHMETAFILE Foreign.conversion and cHMETAFILE: HMETAFILE Foreign.conversion type HICON = HGDIOBJ and HCURSOR = HGDIOBJ val cHICON: HICON Foreign.conversion and cHCURSOR: HCURSOR Foreign.conversion val absConversion: {abs: 'a -> 'b, rep: 'b -> 'a} -> 'a Foreign.conversion -> 'b Foreign.conversion val tableLookup: (''a * ''b) list * ((''b -> ''a) * (''a -> ''b)) option -> (''a -> ''b) * (''b -> ''a) and tableSetLookup: (''a * Word32.word) list * ((Word32.word -> ''a) * (''a -> Word32.word)) option -> (''a list -> Word32.word) * (Word32.word -> ''a list) val tableConversion: (''a * ''b) list * ((''b -> ''a) * (''a -> ''b)) option -> ''b Foreign.conversion -> ''a Foreign.conversion (* tableSetConversion is always a cUint *) and tableSetConversion: (''a * Word32.word) list * ((Word32.word -> ''a) * (''a -> Word32.word)) option -> ''a list Foreign.conversion val list2Vector: 'a Foreign.conversion -> 'a list -> Foreign.Memory.voidStar * int datatype ClassType = NamedClass of string | ClassAtom of int val cCLASS: ClassType Foreign.conversion datatype ClipboardFormat = CF_NONE | CF_TEXT | CF_BITMAP | CF_METAFILEPICT | CF_SYLK | CF_DIF | CF_TIFF | CF_OEMTEXT | CF_DIB | CF_PALETTE | CF_PENDATA | CF_RIFF | CF_WAVE | CF_UNICODETEXT | CF_ENHMETAFILE | CF_OWNERDISPLAY | CF_DSPTEXT | CF_DSPBITMAP | CF_DSPMETAFILEPICT | CF_DSPENHMETAFILE | CF_PRIVATE of int | CF_GDIOBJ of int | CF_REGISTERED of int | CF_HDROP | CF_LOCALE val clipLookup: (ClipboardFormat -> int) * (int -> ClipboardFormat) datatype RESID = IdAsInt of int | IdAsString of string val cRESID: RESID Foreign.conversion val STRINGOPT: string option Foreign.conversion val cCHARARRAY: int -> string Foreign.conversion val fromCstring: Foreign.Memory.voidStar -> string val toCstring: string -> Foreign.Memory.voidStar (* Memory must be freed *) val copyStringToMem: Foreign.Memory.voidStar * int * string -> unit val fromCWord8vec: Foreign.Memory.voidStar * int -> Word8Vector.vector val toCWord8vec: Word8Vector.vector -> Foreign.Memory.voidStar (* Memory must be freed *) val getStringCall: (Foreign.Memory.voidStar * int -> int) -> string val getStringWithNullIsLength: (Foreign.Memory.voidStar * int -> int) -> string val getVectorResult: 'a Foreign.conversion -> (Foreign.Memory.voidStar * int -> int) -> int -> 'a vector eqtype HGLOBAL val cHGLOBAL: HGLOBAL Foreign.conversion val GlobalAlloc: int * int -> HGLOBAL val GlobalLock: HGLOBAL -> Foreign.Memory.voidStar val GlobalFree: HGLOBAL -> HGLOBAL val GlobalSize: HGLOBAL -> int val GlobalUnlock: HGLOBAL -> bool val HIWORD: Word32.word -> Word.word val LOWORD: Word32.word -> Word.word val MAKELONG: Word.word * Word.word -> Word32.word val HIBYTE: Word.word -> Word8.word val LOBYTE: Word.word -> Word8.word val unicodeToString: Word8Vector.vector -> string val stringToUnicode: string -> Word8Vector.vector val GetLastError: unit -> OS.syserror val checkResult: bool -> unit val raiseSysErr: unit -> 'a structure FindReplaceFlags: sig include BIT_FLAGS val FR_DIALOGTERM : flags val FR_DOWN : flags val FR_FINDNEXT : flags val FR_HIDEMATCHCASE : flags val FR_HIDEUPDOWN : flags val FR_HIDEWHOLEWORD : flags val FR_MATCHCASE : flags val FR_NOMATCHCASE : flags val FR_NOUPDOWN : flags val FR_NOWHOLEWORD : flags val FR_REPLACE : flags val FR_REPLACEALL : flags val FR_SHOWHELP : flags val FR_WHOLEWORD : flags val cFindReplaceFlags: flags Foreign.conversion end end = struct open Foreign (* val System_isShort : vol -> bool = RunCall.run_call1 RuntimeCalls.POLY_SYS_is_short*) fun absConversion {abs: 'a -> 'b, rep: 'b -> 'a} (c: 'a conversion) : 'b conversion = let val { load=loadI, store=storeI, ctype } = breakConversion c fun load m = abs(loadI m) fun store(m, v) = storeI(m, rep v) in makeConversion { load = load, store = store, ctype = ctype } end (* In many cases we can pass a set of options as a bit set. *) (* fun bitsetConversion {abs, rep} = let val (fromC, toC, Ctype) = breakConversion INT val fromList = List.foldl (fn(i, n) => IntInf.orb(rep i, n)) 0 fun toList n = [abs n] (* This is a bit of a mess. *) in mkConversion (toList o fromCuint) (toCuint o fromList) Cuint end*) (* Conversions between Word/Word32/LargeWord etc. *) local open Memory LowLevel fun noFree () = () in local fun load(m: voidStar): Word8.word = get8(m, 0w0) fun store(m: voidStar, i: Word8.word) = (set8(m, 0w0, i); noFree) in val cUint8w: Word8.word conversion = makeConversion{ load=load, store=store, ctype = cTypeUint8 } end local fun load(m: voidStar): Word.word = get16(m, 0w0) fun store(m: voidStar, i: Word.word) = (set16(m, 0w0, i); noFree) in val cUint16w: Word.word conversion = makeConversion{ load=load, store=store, ctype = cTypeInt16 } end local fun load(m: voidStar): Word32.word = get32(m, 0w0) fun store(m: voidStar, i: Word32.word) = (set32(m, 0w0, i); noFree) in val cUint32w: Word32.word conversion = makeConversion{ load=load, store=store, ctype = cTypeUint32 } end val cUintw = cUint32w (* Int should be 32-bits on Windows. *) val _ = #size LowLevel.cTypeUint = #size LowLevel.cTypeUint32 orelse raise Fail "unsigned int is not 32-bits" val cUlongw = cUint32w val _ = #size LowLevel.cTypeUlong = #size LowLevel.cTypeUint32 orelse raise Fail "unsigned long is not 32-bits" end val cDWORD = cUint32 (* Defined to be 32-bit unsigned *) and cWORD = cUint16 (* Defined to be 16-bit unsigned *) val cDWORDw = cUint32w and cWORDw = cUint16w (* For some reason Windows has both INT_PTR and LONG_PTR and they are slightly different. *) val cLONG_PTR = if #size LowLevel.cTypePointer = 0w4 then cLong else cInt64 val cINT_PTR = if #size LowLevel.cTypePointer = 0w4 then cInt else cInt64 val cULONG_PTR = if #size LowLevel.cTypePointer = 0w4 then cUlong else cUint64 val cUINT_PTR = if #size LowLevel.cTypePointer = 0w4 then cUint else cUint64 val cLPARAM = cLONG_PTR val cSIZE_T = cULONG_PTR (* Probably. *) val cDWORD_PTR = cULONG_PTR (* Defined to be the same so I'm not sure why it's there .*) val cUINT_PTRw = absConversion{abs=Memory.voidStar2Sysword, rep=Memory.sysWord2VoidStar} cPointer (* These are called XXX32.DLL on both 32-bit and 64-bit. *) fun kernel name = getSymbol(loadLibrary "kernel32.dll") name and user sym = getSymbol(loadLibrary "user32.DLL") sym and commdlg sym = getSymbol(loadLibrary "comdlg32.DLL") sym and gdi sym = getSymbol(loadLibrary "gdi32.DLL") sym and shell sym = getSymbol(loadLibrary "shell32.DLL") sym and comctl sym = getSymbol(loadLibrary "comctl32.DLL") sym (* We need to use the Pascal calling convention on 32-bit Windows. *) val winAbi = case List.find (fn ("stdcall", _) => true | _ => false) LibFFI.abiList of SOME(_, abi) => abi | NONE => LibFFI.abiDefault (* As well as setting the abi we can also use the old argument order. *) fun winCall0 sym argConv resConv = buildCall0withAbi(winAbi, sym, argConv, resConv) and winCall1 sym argConv resConv = buildCall1withAbi(winAbi, sym, argConv, resConv) and winCall2 sym argConv resConv = buildCall2withAbi(winAbi, sym, argConv, resConv) and winCall3 sym argConv resConv = buildCall3withAbi(winAbi, sym, argConv, resConv) and winCall4 sym argConv resConv = buildCall4withAbi(winAbi, sym, argConv, resConv) and winCall5 sym argConv resConv = buildCall5withAbi(winAbi, sym, argConv, resConv) and winCall6 sym argConv resConv = buildCall6withAbi(winAbi, sym, argConv, resConv) and winCall7 sym argConv resConv = buildCall7withAbi(winAbi, sym, argConv, resConv) and winCall8 sym argConv resConv = buildCall8withAbi(winAbi, sym, argConv, resConv) and winCall9 sym argConv resConv = buildCall9withAbi(winAbi, sym, argConv, resConv) and winCall10 sym argConv resConv = buildCall10withAbi(winAbi, sym, argConv, resConv) and winCall11 sym argConv resConv = buildCall11withAbi(winAbi, sym, argConv, resConv) and winCall12 sym argConv resConv = buildCall12withAbi(winAbi, sym, argConv, resConv) and winCall13 sym argConv resConv = buildCall13withAbi(winAbi, sym, argConv, resConv) and winCall14 sym argConv resConv = buildCall14withAbi(winAbi, sym, argConv, resConv) - (* Previously we had a specific call to do this. The error state is - no longer set by the new FFI. *) -(* - fun GetLastError(): OS.syserror = - RunCall.run_call2 RuntimeCalls.POLY_SYS_os_specific (1100, ()) -*) local - val getLastError = winCall0 (kernel "GetLastError") () cDWORD + open Foreign.Error in - fun GetLastError(): OS.syserror = - (* Windows error codes are negative values in OS.syserror. *) - RunCall.unsafeCast (~ (getLastError())) + val GetLastError: unit -> OS.syserror = fromWord o getLastError end (* The string argument of the SysErr exception is supposed to match the result of OS.errMsg. *) fun raiseSysErr () = let val err = GetLastError() in raise OS.SysErr(OS.errorMsg err, SOME err) end (* Many system calls return bool. If the result is false we raise an exception. *) fun checkResult true = () | checkResult false = raiseSysErr () val cBool: bool conversion = absConversion{abs = fn 0 => false | _ => true, rep = fn false => 0 | true => 1} cInt fun successState name: unit conversion = absConversion { abs = checkResult, rep = fn _ => raise Fail ("successState:" ^ name) } cBool type POINT = { x: int, y: int } local fun breakPoint ({x,y}: POINT) = (x,y) fun mkPoint (x,y): POINT = {x=x, y=y} in val cPoint = absConversion {abs=mkPoint, rep=breakPoint} (cStruct2 (cLong, cLong)) end type RECT = { left: int, top: int, right: int, bottom: int } local fun breakRect ({left,top,right,bottom}: RECT) = (left,top,right,bottom) fun mkRect (left,top,right,bottom): RECT = {left=left,top=top,right=right,bottom=bottom} in val cRect = absConversion {abs=mkRect, rep=breakRect} (cStruct4 (cLong,cLong,cLong,cLong)) end type SIZE = { cx: int, cy: int } local fun breakSize ({cx,cy}: SIZE) = (cx,cy) fun mkSize (cx,cy): SIZE = {cx=cx, cy=cy} in val cSize = absConversion {abs=mkSize, rep=breakSize} (cStruct2 (cLong,cLong)) end (* Handles are generally opaque values. We want them to be eqtypes, though. *) local structure HandStruct :> sig eqtype 'a HANDLE val hNull: 'a HANDLE val isHNull: 'a HANDLE -> bool val handleOfVoidStar: Memory.voidStar -> 'a HANDLE and voidStarOfHandle: 'a HANDLE -> Memory.voidStar end = struct type 'a HANDLE = Memory.voidStar val hNull = Memory.null fun isHNull h = h = hNull (* We sometimes need the next two functions internally. They're needed externally unless we change the result type of SendMessage to allow us to return a handle for certain messages. *) fun handleOfVoidStar h = h and voidStarOfHandle h = h end in open HandStruct end (* We just need these as placeholders. We never create values of these types. They are used simply as a way of creating different handle types. *) (* Don't use abstype - we want them to eqtypes *) datatype GdiObj = GdiObj and Instance = Instance and Drop = Drop and DeviceContext = DeviceContext and Menu = Menu and Window = Window and Global = Global and Src = Src and Update = Update (* HINSTANCE is used as an instance of a module. *) type HINSTANCE = Instance HANDLE and HDROP = Drop HANDLE and HGDIOBJ = GdiObj HANDLE and HDC = DeviceContext HANDLE and HMENU = Menu HANDLE and HWND = Window HANDLE and HGLOBAL = Global HANDLE and HRSRC = Src HANDLE and HUPDATE = Update HANDLE local fun cHANDLE() = absConversion {abs=handleOfVoidStar, rep=voidStarOfHandle} cPointer fun hoptOfvs n = if Memory.voidStar2Sysword n = 0w0 then NONE else SOME(handleOfVoidStar n) fun cHANDLEOPT() = absConversion {abs=hoptOfvs, rep=fn v => voidStarOfHandle(getOpt(v, hNull)) } cPointer in val cHGDIOBJ: HGDIOBJ conversion = cHANDLE() and cHDROP: HDROP conversion = cHANDLE() and cHMENU: HMENU conversion = cHANDLE() and cHINSTANCE: HINSTANCE conversion = cHANDLE() and cHDC: HDC conversion = cHANDLE() and cHWND: HWND conversion = cHANDLE() val cHMENUOPT: HMENU option conversion = cHANDLEOPT() and cHGDIOBJOPT: HGDIOBJ option conversion = cHANDLEOPT() and cHWNDOPT: HWND option conversion = cHANDLEOPT() val cHGLOBAL: HGLOBAL conversion = cHANDLE() and cHRSRC: HRSRC conversion = cHANDLE() and cHUPDATE: HUPDATE conversion = cHANDLE() end (* Temporary declarations. *) val hgdiObjNull:HGDIOBJ = hNull and isHgdiObjNull: HGDIOBJ -> bool = isHNull and hdcNull: HDC = hNull and isHdcNull: HDC -> bool = isHNull and hmenuNull: HMENU = hNull and isHmenuNull: HMENU -> bool = isHNull and hinstanceNull: HINSTANCE = hNull and isHinstanceNull: HINSTANCE -> bool = isHNull and hwndNull: HWND = hNull (* All these are various kinds of HGDIOBJ. It's too complicated to try to use different types for them. *) type HPALETTE = HGDIOBJ and HFONT = HGDIOBJ and HPEN = HGDIOBJ and HBITMAP = HGDIOBJ and HRGN = HGDIOBJ and HBRUSH = HGDIOBJ and HENHMETAFILE = HGDIOBJ and HMETAFILE = HGDIOBJ val cHPALETTE: HPALETTE conversion = cHGDIOBJ and cHFONT: HFONT conversion = cHGDIOBJ and cHPEN: HPEN conversion = cHGDIOBJ and cHBITMAP: HBITMAP conversion = cHGDIOBJ and cHRGN: HRGN conversion = cHGDIOBJ and cHBRUSH: HBRUSH conversion = cHGDIOBJ and cHENHMETAFILE: HENHMETAFILE conversion = cHGDIOBJ and cHMETAFILE: HMETAFILE conversion = cHGDIOBJ (* I'm not so happy about treating these as HGDIOBJ but it makes the types of messages such as BM_SETIMAGE simpler. *) type HICON = HGDIOBJ and HCURSOR = HGDIOBJ val cHICON = cHGDIOBJ and cHCURSOR = cHGDIOBJ (* The easiest way to deal with datatypes is often by way of a table. *) fun tableLookup (table: (''a * ''b) list, default) = let fun toInt [] x = (case default of NONE => raise Fail "tableLookup: not found" | SOME (_, d) => d x) | toInt ((y, i) :: tl) x = if x = y then i else toInt tl x fun fromInt [] x = (case default of NONE => raise Fail ("tableLookup: not found") | SOME (d, _) => d x) | fromInt ((y, i) :: tl) x = if x = i then y else fromInt tl x in (toInt table, fromInt table) end fun tableConversion (table: (''a * ''b) list, default) (conv: ''b conversion): ''a conversion = let val (toInt, fromInt) = tableLookup(table, default) in absConversion {abs = fromInt, rep = toInt} conv end (* In other cases we have sets of options. We represent them by a list. The order of the elements in the table is significant if we are to be able to handle multiple bits. Patterns with more than one bit set MUST be placed later than those with a subset of those bits. *) fun tableSetLookup (table: (''a * Word32.word) list, default) = let open Word32 (* Conversion to integer - just fold the values. *) fun toInt' [] x = (case default of NONE => raise Fail "tableLookup: not found" | SOME (_, d) => d x) | toInt' ((y, i) :: tl) x = if x = y then i else toInt' tl x val toInt = List.foldl (fn (a, b) => orb(toInt' table a, b)) 0w0 (* It would speed up the searches if we ordered the list so that multiple bit entries preceded those with fewer bits but it's much easier to lay out the tables if we do it this way. *) fun fromInt _ _ 0w0 = [] (* Zero is an empty list. *) | fromInt [] NONE x = (* Not found *) (case default of NONE => raise Fail ("tableLookup: not found" ^ Word32.toString x) | SOME (d, _) => [d x]) | fromInt [] (SOME(res, bits)) x = (* Found something - remove it from the set. *) (res :: fromInt table NONE (andb(x, notb bits))) | fromInt ((res, bits)::tl) sofar x = if bits <> 0w0 andalso andb(x, bits) = bits then (* Matches *) fromInt tl (SOME(res, bits)) x else (* Doesn't match *) fromInt tl sofar x in (toInt, fromInt table NONE) end fun tableSetConversion (table: (''a * Word32.word) list, default): ''a list conversion = let val (toInt, fromInt) = tableSetLookup(table, default) in absConversion {abs = fromInt, rep = toInt} cUintw end structure FindReplaceFlags:> sig include BIT_FLAGS val FR_DIALOGTERM : flags val FR_DOWN : flags val FR_FINDNEXT : flags val FR_HIDEMATCHCASE : flags val FR_HIDEUPDOWN : flags val FR_HIDEWHOLEWORD : flags val FR_MATCHCASE : flags val FR_NOMATCHCASE : flags val FR_NOUPDOWN : flags val FR_NOWHOLEWORD : flags val FR_REPLACE : flags val FR_REPLACEALL : flags val FR_SHOWHELP : flags val FR_WHOLEWORD : flags val cFindReplaceFlags: flags conversion end = struct open Word32 type flags = word val toWord = toLargeWord and fromWord = fromLargeWord val flags = List.foldl (fn (a, b) => orb(a,b)) 0w0 fun allSet (fl1, fl2) = andb(fl1, fl2) = fl1 fun anySet (fl1, fl2) = andb(fl1, fl2) <> 0w0 fun clear (fl1, fl2) = andb(notb fl1, fl2) val FR_DOWN = 0wx00000001 val FR_WHOLEWORD = 0wx00000002 val FR_MATCHCASE = 0wx00000004 val FR_FINDNEXT = 0wx00000008 val FR_REPLACE = 0wx00000010 val FR_REPLACEALL = 0wx00000020 val FR_DIALOGTERM = 0wx00000040 val FR_SHOWHELP = 0wx00000080 val FR_NOUPDOWN = 0wx00000400 val FR_NOMATCHCASE = 0wx00000800 val FR_NOWHOLEWORD = 0wx00001000 val FR_HIDEUPDOWN = 0wx00004000 val FR_HIDEMATCHCASE = 0wx00008000 val FR_HIDEWHOLEWORD = 0wx00010000 val all = flags[FR_DOWN, FR_WHOLEWORD, FR_MATCHCASE, FR_FINDNEXT, FR_REPLACE, FR_REPLACEALL, FR_DIALOGTERM, FR_NOUPDOWN, FR_NOMATCHCASE, FR_NOWHOLEWORD, FR_HIDEUPDOWN, FR_HIDEMATCHCASE, FR_HIDEWHOLEWORD] val intersect = List.foldl (fn (a, b) => andb(a,b)) all val cFindReplaceFlags = cDWORDw end (* The class "string" may be a name or an atom. *) datatype ClassType = NamedClass of string | ClassAtom of int local open Memory val {store=storeS, load=loadS, ctype} = breakConversion cString fun storeClass(m, ClassAtom i) = if i >= 0 andalso i < 0xC000 then (setAddress(m, 0w0, sysWord2VoidStar(SysWord.fromInt i)); fn () => ()) else raise Fail "atom out of range" | storeClass(m, NamedClass s) = storeS(m, s) fun loadClass m = let val v = getAddress(m, 0w0) in if voidStar2Sysword v < 0wxC000 then ClassAtom(SysWord.toInt(voidStar2Sysword v)) else NamedClass(loadS m) end in val cCLASS = makeConversion { load = loadClass, store = storeClass, ctype = ctype } end (* Clipboard formats. I've added CF_NONE, CF_PRIVATE, CF_GDIOBJ and CF_REGISTERED. This is here because it is used in both Clipboard and Message (WM_RENDERFORMAT) *) datatype ClipboardFormat = CF_NONE | CF_TEXT | CF_BITMAP | CF_METAFILEPICT | CF_SYLK | CF_DIF | CF_TIFF | CF_OEMTEXT | CF_DIB | CF_PALETTE | CF_PENDATA | CF_RIFF | CF_WAVE | CF_UNICODETEXT | CF_ENHMETAFILE | CF_OWNERDISPLAY | CF_DSPTEXT | CF_DSPBITMAP | CF_DSPMETAFILEPICT | CF_DSPENHMETAFILE | CF_PRIVATE of int | CF_GDIOBJ of int | CF_REGISTERED of int | CF_HDROP | CF_LOCALE local val tab = [ (CF_NONE, 0), (CF_TEXT, 1), (CF_BITMAP, 2), (CF_METAFILEPICT, 3), (CF_SYLK, 4), (CF_DIF, 5), (CF_TIFF, 6), (CF_OEMTEXT, 7), (CF_DIB, 8), (CF_PALETTE, 9), (CF_PENDATA, 10), (CF_RIFF, 11), (CF_WAVE, 12), (CF_UNICODETEXT, 13), (CF_ENHMETAFILE, 14), (CF_HDROP, 15), (CF_LOCALE, 16), (CF_OWNERDISPLAY, 0x0080), (CF_DSPTEXT, 0x0081), (CF_DSPBITMAP, 0x0082), (CF_DSPMETAFILEPICT, 0x0083), (CF_DSPENHMETAFILE, 0x008E) ] fun toInt (CF_PRIVATE i) = if i >= 0 andalso i < 0xff then 0x0200 + i else raise Size | toInt (CF_GDIOBJ i) = if i >= 0 andalso i < 0xff then 0x0300 + i else raise Size | toInt (CF_REGISTERED i) = i | toInt _ = raise Match fun fromInt i = if i >= 0x0200 andalso i <= 0x02ff then CF_PRIVATE(i-0x0200) else if i >= 0x0300 andalso i <= 0x03ff then CF_GDIOBJ(i-0x0300) else if i >= 0xC000 andalso i < 0xFFFF then CF_REGISTERED i else raise Match in val clipLookup = tableLookup (tab, SOME(fromInt, toInt)) end (* Resources may be specified by strings or by ints. *) datatype RESID = IdAsInt of int | IdAsString of string local open Memory val {store=storeS, load=loadS, ctype} = breakConversion cString fun storeResid(m, IdAsInt i) = if i >= 0 andalso i < 65536 then (setAddress(m, 0w0, sysWord2VoidStar(SysWord.fromInt i)); fn () => ()) else raise Fail "resource id out of range" | storeResid(m, IdAsString s) = storeS(m, s) fun loadResid m = let val v = getAddress(m, 0w0) in if voidStar2Sysword v < 0w65536 then IdAsInt(SysWord.toInt(voidStar2Sysword v)) else IdAsString(loadS m) end in val cRESID = makeConversion { load = loadResid, store = storeResid, ctype = ctype } end (*datatype HelpContext = HelpInfo_MenuItem of | HelpInfo_Window of type HELPINFO = { }*) (* Useful conversions. *) (* Various functions return zero if error. This conversion checks for that. *) fun cPOSINT _ = absConversion {abs = fn 0 => raiseSysErr() | n => n, rep = fn i => i} cInt (* Conversion between string option and C strings. NONE is converted to NULL. *) val STRINGOPT = cOptionPtr cString (* Convert a C string to ML. *) fun fromCstring buff = let open Memory (* We can't use #load cString because the argument is the address of the address of the string. *) fun sLen i = if get8(buff, i) = 0w0 then i else sLen(i+0w1) val length = sLen 0w0 fun loadChar i = Char.chr(Word8.toInt(get8(buff, Word.fromInt i))) in CharVector.tabulate(Word.toInt length, loadChar) end (* Copy a string to a particular offset in a buffer and add a null terminator. *) fun copyStringToMem (buf, n, s) = let open Memory infix 6 ++ fun copyToBuf (i, v) = set8(buf, Word.fromInt(i+n), Byte.charToByte v) in CharVector.appi copyToBuf s; set8(buf, Word.fromInt(n + size s), 0w0) end fun toCstring s = let open Memory val sLen = Word.fromInt(String.size s) val sMem = malloc(sLen + 0w1) val () = copyStringToMem(sMem, 0, s) in sMem end (* When getting a string it is often the case that passing NULL returns the length required. Then a second call will actually retrieve the string. *) fun getStringWithNullIsLength(f: Memory.voidStar*int -> int): string = let open Memory val realLength = f(null, 0) val buff = malloc (Word.fromInt(realLength+1)) val _ = f(buff, realLength) handle ex => (free buff; raise ex) in fromCstring buff before free buff end (* In several cases when extracting a string it is not possible in advance to know how big to make the buffer. This function loops until all the string has been extracted. *) (* This is at least needed for GetClassName *) fun getStringCall(f: Memory.voidStar*int -> int): string = let open Memory fun doCall initialSize = let (* Allocate a buffer to receive the result. For safety we make it one character longer than we actually say because it's not always clear whether the length we pass is the size including the NULL. Equally we are only certain we have read the whole string if the return value is less than initialSize-1 because the return value could be the number of real characters copied to the buffer. *) val buff = malloc (Word.fromInt(initialSize+1)) val resultSize = f(buff, initialSize) handle ex => (free buff; raise ex) in if resultSize < initialSize-1 then (* We've got it all. *) fromCstring buff before free buff else ( free buff; doCall(initialSize + initialSize div 2) ) end in doCall (*1024*) 3 (* Use a small size initially for testing. *) end (* We have a number of calls that extract a vector of results. They are called with an initial size, set the vector to the results and return a count of the number actually assigned. *) fun getVectorResult(element: 'a conversion) = let val { load=loadElem, ctype={size=sizeElem, ...}, ...} = breakConversion element fun run f initialCount = let open Memory infix 6 ++ -- val vec = malloc(Word.fromInt initialCount * sizeElem) fun getElement i = loadElem(vec ++ Word.fromInt i * sizeElem) val resultCount = f (vec, initialCount) handle ex => (free vec; raise ex) in Vector.tabulate(resultCount, getElement) before free vec end in run end (* Some C functions take a vector of values to allow a variable number of elements to be passed. We use a list for this in ML. *) (* TODO: This discards the result of any store function so if we store strings we'll leak store. *) fun list2Vector (conv: 'a conversion) (l:'a list): Memory.voidStar * int = let val count = List.length l val {store=storea, ctype={size=sizea, ...}, ...} = breakConversion conv open Memory infix 6 ++ val vec = malloc(Word.fromInt count * sizea) fun setItem(item, v) = (ignore(storea(v, item)); v ++ sizea) val _ = List.foldl setItem vec l in (vec, count) end val GlobalAlloc = winCall2 (kernel "GlobalAlloc") (cInt, cSIZE_T) cHGLOBAL val GlobalLock = winCall1 (kernel "GlobalLock") (cHGLOBAL) cPointer val GlobalFree = winCall1 (kernel "GlobalFree") (cHGLOBAL) cHGLOBAL val GlobalSize = winCall1 (kernel "GlobalSize") (cHGLOBAL) cSIZE_T val GlobalUnlock = winCall1 (kernel "GlobalUnlock") (cHGLOBAL) cBool (* Conversion for Word8Vector. We can't do this as a general conversion because we can't find out how big the C vector is. *) fun fromCWord8vec (buff, length) = Word8Vector.tabulate(length, fn i => Memory.get8(buff, Word.fromInt i)) fun toCWord8vec(s: Word8Vector.vector): Memory.voidStar = let open Memory Word8Vector val sLen = Word.fromInt(length s) val sMem = malloc sLen val () = appi(fn(i, b) => set8(sMem, Word.fromInt i, b)) s in sMem end (* (* Conversion for a fixed size byte array. *) fun BYTEARRAY n = let val base = Cstruct (List.tabulate (n, fn _ => Cchar)) fun from v = toWord8vec(address v, n) fun to w = if Word8Vector.length w <> n then raise Size else deref(fromWord8vec w) in mkConversion from to base end *) (* Conversion for a fixed size char array. *) fun cCHARARRAY n : string conversion = let (* Make it a struct of chars *) val { size=sizeC, align=alignC, ffiType=ffiTypeC } = LowLevel.cTypeChar val arraySize = sizeC * Word.fromInt n fun ffiType () = LibFFI.createFFItype { size = arraySize, align = alignC, typeCode=LibFFI.ffiTypeCodeStruct, elements = List.tabulate (n, fn _ => ffiTypeC()) } val arrayType: LowLevel.ctype = { size = arraySize, align = alignC, ffiType = ffiType } open Memory fun load(v: voidStar): string = let (* It should be null-terminated but just in case... *) fun sLen i = if i = Word.fromInt n orelse get8(v, i) = 0w0 then i else sLen(i+0w1) val length = sLen 0w0 fun loadChar i = Char.chr(Word8.toInt(get8(v, Word.fromInt i))) in CharVector.tabulate(Word.toInt length, loadChar) end fun store(v: voidStar, s: string) = let (* The length must be less than the size to allow for the null *) val sLen = size s val _ = sLen < n orelse raise Fail "string too long" in CharVector.appi(fn(i, ch) => set8(v, Word.fromInt i, Word8.fromInt(Char.ord ch))) s; set8(v, Word.fromInt sLen, 0w0); fn () => () end in makeConversion { load = load, store = store, ctype = arrayType } end (* These should always be UNSIGNED values. *) local open Word32 infix << >> orb andb val w32ToW = Word.fromLargeWord o Word32.toLargeWord and wTow32 = Word32.fromLargeWord o Word.toLargeWord in fun LOWORD(l) = w32ToW(l andb 0wxFFFF) fun HIWORD(l) = w32ToW((l >> 0w16) andb 0wxFFFF) fun MAKELONG(a, b) = (wTow32 b << 0w16) orb (wTow32 a andb 0wxFFFF) end local open Word infix << >> orb andb val wToW8 = Word8.fromLargeWord o Word.toLargeWord in fun HIBYTE(w) = wToW8((w >> 0w8) andb 0wxFF) fun LOBYTE(w) = wToW8(w andb 0wxFF) end (* Convert between strings and vectors containing Unicode characters. N.B. These are not null terminated. *) local val CP_ACP = 0 (* Default *) val WideCharToMultiByte = winCall8 (kernel "WideCharToMultiByte") (cUint, cDWORD, cByteArray, cInt, cPointer, cInt, cPointer, cPointer) cInt val MultiByteToWideChar = winCall6 (kernel "MultiByteToWideChar") (cUint, cDWORD, cString, cInt, cPointer, cInt) cInt in fun unicodeToString(w: Word8Vector.vector): string = let open Memory val inputLength = Word8Vector.length w div 2 (* Number of unicode chars *) val outputLength = WideCharToMultiByte(CP_ACP, 0, w, inputLength, null, 0, null, null) val outputBuf = malloc(Word.fromInt outputLength) val conv = WideCharToMultiByte(CP_ACP, 0, w, inputLength, outputBuf, outputLength, null, null) fun loadChar i = Char.chr(Word8.toInt(get8(outputBuf, Word.fromInt i))) in (* We can't use fromCstring here because it's not necessarily null terminated. *) CharVector.tabulate(conv, loadChar) before free outputBuf end fun stringToUnicode(s: string): Word8Vector.vector = let open Memory val inputLength = size s (* This does not include a terminating NULL *) (* The lengths returned by MultiByteToWideChar are the number of Unicode chars *) val outputLength = MultiByteToWideChar(CP_ACP, 0, s, inputLength, null, 0) val outputBuf = malloc(Word.fromInt outputLength * 0w2) val conv = MultiByteToWideChar(CP_ACP, 0, s, inputLength, outputBuf, outputLength) fun loadByte i = get8(outputBuf, Word.fromInt i) in Word8Vector.tabulate(conv*2, loadByte) before free outputBuf end end end; diff --git a/mlsource/extra/Win/Globals.sml b/mlsource/extra/Win/Globals.sml index 9ad7cd2d..e95c7d1a 100644 --- a/mlsource/extra/Win/Globals.sml +++ b/mlsource/extra/Win/Globals.sml @@ -1,58 +1,61 @@ (* Copyright (c) 2001, 2015, 2019 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) structure Globals : sig eqtype 'a HANDLE eqtype HINSTANCE eqtype HWND val hNull : 'a HANDLE val isHNull : 'a HANDLE -> bool val ApplicationInstance : unit -> HINSTANCE val GetLastError : unit -> OS.syserror val MainWindow : unit -> HWND end = struct local open Foreign open Base in type 'a HANDLE = 'a HANDLE val hNull = hNull and isHNull = isHNull type HINSTANCE = HINSTANCE type HWND = HWND val GetLastError = Base.GetLastError local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val getModHandle = + winCall1 (kernel "GetModuleHandleA") (cOptionPtr cString) cHINSTANCE + (* The current hInstance is also returned as Foreign.System.loadExecutable. *) in - fun ApplicationInstance() = winCall (1103, ()) + fun ApplicationInstance() = getModHandle NONE end local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val FindWindow = + winCall2 (user "FindWindowA") (STRINGOPT, STRINGOPT) cHWND in - fun MainWindow() = winCall (1104, ()) + fun MainWindow() = FindWindow(SOME "PolyMLWindowClass", SOME "Poly/ML") end end end; diff --git a/mlsource/extra/Win/Message.sml b/mlsource/extra/Win/Message.sml index e4726525..8edd356a 100644 --- a/mlsource/extra/Win/Message.sml +++ b/mlsource/extra/Win/Message.sml @@ -1,3876 +1,3866 @@ (* Copyright (c) 2001-7, 2015, 2019 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) structure Message: MESSAGE = struct local open Foreign open Memory open Base open Globals open WinBase fun user name = getSymbol(loadLibrary "user32.dll") name val toAddr = Memory.sysWord2VoidStar and fromAddr = Memory.voidStar2Sysword val RegisterMessage = winCall1 (user "RegisterWindowMessageA") cString cUint (* Used in WM_WINDOWPOSXXX and also WM_NCCALCSIZE *) val WINDOWPOS = cStruct7(cHWND, cHWND, cInt, cInt, cInt, cInt, cWINDOWPOSITIONSTYLE) local (* WM_WINDOWPOSCHANGING and WM_WINDOWPOSCHANGED. The C structure is the same but WM_WINDOWPOSCHANGING has refs in the ML to allow the call-back to change the position. *) val {load=fromCwindowpos, store=toCwindowpos, ctype={size=sizeCwp, ...}, ...} = breakConversion WINDOWPOS type wmWINDOWPOSCHANGED = { hwnd: HWND, front: HWND, x: int, y: int, width: int, height: int, flags: WindowPositionStyle list } and wmWINDOWPOSCHANGING = { hwnd: HWND, front: HWND ref, x: int ref, y: int ref, width: int ref, height: int ref, flags: WindowPositionStyle list ref } in fun cToMLWindowPosChanging{wp=_, lp}: wmWINDOWPOSCHANGING = let val (wh,front,x,y,width,height,flags) = fromCwindowpos(toAddr lp) in {hwnd = wh, front = ref front, x = ref x, y = ref y, width = ref width, height = ref height, flags = ref flags} end and cToMLWindowPosChanged{wp=_, lp}: wmWINDOWPOSCHANGED = let val (wh,front,x,y,width,height,flags) = fromCwindowpos(toAddr lp) in {hwnd = wh, front = front, x = x, y = y, width = width, height = height, flags = flags} end fun mlToCWindowPosChanging(msgNo, {hwnd, front=ref front, x=ref x, y=ref y, width=ref width, height=ref height, flags=ref flags}: wmWINDOWPOSCHANGING) = let open Memory val mem = malloc sizeCwp val freeCwp = toCwindowpos(mem, (hwnd, front, x, y, width, height, flags)) in (msgNo, 0w0, fromAddr mem, fn() => (freeCwp(); free mem)) end and mlToCWindowPosChanged(msgNo, {hwnd, front, x, y, width, height, flags}: wmWINDOWPOSCHANGED) = let open Memory val mem = malloc sizeCwp val freeCwp = toCwindowpos(mem, (hwnd, front, x, y, width, height, flags)) in (msgNo, 0w0, fromAddr mem, fn() => (freeCwp(); free mem)) end fun updateCfromMLwmWindowPosChanging( {wp=_, lp}, { front, x, y, width, height, flags, ...}:wmWINDOWPOSCHANGING) = let val (_,newfront,newx,newy,newwidth,newheight,newflags) = fromCwindowpos(toAddr lp) in front := newfront; x := newx; y := newy; width := newwidth; height := newheight; flags := newflags end and updateWindowPosChangingParms({wp=_, lp}, { hwnd, front=ref front, x=ref x, y=ref y, width=ref width, height=ref height, flags=ref flags}) = ignore(toCwindowpos(toAddr lp, (hwnd, front, x, y, width, height, flags))) end datatype ControlType = ODT_MENU | ODT_LISTBOX | ODT_COMBOBOX | ODT_BUTTON | ODT_STATIC local val tab = [ (ODT_MENU, 1), (ODT_LISTBOX, 2), (ODT_COMBOBOX, 3), (ODT_BUTTON, 4), (ODT_STATIC, 5) ] in val cCONTROLTYPE = tableConversion(tab, NONE) cUint end fun structAsAddr strConv = let val {load, store, ctype={size, ...}, ...} = breakConversion strConv fun make v = let open Memory val mem = malloc size val freeS = store(mem, v) in (fromAddr mem, fn () => (freeS(); free mem)) end in (load o toAddr, make) end val (_, makePointStructAddr) = structAsAddr cPoint local val MDICREATESTRUCT = cStruct9(cCLASS,cString,cHINSTANCE,cInt,cInt,cInt,cInt,cDWORD,cLPARAM) in val (toMdiCreate, fromMdiCreate) = structAsAddr MDICREATESTRUCT end local (* WM_COMPAREITEM *) val COMPAREITEMSTRUCT = cStruct8(cCONTROLTYPE,cUint,cHWND,cUint,cUINT_PTRw,cUint,cUINT_PTRw, cDWORD) val MEASUREITEMSTRUCT = cStruct6(cCONTROLTYPE,cUint,cUint,cUint,cUint,cULONG_PTR) val DELETEITEMSTRUCT = cStruct5(cCONTROLTYPE,cUint,cUint,cHWND,cULONG_PTR) val {store=toMeasureItem, ...} = breakConversion MEASUREITEMSTRUCT in val (toMLCompareItem, fromMLCompareItem) = structAsAddr COMPAREITEMSTRUCT and (toMLMeasureItem, fromMLMeasureItem) = structAsAddr MEASUREITEMSTRUCT and (toMLDeleteItem, fromMLDeleteItem) = structAsAddr DELETEITEMSTRUCT fun updateMeasureItemFromWpLp({itemWidth, itemHeight, ...}, {wp=_, lp}) = let val (_, _, _, iWidth, iHeight, _) = toMLMeasureItem lp in itemWidth := iWidth; itemHeight := iHeight end and updateMeasureItemParms({wp=_, lp}, {itemWidth=ref itemWidth, itemHeight=ref itemHeight, ...}) = let val (ctlType, ctlID, itemID, _, _, itemData) = toMLMeasureItem lp in ignore(toMeasureItem(toAddr lp, (ctlType, ctlID, itemID, itemWidth, itemHeight, itemData))) end end local (* WM_CREATE and WM_NCCREATE *) val CREATESTRUCT = cStruct12(cPointer,cHINSTANCE,cHMENU,cHWND,cInt,cInt,cInt,cInt,cUlongw,cString,cCLASS,cDWORD) val (toMLCreate, fromMLCreate) = structAsAddr CREATESTRUCT in fun decompileCreate{wp=_, lp} = let val (cp,inst,menu,parent, cy,cx,y,x, style, name,class, extendedstyle) = toMLCreate lp in { instance = inst, creation = cp, menu = menu, parent = parent, cy = cy, cx = cx, y = y, x = x, style = Style.fromWord(Word32.toLargeWord style), name = name, class = class, extendedstyle = extendedstyle } end and compileCreate(code, { instance, creation, menu, parent, cy, cx, y, x, style, name, class, extendedstyle}) = let val (addr, free) = fromMLCreate(creation, instance, menu, parent, cy, cx, y, x, Word32.fromLargeWord(Style.toWord style), name, class, extendedstyle) in (code, 0w0, addr, free) end end local val MINMAXINFO = cStruct5(cPoint,cPoint,cPoint,cPoint,cPoint) val {store=toCminmaxinfo, ...} = breakConversion MINMAXINFO val (toMLMinMax, fromMLMinMax) = structAsAddr MINMAXINFO in fun decompileMinMax{wp=_, lp} = let val (_, ptms, ptmp, ptts, ptmts) = toMLMinMax lp in { maxSize = ref ptms, maxPosition = ref ptmp, minTrackSize = ref ptts, maxTrackSize = ref ptmts} end and compileMinMax(code, { maxSize=ref maxSize, maxPosition=ref maxPosition, minTrackSize=ref minTrackSize, maxTrackSize=ref maxTrackSize}) = let val (addr, free) = fromMLMinMax({x=0,y=0}, maxSize, maxPosition, minTrackSize, maxTrackSize) in (code, 0w0, addr, free) end fun updateMinMaxFromWpLp({maxSize, maxPosition, minTrackSize, maxTrackSize}, {wp=_, lp}) = let val (_, ptms, ptmp, ptts, ptmts) = toMLMinMax lp in maxSize := ptms; maxPosition := ptmp; minTrackSize := ptts; maxTrackSize := ptmts end and updateMinMaxParms({wp=_, lp}, {maxSize=ref maxSize, maxPosition=ref maxPosition, minTrackSize=ref minTrackSize, maxTrackSize=ref maxTrackSize}) = let val (ptres, _, _, _, _) = toMLMinMax lp in ignore(toCminmaxinfo(toAddr lp, (ptres, maxSize, maxPosition, minTrackSize, maxTrackSize))) end end local val DRAWITEMSTRUCT = cStruct9(cCONTROLTYPE,cUint,cUint,cUint,cUint,cHWND,cHDC,cRect,cULONG_PTR) in val (toMLDrawItem, fromMLDrawItem) = structAsAddr DRAWITEMSTRUCT end local (* WM_NCCALCSIZE *) val NCCALCSIZE_PARAMS = cStruct4(cRect,cRect,cRect, cConstStar WINDOWPOS) val {load=loadStruct, store=storeStruct, ctype={size=sizeStr, ...}, ...} = breakConversion NCCALCSIZE_PARAMS val {load=loadRect, store=storeRect, ctype={size=sizeRect, ...}, ...} = breakConversion cRect in fun decompileNCCalcSize{wp=0w1, lp} = let val (newrect,oldrect,oldclientarea,winpos) = loadStruct (toAddr lp) val (wh,front,x,y,cx,cy,style) = winpos in { validarea = true, newrect = ref newrect, oldrect = oldrect, oldclientarea = oldclientarea, hwnd = wh, insertAfter = front, x = x, y = y, cx = cx, cy = cy, style = style } end | decompileNCCalcSize{wp=_, lp} = let val newrect = loadRect (toAddr lp) val zeroRect = {left=0, top=0, right=0, bottom=0} in { validarea = false, newrect = ref newrect, oldrect = zeroRect, oldclientarea = zeroRect, insertAfter = hwndNull, hwnd = hwndNull, x = 0, y = 0, cx = 0, cy = 0, style = [] } end and compileNCCalcSize{validarea=true, newrect=ref newrect, oldrect, oldclientarea, hwnd, insertAfter, x, y, cx, cy, style} = let open Memory val mem = malloc sizeStr val freeRect = storeStruct(mem, (newrect,oldrect,oldclientarea, (hwnd,insertAfter,x,y,cx,cy, style))) in (0x0083, 0w1, fromAddr mem, fn () => (freeRect(); free mem)) end | compileNCCalcSize{validarea=false, newrect=ref newrect, ...} = let open Memory val mem = malloc sizeRect val () = ignore(storeRect(mem, newrect)) in (0x0083, 0w0, fromAddr mem, fn () => free mem) end end local val HELPINFO = cStruct6(cUint, cInt, cInt, cPointer (* HANDLE *), cDWORD, cPoint) val {ctype={size=sizeHelpInfo, ...}, ...} = breakConversion HELPINFO val (toHelpInfo, fromHelpInfo) = structAsAddr HELPINFO in datatype HelpHandle = MenuHandle of HMENU | WindowHandle of HWND fun compileHelpInfo(code, {ctrlId, itemHandle, contextId, mousePos}) = let val (ctype, handl) = case itemHandle of MenuHandle m => (2, voidStarOfHandle m) | WindowHandle w => (1, voidStarOfHandle w) val (addr, free) = fromHelpInfo(Word.toInt sizeHelpInfo, ctype, ctrlId, handl, contextId, mousePos) in (code, 0w0, addr, free) end and decompileHelpInfo{wp=_, lp} = let val (_, ctype, ctrlId, itemHandle, contextId, mousePos) = toHelpInfo lp val hndl = if ctype = 2 then MenuHandle(handleOfVoidStar itemHandle) else WindowHandle(handleOfVoidStar itemHandle) in { ctrlId = ctrlId, itemHandle = hndl, contextId = contextId, mousePos = mousePos} end end local val {store=storeScrollInfo, ctype = {size=sizeStruct, ...}, ...} = breakConversion ScrollBase.cSCROLLINFOSTRUCT val (toScrollInfoStruct, fromScrollInfoStruct) = structAsAddr ScrollBase.cSCROLLINFOSTRUCT in fun toScrollInfo lp = let val (_, options, minPos, maxPos, pageSize, pos, trackPos) = toScrollInfoStruct lp val info = { minPos = minPos, maxPos = maxPos, pageSize = pageSize, pos = pos, trackPos = trackPos } in (info, options) end and fromScrollInfo({minPos, maxPos, pageSize, pos, trackPos}, options) = fromScrollInfoStruct(Word.toInt sizeStruct, options, minPos, maxPos, pageSize, pos, trackPos) and updateScrollInfo({wp=_, lp=lp}, {info=ref {minPos, maxPos, pageSize, pos, trackPos}, options}) = ignore(storeScrollInfo(toAddr lp, (Word.toInt sizeStruct, options, minPos, maxPos, pageSize, pos, trackPos))) end local val {store=storeWord, load=loadWord, ctype={size=sizeWord, ...}, ...} = breakConversion cWORD in (* We have to allocate a buffer big enough to receive the text and set the first word to the length of the buffer. *) fun compileGetLine {lineNo, size, ...} = let open Memory (* Allocate one extra byte so there's space for a null terminator. *) val vec = malloc (Word.max(Word.fromInt(size+1), sizeWord)) in ignore(storeWord(vec, size+1)); (0x00C5, SysWord.fromInt lineNo, fromAddr vec, fn () => free vec) end and decompileGetLine{wp, lp} = let (* The first word is supposed to contain the length *) val size = loadWord(toAddr lp) in { lineNo = SysWord.toInt wp, size = size(*-1 ? *), result = ref "" } end end val {load=loadInt, store=storeInt, ctype={size=sizeInt, ...}, ...} = breakConversion cInt local (* EM_SETTABSTOPS and LB_SETTABSTOPS *) open Memory infix 6 ++ in fun decompileTabStops{wp, lp} = let val v = toAddr lp fun getTab i = loadInt(v ++ Word.fromInt i * sizeInt) in IntVector.tabulate(SysWord.toInt wp, getTab) end and compileTabStops(code, tabs) = let val cTabs = IntVector.length tabs val vec = malloc(Word.fromInt cTabs * sizeInt) fun setVec(tab, addr) = (ignore(storeInt(addr, tab)); addr ++ sizeInt) val _ = IntVector.foldl setVec vec tabs in (code, SysWord.fromInt cTabs, fromAddr vec, fn () => free vec) end end local open Memory IntArray infix 6 ++ in fun compileGetSelItems(code, {items}) = (* Allocate a buffer to receive the items. Set each element of the buffer to ~1 so that the values are defined if not all of them are set. *) let open Memory IntArray val itemCount = length items infix 6 ++ val v = malloc(Word.fromInt itemCount * sizeInt) in appi(fn (i, s) => ignore(storeInt(v ++ Word.fromInt i * sizeInt, s))) items; (code, SysWord.fromInt itemCount, fromAddr v, fn () => free v) end fun updateGetSelItemsParms({wp=_, lp=lp}, {items}) = let val v = toAddr lp in appi(fn (i, s) => ignore(storeInt(v ++ Word.fromInt i * sizeInt, s))) items end and updateGetSelItemsFromWpLp({items}, {wp=_, lp, reply}) = let (* The return value is the actual number of items copied *) val nItems = SysWord.toIntX reply val b = toAddr lp open Memory infix 6 ++ fun newValue (i, old) = if i < nItems then loadInt(b ++ sizeInt * Word.fromInt i) else old in IntArray.modifyi newValue items end end (* Passed in the lpParam argument of a WM_NOTIFY message. TODO: Many of these have additional information. *) datatype Notification = NM_OUTOFMEMORY | NM_CLICK | NM_DBLCLK | NM_RETURN | NM_RCLICK | NM_RDBLCLK | NM_SETFOCUS | NM_KILLFOCUS | NM_CUSTOMDRAW | NM_HOVER | NM_NCHITTEST | NM_KEYDOWN | NM_RELEASEDCAPTURE | NM_SETCURSOR | NM_CHAR | NM_TOOLTIPSCREATED | NM_LDOWN | NM_RDOWN | NM_THEMECHANGED | LVN_ITEMCHANGING | LVN_ITEMCHANGED | LVN_INSERTITEM | LVN_DELETEITEM | LVN_DELETEALLITEMS | LVN_BEGINLABELEDIT | LVN_ENDLABELEDIT | LVN_COLUMNCLICK | LVN_BEGINDRAG | LVN_BEGINRDRAG | LVN_GETDISPINFO | LVN_SETDISPINFO | LVN_KEYDOWN | LVN_GETINFOTIP | HDN_ITEMCHANGING | HDN_ITEMCHANGED | HDN_ITEMCLICK | HDN_ITEMDBLCLICK | HDN_DIVIDERDBLCLICK | HDN_BEGINTRACK | HDN_ENDTRACK | HDN_TRACK | HDN_ENDDRAG | HDN_BEGINDRAG | HDN_GETDISPINFO | TVN_SELCHANGING | TVN_SELCHANGED | TVN_GETDISPINFO | TVN_SETDISPINFO | TVN_ITEMEXPANDING | TVN_ITEMEXPANDED | TVN_BEGINDRAG | TVN_BEGINRDRAG | TVN_DELETEITEM | TVN_BEGINLABELEDIT | TVN_ENDLABELEDIT | TVN_KEYDOWN | TVN_GETINFOTIP | TVN_SINGLEEXPAND | TTN_GETDISPINFO of string ref | TTN_SHOW | TTN_POP | TCN_KEYDOWN | TCN_SELCHANGE | TCN_SELCHANGING | TBN_GETBUTTONINFO | TBN_BEGINDRAG | TBN_ENDDRAG | TBN_BEGINADJUST | TBN_ENDADJUST | TBN_RESET | TBN_QUERYINSERT | TBN_QUERYDELETE | TBN_TOOLBARCHANGE | TBN_CUSTHELP | TBN_DROPDOWN | TBN_HOTITEMCHANGE | TBN_DRAGOUT | TBN_DELETINGBUTTON | TBN_GETDISPINFO | TBN_GETINFOTIP | UDN_DELTAPOS | RBN_GETOBJECT | RBN_LAYOUTCHANGED | RBN_AUTOSIZE | RBN_BEGINDRAG | RBN_ENDDRAG | RBN_DELETINGBAND | RBN_DELETEDBAND | RBN_CHILDSIZE | CBEN_GETDISPINFO | CBEN_DRAGBEGIN | IPN_FIELDCHANGED | SBN_SIMPLEMODECHANGE | PGN_SCROLL | PGN_CALCSIZE | NM_OTHER of int (* Catch-all for other cases. *) local (* Notification structures *) val NMHDR = cStruct3(cHWND, cUINT_PTR, cUint) val (toMLNmhdr, fromMLNmhdr) = structAsAddr NMHDR val CHARARRAY80 = cCHARARRAY 80 val NMTTDISPINFO = cStruct6(NMHDR, cPointer (* String or resource id *), CHARARRAY80, cHINSTANCE, cUint, cLPARAM); val (toMLNMTTDISPINFO, fromMLNMTTDISPINFO) = structAsAddr NMTTDISPINFO in fun compileNotification (from, idFrom, NM_OUTOFMEMORY) = fromMLNmhdr(from, idFrom, ~1) | compileNotification (from, idFrom, NM_CLICK) = fromMLNmhdr(from, idFrom, ~2) | compileNotification (from, idFrom, NM_DBLCLK) = fromMLNmhdr(from, idFrom, ~3) | compileNotification (from, idFrom, NM_RETURN) = fromMLNmhdr(from, idFrom, ~4) | compileNotification (from, idFrom, NM_RCLICK) = fromMLNmhdr(from, idFrom, ~5) | compileNotification (from, idFrom, NM_RDBLCLK) = fromMLNmhdr(from, idFrom, ~6) | compileNotification (from, idFrom, NM_SETFOCUS) = fromMLNmhdr(from, idFrom, ~7) | compileNotification (from, idFrom, NM_KILLFOCUS) = fromMLNmhdr(from, idFrom, ~8) | compileNotification (from, idFrom, NM_CUSTOMDRAW) = fromMLNmhdr(from, idFrom, ~12) | compileNotification (from, idFrom, NM_HOVER) = fromMLNmhdr(from, idFrom, ~13) | compileNotification (from, idFrom, NM_NCHITTEST) = fromMLNmhdr(from, idFrom, ~14) | compileNotification (from, idFrom, NM_KEYDOWN) = fromMLNmhdr(from, idFrom, ~15) | compileNotification (from, idFrom, NM_RELEASEDCAPTURE) = fromMLNmhdr(from, idFrom, ~16) | compileNotification (from, idFrom, NM_SETCURSOR) = fromMLNmhdr(from, idFrom, ~17) | compileNotification (from, idFrom, NM_CHAR) = fromMLNmhdr(from, idFrom, ~18) | compileNotification (from, idFrom, NM_TOOLTIPSCREATED) = fromMLNmhdr(from, idFrom, ~19) | compileNotification (from, idFrom, NM_LDOWN) = fromMLNmhdr(from, idFrom, ~20) | compileNotification (from, idFrom, NM_RDOWN) = fromMLNmhdr(from, idFrom, ~21) | compileNotification (from, idFrom, NM_THEMECHANGED) = fromMLNmhdr(from, idFrom, ~22) | compileNotification (from, idFrom, LVN_ITEMCHANGING) = fromMLNmhdr(from, idFrom, ~100) | compileNotification (from, idFrom, LVN_ITEMCHANGED) = fromMLNmhdr(from, idFrom, ~101) | compileNotification (from, idFrom, LVN_INSERTITEM) = fromMLNmhdr(from, idFrom, ~102) | compileNotification (from, idFrom, LVN_DELETEITEM) = fromMLNmhdr(from, idFrom, ~103) | compileNotification (from, idFrom, LVN_DELETEALLITEMS) = fromMLNmhdr(from, idFrom, ~104) | compileNotification (from, idFrom, LVN_BEGINLABELEDIT) = fromMLNmhdr(from, idFrom, ~105) | compileNotification (from, idFrom, LVN_ENDLABELEDIT) = fromMLNmhdr(from, idFrom, ~106) | compileNotification (from, idFrom, LVN_COLUMNCLICK) = fromMLNmhdr(from, idFrom, ~108) | compileNotification (from, idFrom, LVN_BEGINDRAG) = fromMLNmhdr(from, idFrom, ~109) | compileNotification (from, idFrom, LVN_BEGINRDRAG) = fromMLNmhdr(from, idFrom, ~111) | compileNotification (from, idFrom, LVN_GETDISPINFO) = fromMLNmhdr(from, idFrom, ~150) | compileNotification (from, idFrom, LVN_SETDISPINFO) = fromMLNmhdr(from, idFrom, ~151) | compileNotification (from, idFrom, LVN_KEYDOWN) = fromMLNmhdr(from, idFrom, ~155) | compileNotification (from, idFrom, LVN_GETINFOTIP) = fromMLNmhdr(from, idFrom, ~157) | compileNotification (from, idFrom, HDN_ITEMCHANGING) = fromMLNmhdr(from, idFrom, ~300) | compileNotification (from, idFrom, HDN_ITEMCHANGED) = fromMLNmhdr(from, idFrom, ~301) | compileNotification (from, idFrom, HDN_ITEMCLICK) = fromMLNmhdr(from, idFrom, ~302) | compileNotification (from, idFrom, HDN_ITEMDBLCLICK) = fromMLNmhdr(from, idFrom, ~303) | compileNotification (from, idFrom, HDN_DIVIDERDBLCLICK) = fromMLNmhdr(from, idFrom, ~305) | compileNotification (from, idFrom, HDN_BEGINTRACK) = fromMLNmhdr(from, idFrom, ~306) | compileNotification (from, idFrom, HDN_ENDTRACK) = fromMLNmhdr(from, idFrom, ~307) | compileNotification (from, idFrom, HDN_TRACK) = fromMLNmhdr(from, idFrom, ~308) | compileNotification (from, idFrom, HDN_ENDDRAG) = fromMLNmhdr(from, idFrom, ~311) | compileNotification (from, idFrom, HDN_BEGINDRAG) = fromMLNmhdr(from, idFrom, ~310) | compileNotification (from, idFrom, HDN_GETDISPINFO) = fromMLNmhdr(from, idFrom, ~309) | compileNotification (from, idFrom, TVN_SELCHANGING) = fromMLNmhdr(from, idFrom, ~401) | compileNotification (from, idFrom, TVN_SELCHANGED) = fromMLNmhdr(from, idFrom, ~402) | compileNotification (from, idFrom, TVN_GETDISPINFO) = fromMLNmhdr(from, idFrom, ~403) | compileNotification (from, idFrom, TVN_SETDISPINFO) = fromMLNmhdr(from, idFrom, ~404) | compileNotification (from, idFrom, TVN_ITEMEXPANDING) = fromMLNmhdr(from, idFrom, ~405) | compileNotification (from, idFrom, TVN_ITEMEXPANDED) = fromMLNmhdr(from, idFrom, ~406) | compileNotification (from, idFrom, TVN_BEGINDRAG) = fromMLNmhdr(from, idFrom, ~407) | compileNotification (from, idFrom, TVN_BEGINRDRAG) = fromMLNmhdr(from, idFrom, ~408) | compileNotification (from, idFrom, TVN_DELETEITEM) = fromMLNmhdr(from, idFrom, ~409) | compileNotification (from, idFrom, TVN_BEGINLABELEDIT) = fromMLNmhdr(from, idFrom, ~410) | compileNotification (from, idFrom, TVN_ENDLABELEDIT) = fromMLNmhdr(from, idFrom, ~411) | compileNotification (from, idFrom, TVN_KEYDOWN) = fromMLNmhdr(from, idFrom, ~412) | compileNotification (from, idFrom, TVN_GETINFOTIP) = fromMLNmhdr(from, idFrom, ~413) | compileNotification (from, idFrom, TVN_SINGLEEXPAND) = fromMLNmhdr(from, idFrom, ~415) | compileNotification (from, idFrom, TTN_GETDISPINFO(ref s)) = fromMLNMTTDISPINFO((from, idFrom, ~520), Memory.null, s, Globals.hNull, 0, 0) | compileNotification (from, idFrom, TTN_SHOW) = fromMLNmhdr(from, idFrom, ~521) | compileNotification (from, idFrom, TTN_POP) = fromMLNmhdr(from, idFrom, ~522) | compileNotification (from, idFrom, TCN_KEYDOWN) = fromMLNmhdr(from, idFrom, ~550) | compileNotification (from, idFrom, TCN_SELCHANGE) = fromMLNmhdr(from, idFrom, ~551) | compileNotification (from, idFrom, TCN_SELCHANGING) = fromMLNmhdr(from, idFrom, ~552) | compileNotification (from, idFrom, TBN_GETBUTTONINFO) = fromMLNmhdr(from, idFrom, ~700) | compileNotification (from, idFrom, TBN_BEGINDRAG) = fromMLNmhdr(from, idFrom, ~701) | compileNotification (from, idFrom, TBN_ENDDRAG) = fromMLNmhdr(from, idFrom, ~702) | compileNotification (from, idFrom, TBN_BEGINADJUST) = fromMLNmhdr(from, idFrom, ~703) | compileNotification (from, idFrom, TBN_ENDADJUST) = fromMLNmhdr(from, idFrom, ~704) | compileNotification (from, idFrom, TBN_RESET) = fromMLNmhdr(from, idFrom, ~705) | compileNotification (from, idFrom, TBN_QUERYINSERT) = fromMLNmhdr(from, idFrom, ~706) | compileNotification (from, idFrom, TBN_QUERYDELETE) = fromMLNmhdr(from, idFrom, ~707) | compileNotification (from, idFrom, TBN_TOOLBARCHANGE) = fromMLNmhdr(from, idFrom, ~708) | compileNotification (from, idFrom, TBN_CUSTHELP) = fromMLNmhdr(from, idFrom, ~709) | compileNotification (from, idFrom, TBN_DROPDOWN) = fromMLNmhdr(from, idFrom, ~710) | compileNotification (from, idFrom, TBN_HOTITEMCHANGE) = fromMLNmhdr(from, idFrom, ~713) | compileNotification (from, idFrom, TBN_DRAGOUT) = fromMLNmhdr(from, idFrom, ~714) | compileNotification (from, idFrom, TBN_DELETINGBUTTON) = fromMLNmhdr(from, idFrom, ~715) | compileNotification (from, idFrom, TBN_GETDISPINFO) = fromMLNmhdr(from, idFrom, ~716) | compileNotification (from, idFrom, TBN_GETINFOTIP) = fromMLNmhdr(from, idFrom, ~718) | compileNotification (from, idFrom, UDN_DELTAPOS) = fromMLNmhdr(from, idFrom, ~722) | compileNotification (from, idFrom, RBN_GETOBJECT) = fromMLNmhdr(from, idFrom, ~832) | compileNotification (from, idFrom, RBN_LAYOUTCHANGED) = fromMLNmhdr(from, idFrom, ~833) | compileNotification (from, idFrom, RBN_AUTOSIZE) = fromMLNmhdr(from, idFrom, ~834) | compileNotification (from, idFrom, RBN_BEGINDRAG) = fromMLNmhdr(from, idFrom, ~835) | compileNotification (from, idFrom, RBN_ENDDRAG) = fromMLNmhdr(from, idFrom, ~836) | compileNotification (from, idFrom, RBN_DELETINGBAND) = fromMLNmhdr(from, idFrom, ~837) | compileNotification (from, idFrom, RBN_DELETEDBAND) = fromMLNmhdr(from, idFrom, ~838) | compileNotification (from, idFrom, RBN_CHILDSIZE) = fromMLNmhdr(from, idFrom, ~839) | compileNotification (from, idFrom, CBEN_GETDISPINFO) = fromMLNmhdr(from, idFrom, ~800) | compileNotification (from, idFrom, CBEN_DRAGBEGIN) = fromMLNmhdr(from, idFrom, ~808) | compileNotification (from, idFrom, IPN_FIELDCHANGED) = fromMLNmhdr(from, idFrom, ~860) | compileNotification (from, idFrom, SBN_SIMPLEMODECHANGE) = fromMLNmhdr(from, idFrom, ~880) | compileNotification (from, idFrom, PGN_SCROLL) = fromMLNmhdr(from, idFrom, ~901) | compileNotification (from, idFrom, PGN_CALCSIZE) = fromMLNmhdr(from, idFrom, ~902) | compileNotification (from, idFrom, NM_OTHER code) = fromMLNmhdr(from, idFrom, code) local fun decompileNotifyArg (_, ~1) = NM_OUTOFMEMORY | decompileNotifyArg (_, ~2) = NM_CLICK | decompileNotifyArg (_, ~3) = NM_DBLCLK | decompileNotifyArg (_, ~4) = NM_RETURN | decompileNotifyArg (_, ~5) = NM_RCLICK | decompileNotifyArg (_, ~6) = NM_RDBLCLK | decompileNotifyArg (_, ~7) = NM_SETFOCUS | decompileNotifyArg (_, ~8) = NM_KILLFOCUS | decompileNotifyArg (_, ~12) = NM_CUSTOMDRAW | decompileNotifyArg (_, ~13) = NM_HOVER | decompileNotifyArg (_, ~14) = NM_NCHITTEST | decompileNotifyArg (_, ~15) = NM_KEYDOWN | decompileNotifyArg (_, ~16) = NM_RELEASEDCAPTURE | decompileNotifyArg (_, ~17) = NM_SETCURSOR | decompileNotifyArg (_, ~18) = NM_CHAR | decompileNotifyArg (_, ~19) = NM_TOOLTIPSCREATED | decompileNotifyArg (_, ~20) = NM_LDOWN | decompileNotifyArg (_, ~21) = NM_RDOWN | decompileNotifyArg (_, ~22) = NM_THEMECHANGED | decompileNotifyArg (_, ~100) = LVN_ITEMCHANGING | decompileNotifyArg (_, ~101) = LVN_ITEMCHANGED | decompileNotifyArg (_, ~102) = LVN_INSERTITEM | decompileNotifyArg (_, ~103) = LVN_DELETEITEM | decompileNotifyArg (_, ~104) = LVN_DELETEALLITEMS | decompileNotifyArg (_, ~105) = LVN_BEGINLABELEDIT | decompileNotifyArg (_, ~106) = LVN_ENDLABELEDIT | decompileNotifyArg (_, ~108) = LVN_COLUMNCLICK | decompileNotifyArg (_, ~109) = LVN_BEGINDRAG | decompileNotifyArg (_, ~111) = LVN_BEGINRDRAG | decompileNotifyArg (_, ~150) = LVN_GETDISPINFO | decompileNotifyArg (_, ~151) = LVN_SETDISPINFO | decompileNotifyArg (_, ~155) = LVN_KEYDOWN | decompileNotifyArg (_, ~157) = LVN_GETINFOTIP | decompileNotifyArg (_, ~300) = HDN_ITEMCHANGING | decompileNotifyArg (_, ~301) = HDN_ITEMCHANGED | decompileNotifyArg (_, ~302) = HDN_ITEMCLICK | decompileNotifyArg (_, ~303) = HDN_ITEMDBLCLICK | decompileNotifyArg (_, ~305) = HDN_DIVIDERDBLCLICK | decompileNotifyArg (_, ~306) = HDN_BEGINTRACK | decompileNotifyArg (_, ~307) = HDN_ENDTRACK | decompileNotifyArg (_, ~308) = HDN_TRACK | decompileNotifyArg (_, ~311) = HDN_ENDDRAG | decompileNotifyArg (_, ~310) = HDN_BEGINDRAG | decompileNotifyArg (_, ~309) = HDN_GETDISPINFO | decompileNotifyArg (_, ~401) = TVN_SELCHANGING | decompileNotifyArg (_, ~402) = TVN_SELCHANGED | decompileNotifyArg (_, ~403) = TVN_GETDISPINFO | decompileNotifyArg (_, ~404) = TVN_SETDISPINFO | decompileNotifyArg (_, ~405) = TVN_ITEMEXPANDING | decompileNotifyArg (_, ~406) = TVN_ITEMEXPANDED | decompileNotifyArg (_, ~407) = TVN_BEGINDRAG | decompileNotifyArg (_, ~408) = TVN_BEGINRDRAG | decompileNotifyArg (_, ~409) = TVN_DELETEITEM | decompileNotifyArg (_, ~410) = TVN_BEGINLABELEDIT | decompileNotifyArg (_, ~411) = TVN_ENDLABELEDIT | decompileNotifyArg (_, ~412) = TVN_KEYDOWN | decompileNotifyArg (_, ~413) = TVN_GETINFOTIP | decompileNotifyArg (_, ~415) = TVN_SINGLEEXPAND | decompileNotifyArg (lp, ~520) = let val nmt = toMLNMTTDISPINFO lp (* Just look at the byte data at the moment. *) in TTN_GETDISPINFO(ref(#3 nmt)) end | decompileNotifyArg (_, ~521) = TTN_SHOW | decompileNotifyArg (_, ~522) = TTN_POP | decompileNotifyArg (_, ~550) = TCN_KEYDOWN | decompileNotifyArg (_, ~551) = TCN_SELCHANGE | decompileNotifyArg (_, ~552) = TCN_SELCHANGING | decompileNotifyArg (_, ~700) = TBN_GETBUTTONINFO | decompileNotifyArg (_, ~701) = TBN_BEGINDRAG | decompileNotifyArg (_, ~702) = TBN_ENDDRAG | decompileNotifyArg (_, ~703) = TBN_BEGINADJUST | decompileNotifyArg (_, ~704) = TBN_ENDADJUST | decompileNotifyArg (_, ~705) = TBN_RESET | decompileNotifyArg (_, ~706) = TBN_QUERYINSERT | decompileNotifyArg (_, ~707) = TBN_QUERYDELETE | decompileNotifyArg (_, ~708) = TBN_TOOLBARCHANGE | decompileNotifyArg (_, ~709) = TBN_CUSTHELP | decompileNotifyArg (_, ~710) = TBN_DROPDOWN | decompileNotifyArg (_, ~713) = TBN_HOTITEMCHANGE | decompileNotifyArg (_, ~714) = TBN_DRAGOUT | decompileNotifyArg (_, ~715) = TBN_DELETINGBUTTON | decompileNotifyArg (_, ~716) = TBN_GETDISPINFO | decompileNotifyArg (_, ~718) = TBN_GETINFOTIP (*<<<*) | decompileNotifyArg (_, ~722) = UDN_DELTAPOS | decompileNotifyArg (_, ~832) = RBN_GETOBJECT | decompileNotifyArg (_, ~833) = RBN_LAYOUTCHANGED | decompileNotifyArg (_, ~834) = RBN_AUTOSIZE | decompileNotifyArg (_, ~835) = RBN_BEGINDRAG | decompileNotifyArg (_, ~836) = RBN_ENDDRAG | decompileNotifyArg (_, ~837) = RBN_DELETINGBAND | decompileNotifyArg (_, ~838) = RBN_DELETEDBAND | decompileNotifyArg (_, ~839) = RBN_CHILDSIZE | decompileNotifyArg (_, ~800) = CBEN_GETDISPINFO | decompileNotifyArg (_, ~808) = CBEN_DRAGBEGIN | decompileNotifyArg (_, ~860) = IPN_FIELDCHANGED | decompileNotifyArg (_, ~880) = SBN_SIMPLEMODECHANGE | decompileNotifyArg (_, ~901) = PGN_SCROLL | decompileNotifyArg (_, ~902) = PGN_CALCSIZE | decompileNotifyArg (_, code) = NM_OTHER code in fun decompileNotify {wp, lp} = let val (hwndFrom, idFrom, code) = toMLNmhdr lp val notification = decompileNotifyArg (lp, code) in { idCtrl = SysWord.toInt wp, from = hwndFrom, idFrom = idFrom, notification = notification} end end end local val cFINDREPLACE = cStruct11(cDWORD, cHWND, cHINSTANCE, FindReplaceFlags.cFindReplaceFlags, cString, cString, cWORD, cWORD, cPointer, cPointer, cPointer) val {load=loadFindReplace, store=storeFindReplace, ctype={size=sizeFindReplace, ...}, ...} = breakConversion cFINDREPLACE type findMsg = { flags: FindReplaceFlags.flags, findWhat: string, replaceWith: string } in fun compileFindMsg({flags, findWhat, replaceWith}: findMsg) = let open Memory val vec = malloc sizeFindReplace (* Is this right? It's supposed to create a buffer to store the result. *) val freeFR = storeFindReplace(vec, (Word.toInt sizeFindReplace, hNull, hNull, flags, findWhat, replaceWith, 0, 0, null, null, null)) in (RegisterMessage "commdlg_FindReplace", 0w0, fromAddr vec, fn() => (freeFR(); free vec)) end fun decompileFindMsg{wp=_, lp}: findMsg = let val (_, _, _, flags, findwhat, replace, _, _, _, _, _) = loadFindReplace(toAddr lp) (* The argument is really a FINDREPLACE struct. *) in {flags=flags, findWhat=findwhat, replaceWith=replace} end end val toHMENU: SysWord.word -> HMENU = handleOfVoidStar o Memory.sysWord2VoidStar and fromHMENU: HMENU -> SysWord.word = Memory.voidStar2Sysword o voidStarOfHandle val toHWND: SysWord.word -> HWND = handleOfVoidStar o Memory.sysWord2VoidStar and fromHWND: HWND -> SysWord.word = Memory.voidStar2Sysword o voidStarOfHandle val toHDC: SysWord.word -> HDC = handleOfVoidStar o Memory.sysWord2VoidStar and fromHDC: HDC -> SysWord.word = Memory.voidStar2Sysword o voidStarOfHandle val toHFONT: SysWord.word -> HFONT = handleOfVoidStar o Memory.sysWord2VoidStar and fromHFONT: HFONT -> SysWord.word = Memory.voidStar2Sysword o voidStarOfHandle val toHRGN: SysWord.word -> HRGN = handleOfVoidStar o Memory.sysWord2VoidStar and fromHRGN: HRGN -> SysWord.word = Memory.voidStar2Sysword o voidStarOfHandle val toHDROP: SysWord.word -> HDROP = handleOfVoidStar o Memory.sysWord2VoidStar and fromHDROP: HDROP -> SysWord.word = Memory.voidStar2Sysword o voidStarOfHandle val toHICON: SysWord.word -> HICON = handleOfVoidStar o Memory.sysWord2VoidStar and fromHICON: HICON -> SysWord.word = Memory.voidStar2Sysword o voidStarOfHandle val toHGDIOBJ: SysWord.word -> HGDIOBJ = handleOfVoidStar o Memory.sysWord2VoidStar and fromHGDIOBJ: HGDIOBJ -> SysWord.word = Memory.voidStar2Sysword o voidStarOfHandle (* Maybe we should have two different types for horizontal and vertical. *) datatype ScrollDirection = SB_BOTTOM | SB_ENDSCROLL | SB_LINEDOWN | SB_LINEUP | SB_PAGEDOWN | SB_PAGEUP | SB_THUMBPOSITION | SB_THUMBTRACK | SB_TOP | SB_LEFT | SB_RIGHT | SB_LINELEFT | SB_LINERIGHT | SB_PAGELEFT | SB_PAGERIGHT local val tab = [ (SB_LINEUP, 0w0: word), (SB_LINELEFT, 0w0), (SB_LINEDOWN, 0w1), (SB_LINERIGHT, 0w1), (SB_PAGEUP, 0w2), (SB_PAGELEFT, 0w2), (SB_PAGEDOWN, 0w3), (SB_PAGERIGHT, 0w3), (SB_THUMBPOSITION, 0w4), (SB_THUMBTRACK, 0w5), (SB_TOP, 0w6), (SB_LEFT, 0w6), (SB_BOTTOM, 0w7), (SB_RIGHT, 0w7), (SB_ENDSCROLL, 0w8) ] in val (toCsd, fromCsd) = tableLookup(tab, NONE) end (* This is a bit of a mess. Various operations take or return handles to these types of image and also take this value as a parameter. *) datatype ImageType = IMAGE_BITMAP | IMAGE_CURSOR | IMAGE_ENHMETAFILE | IMAGE_ICON local val tab = [ (IMAGE_BITMAP, 0), (IMAGE_ICON, 1), (IMAGE_CURSOR, 2), (IMAGE_ENHMETAFILE, 3) ] in val (toCit, fromCit) = tableLookup(tab, NONE) end val (toCcbf, fromCcbf) = clipLookup datatype MouseKeyFlags = MK_LBUTTON | MK_RBUTTON | MK_SHIFT | MK_CONTROL | MK_MBUTTON local val tab = [ (MK_LBUTTON, 0wx0001), (MK_RBUTTON, 0wx0002), (MK_SHIFT, 0wx0004), (MK_CONTROL, 0wx0008), (MK_MBUTTON, 0wx0010) ] in val (toCmkf, fromCmkf) = tableSetLookup(tab, NONE) end datatype MDITileFlags = MDITILE_VERTICAL | MDITILE_HORIZONTAL | MDITILE_SKIPDISABLED local val tab = [ (MDITILE_VERTICAL, 0wx0000), (MDITILE_HORIZONTAL, 0wx0001), (MDITILE_SKIPDISABLED, 0wx0002) ] in val (toCmdif, fromCmdif) = tableSetLookup(tab, NONE) end datatype WMPrintOption = PRF_CHECKVISIBLE | PRF_NONCLIENT | PRF_CLIENT | PRF_ERASEBKGND | PRF_CHILDREN | PRF_OWNED local val tab = [ (PRF_CHECKVISIBLE, 0wx00000001), (PRF_NONCLIENT, 0wx00000002), (PRF_CLIENT, 0wx00000004), (PRF_ERASEBKGND, 0wx00000008), (PRF_CHILDREN, 0wx00000010), (PRF_OWNED, 0wx00000020) ] in val (toCwmpl, fromCwmpl) = tableSetLookup(tab, NONE) end val (toCcbal, fromCcbal) = ComboBase.CBDIRATTRS val (toCesbf, fromCesbf) = ScrollBase.ENABLESCROLLBARFLAG (*fun itob i = i <> 0*) (* These deal with signed quantities. LOWORD/HIWORD deal with words *) local val shift32 = Word.fromInt(SysWord.wordSize-32) and shift16 = Word.fromInt(SysWord.wordSize-16) open SysWord infix 5 << ~>> infix 7 andb infix 6 orb (* Y is the high order word, X is the low order word. *) in fun getYLParam (i: SysWord.word) = toIntX((i << shift32) ~>> shift16) and getXLParam (i: SysWord.word) = toIntX((i << shift16) ~>> shift16) fun makeXYParam (x, y) = ((fromInt y andb 0wxffff) << 0w16) orb (fromInt x andb 0wxffff) end in type flags = WinBase.Style.flags and WindowPositionStyle = WinBase.WindowPositionStyle datatype ControlType = datatype ControlType datatype ScrollDirection = datatype ScrollDirection datatype HitTest = HTBORDER | HTBOTTOM | HTBOTTOMLEFT | HTBOTTOMRIGHT | HTCAPTION | HTCLIENT | HTCLOSE | HTERROR | HTGROWBOX | HTHELP | HTHSCROLL | HTLEFT | HTMENU | HTMAXBUTTON | HTMINBUTTON | HTNOWHERE | HTREDUCE | HTRIGHT | HTSIZE | HTSYSMENU | HTTOP | HTTOPLEFT | HTTOPRIGHT | HTTRANSPARENT | HTVSCROLL | HTZOOM datatype LRESULT = LRESINT of int | LRESHANDLE of HGDIOBJ datatype ImageType = datatype ImageType (* WM_SIZE options. *) datatype WMSizeOptions = SIZE_RESTORED | SIZE_MINIMIZED | SIZE_MAXIMIZED | SIZE_MAXSHOW | SIZE_MAXHIDE local val tab = [ (SIZE_RESTORED, 0w0: SysWord.word), (SIZE_MINIMIZED, 0w1), (SIZE_MAXIMIZED, 0w2), (SIZE_MAXSHOW, 0w3), (SIZE_MAXHIDE, 0w4) ] in val (fromWMSizeOpt, toWMSizeOpt) = tableLookup(tab, NONE) end (* WM_ACTIVATE options *) datatype WMActivateOptions = WA_INACTIVE | WA_ACTIVE | WA_CLICKACTIVE local val tab = [ (WA_INACTIVE, 0w0: word), (WA_ACTIVE, 0w1), (WA_CLICKACTIVE, 0w2) ] in val (fromWMactive, toWMactive) = tableLookup(tab, NONE) end datatype SystemCommand = SC_SIZE | SC_MOVE | SC_MINIMIZE | SC_MAXIMIZE | SC_NEXTWINDOW | SC_PREVWINDOW | SC_CLOSE | SC_VSCROLL | SC_HSCROLL | SC_MOUSEMENU | SC_KEYMENU | SC_ARRANGE | SC_RESTORE | SC_TASKLIST | SC_SCREENSAVE | SC_HOTKEY | SC_DEFAULT | SC_MONITORPOWER | SC_CONTEXTHELP | SC_SEPARATOR local val tab = [ (SC_SIZE, 0xF000), (SC_MOVE, 0xF010), (SC_MINIMIZE, 0xF020), (SC_MAXIMIZE, 0xF030), (SC_NEXTWINDOW, 0xF040), (SC_PREVWINDOW, 0xF050), (SC_CLOSE, 0xF060), (SC_VSCROLL, 0xF070), (SC_HSCROLL, 0xF080), (SC_MOUSEMENU, 0xF090), (SC_KEYMENU, 0xF100), (SC_ARRANGE, 0xF110), (SC_RESTORE, 0xF120), (SC_TASKLIST, 0xF130), (SC_SCREENSAVE, 0xF140), (SC_HOTKEY, 0xF150), (SC_DEFAULT, 0xF160), (SC_MONITORPOWER, 0xF170), (SC_CONTEXTHELP, 0xF180)] in val (fromSysCommand, toSysCommand) = tableLookup(tab, NONE) end datatype EMCharFromPos = EMcfpEdit of POINT | EMcfpRichEdit of POINT | EMcfpUnknown of SysWord.word datatype WMPrintOption = datatype WMPrintOption (* Parameters to EM_SETMARGINS. *) datatype MarginSettings = UseFontInfo | Margins of {left: int option, right: int option } datatype MouseKeyFlags = datatype MouseKeyFlags datatype MDITileFlags = datatype MDITileFlags (* TODO: Perhaps use a record for this. It's always possible to use functions from Word32 though. *) type KeyData = Word32.word datatype Notification = datatype Notification datatype HelpHandle = datatype HelpHandle local val tab = [ (HTBORDER, 18), (HTBOTTOM, 15), (HTBOTTOMLEFT, 16), (HTBOTTOMRIGHT, 17), (HTCAPTION, 2), (HTCLIENT, 1), (HTCLOSE, 20), (HTERROR, ~2), (HTGROWBOX, 4), (HTHELP, 21), (HTHSCROLL, 6), (HTLEFT, 10), (HTMENU, 5), (HTMAXBUTTON, 9), (HTMINBUTTON, 8), (HTNOWHERE, 0), (HTREDUCE, 8), (HTRIGHT, 11), (HTSIZE, 4), (HTSYSMENU, 3), (HTTOP, 12), (HTTOPLEFT, 13), (HTTOPRIGHT, 14), (HTTRANSPARENT, ~1), (HTVSCROLL, 7), (HTZOOM, 9) ] in val (fromHitTest, toHitTest) = tableLookup(tab, SOME(fn _ => HTERROR, fn _ => ~2)) (* Include default just in case a new value is added some time *) end type findReplaceFlags = FindReplaceFlags.flags type windowFlags = flags datatype Message = WM_NULL | WM_ACTIVATE of {active: WMActivateOptions, minimize: bool } (* Indicates a change in activation state *) | WM_ACTIVATEAPP of {active: bool, threadid: int } (* Notifies applications when a new task activates *) | WM_ASKCBFORMATNAME of { length: int, formatName: string ref} (* Retrieves the name of the clipboard format *) | WM_CANCELJOURNAL (* Notifies application when user cancels journaling *) | WM_CANCELMODE (* Notifies a Window to cancel internal modes *) | WM_CHANGECBCHAIN of { removed: HWND, next: HWND } (* Notifies clipboard viewer of removal from chain *) | WM_CHAR of {charCode: char, data: KeyData } (* Indicates the user pressed a character key *) | WM_CHARTOITEM of {key: int, caretpos: int, listbox: HWND } (* Provides list-box keystrokes to owner Window *) | WM_CHILDACTIVATE (* Notifies a child Window of activation *) (* This is WM_USER+1. It's only used in a GetFont dialogue box. | WM_CHOOSEFONT_GETLOGFONT of LOGFONT ref *) (* Retrieves LOGFONT structure for Font dialog box *) | WM_CLEAR (* Clears an edit control *) | WM_CLOSE (* System Close menu command was chosen *) | WM_COMMAND of {notifyCode: int, wId: int, control: HWND } (* Specifies a command message *) | WM_COMPAREITEM of (* Determines position of combo- or list-box item *) { controlid: int, ctlType: ControlType, ctlID: int, hItem: HWND, itemID1: int, itemData1: SysWord.word, itemID2: int, itemData2: SysWord.word } | WM_COPY (* Copies a selection to the clipboard *) | WM_CREATE of { instance: HINSTANCE, creation: Foreign.Memory.voidStar, menu: HMENU, parent: HWND, cy: int, cx: int, y: int, x: int, style: windowFlags, name: string, (* The class may be a string or an atom. *) class: ClassType, extendedstyle: int } (* Indicates a Window is being created *) | WM_CTLCOLORBTN of { displaycontext: HDC, button: HWND } (* Button is about to be drawn *) | WM_CTLCOLORDLG of { displaycontext: HDC, dialogbox: HWND } (* Dialog box is about to be drawn *) | WM_CTLCOLOREDIT of { displaycontext: HDC, editcontrol: HWND } (* Control is about to be drawn *) | WM_CTLCOLORLISTBOX of { displaycontext: HDC, listbox: HWND } (* List box is about to be drawn *) | WM_CTLCOLORMSGBOX of { displaycontext: HDC, messagebox: HWND } (* Message box is about to be drawn *) | WM_CTLCOLORSCROLLBAR of { displaycontext: HDC, scrollbar: HWND } (* Indicates scroll bar is about to be drawn *) | WM_CTLCOLORSTATIC of { displaycontext: HDC, staticcontrol: HWND } (* Control is about to be drawn *) (* Note the return value is an HBRUSH *) | WM_CUT (* Deletes a selection and copies it to the clipboard *) | WM_DEADCHAR of { charCode: char, data: KeyData } (* Indicates the user pressed a dead key *) | WM_DELETEITEM of { senderId: int, ctlType: ControlType, ctlID: int, itemID: int, item: HWND, itemData: int } (* Indicates owner-draw item or control was altered *) | WM_DESTROY (* Indicates Window is about to be destroyed *) | WM_DESTROYCLIPBOARD (* Notifies owner that the clipboard was emptied *) | WM_DEVMODECHANGE of { devicename: string } (* Indicates the device-mode settings have changed *) | WM_DRAWCLIPBOARD (* Indicates the clipboard's contents have changed *) | WM_DRAWITEM of { senderId: int, ctlType: ControlType, ctlID: int, itemID: int, itemAction: int, itemState: int, hItem: HWND , hDC: HDC, rcItem: RECT, itemData: int } (* Indicates owner-draw control/menu needs redrawing *) | WM_DROPFILES of { hDrop: HDROP } (* Indicates that a file has been dropped *) | WM_ENABLE of { enabled: bool } (* Indicates a Window's enable state is changing *) | WM_ENDSESSION of { endsession: bool } (* Indicates whether the Windows session is ending *) | WM_ENTERIDLE of { flag: int, window: HWND } (* Indicates a modal dialog box or menu is idle *) | WM_ENTERMENULOOP of { istrack: bool } (* Indicates entry into menu modal loop *) | WM_EXITMENULOOP of { istrack: bool } (* Indicates exit from menu modal loop *) | WM_ERASEBKGND of { devicecontext: HDC } (* Indicates a Window's background need erasing *) | WM_FONTCHANGE (* Indicates a change in the font-resource pool *) | WM_GETDLGCODE (* Allows dialog procedure to process control input TODO: This has parameters! *) | WM_GETFONT (* Retrieves the font that a control is using *) | WM_GETHOTKEY (* Gets the virtual-key code of a Window's hot key *) | WM_GETMINMAXINFO of { maxSize: POINT ref, maxPosition: POINT ref, minTrackSize: POINT ref, maxTrackSize: POINT ref } (* Gets minimum and maximum sizing information *) | WM_GETTEXT of { length: int, text: string ref } (* Gets the text that corresponds to a Window *) | WM_GETTEXTLENGTH (* Gets length of text associated with a Window *) | WM_HOTKEY of { id: int } (* Hot key has been detected *) | WM_HSCROLL of { value: ScrollDirection, position: int, scrollbar: HWND } (* Indicates a click in a horizontal scroll bar *) | WM_HSCROLLCLIPBOARD of { viewer: HWND, code: int, position: int } (* Prompts owner to scroll clipboard contents *) | WM_ICONERASEBKGND of { devicecontext: HDC } (* Notifies minimized Window to fill icon background *) | WM_INITDIALOG of { dialog: HWND, initdata: int } (* Initializes a dialog box *) | WM_INITMENU of { menu: HMENU } (* Indicates a menu is about to become active *) | WM_INITMENUPOPUP of { menupopup: HMENU, itemposition: int, isSystemMenu: bool } (* Indicates a pop-up menu is being created *) | WM_KEYDOWN of { virtualKey: int, data: KeyData } (* Indicates a nonsystem key was pressed *) | WM_KEYUP of { virtualKey: int, data: KeyData } (* Indicates a nonsystem key was released *) | WM_KILLFOCUS of { receivefocus: HWND } (* Indicates the Window is losing keyboard focus *) | WM_LBUTTONDBLCLK of { keyflags: MouseKeyFlags list, x: int, y: int } (* Indicates double-click of left button *) | WM_LBUTTONDOWN of { keyflags: MouseKeyFlags list, x: int, y: int } (* Indicates when left mouse button is pressed *) | WM_LBUTTONUP of { keyflags: MouseKeyFlags list, x: int, y: int } (* Indicates when left mouse button is released *) | WM_MBUTTONDBLCLK of { keyflags: MouseKeyFlags list, x: int, y: int } (* Indicates double-click of middle mouse button *) | WM_MBUTTONDOWN of { keyflags: MouseKeyFlags list, x: int, y: int } (* Indicates when middle mouse button is pressed *) | WM_MBUTTONUP of { keyflags: MouseKeyFlags list, x: int, y: int } (* Indicates when middle mouse button is released *) | WM_MDICASCADE of { skipDisabled: bool } (* Arranges MDI child Windows in cascade format *) | WM_MDICREATE of { class: ClassType, title: string, instance: HINSTANCE, x: int, y: int, cx: int, cy: int, style: int, cdata: int } (* Prompts MDI client to create a child Window *) | WM_MDIDESTROY of { child: HWND } (* Closes an MDI child Window *) | WM_MDIGETACTIVE (* Retrieves data about the active MDI child Window *) | WM_MDIICONARRANGE (* Arranges minimized MDI child Windows *) | WM_MDIMAXIMIZE of { child: HWND } (* Maximizes an MDI child Window *) | WM_MDINEXT of { child: HWND, flagnext: bool } (* Activates the next MDI child Window *) | WM_MDIREFRESHMENU (* Refreshes an MDI frame Window's menu *) | WM_MDIRESTORE of { child: HWND } (* Prompts MDI client to restore a child Window *) | WM_MDISETMENU of { frameMenu: HMENU, windowMenu: HMENU } (* Replaces an MDI frame Window's menu *) | WM_MDITILE of { tilingflag: MDITileFlags list } (* Arranges MDI child Windows in tiled format *) | WM_MEASUREITEM of { senderId: int, ctlType: ControlType, ctlID: int, itemID: int, itemWidth: int ref, itemHeight: int ref, itemData: int } (* Requests dimensions of owner-draw control or item *) | WM_MENUCHAR of { ch: char, menuflag: MenuBase.MenuFlag, menu: HMENU } (* Indicates an unknown menu mnemonic was pressed *) | WM_MENUSELECT of { menuitem: int, menuflags: MenuBase.MenuFlag list, menu: HMENU } (* Indicates that the user selected a menu item *) | WM_MOUSEACTIVATE of { parent: HWND, hitTest: HitTest, message: int } (* Indicates a mouse click in an inactive Window *) | WM_MOUSEMOVE of { keyflags: MouseKeyFlags list, x: int, y: int } (* Indicates mouse-cursor movement *) | WM_MOUSEHOVER of { keyflags: MouseKeyFlags list, x: int, y: int } (* Indicates the mouse hovering in the client area *) | WM_MOUSELEAVE (* Indicates the mouse leaving the client area *) | WM_MOVE of { x: int, y: int } (* Indicates a Window's position has changed *) | WM_NCACTIVATE of { active: bool } (* Changes the active state of nonclient area *) | WM_NCCALCSIZE of { validarea: bool, newrect: RECT ref, oldrect: RECT, oldclientarea: RECT, hwnd: HWND, insertAfter: HWND, x: int, y: int, cx: int, cy: int, style: WindowPositionStyle list} (* Calculates the size of a Window's client area *) | WM_NCCREATE of { instance: HINSTANCE, creation: Foreign.Memory.voidStar, menu: HMENU, parent: HWND, cy: int, cx: int, y: int, x: int, style: windowFlags, name: string, class: ClassType, extendedstyle: int } (* Indicates a Window's nonclient area being created *) | WM_NCDESTROY (* Indicates Window's nonclient area being destroyed *) | WM_NCHITTEST of { x: int, y: int } (* Indicates mouse-cursor movement *) | WM_NCLBUTTONDBLCLK of { hitTest: HitTest, x: int, y: int } (* Indicates nonclient left button double-click *) | WM_NCLBUTTONDOWN of { hitTest: HitTest, x: int, y: int } (* Indicates left button pressed in nonclient area *) | WM_NCLBUTTONUP of { hitTest: HitTest, x: int, y: int } (* Indicates left button released in nonclient area *) | WM_NCMBUTTONDBLCLK of { hitTest: HitTest, x: int, y: int } (* Indicates nonclient middle button double-click *) | WM_NCMBUTTONDOWN of { hitTest: HitTest, x: int, y: int } (* Indicates middle button pressed in nonclient area *) | WM_NCMBUTTONUP of { hitTest: HitTest, x: int, y: int } (* Indicates middle button released in nonclient area *) | WM_NCMOUSEMOVE of { hitTest: HitTest, x: int, y: int } (* Indicates mouse-cursor movement in nonclient area *) | WM_NCMOUSEHOVER of { hitTest: HitTest, x: int, y: int } (* Indicates the mouse hovering in the nonclient area *) | WM_NCMOUSELEAVE (* Indicates the mouse leaving the nonclient area *) | WM_NCPAINT of { region: HRGN } (* Indicates a Window's frame needs painting *) | WM_NCRBUTTONDBLCLK of { hitTest: HitTest, x: int, y: int } (* Indicates nonclient right button double-click *) | WM_NCRBUTTONDOWN of { hitTest: HitTest, x: int, y: int } (* Indicates right button pressed in nonclient area *) | WM_NCRBUTTONUP of { hitTest: HitTest, x: int, y: int } (* Indicates right button released in nonclient area *) | WM_NEXTDLGCTL of { control: int, handleflag: bool } (* Sets focus to different dialog box control *) | WM_PAINT (* Indicates a Window's client area need painting *) | WM_PAINTCLIPBOARD of { clipboard: HWND } (* Prompts owner to display clipboard contents *) | WM_PAINTICON (* Icon is about to be painted *) | WM_PALETTECHANGED of { palChg: HWND } (* Indicates the focus-Window realized its palette *) | WM_PALETTEISCHANGING of { realize: HWND } (* Informs Windows that palette is changing *) | WM_PARENTNOTIFY of { eventflag: int, idchild: int, value: int } (* Notifies parent of child-Window activity *) | WM_PASTE (* Inserts clipboard data into an edit control *) | WM_POWER of { powerevent: int } (* Indicates the system is entering suspended mode *) | WM_QUERYDRAGICON (* Requests a cursor handle for a minimized Window *) | WM_QUERYENDSESSION of { source: int } (* Requests that the Windows session be ended *) | WM_QUERYNEWPALETTE (* Allows a Window to realize its logical palette *) | WM_QUERYOPEN (* Requests that a minimized Window be restored *) | WM_QUEUESYNC (* Delimits CBT messages *) | WM_QUIT of { exitcode: int } (* Requests that an application be terminated *) | WM_RBUTTONDBLCLK of { keyflags: MouseKeyFlags list, x: int, y: int } (* Indicates double-click of right mouse button *) | WM_RBUTTONDOWN of { keyflags: MouseKeyFlags list, x: int, y: int } (* Indicates when right mouse button is pressed *) | WM_RBUTTONUP of { keyflags: MouseKeyFlags list, x: int, y: int } (* Indicates when right mouse button is released *) | WM_RENDERALLFORMATS (* Notifies owner to render all clipboard formats *) | WM_RENDERFORMAT of { format: ClipboardFormat } (* Notifies owner to render clipboard data *) | WM_SETCURSOR of { cursorwindow: HWND, hitTest: HitTest, mousemessage: int } (* Prompts a Window to set the cursor shape *) | WM_SETFOCUS of { losing: HWND } | WM_SETFONT of {font: HFONT, redrawflag: bool } | WM_SETHOTKEY of { virtualKey: int } | WM_SETREDRAW of { redrawflag: bool } | WM_SETTEXT of { text: string } | WM_SHOWWINDOW of { showflag: bool, statusflag: int } | WM_SIZE of { flag: WMSizeOptions, width: int, height: int } | WM_SIZECLIPBOARD of { viewer: HWND} | WM_SYSCHAR of { charCode: char, data: KeyData } | WM_SYSCOLORCHANGE | WM_SYSCOMMAND of { commandvalue: SystemCommand, sysBits: int, p: POINT } | WM_SYSDEADCHAR of { charCode: char, data: KeyData } | WM_SYSKEYDOWN of { virtualKey: int, data: KeyData } | WM_SYSKEYUP of { virtualKey: int, data: KeyData } | WM_TIMECHANGE (* Indicates the system time has been set *) | WM_TIMER of { timerid: int } | WM_UNDO | WM_SYSTEM_OTHER of { uMsg: int, wParam: SysWord.word, lParam: SysWord.word } | WM_USER of { uMsg: int, wParam: SysWord.word, lParam: SysWord.word } | WM_APP of { uMsg: int, wParam: SysWord.word, lParam: SysWord.word } | WM_REGISTERED of { uMsg: int, wParam: SysWord.word, lParam: SysWord.word } | WM_VKEYTOITEM of { virtualKey: int, caretpos: int, listbox: HWND } | WM_VSCROLL of { value: ScrollDirection, position: int, scrollbar: HWND } | WM_VSCROLLCLIPBOARD of { viewer: HWND, code: int, position: int } | WM_WINDOWPOSCHANGED of { hwnd: HWND, front: HWND, x: int, y: int, width: int, height: int, flags: WindowPositionStyle list } | WM_WINDOWPOSCHANGING of { hwnd: HWND, front: HWND ref, x: int ref, y: int ref, width: int ref, height: int ref, flags: WindowPositionStyle list ref } | WM_NOTIFY of {from: HWND, idCtrl: int, idFrom: int, notification: Notification } | WM_CAPTURECHANGED of { newCapture: HWND } | WM_ENTERSIZEMOVE | WM_EXITSIZEMOVE | WM_PRINT of {hdc: HDC, flags: WMPrintOption list } | WM_PRINTCLIENT of {hdc: HDC, flags: WMPrintOption list } | WM_HELP of { ctrlId: int, itemHandle: HelpHandle, contextId: int, mousePos: POINT } | WM_GETICON of { big: bool } | WM_SETICON of { big: bool, icon: HICON } | WM_CONTEXTMENU of { hwnd: HWND, xPos: int, yPos: int } | WM_DISPLAYCHANGE of { bitsPerPixel: int, xScreen: int, yScreen: int } | EM_CANUNDO | EM_CHARFROMPOS of EMCharFromPos | EM_EMPTYUNDOBUFFER | EM_FMTLINES of {addEOL: bool} | EM_GETFIRSTVISIBLELINE | EM_GETLIMITTEXT | EM_GETLINE of { lineNo: int, size: int, result: string ref } | EM_GETLINECOUNT | EM_GETMARGINS | EM_GETMODIFY | EM_GETPASSWORDCHAR | EM_GETRECT of {rect: RECT ref} | EM_GETSEL of {startPos: int ref, endPos: int ref} | EM_GETTHUMB | EM_LIMITTEXT of {limit: int} | EM_LINEFROMCHAR of {index: int} | EM_LINEINDEX of {line: int} | EM_LINELENGTH of {index: int} | EM_LINESCROLL of {xScroll: int, yScroll: int} | EM_POSFROMCHAR of {index: int} | EM_REPLACESEL of {canUndo: bool, text: string} | EM_SCROLL of {action: ScrollDirection} | EM_SCROLLCARET | EM_SETMARGINS of {margins: MarginSettings} | EM_SETMODIFY of { modified: bool } | EM_SETPASSWORDCHAR of { ch: char } | EM_SETREADONLY of { readOnly: bool } | EM_SETRECT of {rect: RECT} | EM_SETRECTNP of {rect: RECT} | EM_SETSEL of {startPos: int, endPos: int} | EM_SETTABSTOPS of {tabs: IntVector.vector} | EM_UNDO | BM_CLICK | BM_GETCHECK | BM_GETIMAGE of {imageType: ImageType} | BM_GETSTATE | BM_SETCHECK of {state: int} | BM_SETIMAGE of {image: HGDIOBJ, imageType: ImageType} | BM_SETSTATE of {highlight: bool } | BM_SETSTYLE of {redraw: bool, style: windowFlags} | CB_GETEDITSEL of {startPos: int ref, endPos: int ref} | CB_LIMITTEXT of {limit: int} | CB_SETEDITSEL of {startPos: int, endPos: int} | CB_ADDSTRING of { text: string } | CB_DELETESTRING of { index: int } | CB_GETCOUNT | CB_GETCURSEL | CB_DIR of { attrs: ComboBase.CBDirAttr list, fileSpec: string } | CB_GETLBTEXT of { index: int, length: int, text: string ref } | CB_GETLBTEXTLEN of { index: int } | CB_INSERTSTRING of { index: int, text: string } | CB_RESETCONTENT | CB_FINDSTRING of { indexStart: int, text: string } | CB_SELECTSTRING of { indexStart: int, text: string } | CB_SETCURSEL of { index: int } | CB_SHOWDROPDOWN of { show: bool } | CB_GETITEMDATA of { index: int } | CB_SETITEMDATA of { index: int, data: int } | CB_GETDROPPEDCONTROLRECT of { rect: RECT ref } | CB_SETITEMHEIGHT of { index: int, height: int } | CB_GETITEMHEIGHT of { index: int } | CB_SETEXTENDEDUI of { extended: bool } | CB_GETEXTENDEDUI | CB_GETDROPPEDSTATE | CB_FINDSTRINGEXACT of { indexStart: int, text: string } | CB_SETLOCALE of { locale: int } | CB_GETLOCALE | CB_GETTOPINDEX | CB_SETTOPINDEX of { index: int } | CB_GETHORIZONTALEXTENT | CB_SETHORIZONTALEXTENT of { extent: int } | CB_GETDROPPEDWIDTH | CB_SETDROPPEDWIDTH of { width: int } | CB_INITSTORAGE of { items: int, bytes: int } | LB_ADDSTRING of { text: string } | LB_INSERTSTRING of { index: int, text: string } | LB_DELETESTRING of { index: int } | LB_SELITEMRANGEEX of { first: int, last: int } | LB_RESETCONTENT | LB_SETSEL of { select: bool, index: int } | LB_SETCURSEL of { index: int } | LB_GETSEL of { index: int } | LB_GETCURSEL | LB_GETTEXT of { index: int, length: int, text: string ref } | LB_GETTEXTLEN of { index: int } | LB_GETCOUNT | LB_SELECTSTRING of { indexStart: int, text: string } | LB_DIR of { attrs: ComboBase.CBDirAttr list, fileSpec: string } | LB_GETTOPINDEX | LB_FINDSTRING of { indexStart: int, text: string } | LB_GETSELCOUNT | LB_GETSELITEMS of { items: IntArray.array } | LB_SETTABSTOPS of { tabs: IntVector.vector } | LB_GETHORIZONTALEXTENT | LB_SETHORIZONTALEXTENT of { extent: int } | LB_SETCOLUMNWIDTH of { column: int } | LB_ADDFILE of { fileName: string } | LB_SETTOPINDEX of { index: int } | LB_GETITEMRECT of { rect: RECT ref, index: int } | LB_GETITEMDATA of { index: int } | LB_SETITEMDATA of { index: int, data: int } | LB_SELITEMRANGE of { select: bool, first: int, last: int } | LB_SETANCHORINDEX of { index: int } | LB_GETANCHORINDEX | LB_SETCARETINDEX of { index: int, scroll: bool } | LB_GETCARETINDEX | LB_SETITEMHEIGHT of { index: int, height: int } | LB_GETITEMHEIGHT of { index: int } | LB_FINDSTRINGEXACT of { indexStart: int, text: string } | LB_SETLOCALE of { locale: int } (* Should be an abstract type? *) | LB_GETLOCALE (* Result will be the type used above. *) | LB_SETCOUNT of { items: int } | LB_INITSTORAGE of { items: int, bytes: int } | LB_ITEMFROMPOINT of { point: POINT } | STM_GETICON | STM_GETIMAGE of {imageType: ImageType} | STM_SETICON of {icon: HICON} | STM_SETIMAGE of {image: HGDIOBJ, imageType: ImageType} | SBM_SETPOS of { pos: int, redraw: bool } | SBM_GETPOS | SBM_SETRANGE of { minPos: int, maxPos: int } | SBM_SETRANGEREDRAW of { minPos: int, maxPos: int } | SBM_GETRANGE of { minPos: int ref, maxPos: int ref } | SBM_ENABLE_ARROWS of ScrollBase.enableArrows | SBM_SETSCROLLINFO of { info: ScrollBase.SCROLLINFO, options: ScrollBase.ScrollInfoOption list } | SBM_GETSCROLLINFO of { info: ScrollBase.SCROLLINFO ref, options: ScrollBase.ScrollInfoOption list } | FINDMSGSTRING of { flags: findReplaceFlags, findWhat: string, replaceWith: string } (* GetMessage and PeekMessage return these values. *) type MSG = { msg: Message, hwnd: HWND, time: Time.time, pt: {x: int, y: int} } type HGDIOBJ = HGDIOBJ and HWND = HWND and RECT = RECT and POINT = POINT and HMENU = HMENU and HICON = HICON and HINSTANCE = HINSTANCE and HDC = HDC and HFONT = HFONT and HRGN = HRGN and HDROP = HDROP and ClipboardFormat = ClipboardFormat and ClassType = ClassType and findReplaceFlags = FindReplaceFlags.flags and windowFlags = flags (* WM_MOUSEMOVE etc *) fun decompileMouseMove(constr, wp, lp) = let val lp32 = Word32.fromLargeWord lp in constr { keyflags = fromCmkf(Word32.fromLargeWord wp), x = Word.toInt(LOWORD lp32), y = Word.toInt(HIWORD lp32) } end fun compileMouseMove(code, { keyflags, x, y}) = (code, Word32.toLargeWord (toCmkf keyflags), Word32.toLargeWord(MAKELONG(Word.fromInt x, Word.fromInt y)), fn()=>()) local (* EM_GETSEL and CB_GETEDITSEL *) val {load=loadDword, store=storeDword, ctype={size=sizeDword, ...}, ...} = breakConversion cDWORD in fun compileGetSel(code, {startPos=ref s, endPos=ref e}) = let open Memory infix 6 ++ (* Allocate space for two DWORDs *) val mem = malloc(sizeDword * 0w2) val eAddr = mem ++ sizeDword val () = ignore(storeDword(mem, s)) (* Can ignore the results *) and () = ignore(storeDword(eAddr, e)) in (code, fromAddr mem, fromAddr eAddr, fn () => free mem) end and decompileGetSel{wp, lp} = let val s = loadDword(toAddr wp) and e = loadDword(toAddr lp) in {startPos = ref s, endPos=ref e} end (* Update ML from wp/lp values *) fun updateGetSelFromWpLp({startPos, endPos}, {wp, lp}) = ( startPos := loadDword(toAddr wp); endPos := loadDword(toAddr lp) ) (* Update wp/lp from ML *) and updateGetSelParms({wp, lp}, {startPos = ref s, endPos = ref e}) = ( ignore(storeDword(toAddr wp, s)); ignore(storeDword(toAddr lp, e)) ) end local (* EM_GETRECT and CB_GETDROPPEDCONTROLRECT. LB_GETITEMRECT and WM_NCCALCSIZE are similar *) val {load=loadRect, store=storeRect, ctype={size=sizeRect, ...}, ...} = breakConversion cRect in fun compileGetRect(code, wp, r) = let open Memory val mem = malloc sizeRect val () = ignore(storeRect(mem, r)) (* Can ignore the result *) in (code, wp, fromAddr mem, fn () => free mem) end and compileSetRect(code, rect) = let open Memory val mem = malloc sizeRect val () = ignore(storeRect(mem, rect)) in (code, 0w0, fromAddr mem, fn () => free mem) end (* These can be used for updating *) val fromCrect = loadRect (* For the moment *) and toCrect = ignore o storeRect end val hiWord = Word.toInt o HIWORD o Word32.fromLargeWord and loWord = Word.toInt o LOWORD o Word32.fromLargeWord (* Decode a received message. *) fun decompileMessage (0x0000, _: SysWord.word, _: SysWord.word) = WM_NULL | decompileMessage (0x0001, wp, lp) = WM_CREATE(decompileCreate{wp=wp, lp=lp}) | decompileMessage (0x0002, _, _) = WM_DESTROY | decompileMessage (0x0003, _, lp) = WM_MOVE { x = loWord lp, y = hiWord lp } | decompileMessage (0x0005, wp, lp) = WM_SIZE { flag = toWMSizeOpt wp, width = loWord lp, height = hiWord lp } | decompileMessage (0x0006, wp, _) = let val wp32 = Word32.fromLargeWord wp in WM_ACTIVATE { active = toWMactive (LOWORD wp32), minimize = HIWORD wp32 <> 0w0 } end | decompileMessage (0x0007, wp, _) = WM_SETFOCUS { losing = handleOfVoidStar(toAddr wp) } | decompileMessage (0x0008, wp, _) = WM_KILLFOCUS { receivefocus = handleOfVoidStar(toAddr wp) } | decompileMessage (0x000A, wp, _) = WM_ENABLE { enabled = wp <> 0w0 } | decompileMessage (0x000B, wp, _) = WM_SETREDRAW { redrawflag = wp <> 0w0 } | decompileMessage (0x000C, _, lp) = WM_SETTEXT { text = fromCstring(toAddr lp) } (* When the message arrives we don't know what the text is. *) | decompileMessage (0x000D, wp, _) = WM_GETTEXT { length = SysWord.toInt wp, text = ref "" } | decompileMessage ( 0x000E, _, _) = WM_GETTEXTLENGTH | decompileMessage ( 0x000F, _, _) = WM_PAINT | decompileMessage ( 0x0010, _, _) = WM_CLOSE | decompileMessage ( 0x0011, wp, _) = WM_QUERYENDSESSION { source = SysWord.toInt wp } | decompileMessage (0x0012, wp, _) = WM_QUIT {exitcode = SysWord.toInt wp } | decompileMessage ( 0x0013, _, _) = WM_QUERYOPEN | decompileMessage ( 0x0014, wp, _) = WM_ERASEBKGND { devicecontext = toHDC wp } | decompileMessage ( 0x0015, _, _) = WM_SYSCOLORCHANGE | decompileMessage ( 0x0016, wp, _) = WM_ENDSESSION { endsession = wp <> 0w0 } | decompileMessage ( 0x0018, wp, lp) = WM_SHOWWINDOW { showflag = wp <> 0w0, statusflag = SysWord.toInt lp } | decompileMessage ( 0x001B, _, lp) = WM_DEVMODECHANGE { devicename = fromCstring(toAddr lp) } (* "0x001B" *) | decompileMessage ( 0x001C, wp, lp) = WM_ACTIVATEAPP { active = wp <> 0w0, threadid = SysWord.toInt lp } (* "0x001C" *) | decompileMessage ( 0x001D, _, _) = WM_FONTCHANGE | decompileMessage ( 0x001E, _, _) = WM_TIMECHANGE (* "0x001E" *) | decompileMessage ( 0x001F, _, _) = WM_CANCELMODE (* "0x001F" *) | decompileMessage ( 0x0020, wp, lp) = WM_SETCURSOR { cursorwindow = toHWND wp, hitTest = toHitTest(loWord lp), mousemessage = hiWord lp } | decompileMessage ( 0x0021, wp, lp) = WM_MOUSEACTIVATE { parent = toHWND wp, hitTest = toHitTest(loWord lp), message = hiWord lp } | decompileMessage (0x0022, _, _) = WM_CHILDACTIVATE (* "0x0022" *) | decompileMessage (0x0023, _, _) = WM_QUEUESYNC (* "0x0023" *) | decompileMessage (0x0024, wp, lp) = WM_GETMINMAXINFO(decompileMinMax{lp=lp, wp=wp}) | decompileMessage ( 0x0026, _, _) = WM_PAINTICON | decompileMessage ( 0x0027, wp, _) = WM_ICONERASEBKGND { devicecontext = toHDC wp } (* "0x0027" *) | decompileMessage ( 0x0028, wp, lp) = WM_NEXTDLGCTL { control = SysWord.toInt wp, handleflag = lp <> 0w0 } (* "0x0028" *) | decompileMessage (0x002B, wp, lp) = let val (ctlType,ctlID,itemID,itemAction,itemState,hItem,hDC, rcItem,itemData) = toMLDrawItem lp in WM_DRAWITEM{ senderId = SysWord.toInt wp, ctlType = ctlType, ctlID = ctlID, itemID = itemID, itemAction = itemAction, itemState = itemState, hItem = hItem, hDC = hDC, rcItem = rcItem, itemData = itemData } end | decompileMessage (0x002C, wp, lp) = let val (ctlType,ctlID,itemID, itemWidth,itemHeight,itemData) = toMLMeasureItem lp in WM_MEASUREITEM { senderId = SysWord.toInt wp, ctlType = ctlType, ctlID = ctlID, itemID = itemID, itemWidth = ref itemWidth, itemHeight = ref itemHeight, itemData = itemData } end | decompileMessage (0x002D, wp, lp) = let val (ctlType,ctlID,itemID,hItem,itemData) = toMLDeleteItem lp in WM_DELETEITEM { senderId = SysWord.toInt wp, ctlType = ctlType, ctlID = ctlID, itemID = itemID, item = hItem, itemData = itemData } end | decompileMessage ( 0x002E, wp, lp) = WM_VKEYTOITEM { virtualKey = loWord wp, caretpos = hiWord wp, listbox = toHWND lp } (* "0x002E" *) | decompileMessage ( 0x002F, wp, lp) = WM_CHARTOITEM { key = loWord wp, caretpos = hiWord wp,listbox = toHWND lp } (* "0x002F" *) | decompileMessage ( 0x0030, wp, lp) = (* The definition of WM_SETFONT says that it is the low order word of lp that says whether the control should be redrawn immediately. *) WM_SETFONT { font = toHFONT wp, redrawflag = SysWord.andb(0wxffff, lp) <> 0w0 } (* "0x0030" *) | decompileMessage ( 0x0031, _, _) = WM_GETFONT (* "0x0031" *) | decompileMessage ( 0x0032, wp, _) = WM_SETHOTKEY { virtualKey = SysWord.toInt wp } (* "0x0032" *) | decompileMessage ( 0x0033, _, _) = WM_GETHOTKEY (* "0x0033" *) | decompileMessage ( 0x0037, _, _) = WM_QUERYDRAGICON (* "0x0037" *) | decompileMessage (0x0039, wp, lp) = let val (ctlType, ctlID, hItem, itemID1, itemData1, itemID2, itemData2, _) = toMLCompareItem lp in WM_COMPAREITEM { controlid = SysWord.toInt wp, ctlType = ctlType, ctlID = ctlID, hItem = hItem, itemID1 = itemID1, itemData1 = itemData1, itemID2 = itemID2, itemData2 = itemData2 } end | decompileMessage (0x0046, wp, lp) = WM_WINDOWPOSCHANGING(cToMLWindowPosChanging{wp=wp, lp=lp}) | decompileMessage (0x0047, wp, lp) = WM_WINDOWPOSCHANGED(cToMLWindowPosChanged{wp=wp, lp=lp}) | decompileMessage ( 0x0048, wp, _) = WM_POWER { powerevent = SysWord.toInt wp } (* "0x0048" *) | decompileMessage ( 0x004B, _, _) = WM_CANCELJOURNAL (* "0x004B" *) | decompileMessage ( 0x004E, wp, lp) = WM_NOTIFY(decompileNotify{wp=wp, lp=lp}) | decompileMessage ( 0x0053, wp, lp) = WM_HELP(decompileHelpInfo{wp=wp, lp=lp}) (* WM_INPUTLANGCHANGEREQUEST 0x0050 WM_INPUTLANGCHANGE 0x0051 WM_TCARD 0x0052 WM_USERCHANGED 0x0054 WM_NOTIFYFORMAT 0x0055 NFR_ANSI 1 NFR_UNICODE 2 NF_QUERY 3 NF_REQUERY 4 WM_CONTEXTMENU 0x007B WM_STYLECHANGING 0x007C WM_STYLECHANGED 0x007D *) | decompileMessage ( 0x007B, wp, lp) = WM_CONTEXTMENU { hwnd = toHWND wp, xPos = loWord lp, yPos = hiWord lp} | decompileMessage ( 0x007E, wp, lp) = WM_DISPLAYCHANGE { bitsPerPixel = SysWord.toInt wp, xScreen = loWord lp, yScreen = hiWord lp} | decompileMessage ( 0x007F, wp, _) = WM_GETICON { big = SysWord.toInt wp = 1} | decompileMessage ( 0x0080, wp, lp) = WM_SETICON { big = SysWord.toInt wp = 1, icon = toHICON lp} | decompileMessage ( 0x0081, wp, lp) = WM_NCCREATE(decompileCreate{wp=wp, lp=lp}) | decompileMessage ( 0x0082, _, _) = WM_NCDESTROY | decompileMessage ( 0x0083, wp, lp) = WM_NCCALCSIZE(decompileNCCalcSize{wp=wp, lp=lp}) | decompileMessage ( 0x0084, _, lp) = WM_NCHITTEST { x = loWord lp, y = hiWord lp } (* "0x0084" *) | decompileMessage ( 0x0085, wp, _) = WM_NCPAINT { region = toHRGN wp } (* "0x0085" *) | decompileMessage ( 0x0086, wp, _) = WM_NCACTIVATE { active = wp <> 0w0 } (* "0x0086" *) | decompileMessage ( 0x0087, _, _) = WM_GETDLGCODE (* "0x0087" *) | decompileMessage ( 0x00A0, wp, lp) = WM_NCMOUSEMOVE { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } | decompileMessage ( 0x00A1, wp, lp) = WM_NCLBUTTONDOWN { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } | decompileMessage ( 0x00A2, wp, lp) = WM_NCLBUTTONUP { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } | decompileMessage ( 0x00A3, wp, lp) = WM_NCLBUTTONDBLCLK { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } | decompileMessage ( 0x00A4, wp, lp) = WM_NCRBUTTONDOWN { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } | decompileMessage ( 0x00A5, wp, lp) = WM_NCRBUTTONUP { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } | decompileMessage ( 0x00A6, wp, lp) = WM_NCRBUTTONDBLCLK { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } | decompileMessage ( 0x00A7, wp, lp) = WM_NCMBUTTONDOWN { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } | decompileMessage ( 0x00A8, wp, lp) = WM_NCMBUTTONUP { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } | decompileMessage ( 0x00A9, wp, lp) = WM_NCMBUTTONDBLCLK { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } (* Edit control messages *) | decompileMessage ( 0x00B0, wp, lp) = EM_GETSEL (decompileGetSel{wp=wp, lp=lp}) | decompileMessage ( 0x00B1, wp, lp) = EM_SETSEL { startPos = SysWord.toInt wp, endPos = SysWord.toInt lp } | decompileMessage ( 0x00B2, _, lp) = EM_GETRECT {rect = ref(fromCrect(toAddr lp))} | decompileMessage ( 0x00B3, _, lp) = EM_SETRECT { rect = fromCrect(toAddr lp) } | decompileMessage ( 0x00B4, _, lp) = EM_SETRECTNP { rect = fromCrect(toAddr lp) } | decompileMessage ( 0x00B5, wp, _) = EM_SCROLL{action = fromCsd(Word.fromLargeWord wp)} | decompileMessage ( 0x00B6, wp, lp) = EM_LINESCROLL{xScroll = SysWord.toInt wp, yScroll = SysWord.toInt lp} | decompileMessage ( 0x00B7, _, _) = EM_SCROLLCARET | decompileMessage ( 0x00B8, _, _) = EM_GETMODIFY | decompileMessage ( 0x00B9, wp, _) = EM_SETMODIFY{modified = wp <> 0w0} | decompileMessage ( 0x00BA, _, _) = EM_GETLINECOUNT | decompileMessage ( 0x00BB, wp, _) = EM_LINEINDEX {line = SysWord.toIntX (* -1 = current line *) wp} (* EM_SETHANDLE 0x00BC *) | decompileMessage ( 0x00BE, _, _) = EM_GETTHUMB | decompileMessage ( 0x00C1, wp, _) = EM_LINELENGTH {index = SysWord.toIntX (* May be -1 *) wp} | decompileMessage ( 0x00C2, wp, lp) = EM_REPLACESEL {canUndo = wp <> 0w0, text = fromCstring(toAddr lp)} | decompileMessage ( 0x00C4, wp, lp) = EM_GETLINE(decompileGetLine{wp=wp, lp=lp}) | decompileMessage ( 0x00C5, wp, _) = EM_LIMITTEXT {limit = SysWord.toInt wp} | decompileMessage ( 0x00C6, _, _) = EM_CANUNDO | decompileMessage ( 0x00C7, _, _) = EM_UNDO | decompileMessage ( 0x00C8, wp, _) = EM_FMTLINES{addEOL = wp <> 0w0} | decompileMessage ( 0x00C9, wp, _) = EM_LINEFROMCHAR{index = SysWord.toInt wp} | decompileMessage ( 0x00CB, wp, lp) = EM_SETTABSTOPS{tabs=decompileTabStops{wp=wp, lp=lp}} | decompileMessage ( 0x00CC, wp, _) = EM_SETPASSWORDCHAR{ch = chr (SysWord.toInt wp)} | decompileMessage ( 0x00CD, _, _) = EM_EMPTYUNDOBUFFER | decompileMessage ( 0x00CE, _, _) = EM_GETFIRSTVISIBLELINE | decompileMessage ( 0x00CF, wp, _) = EM_SETREADONLY{readOnly = wp <> 0w0} (* EM_SETWORDBREAKPROC 0x00D0 EM_GETWORDBREAKPROC 0x00D1 *) | decompileMessage (0x00D2, _, _) = EM_GETPASSWORDCHAR | decompileMessage (0x00D3, wp, lp) = if wp = 0wxffff then EM_SETMARGINS{margins=UseFontInfo} else let val left = if SysWord.andb(wp, 0w1) <> 0w0 then SOME(loWord lp) else NONE val right = if SysWord.andb(wp, 0w2) <> 0w0 then SOME(hiWord lp) else NONE in EM_SETMARGINS{margins=Margins{left=left, right=right}} end | decompileMessage (0x00D4, _, _) = EM_GETMARGINS | decompileMessage (0x00D5, _, _) = EM_GETLIMITTEXT | decompileMessage (0x00D6, wp, _) = EM_POSFROMCHAR {index = SysWord.toInt wp} | decompileMessage (0x00D7, _, lp) = (* The value in lParam is different depending on whether this is an edit control or a rich edit control. Since we don't know we just pass the lp value. *) EM_CHARFROMPOS(EMcfpUnknown lp) (* Scroll bar messages *) | decompileMessage (0x00E0, wp, lp) = SBM_SETPOS {pos = SysWord.toInt wp, redraw = lp <> 0w0} | decompileMessage (0x00E1, _, _) = SBM_GETPOS | decompileMessage (0x00E2, wp, lp) = SBM_SETRANGE {minPos = SysWord.toInt wp, maxPos = SysWord.toInt lp} | decompileMessage (0x00E6, wp, lp) = SBM_SETRANGEREDRAW {minPos = SysWord.toInt wp, maxPos = SysWord.toInt lp} | decompileMessage (0x00E3, wp, lp) = SBM_GETRANGE { minPos = ref(loadInt(toAddr wp)), maxPos = ref(loadInt(toAddr lp)) } | decompileMessage (0x00E4, wp, _) = SBM_ENABLE_ARROWS(fromCesbf(SysWord.toInt wp)) | decompileMessage (0x00E9, _, lp) = let val (info, options) = toScrollInfo lp in SBM_SETSCROLLINFO{ info = info, options = options } end | decompileMessage (0x00EA, _, lp) = let (* The values may not be correct at this point but the mask should have been set. *) val (info, options) = toScrollInfo lp in SBM_GETSCROLLINFO{ info = ref info, options = options } end (* Button control messages *) | decompileMessage (0x00F0, _, _) = BM_GETCHECK | decompileMessage (0x00F1, wp, _) = BM_SETCHECK{state = SysWord.toInt wp} | decompileMessage (0x00F2, _, _) = BM_GETSTATE | decompileMessage (0x00F3, wp, _) = BM_SETSTATE{highlight = SysWord.toInt wp <> 0} | decompileMessage (0x00F4, wp, lp) = BM_SETSTYLE{redraw = SysWord.toInt lp <> 0, style = Style.fromWord wp} | decompileMessage (0x00F5, _, _) = BM_CLICK | decompileMessage (0x00F6, wp, _) = BM_GETIMAGE{imageType = fromCit(SysWord.toInt wp)} | decompileMessage (0x00F7, wp, lp) = BM_SETIMAGE{imageType = fromCit (SysWord.toInt wp), image = toHGDIOBJ lp} | decompileMessage (0x0100, wp, lp) = WM_KEYDOWN { virtualKey = SysWord.toInt wp, data = Word32.fromLargeWord lp } | decompileMessage (0x0101, wp, lp) = WM_KEYUP { virtualKey = SysWord.toInt wp, data = Word32.fromLargeWord lp } | decompileMessage (0x0102, wp, lp) = WM_CHAR { charCode = chr (SysWord.toInt wp), data = Word32.fromLargeWord lp } | decompileMessage (0x0103, wp, lp) = WM_DEADCHAR { charCode = chr (SysWord.toInt wp), data = Word32.fromLargeWord lp } | decompileMessage (0x0104, wp, lp) = WM_SYSKEYDOWN { virtualKey = SysWord.toInt wp, data = Word32.fromLargeWord lp } | decompileMessage (0x0105, wp, lp) = WM_SYSKEYUP { virtualKey = SysWord.toInt wp, data = Word32.fromLargeWord lp } | decompileMessage (0x0106, wp, lp) = WM_SYSCHAR { charCode = chr (SysWord.toInt wp), data = Word32.fromLargeWord lp } | decompileMessage (0x0107, wp, lp) = WM_SYSDEADCHAR { charCode = chr (SysWord.toInt wp), data = Word32.fromLargeWord lp } (* WM_IME_STARTCOMPOSITION 0x010D WM_IME_ENDCOMPOSITION 0x010E WM_IME_COMPOSITION 0x010F WM_IME_KEYLAST 0x010F *) | decompileMessage (0x0110, wp, lp) = WM_INITDIALOG { dialog = toHWND wp, initdata = SysWord.toInt lp } (* "0x0110" *) | decompileMessage (0x0111, wp, lp) = let val wp32 = Word32.fromLargeWord wp in WM_COMMAND { notifyCode = Word.toInt(HIWORD wp32), wId = Word.toInt(LOWORD wp32), control = toHWND lp } end | decompileMessage (0x0112, wp, lp) = WM_SYSCOMMAND { commandvalue = toSysCommand(SysWord.toInt(SysWord.andb(wp, 0wxFFF0))), sysBits = SysWord.toInt(SysWord.andb(wp, 0wxF)), p = {x= getXLParam lp, y= getYLParam lp}} | decompileMessage (0x0113, wp, _) = WM_TIMER { timerid = SysWord.toInt wp } (* "0x0113" *) | decompileMessage (0x0114, wp, lp) = WM_HSCROLL { value = fromCsd(LOWORD(Word32.fromLargeWord wp)), position = hiWord wp, scrollbar = toHWND lp } (* "0x0114" *) | decompileMessage (0x0115, wp, lp) = WM_VSCROLL { value = fromCsd(LOWORD(Word32.fromLargeWord wp)), position = hiWord wp, scrollbar = toHWND lp } (* "0x0115" *) | decompileMessage (0x0116, wp, _) = WM_INITMENU { menu = toHMENU wp } (* "0x0116" *) | decompileMessage (0x0117, wp, lp) = WM_INITMENUPOPUP { menupopup = toHMENU wp, itemposition = loWord lp, isSystemMenu = hiWord lp <> 0 } (* "0x0117" *) | decompileMessage (0x011F, wp, lp) = let val wp32 = Word32.fromLargeWord wp in WM_MENUSELECT { menuitem = Word.toInt(LOWORD wp32), menuflags = MenuBase.toMenuFlagSet(Word32.fromLargeWord(Word.toLargeWord(Word.andb(HIWORD wp32, 0wxffff)))), menu = toHMENU lp } (* "0x011F" *) end | decompileMessage (0x0120, wp, lp) = let val wp32 = Word32.fromLargeWord wp in WM_MENUCHAR { ch = chr(Word.toInt(LOWORD wp32)), menuflag = (* Just a single flag *) MenuBase.toMenuFlag(Word32.fromLargeWord(Word.toLargeWord(Word.andb(HIWORD wp32, 0wxffff)))), menu= toHMENU lp } (* "0x0120" *) end | decompileMessage (0x0121, wp, lp) = WM_ENTERIDLE { flag = SysWord.toInt wp, window = toHWND lp } (* "0x0121" *) | decompileMessage (0x0132, wp, lp) = WM_CTLCOLORMSGBOX { displaycontext = toHDC wp, messagebox = toHWND lp } (* "0x0132" *) | decompileMessage (0x0133, wp, lp) = WM_CTLCOLOREDIT { displaycontext = toHDC wp, editcontrol = toHWND lp } (* "0x0133" *) | decompileMessage (0x0134, wp, lp) = WM_CTLCOLORLISTBOX { displaycontext = toHDC wp, listbox = toHWND lp } (* "0x0134" *) | decompileMessage (0x0135, wp, lp) = WM_CTLCOLORBTN { displaycontext = toHDC wp, button = toHWND lp }(* "0x0135" *) | decompileMessage (0x0136, wp, lp) = WM_CTLCOLORDLG { displaycontext = toHDC wp, dialogbox = toHWND lp } (* "0x0136" *) | decompileMessage (0x0137, wp, lp) = WM_CTLCOLORSCROLLBAR { displaycontext = toHDC wp, scrollbar = toHWND lp } (* "0x0137" *) | decompileMessage (0x0138, wp, lp) = WM_CTLCOLORSTATIC { displaycontext = toHDC wp, staticcontrol = toHWND lp } (* "0x0138" *) (* Combobox messages. *) | decompileMessage (0x0140, wp, lp) = CB_GETEDITSEL (decompileGetSel{wp=wp, lp=lp}) | decompileMessage (0x0141, wp, _) = CB_LIMITTEXT {limit = SysWord.toInt wp} | decompileMessage (0x0142, _, lp) = CB_SETEDITSEL { startPos = loWord lp, endPos = hiWord lp } | decompileMessage (0x0143, _, lp) = CB_ADDSTRING {text = fromCstring(toAddr lp) } | decompileMessage (0x0144, wp, _) = CB_DELETESTRING {index = SysWord.toInt wp} | decompileMessage (0x0145, wp, lp) = CB_DIR {attrs = fromCcbal(Word32.fromLargeWord wp), fileSpec = fromCstring(toAddr lp) } | decompileMessage (0x0146, _, _) = CB_GETCOUNT | decompileMessage (0x0147, _, _) = CB_GETCURSEL | decompileMessage (0x0148, wp, _) = CB_GETLBTEXT { index = SysWord.toInt wp, length = 0, text = ref "" } | decompileMessage (0x0149, wp, _) = CB_GETLBTEXTLEN {index = SysWord.toInt wp} | decompileMessage (0x014A, wp, lp) = CB_INSERTSTRING {text = fromCstring(toAddr lp), index = SysWord.toInt wp } | decompileMessage (0x014B, _, _) = CB_RESETCONTENT | decompileMessage (0x014C, wp, lp) = CB_FINDSTRING {text = fromCstring(toAddr lp), indexStart = SysWord.toInt wp } | decompileMessage (0x014D, wp, lp) = CB_SELECTSTRING {text = fromCstring(toAddr lp), indexStart = SysWord.toInt wp } | decompileMessage (0x014E, wp, _) = CB_SETCURSEL {index = SysWord.toInt wp} | decompileMessage (0x014F, wp, _) = CB_SHOWDROPDOWN {show = wp <> 0w0} | decompileMessage (0x0150, wp, _) = CB_GETITEMDATA {index = SysWord.toInt wp} | decompileMessage (0x0151, wp, lp) = CB_SETITEMDATA {index = SysWord.toInt wp, data = SysWord.toInt lp} | decompileMessage (0x0152, _, lp) = CB_GETDROPPEDCONTROLRECT {rect = ref(fromCrect(toAddr lp))} | decompileMessage (0x0153, wp, lp) = CB_SETITEMHEIGHT {index = SysWord.toInt wp, height = SysWord.toInt lp} | decompileMessage (0x0154, wp, _) = CB_GETITEMHEIGHT {index = SysWord.toInt wp} | decompileMessage (0x0155, wp, _) = CB_SETEXTENDEDUI {extended = wp <> 0w0} | decompileMessage (0x0156, _, _) = CB_GETEXTENDEDUI | decompileMessage (0x0157, _, _) = CB_GETDROPPEDSTATE | decompileMessage (0x0158, wp, lp) = CB_FINDSTRINGEXACT {text = fromCstring(toAddr lp), indexStart = SysWord.toInt wp } | decompileMessage (0x0159, wp, _) = CB_SETLOCALE {locale = SysWord.toInt wp} | decompileMessage (0x015A, _, _) = CB_GETLOCALE | decompileMessage (0x015b, _, _) = CB_GETTOPINDEX | decompileMessage (0x015c, wp, _) = CB_SETTOPINDEX {index = SysWord.toInt wp} | decompileMessage (0x015d, _, _) = CB_GETHORIZONTALEXTENT | decompileMessage (0x015e, wp, _) = CB_SETHORIZONTALEXTENT {extent = SysWord.toInt wp} | decompileMessage (0x015f, _, _) = CB_GETDROPPEDWIDTH | decompileMessage (0x0160, wp, _) = CB_SETDROPPEDWIDTH {width = SysWord.toInt wp} | decompileMessage (0x0161, wp, lp) = CB_INITSTORAGE {items = SysWord.toInt wp, bytes = SysWord.toInt lp} (* Static control messages. *) | decompileMessage (0x0170, wp, _) = STM_SETICON{icon = toHICON wp} | decompileMessage (0x0171, _, _) = STM_GETICON | decompileMessage (0x0172, wp, lp) = STM_SETIMAGE{imageType = fromCit(SysWord.toInt wp), image = toHGDIOBJ lp} | decompileMessage (0x0173, wp, _) = STM_GETIMAGE{imageType = fromCit(SysWord.toInt wp)} (* Listbox messages *) | decompileMessage (0x0180, _, lp) = LB_ADDSTRING {text = fromCstring(toAddr lp) } | decompileMessage (0x0181, wp, lp) = LB_INSERTSTRING {text = fromCstring(toAddr lp), index = SysWord.toInt wp } | decompileMessage (0x0182, wp, _) = LB_DELETESTRING {index = SysWord.toInt wp} | decompileMessage (0x0183, wp, lp) = LB_SELITEMRANGEEX {first = SysWord.toInt wp, last = SysWord.toInt lp} | decompileMessage (0x0184, _, _) = LB_RESETCONTENT | decompileMessage (0x0185, wp, lp) = LB_SETSEL {select = wp <> 0w0, index = SysWord.toInt lp} | decompileMessage (0x0186, wp, _) = LB_SETCURSEL {index = SysWord.toInt wp} | decompileMessage (0x0187, wp, _) = LB_GETSEL {index = SysWord.toInt wp} | decompileMessage (0x0188, _, _) = LB_GETCURSEL | decompileMessage (0x0189, wp, _) = LB_GETTEXT { index = SysWord.toInt wp, length = 0, text = ref "" } | decompileMessage (0x018A, wp, _) = LB_GETTEXTLEN {index = SysWord.toInt wp} | decompileMessage (0x018B, _, _) = LB_GETCOUNT | decompileMessage (0x018C, wp, lp) = LB_SELECTSTRING {text = fromCstring(toAddr lp), indexStart = SysWord.toInt wp } | decompileMessage (0x018D, wp, lp) = LB_DIR {attrs = fromCcbal(Word32.fromLargeWord wp), fileSpec = fromCstring(toAddr lp) } | decompileMessage (0x018E, _, _) = LB_GETTOPINDEX | decompileMessage (0x018F, wp, lp) = LB_FINDSTRING {text = fromCstring(toAddr lp), indexStart = SysWord.toInt wp } | decompileMessage (0x0190, _, _) = LB_GETSELCOUNT | decompileMessage (0x0191, wp, _) = LB_GETSELITEMS { items = IntArray.array(SysWord.toInt wp, ~1) } | decompileMessage (0x0192, wp, lp) = LB_SETTABSTOPS{tabs=decompileTabStops{wp=wp, lp=lp}} | decompileMessage (0x0193, _, _) = LB_GETHORIZONTALEXTENT | decompileMessage (0x0194, wp, _) = LB_SETHORIZONTALEXTENT {extent = SysWord.toInt wp} | decompileMessage (0x0195, wp, _) = LB_SETCOLUMNWIDTH {column = SysWord.toInt wp} | decompileMessage (0x0196, _, lp) = LB_ADDFILE {fileName = fromCstring(toAddr lp) } | decompileMessage (0x0197, wp, _) = LB_SETTOPINDEX {index = SysWord.toInt wp} | decompileMessage (0x0198, wp, lp) = LB_GETITEMRECT {index = SysWord.toInt wp, rect = ref(fromCrect(toAddr lp))} | decompileMessage (0x0199, wp, _) = LB_GETITEMDATA {index = SysWord.toInt wp} | decompileMessage (0x019A, wp, lp) = LB_SETITEMDATA {index = SysWord.toInt wp, data = SysWord.toInt lp} | decompileMessage (0x019B, wp, lp) = LB_SELITEMRANGE {select = wp <> 0w0, first = loWord lp, last = hiWord lp} | decompileMessage (0x019C, wp, _) = LB_SETANCHORINDEX {index = SysWord.toInt wp} | decompileMessage (0x019D, _, _) = LB_GETANCHORINDEX | decompileMessage (0x019E, wp, lp) = LB_SETCARETINDEX {index = SysWord.toInt wp, scroll = lp <> 0w0} | decompileMessage (0x019F, _, _) = LB_GETCARETINDEX | decompileMessage (0x01A0, wp, lp) = LB_SETITEMHEIGHT {index = SysWord.toInt wp, height = loWord lp} | decompileMessage (0x01A1, wp, _) = LB_GETITEMHEIGHT {index = SysWord.toInt wp} | decompileMessage (0x01A2, wp, lp) = LB_FINDSTRINGEXACT {text = fromCstring(toAddr lp), indexStart = SysWord.toInt wp } | decompileMessage (0x01A5, wp, _) = LB_SETLOCALE {locale = SysWord.toInt wp} | decompileMessage (0x01A6, _, _) = LB_GETLOCALE | decompileMessage (0x01A7, wp, _) = LB_SETCOUNT {items = SysWord.toInt wp} | decompileMessage (0x01A8, wp, lp) = LB_INITSTORAGE {items = SysWord.toInt wp, bytes = SysWord.toInt lp} | decompileMessage (0x01A9, _, lp) = LB_ITEMFROMPOINT {point = {x = loWord lp, y = hiWord lp }} | decompileMessage (0x0200, wp, lp) = decompileMouseMove(WM_MOUSEMOVE, wp, lp) | decompileMessage (0x0201, wp, lp) = decompileMouseMove(WM_LBUTTONDOWN, wp, lp) | decompileMessage (0x0202, wp, lp) = decompileMouseMove(WM_LBUTTONUP, wp, lp) | decompileMessage (0x0203, wp, lp) = decompileMouseMove(WM_LBUTTONDBLCLK, wp, lp) | decompileMessage (0x0204, wp, lp) = decompileMouseMove(WM_RBUTTONDOWN, wp, lp) | decompileMessage (0x0205, wp, lp) = decompileMouseMove(WM_RBUTTONUP, wp, lp) | decompileMessage (0x0206, wp, lp) = decompileMouseMove(WM_RBUTTONDBLCLK, wp, lp) | decompileMessage (0x0207, wp, lp) = decompileMouseMove(WM_MBUTTONDOWN, wp, lp) | decompileMessage (0x0208, wp, lp) = decompileMouseMove(WM_MBUTTONUP, wp, lp) | decompileMessage (0x0209, wp, lp) = decompileMouseMove(WM_MBUTTONDBLCLK, wp, lp) (* WM_MOUSEWHEEL 0x020A *) | decompileMessage (0x0210, wp, lp) = WM_PARENTNOTIFY { eventflag = loWord wp, idchild = hiWord wp, value = SysWord.toInt lp } | decompileMessage (0x0211, wp, _) = WM_ENTERMENULOOP { istrack= wp <> 0w0 } (* "0x0211" *) | decompileMessage (0x0212, wp, _) = WM_EXITMENULOOP { istrack= wp <> 0w0 } (* "0x0212" *) (* WM_NEXTMENU 0x0213 WM_SIZING 0x0214 *) | decompileMessage (0x0215, _, lp) = WM_CAPTURECHANGED { newCapture = toHWND lp } (* WM_MOVING 0x0216 WM_POWERBROADCAST 0x0218 WM_DEVICECHANGE 0x0219 *) | decompileMessage (0x0220, _, lp) = let val (class, title, hinst, x,y,cx,cy, style, lParam) = toMdiCreate lp in WM_MDICREATE { class = class, title = title, instance = hinst, x = x, y = y, cx = cx, cy = cy, style = style, cdata = lParam } end | decompileMessage (0x0221, wp, _) = WM_MDIDESTROY { child = toHWND wp } (* "0x0221" *) | decompileMessage (0x0223, wp, _) = WM_MDIRESTORE { child = toHWND wp } (* "0x0223" *) | decompileMessage (0x0224, wp, lp) = WM_MDINEXT { child = toHWND wp, flagnext = lp <> 0w0 } (* "0x0224" *) | decompileMessage (0x0225, wp, _) = WM_MDIMAXIMIZE { child = toHWND wp } (* "0x0225" *) | decompileMessage (0x0226, wp, _) = WM_MDITILE { tilingflag = fromCmdif(Word32.fromLargeWord wp) } (* "0x0226" *) | decompileMessage (0x0227, wp, _) = WM_MDICASCADE { skipDisabled = SysWord.andb(wp, 0w2) <> 0w0 } | decompileMessage (0x0228, _, _) = WM_MDIICONARRANGE | decompileMessage (0x0229, _, _) = WM_MDIGETACTIVE | decompileMessage (0x0230, wp, lp) = WM_MDISETMENU { frameMenu = toHMENU wp, windowMenu = toHMENU lp } (* "0x0230" *) | decompileMessage (0x0231, _, _) = WM_ENTERSIZEMOVE | decompileMessage (0x0232, _, _) = WM_EXITSIZEMOVE | decompileMessage (0x0233, wp, _) = WM_DROPFILES { hDrop = toHDROP wp } | decompileMessage (0x0234, _, _) = WM_MDIREFRESHMENU (* "0x0234" *) (* WM_IME_SETCONTEXT 0x0281 WM_IME_NOTIFY 0x0282 WM_IME_CONTROL 0x0283 WM_IME_COMPOSITIONFULL 0x0284 WM_IME_SELECT 0x0285 WM_IME_CHAR 0x0286 WM_IME_KEYDOWN 0x0290 WM_IME_KEYUP 0x0291 *) | decompileMessage (0x02A0, wp, lp) = WM_NCMOUSEHOVER { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } | decompileMessage (0x02A1, wp, lp) = decompileMouseMove(WM_MOUSEHOVER, wp, lp)(* "0x02A1" *) | decompileMessage (0x02A2, _, _) = WM_NCMOUSELEAVE (* "0x02A2" *) | decompileMessage (0x02A3, _, _) = WM_MOUSELEAVE (* "0x02A3" *) | decompileMessage (0x0300, _, _) = WM_CUT (* "0x0300" *) | decompileMessage (0x0301, _, _) = WM_COPY (* "0x0301" *) | decompileMessage (0x0302, _, _) = WM_PASTE (* "0x0302" *) | decompileMessage (0x0303, _, _) = WM_CLEAR (* "0x0303" *) | decompileMessage (0x0304, _, _) = WM_UNDO (* "0x0304" *) | decompileMessage (0x0305, wp, _) = WM_RENDERFORMAT { format = fromCcbf(SysWord.toInt wp) } (* "0x0305" *) | decompileMessage (0x0306, _, _) = WM_RENDERALLFORMATS (* "0x0306" *) | decompileMessage (0x0307, _, _) = WM_DESTROYCLIPBOARD (* "0x0307" *) | decompileMessage (0x0308, _, _) = WM_DRAWCLIPBOARD (* "0x0308" *) | decompileMessage (0x0309, wp, _) = WM_PAINTCLIPBOARD { clipboard = toHWND wp } (* "0x0309" *) | decompileMessage (0x030A, wp, lp) = WM_VSCROLLCLIPBOARD { viewer = toHWND wp, code = loWord lp, position = hiWord lp } (* "0x030A" *) | decompileMessage (0x030B, _, lp) = WM_SIZECLIPBOARD { viewer = toHWND lp } (* "0x030B" *) (* The format name is inserted by the window procedure so any incoming message won't have the information. Indeed the buffer may not have been initialised. *) | decompileMessage (0x030C, wp, _) = WM_ASKCBFORMATNAME { length = SysWord.toInt wp, formatName = ref "" } | decompileMessage (0x030D, wp, lp) = WM_CHANGECBCHAIN { removed = toHWND wp, next = toHWND lp } | decompileMessage (0x030E, wp, lp) = WM_HSCROLLCLIPBOARD { viewer = toHWND wp, code = loWord lp, position = hiWord lp } (* "0x030E" *) | decompileMessage (0x030F, _, _) = WM_QUERYNEWPALETTE (* "0x030F" *) | decompileMessage (0x0310, wp, _) = WM_PALETTEISCHANGING { realize = toHWND wp } (* "0x0310" *) | decompileMessage (0x0311, wp, _) = WM_PALETTECHANGED { palChg = toHWND wp } (* "0x0311" *) | decompileMessage (0x0312, wp, _) = WM_HOTKEY { id = SysWord.toInt wp } (* "0x0312" *) | decompileMessage (0x0317, wp, lp) = WM_PRINT { hdc = toHDC wp, flags = fromCwmpl(Word32.fromLargeWord lp) } | decompileMessage (0x0318, wp, lp) = WM_PRINTCLIENT { hdc = toHDC wp, flags = fromCwmpl(Word32.fromLargeWord lp) } | decompileMessage (m, wp, lp) = (* User, application and registered messages. *) (* Rich edit controls use WM_USER+37 to WM_USER+122. As and when we implement rich edit controls we may want to treat those messages specially. *) if m >= 0x0400 andalso m <= 0x7FFF then WM_USER { uMsg = m, wParam = wp, lParam = lp } else if m >= 0x8000 andalso m <= 0xBFFF then WM_APP { uMsg = m, wParam = wp, lParam = lp } else if m >= 0x8000 andalso m <= 0xFFFF then ( (* We could use PolyML.OnEntry or use a weak byte ref to initialise the registered messages. *) if m = RegisterMessage "commdlg_FindReplace" then FINDMSGSTRING(decompileFindMsg{wp=wp, lp=lp}) else WM_REGISTERED { uMsg = m, wParam = wp, lParam = lp } ) else (* Other system messages. *) WM_SYSTEM_OTHER { uMsg = m, wParam = wp, lParam = lp } fun btoi false = 0 | btoi true = 1 fun makeLong(x, y) = Word32.toLargeWord(MAKELONG(Word.fromInt x, Word.fromInt y)) (* If we return a string we need to ensure it's freed *) fun compileStringAsLp(code, wp, string) = let val s = toCstring string in (code, wp, fromAddr s, fn () => Memory.free s) end (* Requests for strings. Many of these don't pass the length as an argument. *) fun compileStringRequest(code, wparam, length) = let open Memory val mem = malloc(Word.fromInt length) in (code, wparam, fromAddr mem, fn () => free mem) end fun strAddrAsLp(code, wp, (addr, free)) = (code, wp, addr, free) fun noFree () = () fun compileMessage WM_NULL = (0x0000, 0w0: SysWord.word, 0w0: SysWord.word, noFree) | compileMessage (WM_CREATE args) = compileCreate(0x0001, args) | compileMessage WM_DESTROY = (0x0002, 0w0, 0w0, noFree) | compileMessage (WM_MOVE {x, y}) = (0x0003, 0w0, makeLong(x, y), noFree) | compileMessage (WM_SIZE {flag, width, height}) = (0x0005, fromWMSizeOpt flag, makeLong(width, height), noFree) | compileMessage (WM_ACTIVATE {active, minimize}) = (0x0006, Word32.toLargeWord(MAKELONG(fromWMactive active, if minimize then 0w1 else 0w1)), 0w0, noFree) | compileMessage (WM_SETFOCUS {losing}) = (0x0007, 0w0, fromHWND losing, noFree) | compileMessage (WM_KILLFOCUS {receivefocus}) = (0x0008, 0w0, fromHWND receivefocus, noFree) | compileMessage (WM_ENABLE {enabled}) = (0x000A, if enabled then 0w1 else 0w0, 0w0, noFree) | compileMessage (WM_SETREDRAW {redrawflag}) = (0x000B, if redrawflag then 0w1 else 0w0, 0w0, noFree) | compileMessage (WM_SETTEXT {text}) = compileStringAsLp(0x000C, 0w0, text) | compileMessage (WM_GETTEXT {length, ...}) = compileStringRequest(0x000D, SysWord.fromInt length, length) | compileMessage WM_GETTEXTLENGTH = (0x000E, 0w0, 0w0, noFree) | compileMessage WM_PAINT = (0x000F, 0w0, 0w0, noFree) | compileMessage WM_CLOSE = (0x0010, 0w0, 0w0, noFree) | compileMessage (WM_QUERYENDSESSION { source}) = (0x0011, SysWord.fromInt source, 0w0, noFree) | compileMessage (WM_QUIT {exitcode}) = (0x0012, SysWord.fromInt exitcode, 0w0, noFree) | compileMessage WM_QUERYOPEN = (0x0013, 0w0, 0w0, noFree) | compileMessage (WM_ERASEBKGND {devicecontext}) = (0x0014, 0w0, fromHDC devicecontext, noFree) | compileMessage WM_SYSCOLORCHANGE = (0x0015, 0w0, 0w0, noFree) | compileMessage (WM_ENDSESSION {endsession}) = (0x0016, SysWord.fromInt(btoi endsession), 0w0, noFree) | compileMessage (WM_SHOWWINDOW {showflag, statusflag}) = (0x0018, SysWord.fromInt(btoi showflag), SysWord.fromInt statusflag, noFree) | compileMessage (WM_DEVMODECHANGE {devicename}) = compileStringAsLp(0x001B, 0w0, devicename) | compileMessage (WM_ACTIVATEAPP {active, threadid}) = (0x001B, SysWord.fromInt(btoi active), SysWord.fromInt threadid, noFree) | compileMessage WM_FONTCHANGE = (0x001D, 0w0, 0w0, noFree) | compileMessage WM_TIMECHANGE = (0x001E, 0w0, 0w0, noFree) | compileMessage WM_CANCELMODE = (0x001F, 0w0, 0w0, noFree) | compileMessage (WM_SETCURSOR {cursorwindow, hitTest, mousemessage}) = (0x0020, fromHWND cursorwindow, makeLong(fromHitTest hitTest, mousemessage), noFree) | compileMessage (WM_MOUSEACTIVATE {parent, hitTest, message}) = (0x0021, fromHWND parent, makeLong(fromHitTest hitTest, message), noFree) | compileMessage WM_CHILDACTIVATE = (0x0022, 0w0, 0w0, noFree) | compileMessage WM_QUEUESYNC = (0x0023, 0w0, 0w0, noFree) | compileMessage(WM_GETMINMAXINFO args) = compileMinMax(0x0024, args) | compileMessage WM_PAINTICON = (0x0026, 0w0, 0w0, noFree) | compileMessage (WM_ICONERASEBKGND {devicecontext}) = (0x0027, fromHDC devicecontext, 0w0, noFree) | compileMessage (WM_NEXTDLGCTL {control, handleflag}) = (0x0028, SysWord.fromInt control, SysWord.fromInt(btoi handleflag), noFree) | compileMessage (WM_DRAWITEM { senderId, ctlType, ctlID, itemID, itemAction,itemState, hItem, hDC, rcItem, itemData}) = strAddrAsLp(0x002B, SysWord.fromInt senderId, fromMLDrawItem(ctlType, ctlID, itemID, itemAction,itemState, hItem, hDC,rcItem,itemData)) | compileMessage (WM_MEASUREITEM{ senderId, ctlType, ctlID, itemID, itemWidth=ref itemWidth, itemHeight=ref itemHeight, itemData}) = strAddrAsLp(0x002C, SysWord.fromInt senderId, fromMLMeasureItem(ctlType, ctlID, itemID, itemWidth, itemHeight, itemData)) | compileMessage (WM_DELETEITEM{ senderId, ctlType, ctlID, itemID, item, itemData}) = strAddrAsLp(0x002D, SysWord.fromInt senderId, fromMLDeleteItem(ctlType, ctlID, itemID, item, itemData)) | compileMessage (WM_VKEYTOITEM {virtualKey, caretpos, listbox}) = (0x002E, makeLong(virtualKey, caretpos), fromHWND listbox, noFree) | compileMessage (WM_CHARTOITEM {key, caretpos, listbox}) = (0x002F, makeLong(key, caretpos), fromHWND listbox, noFree) | compileMessage (WM_SETFONT {font, redrawflag}) = (0x0030, fromHFONT font, if redrawflag then 0w1 else 0w0, noFree) | compileMessage WM_GETFONT = (0x0031, 0w0, 0w0, noFree) | compileMessage (WM_SETHOTKEY {virtualKey}) = (0x0032, SysWord.fromInt virtualKey, 0w0, noFree) | compileMessage WM_GETHOTKEY = (0x0033, 0w0, 0w0, noFree) | compileMessage WM_QUERYDRAGICON = (0x0037, 0w0, 0w0, noFree) | compileMessage (WM_COMPAREITEM { controlid, ctlType, ctlID, hItem, itemID1,itemData1, itemID2,itemData2}) = let (* TODO: Perhaps we should have locale Id in the argument record. *) val LOCALE_USER_DEFAULT = 0x0400 in strAddrAsLp(0x0039, SysWord.fromInt controlid, fromMLCompareItem (ctlType, ctlID, hItem, itemID1, itemData1, itemID2, itemData2, LOCALE_USER_DEFAULT)) end | compileMessage (WM_WINDOWPOSCHANGING wpc) = mlToCWindowPosChanging(0x0046, wpc) | compileMessage (WM_WINDOWPOSCHANGED wpc) = mlToCWindowPosChanged(0x0047, wpc) | compileMessage (WM_POWER {powerevent}) = (0x0048, SysWord.fromInt powerevent, 0w0, noFree) | compileMessage WM_CANCELJOURNAL = (0x004B, 0w0, 0w0, noFree) | compileMessage (WM_NOTIFY {idCtrl, from, idFrom, notification}) = strAddrAsLp (0x004E, SysWord.fromInt idCtrl, compileNotification(from, idFrom, notification)) (* WM_INPUTLANGCHANGEREQUEST 0x0050 WM_INPUTLANGCHANGE 0x0051 WM_TCARD 0x0052 WM_USERCHANGED 0x0054 WM_NOTIFYFORMAT 0x0055 WM_STYLECHANGING 0x007C WM_STYLECHANGED 0x007D *) | compileMessage (WM_HELP args) = compileHelpInfo(0x0053, args) | compileMessage (WM_CONTEXTMENU { hwnd, xPos, yPos }) = (0x007B, fromHWND hwnd, makeLong(xPos, yPos), noFree) | compileMessage (WM_DISPLAYCHANGE { bitsPerPixel, xScreen, yScreen}) = (0x007E, SysWord.fromInt bitsPerPixel, makeLong(xScreen, yScreen), noFree) | compileMessage (WM_GETICON {big}) = (0x007F, SysWord.fromInt(btoi big), 0w0, noFree) | compileMessage (WM_SETICON { big, icon }) = (0x0080, SysWord.fromInt(btoi big), fromAddr(voidStarOfHandle icon), noFree) | compileMessage (WM_NCCREATE args) = compileCreate(0x0081, args) | compileMessage WM_NCDESTROY = (0x0082, 0w0, 0w0, noFree) | compileMessage (WM_NCCALCSIZE args) = compileNCCalcSize args | compileMessage (WM_NCHITTEST {x, y}) = (0x0084, 0w0, makeLong(x, y), noFree) | compileMessage (WM_NCPAINT {region}) = (0x0085, fromHRGN region, 0w0, noFree) | compileMessage (WM_NCACTIVATE {active}) = (0x0086, SysWord.fromInt(btoi active), 0w0, noFree) | compileMessage WM_GETDLGCODE = (0x0087, 0w0, 0w0, noFree) | compileMessage (WM_NCMOUSEMOVE {hitTest, x, y}) = (0x00A0, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) | compileMessage (WM_NCLBUTTONDOWN {hitTest, x, y}) = (0x00A1, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) | compileMessage (WM_NCLBUTTONUP {hitTest, x, y}) = (0x00A2, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) | compileMessage (WM_NCLBUTTONDBLCLK {hitTest, x, y}) = (0x00A3, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) | compileMessage (WM_NCRBUTTONDOWN {hitTest, x, y}) = (0x00A4, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) | compileMessage (WM_NCRBUTTONUP {hitTest, x, y}) = (0x00A5, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) | compileMessage (WM_NCRBUTTONDBLCLK {hitTest, x, y}) = (0x00A6, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) | compileMessage (WM_NCMBUTTONDOWN {hitTest, x, y}) = (0x00A7, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) | compileMessage (WM_NCMBUTTONUP {hitTest, x, y}) = (0x00A8, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) | compileMessage (WM_NCMBUTTONDBLCLK {hitTest, x, y}) = (0x00A9, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) (* Edit control messages *) | compileMessage (EM_GETSEL args) = compileGetSel(0x00B0, args) | compileMessage (EM_SETSEL{startPos, endPos}) = (0x00B1, SysWord.fromInt startPos, SysWord.fromInt endPos, noFree) | compileMessage (EM_GETRECT {rect=ref r}) = compileGetRect(0x00B2, 0w0, r) | compileMessage (EM_SETRECT {rect}) = compileSetRect(0x00B3, rect) | compileMessage (EM_SETRECTNP {rect}) = compileSetRect(0x00B4, rect) | compileMessage (EM_SCROLL{action}) = (0x00B5, Word.toLargeWord(toCsd action), 0w0, noFree) | compileMessage (EM_LINESCROLL{xScroll, yScroll}) = (0x00B6, SysWord.fromInt xScroll, SysWord.fromInt yScroll, noFree) | compileMessage EM_SCROLLCARET = (0x00B7, 0w0, 0w0, noFree) | compileMessage EM_GETMODIFY = (0x00B8, 0w0, 0w0, noFree) | compileMessage (EM_SETMODIFY{modified}) = (0x00B9, if modified then 0w1 else 0w0, 0w0, noFree) | compileMessage EM_GETLINECOUNT = (0x00BA, 0w0, 0w0, noFree) | compileMessage (EM_LINEINDEX{line}) = (0x00BB, SysWord.fromInt line, 0w0, noFree) (* EM_SETHANDLE 0x00BC *) | compileMessage EM_GETTHUMB = (0x00BE, 0w0, 0w0, noFree) | compileMessage (EM_LINELENGTH{index}) = (0x00BB, SysWord.fromInt index, 0w0, noFree) | compileMessage (EM_REPLACESEL{canUndo, text}) = compileStringAsLp(0x00C2, SysWord.fromInt(btoi canUndo), text) | compileMessage (EM_GETLINE args) = compileGetLine args | compileMessage (EM_LIMITTEXT{limit}) = (0x00C5, SysWord.fromInt limit, 0w0, noFree) | compileMessage EM_CANUNDO = (0x00C6, 0w0, 0w0, noFree) | compileMessage EM_UNDO = (0x00C7, 0w0, 0w0, noFree) | compileMessage (EM_FMTLINES{addEOL}) = (0x00C8, SysWord.fromInt(btoi addEOL), 0w0, noFree) | compileMessage (EM_LINEFROMCHAR{index}) = (0x00C9, SysWord.fromInt index, 0w0, noFree) | compileMessage (EM_SETTABSTOPS{tabs}) = compileTabStops(0x00CB, tabs) | compileMessage (EM_SETPASSWORDCHAR{ch}) = (0x00CC, SysWord.fromInt(ord ch), 0w0, noFree) | compileMessage EM_EMPTYUNDOBUFFER = (0x00CD, 0w0, 0w0, noFree) | compileMessage EM_GETFIRSTVISIBLELINE = (0x00CE, 0w0, 0w0, noFree) | compileMessage (EM_SETREADONLY{readOnly}) = (0x00CF, SysWord.fromInt(btoi readOnly), 0w0, noFree) (* EM_SETWORDBREAKPROC 0x00D0 EM_GETWORDBREAKPROC 0x00D1 *) | compileMessage EM_GETPASSWORDCHAR = (0x00D2, 0w0, 0w0, noFree) | compileMessage (EM_SETMARGINS{margins}) = ( case margins of UseFontInfo => (0x00D3, SysWord.fromInt 0xffff, 0w0, noFree) | Margins{left, right} => let val (b0, lo) = case left of SOME l => (0w1, l) | NONE => (0w0, 0) val (b1, hi) = case right of SOME r => (0w2, r) | NONE => (0w0, 0) in (0x00D3, SysWord.orb(b0, b1), makeLong(hi,lo), noFree) end ) | compileMessage EM_GETMARGINS = (0x00D4, 0w0, 0w0, noFree) (* Returns margins in lResult *) | compileMessage EM_GETLIMITTEXT = (0x00D5, 0w0, 0w0, noFree) | compileMessage (EM_POSFROMCHAR {index}) = (0x00D6, SysWord.fromInt index, 0w0, noFree) | compileMessage (EM_CHARFROMPOS arg) = let val (lParam, toFree) = case arg of EMcfpEdit{x,y} => (makeLong(x, y), noFree) | EMcfpRichEdit pt => makePointStructAddr pt | EMcfpUnknown lp => (lp, noFree) in (0x00D7, 0w0, lParam, toFree) end (* Scroll bar messages *) | compileMessage (SBM_SETPOS {pos, redraw}) = (0x00E0, SysWord.fromInt pos, SysWord.fromInt(btoi redraw), noFree) | compileMessage SBM_GETPOS = (0x00E1, 0w0, 0w0, noFree) | compileMessage (SBM_SETRANGE {minPos, maxPos}) = (0x00E2, SysWord.fromInt minPos, SysWord.fromInt maxPos, noFree) | compileMessage (SBM_SETRANGEREDRAW {minPos, maxPos}) = (0x00E6, SysWord.fromInt minPos, SysWord.fromInt maxPos, noFree) | compileMessage (SBM_GETRANGE _) = let (* An application should use GetScrollRange rather than sending this.*) open Memory (* We need to allocate two ints and pass their addresses *) val mem = malloc(0w2 * sizeInt) infix 6 ++ in (0x00E3, fromAddr mem, fromAddr(mem ++ sizeInt), fn () => free mem) end | compileMessage (SBM_ENABLE_ARROWS flags) = (0x00E4, SysWord.fromInt(toCesbf flags), 0w0, noFree) | compileMessage (SBM_SETSCROLLINFO {info, options}) = strAddrAsLp(0x00E9, 0w0, fromScrollInfo(info, options)) | compileMessage (SBM_GETSCROLLINFO {info = ref info, options}) = strAddrAsLp(0x00EA, 0w0, fromScrollInfo(info, options)) (* Button control messages *) | compileMessage BM_GETCHECK = (0x00F0, 0w0, 0w0, noFree) | compileMessage (BM_SETCHECK{state}) = (0x00F1, SysWord.fromInt state, 0w0, noFree) | compileMessage BM_GETSTATE = (0x00F2, 0w0, 0w0, noFree) | compileMessage (BM_SETSTATE{highlight}) = (0x00F3, SysWord.fromInt(btoi highlight), 0w0, noFree) | compileMessage (BM_SETSTYLE{redraw, style}) = (0x00F3, SysWord.fromInt(LargeWord.toInt(Style.toWord style)), SysWord.fromInt(btoi redraw), noFree) | compileMessage BM_CLICK = (0x00F5, 0w0, 0w0, noFree) | compileMessage (BM_GETIMAGE{imageType}) = (0x00F6, SysWord.fromInt(toCit imageType), 0w0, noFree) | compileMessage (BM_SETIMAGE{imageType, image}) = (0x00F7, SysWord.fromInt(toCit imageType), fromHGDIOBJ image, noFree) | compileMessage (WM_KEYDOWN {virtualKey, data}) = (0x0100, SysWord.fromInt virtualKey, Word32.toLargeWord data, noFree) | compileMessage (WM_KEYUP {virtualKey, data}) = (0x0101, SysWord.fromInt virtualKey, Word32.toLargeWord data, noFree) | compileMessage (WM_CHAR {charCode, data}) = (0x0102, SysWord.fromInt(ord charCode), Word32.toLargeWord data, noFree) | compileMessage (WM_DEADCHAR {charCode, data}) = (0x0103, SysWord.fromInt(ord charCode), Word32.toLargeWord data, noFree) | compileMessage (WM_SYSKEYDOWN {virtualKey, data}) = (0x0104, SysWord.fromInt virtualKey, Word32.toLargeWord data, noFree) | compileMessage (WM_SYSKEYUP {virtualKey, data}) = (0x0105, SysWord.fromInt virtualKey, Word32.toLargeWord data, noFree) | compileMessage (WM_SYSCHAR {charCode, data}) = (0x0106, SysWord.fromInt(ord charCode), Word32.toLargeWord data, noFree) | compileMessage (WM_SYSDEADCHAR {charCode, data}) = (0x0107, SysWord.fromInt(ord charCode), Word32.toLargeWord data, noFree) (* WM_IME_STARTCOMPOSITION 0x010D WM_IME_ENDCOMPOSITION 0x010E WM_IME_COMPOSITION 0x010F WM_IME_KEYLAST 0x010F *) | compileMessage (WM_INITDIALOG { dialog, initdata}) = (0x0110, fromHWND dialog, SysWord.fromInt initdata, noFree) | compileMessage (WM_COMMAND {notifyCode, wId, control}) = (0x0111, makeLong(wId, notifyCode), fromHWND control, noFree) | compileMessage (WM_SYSCOMMAND {commandvalue, sysBits, p={x,y}}) = (0x0112, Word.toLargeWord(Word.orb(Word.fromInt sysBits, Word.fromInt(fromSysCommand commandvalue))), makeLong(x,y), noFree) | compileMessage (WM_TIMER {timerid}) = (0x0113, SysWord.fromInt timerid, 0w0, noFree) | compileMessage (WM_HSCROLL {value, position, scrollbar}) = (0x0114, makeLong(Word.toInt(toCsd value), position), fromHWND scrollbar, noFree) | compileMessage (WM_VSCROLL {value, position, scrollbar}) = (0x0115, makeLong(Word.toInt(toCsd value), position), fromHWND scrollbar, noFree) | compileMessage (WM_INITMENU {menu}) = (0x0116, fromHMENU menu, 0w0, noFree) | compileMessage (WM_INITMENUPOPUP {menupopup, itemposition, isSystemMenu}) = (0x0117, fromHMENU menupopup, makeLong(itemposition, btoi isSystemMenu), noFree) | compileMessage (WM_MENUSELECT {menuitem, menuflags, menu}) = (0x011F, makeLong(menuitem, Word32.toInt(MenuBase.fromMenuFlagSet menuflags)), fromHMENU menu, noFree) | compileMessage (WM_MENUCHAR { ch, menuflag, menu}) = (0x0120, makeLong(ord ch, Word32.toInt(MenuBase.fromMenuFlag menuflag)), fromHMENU menu, noFree) | compileMessage (WM_ENTERIDLE { flag, window}) = (0x0121, SysWord.fromInt flag, fromHWND window, noFree) | compileMessage (WM_CTLCOLORMSGBOX { displaycontext, messagebox}) = (0x0132, fromHDC displaycontext, fromHWND messagebox, noFree) | compileMessage (WM_CTLCOLOREDIT { displaycontext, editcontrol}) = (0x0133, fromHDC displaycontext, fromHWND editcontrol, noFree) | compileMessage (WM_CTLCOLORLISTBOX { displaycontext, listbox}) = (0x0134, fromHDC displaycontext, fromHWND listbox, noFree) | compileMessage (WM_CTLCOLORBTN { displaycontext, button}) = (0x0135, fromHDC displaycontext, fromHWND button, noFree) | compileMessage (WM_CTLCOLORDLG { displaycontext, dialogbox}) = (0x0136, fromHDC displaycontext, fromHWND dialogbox, noFree) | compileMessage (WM_CTLCOLORSCROLLBAR { displaycontext, scrollbar}) = (0x0137, fromHDC displaycontext, fromHWND scrollbar, noFree) | compileMessage (WM_CTLCOLORSTATIC { displaycontext, staticcontrol}) = (0x0138, fromHDC displaycontext, fromHWND staticcontrol, noFree) (* Combobox messages. *) | compileMessage (CB_GETEDITSEL args) = compileGetSel(0x0140, args) | compileMessage (CB_LIMITTEXT{limit}) = (0x0141, SysWord.fromInt limit, 0w0, noFree) | compileMessage (CB_SETEDITSEL{startPos, endPos}) = (0x0142, 0w0, makeLong(startPos, endPos), noFree) | compileMessage (CB_ADDSTRING{text}) = compileStringAsLp(0x0143, 0w0, text) | compileMessage (CB_DELETESTRING{index}) = (0x0144, SysWord.fromInt index, 0w0, noFree) | compileMessage (CB_DIR{attrs, fileSpec}) = compileStringAsLp(0x0145, Word32.toLargeWord(toCcbal attrs), fileSpec) | compileMessage CB_GETCOUNT = (0x0146, 0w0, 0w0, noFree) | compileMessage CB_GETCURSEL = (0x0147, 0w0, 0w0, noFree) | compileMessage (CB_GETLBTEXT {length, index, ...}) = compileStringRequest(0x0148, SysWord.fromInt index, length) | compileMessage (CB_GETLBTEXTLEN{index}) = (0x0149, SysWord.fromInt index, 0w0, noFree) | compileMessage (CB_INSERTSTRING{text, index}) = compileStringAsLp(0x014A, SysWord.fromInt index, text) | compileMessage CB_RESETCONTENT = (0x014B, 0w0, 0w0, noFree) | compileMessage (CB_FINDSTRING{text, indexStart}) = compileStringAsLp(0x014C, SysWord.fromInt indexStart, text) | compileMessage (CB_SELECTSTRING{text, indexStart}) = compileStringAsLp(0x014D, SysWord.fromInt indexStart, text) | compileMessage (CB_SETCURSEL{index}) = (0x014E, SysWord.fromInt index, 0w0, noFree) | compileMessage (CB_SHOWDROPDOWN{show}) = (0x014F, SysWord.fromInt(btoi show), 0w0, noFree) | compileMessage (CB_GETITEMDATA{index}) = (0x0150, SysWord.fromInt index, 0w0, noFree) | compileMessage (CB_SETITEMDATA{index, data}) = (0x0151, SysWord.fromInt index, SysWord.fromInt data, noFree) | compileMessage (CB_GETDROPPEDCONTROLRECT {rect=ref rect}) = compileGetRect(0x0152, 0w0, rect) | compileMessage (CB_SETITEMHEIGHT{index, height}) = (0x0153, SysWord.fromInt index, SysWord.fromInt height, noFree) | compileMessage (CB_GETITEMHEIGHT{index}) = (0x0154, SysWord.fromInt index, 0w0, noFree) | compileMessage (CB_SETEXTENDEDUI{extended}) = (0x0155, SysWord.fromInt(btoi extended), 0w0, noFree) | compileMessage CB_GETEXTENDEDUI = (0x0156, 0w0, 0w0, noFree) | compileMessage CB_GETDROPPEDSTATE = (0x0157, 0w0, 0w0, noFree) | compileMessage (CB_FINDSTRINGEXACT{text, indexStart}) = compileStringAsLp(0x0158, SysWord.fromInt indexStart, text) | compileMessage (CB_SETLOCALE{locale}) = (0x0159, SysWord.fromInt locale, 0w0, noFree) | compileMessage CB_GETLOCALE = (0x015A, 0w0, 0w0, noFree) | compileMessage CB_GETTOPINDEX = (0x015b, 0w0, 0w0, noFree) | compileMessage (CB_SETTOPINDEX{index}) = (0x015c, SysWord.fromInt index, 0w0, noFree) | compileMessage CB_GETHORIZONTALEXTENT = (0x015d, 0w0, 0w0, noFree) | compileMessage (CB_SETHORIZONTALEXTENT{extent}) = (0x015e, SysWord.fromInt extent, 0w0, noFree) | compileMessage CB_GETDROPPEDWIDTH = (0x015f, 0w0, 0w0, noFree) | compileMessage (CB_SETDROPPEDWIDTH{width}) = (0x0160, SysWord.fromInt width, 0w0, noFree) | compileMessage (CB_INITSTORAGE{items, bytes}) = (0x0161, SysWord.fromInt items, SysWord.fromInt bytes, noFree) (* Static control messages. *) | compileMessage (STM_SETICON{icon}) = (0x0170, fromHICON icon, 0w0, noFree) | compileMessage STM_GETICON = (0x0171, 0w0, 0w0, noFree) | compileMessage (STM_SETIMAGE{imageType, image}) = (0x0172, SysWord.fromInt(toCit imageType), fromHGDIOBJ image, noFree) | compileMessage (STM_GETIMAGE{imageType}) = (0x0173, SysWord.fromInt(toCit imageType), 0w0, noFree) (* Listbox messages *) | compileMessage (LB_ADDSTRING{text}) = compileStringAsLp(0x0180, 0w0, text) | compileMessage (LB_INSERTSTRING{text, index}) = compileStringAsLp(0x0181, SysWord.fromInt index, text) | compileMessage (LB_DELETESTRING{index}) = (0x0182, SysWord.fromInt index, 0w0, noFree) | compileMessage (LB_SELITEMRANGEEX{first, last}) = (0x0183, SysWord.fromInt first, SysWord.fromInt last, noFree) | compileMessage LB_RESETCONTENT = (0x0184, 0w0, 0w0, noFree) | compileMessage (LB_SETSEL{select, index}) = (0x0185, SysWord.fromInt(btoi select), SysWord.fromInt index, noFree) | compileMessage (LB_SETCURSEL{index}) = (0x0186, SysWord.fromInt index, 0w0, noFree) | compileMessage (LB_GETSEL{index}) = (0x0187, SysWord.fromInt index, 0w0, noFree) | compileMessage LB_GETCURSEL = (0x0188, 0w0, 0w0, noFree) | compileMessage (LB_GETTEXT {length, index, ...}) = compileStringRequest(0x0189, SysWord.fromInt index, length) | compileMessage (LB_GETTEXTLEN{index}) = (0x018A, SysWord.fromInt index, 0w0, noFree) | compileMessage LB_GETCOUNT = (0x018B, 0w0, 0w0, noFree) | compileMessage (LB_SELECTSTRING{text, indexStart}) = compileStringAsLp(0x018C, SysWord.fromInt indexStart, text) | compileMessage (LB_DIR{attrs, fileSpec}) = compileStringAsLp(0x018D, Word32.toLargeWord(toCcbal attrs), fileSpec) | compileMessage LB_GETTOPINDEX = (0x018E, 0w0, 0w0, noFree) | compileMessage (LB_FINDSTRING{text, indexStart}) = compileStringAsLp (0x018F, SysWord.fromInt indexStart, text) | compileMessage LB_GETSELCOUNT = (0x0190, 0w0, 0w0, noFree) | compileMessage (LB_GETSELITEMS args) = compileGetSelItems(0x0191, args) | compileMessage (LB_SETTABSTOPS{tabs}) = compileTabStops(0x0192, tabs) | compileMessage LB_GETHORIZONTALEXTENT = (0x0193, 0w0, 0w0, noFree) | compileMessage (LB_SETHORIZONTALEXTENT{extent}) = (0x0194, SysWord.fromInt extent, 0w0, noFree) | compileMessage (LB_SETCOLUMNWIDTH{column}) = (0x0195, SysWord.fromInt column, 0w0, noFree) | compileMessage (LB_ADDFILE{fileName}) = compileStringAsLp(0x0196, 0w0, fileName) | compileMessage (LB_SETTOPINDEX{index}) = (0x0197, SysWord.fromInt index, 0w0, noFree) | compileMessage (LB_GETITEMRECT{rect=ref rect, index}) = compileGetRect(0x0198, SysWord.fromInt index, rect) | compileMessage (LB_GETITEMDATA{index}) = (0x0199, SysWord.fromInt index, 0w0, noFree) | compileMessage (LB_SETITEMDATA{index, data}) = (0x019A, SysWord.fromInt index, SysWord.fromInt data, noFree) | compileMessage (LB_SELITEMRANGE{select, first, last}) = (0x019B, SysWord.fromInt(btoi select), makeLong(first, last), noFree) | compileMessage (LB_SETANCHORINDEX{index}) = (0x019C, SysWord.fromInt index, 0w0, noFree) | compileMessage LB_GETANCHORINDEX = (0x019D, 0w0, 0w0, noFree) | compileMessage (LB_SETCARETINDEX{index, scroll}) = (0x019E, SysWord.fromInt index, SysWord.fromInt(btoi scroll), noFree) | compileMessage LB_GETCARETINDEX = (0x019F, 0w0, 0w0, noFree) | compileMessage (LB_SETITEMHEIGHT{index, height}) = (0x01A0, SysWord.fromInt index, makeLong(height, 0), noFree) | compileMessage (LB_GETITEMHEIGHT{index}) = (0x01A1, SysWord.fromInt index, 0w0, noFree) | compileMessage (LB_FINDSTRINGEXACT{text, indexStart}) = compileStringAsLp(0x01A2, SysWord.fromInt indexStart, text) | compileMessage (LB_SETLOCALE{locale}) = (0x01A5, SysWord.fromInt locale, 0w0, noFree) | compileMessage LB_GETLOCALE = (0x01A6, 0w0, 0w0, noFree) | compileMessage (LB_SETCOUNT{items}) = (0x01A7, SysWord.fromInt items, 0w0, noFree) | compileMessage (LB_INITSTORAGE{items, bytes}) = (0x01A8, SysWord.fromInt items, SysWord.fromInt bytes, noFree) | compileMessage (LB_ITEMFROMPOINT { point = {x, y}}) = (0x01A9, 0w0, makeLong(x,y), noFree) | compileMessage (WM_MOUSEMOVE margs) = compileMouseMove(0x0200, margs) | compileMessage (WM_LBUTTONDOWN margs) = compileMouseMove(0x0201, margs) | compileMessage (WM_LBUTTONUP margs) = compileMouseMove(0x0202, margs) | compileMessage (WM_LBUTTONDBLCLK margs) = compileMouseMove(0x0203, margs) | compileMessage (WM_RBUTTONDOWN margs) = compileMouseMove(0x0204, margs) | compileMessage (WM_RBUTTONUP margs) = compileMouseMove(0x0205, margs) | compileMessage (WM_RBUTTONDBLCLK margs) = compileMouseMove(0x0206, margs) | compileMessage (WM_MBUTTONDOWN margs) = compileMouseMove(0x0207, margs) | compileMessage (WM_MBUTTONUP margs) = compileMouseMove(0x0208, margs) | compileMessage (WM_MBUTTONDBLCLK margs) = compileMouseMove(0x0209, margs) (* WM_MOUSEWHEEL 0x020A *) | compileMessage (WM_PARENTNOTIFY { eventflag, idchild, value}) = (0x0210, makeLong(eventflag,idchild), SysWord.fromInt value, noFree) | compileMessage (WM_ENTERMENULOOP {istrack}) = (0x0211, SysWord.fromInt(btoi istrack), 0w0, noFree) | compileMessage (WM_EXITMENULOOP {istrack}) = (0x0212, SysWord.fromInt(btoi istrack), 0w0, noFree) (* WM_NEXTMENU 0x0213 WM_SIZING 0x0214 *) | compileMessage (WM_CAPTURECHANGED {newCapture}) = (0x0215, 0w0, fromHWND newCapture, noFree) (* WM_MOVING 0x0216 WM_POWERBROADCAST 0x0218 WM_DEVICECHANGE 0x0219 *) | compileMessage (WM_MDICREATE{class, title, instance, x, y, cx, cy, style, cdata}) = strAddrAsLp (0x0220, 0w0, fromMdiCreate(class,title,instance,x,y,cx,cy,style,cdata)) | compileMessage (WM_MDIDESTROY{child}) = (0x0221, fromHWND child, 0w0, noFree) | compileMessage (WM_MDIRESTORE{child}) = (0x0223, fromHWND child, 0w0, noFree) | compileMessage (WM_MDINEXT{child, flagnext}) = (0x0224, fromHWND child, SysWord.fromInt(btoi flagnext), noFree) | compileMessage (WM_MDIMAXIMIZE{child}) = (0x0225, fromHWND child, 0w0, noFree) | compileMessage (WM_MDITILE{tilingflag}) = (0x0226, Word32.toLargeWord(toCmdif tilingflag), 0w0, noFree) | compileMessage (WM_MDICASCADE{skipDisabled}) = (0x0227, SysWord.fromInt(if skipDisabled then 2 else 0), 0w0, noFree) | compileMessage WM_MDIICONARRANGE = (0x0228, 0w0, 0w0, noFree) | compileMessage WM_MDIGETACTIVE = (0x0229, 0w0, 0w0 (* MUST be null *), noFree) | compileMessage (WM_MDISETMENU{frameMenu, windowMenu}) = (0x0230, fromHMENU frameMenu, fromHMENU windowMenu, noFree) | compileMessage WM_ENTERSIZEMOVE = (0x0231, 0w0, 0w0, noFree) | compileMessage WM_EXITSIZEMOVE = (0x0232, 0w0, 0w0, noFree) | compileMessage (WM_DROPFILES{hDrop}) = (0x0233, fromHDROP hDrop, 0w0, noFree) | compileMessage WM_MDIREFRESHMENU = (0x0234, 0w0, 0w0, noFree) (* WM_IME_SETCONTEXT 0x0281 WM_IME_NOTIFY 0x0282 WM_IME_CONTROL 0x0283 WM_IME_COMPOSITIONFULL 0x0284 WM_IME_SELECT 0x0285 WM_IME_CHAR 0x0286 WM_IME_KEYDOWN 0x0290 WM_IME_KEYUP 0x0291 *) | compileMessage (WM_NCMOUSEHOVER {hitTest, x, y}) = (0x02A0, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) | compileMessage (WM_MOUSEHOVER margs) = compileMouseMove(0x02A1, margs) | compileMessage WM_NCMOUSELEAVE = (0x02A2, 0w0, 0w0, noFree) | compileMessage WM_MOUSELEAVE = (0x02A3, 0w0, 0w0, noFree) | compileMessage WM_CUT = (0x0300, 0w0, 0w0, noFree) | compileMessage WM_COPY = (0x0301, 0w0, 0w0, noFree) | compileMessage WM_PASTE = (0x0302, 0w0, 0w0, noFree) | compileMessage WM_CLEAR = (0x0303, 0w0, 0w0, noFree) | compileMessage WM_UNDO = (0x0304, 0w0, 0w0, noFree) | compileMessage (WM_RENDERFORMAT {format}) = (0x0305, SysWord.fromInt(toCcbf format), 0w0, noFree) | compileMessage WM_RENDERALLFORMATS = (0x0306, 0w0, 0w0, noFree) | compileMessage WM_DESTROYCLIPBOARD = (0x0307, 0w0, 0w0, noFree) | compileMessage WM_DRAWCLIPBOARD = (0x0308, 0w0, 0w0, noFree) | compileMessage (WM_PAINTCLIPBOARD{clipboard}) = (0x030A, fromHWND clipboard, 0w0, noFree) | compileMessage (WM_VSCROLLCLIPBOARD{viewer, code, position}) = (0x030A, fromHWND viewer, makeLong(code, position), noFree) | compileMessage (WM_SIZECLIPBOARD{viewer}) = (0x030B, 0w0, fromHWND viewer, noFree) | compileMessage (WM_ASKCBFORMATNAME {length, ...}) = compileStringRequest(0x030C, SysWord.fromInt length, length) | compileMessage (WM_CHANGECBCHAIN{removed, next}) = (0x030D, fromHWND removed, fromHWND next, noFree) | compileMessage (WM_HSCROLLCLIPBOARD{viewer, code, position}) = (0x030E, fromHWND viewer, makeLong(code, position), noFree) | compileMessage WM_QUERYNEWPALETTE = (0x030F, 0w0, 0w0, noFree) | compileMessage (WM_PALETTEISCHANGING{realize}) = (0x0310, fromHWND realize, 0w0, noFree) | compileMessage (WM_PALETTECHANGED{palChg}) = (0x0311, fromHWND palChg, 0w0, noFree) | compileMessage (WM_HOTKEY{id}) = (0x0312, SysWord.fromInt id, 0w0, noFree) | compileMessage (WM_PRINT{hdc, flags}) = (0x0317, fromHDC hdc, Word32.toLargeWord(toCwmpl flags), noFree) | compileMessage (WM_PRINTCLIENT{hdc, flags}) = (0x0318, fromHDC hdc, Word32.toLargeWord(toCwmpl flags), noFree) | compileMessage (FINDMSGSTRING args) = compileFindMsg args | compileMessage (WM_SYSTEM_OTHER{uMsg, wParam, lParam}) = (uMsg, wParam, lParam, noFree) | compileMessage (WM_USER{uMsg, wParam, lParam}) = (uMsg, wParam, lParam, noFree) | compileMessage (WM_APP{uMsg, wParam, lParam}) = (uMsg, wParam, lParam, noFree) | compileMessage (WM_REGISTERED{uMsg, wParam, lParam}) = (uMsg, wParam, lParam, noFree) local val msgStruct = cStruct6(cHWND, cUint, cUINT_PTRw, cUINT_PTRw, cDWORD, cPoint) val { load=loadMsg, store=storeMsg, ctype={size=msgSize, ... }, ... } = breakConversion msgStruct in (* Store the address of the message in the memory. *) fun storeMessage(v: voidStar, {msg, hwnd, time, pt}: MSG) = let val (msgId: int, wParam, lParam, freeMem) = compileMessage msg val mem = Memory.malloc msgSize val f = storeMsg(mem, (hwnd, msgId, wParam, lParam, Int.fromLarge(Time.toMilliseconds time), pt)) in setAddress(v, 0w0, mem); fn () => (freeMem(); f(); Memory.free mem) end fun loadMessage(v: voidStar): MSG = let val (hWnd, msgId, wParam, lParam, t, pt) = loadMsg v val msg = decompileMessage(msgId, wParam, lParam) (*val () = case msg of WM_USER _ => TextIO.print(Int.toString msgId ^ "\n") | _ => ()*) in { msg = msg, hwnd = hWnd, time = Time.fromMilliseconds(LargeInt.fromInt t), pt = pt } end val LPMSG: MSG conversion = makeConversion { load = loadMessage, store = storeMessage, ctype=LowLevel.cTypePointer } val msgSize = msgSize end (* Update the lParam/wParam values from the values in a returned message. This is needed if an ML callback makes a modification that has to be passed back to C. *) (* TODO: The rest of these. *) local fun copyString(_, _, 0) = () (* If the length is zero do nothing *) | copyString(ptr: voidStar, s: string, length: int) = let open Memory fun copyChar(i, c) = if i < length then set8(ptr, Word.fromInt i, Byte.charToByte c) else () in CharVector.appi copyChar s; (* Null terminate either at the end of the string or the buffer *) set8(ptr, Word.fromInt(Int.min(size s + 1, length-1)), 0w0) end in fun updateParamsFromMessage(msg: Message, wp: SysWord.word, lp: SysWord.word): unit = case msg of WM_GETTEXT{text = ref t, ...} => copyString(toAddr lp, t, SysWord.toInt wp) | WM_ASKCBFORMATNAME{formatName = ref t, ...} => copyString(toAddr lp, t, SysWord.toInt wp) | EM_GETLINE{result = ref t, size, ...} => copyString(toAddr lp, t, size) | EM_GETRECT {rect = ref r} => toCrect(toAddr lp, r) | EM_GETSEL args => updateGetSelParms({wp=wp, lp=lp}, args) | CB_GETEDITSEL args => updateGetSelParms({wp=wp, lp=lp}, args) | CB_GETLBTEXT {text = ref t, length, ...} => copyString(toAddr lp, t, length) | CB_GETDROPPEDCONTROLRECT {rect = ref r} => toCrect(toAddr lp, r) | SBM_GETRANGE {minPos=ref minPos, maxPos=ref maxPos} => (ignore(storeInt(toAddr wp, minPos)); ignore(storeInt(toAddr lp, maxPos))) | SBM_GETSCROLLINFO args => updateScrollInfo({wp=wp, lp=lp}, args) | LB_GETTEXT {text = ref t, length, ...} => copyString(toAddr lp, t, length) | LB_GETSELITEMS args => updateGetSelItemsParms({wp=wp, lp=lp}, args) | LB_GETITEMRECT{rect = ref r, ...} => toCrect(toAddr lp, r) | WM_NCCALCSIZE { newrect = ref r, ...} => toCrect(toAddr lp, r) (* This sets the first rect *) | WM_MEASUREITEM args => updateMeasureItemParms({wp=wp, lp=lp}, args) | WM_GETMINMAXINFO args => updateMinMaxParms({wp=wp, lp=lp}, args) | WM_WINDOWPOSCHANGING args => updateWindowPosChangingParms({wp=wp, lp=lp}, args) (* | WM_NOTIFY{ notification=TTN_GETDISPINFO(ref s), ...} => (* This particular notification allows the result to be fed back in several ways. We copy into the char array. *) assign charArray80 (offset 1 (Cpointer Cvoid) (offset 1 nmhdr (deref lp))) (toCcharArray80 s) *) | _ => () end (* Update the message contents from the values of wParam/lParam. This is used when a message has been sent or passed into C code that may have updated the message contents. Casts certain message results to HGDIOBJ. *) fun messageReturnFromParams(msg: Message, wp: SysWord.word, lp: SysWord.word, reply: SysWord.word): LRESULT = let val () = (* For certain messages we need to extract the reply from the arguments. *) case msg of WM_GETTEXT{text, ...} => text := (if reply = 0w0 then "" else fromCstring(toAddr lp)) | WM_ASKCBFORMATNAME{formatName, ...} => formatName := (if reply = 0w0 then "" else fromCstring(toAddr lp)) | EM_GETLINE{result, ...} => result := (if reply = 0w0 then "" else fromCstring(toAddr lp)) | EM_GETRECT { rect } => rect := fromCrect(toAddr lp) | EM_GETSEL args => updateGetSelFromWpLp(args, {wp=wp, lp=lp}) | CB_GETEDITSEL args => updateGetSelFromWpLp(args, {wp=wp, lp=lp}) | CB_GETLBTEXT {text, ...} => text := (if reply = 0w0 then "" else fromCstring(toAddr lp)) | CB_GETDROPPEDCONTROLRECT { rect } => rect := fromCrect(toAddr lp) | SBM_GETRANGE {minPos, maxPos} => (minPos := loadInt(toAddr wp); maxPos := loadInt(toAddr lp)) | SBM_GETSCROLLINFO {info, ...} => let val ({minPos, maxPos, pageSize, pos, trackPos}, _) = toScrollInfo lp in info := {minPos = minPos, maxPos = maxPos, pageSize = pageSize, pos = pos, trackPos = trackPos} end | LB_GETTEXT {text, ...} => text := (if reply = 0w0 then "" else fromCstring(toAddr lp)) | LB_GETSELITEMS args => updateGetSelItemsFromWpLp(args, {wp=wp, lp=lp, reply=reply}) | LB_GETITEMRECT{rect, ...} => rect := fromCrect(toAddr lp) (* This also has an item index *) | WM_NCCALCSIZE { newrect, ...} => (* Whatever the value of "validarea" we just look at the first rectangle. *) newrect := fromCrect (toAddr lp) | WM_GETMINMAXINFO args => updateMinMaxFromWpLp(args, {wp=wp, lp=lp}) | WM_WINDOWPOSCHANGING wpCh => updateCfromMLwmWindowPosChanging({wp=wp, lp=lp}, wpCh) | WM_MEASUREITEM args => updateMeasureItemFromWpLp(args, {wp=wp, lp=lp}) | _ => () val fromHgdi = handleOfVoidStar o toAddr in (* We need to "cast" some of the results. *) case msg of WM_GETFONT => LRESHANDLE(fromHgdi reply) | WM_GETICON _ => LRESHANDLE(fromHgdi reply) | WM_SETICON _ => LRESHANDLE(fromHgdi reply) | BM_GETIMAGE _ => LRESHANDLE(fromHgdi reply) | BM_SETIMAGE _ => LRESHANDLE(fromHgdi reply) | STM_GETICON => LRESHANDLE(fromHgdi reply) | STM_GETIMAGE _ => LRESHANDLE(fromHgdi reply) | STM_SETICON _ => LRESHANDLE(fromHgdi reply) | STM_SETIMAGE _ => LRESHANDLE(fromHgdi reply) | _ => LRESINT (SysWord.toInt reply) end (* Window callback table. *) local type callback = HWND * int * SysWord.word * SysWord.word -> SysWord.word (* *) datatype tableEntry = TableEntry of {hWnd: HWND, callBack: callback} (* Windows belong to the thread that created them so each thread has its own list of windows. Any thread could have one outstanding callback waiting to be assigned to a window that is being created. *) val threadWindows = Universal.tag(): tableEntry list Universal.tag val threadOutstanding = Universal.tag(): callback option Universal.tag (* This message is used to test if we are using the Poly callback. We use the same number as MFC uses so it's unlikely that any Windows class will use this. *) val WMTESTPOLY = 0x0360 fun getWindowList (): tableEntry list = getOpt (Thread.Thread.getLocal threadWindows, []) and setWindowList(t: tableEntry list): unit = Thread.Thread.setLocal(threadWindows, t) fun getOutstanding(): callback option = Option.join(Thread.Thread.getLocal threadOutstanding) and setOutstanding(t: callback option): unit = Thread.Thread.setLocal(threadOutstanding, t) (* Get the callback for this window. If it's the first time we've had a message for this window we need to use the outstanding callback. *) fun getCallback(hw: HWND): callback = case List.find (fn (TableEntry{hWnd, ...}) => hw = hWnd) (getWindowList ()) of SOME(TableEntry{callBack, ...}) => callBack | NONE => (* See if this has just been set up. *) (case getOutstanding() of SOME cb => (* It has. We now know the window handle so link it up. *) ( setWindowList(TableEntry{hWnd=hw, callBack=cb} :: getWindowList ()); setOutstanding NONE; cb ) | NONE => raise Fail "No callback found" ) fun removeCallback(hw: HWND): unit = setWindowList(List.filter (fn(TableEntry{hWnd, ...}) => hw <> hWnd) (getWindowList ())) fun mainCallbackFunction(hw:HWND, msgId:int, wParam:SysWord.word, lParam:SysWord.word): SysWord.word = if msgId = WMTESTPOLY then SysWord.fromInt ~1 (* This tests whether we are already installed. *) else getCallback hw (hw, msgId, wParam, lParam) val mainWinProc = buildClosure4withAbi(mainCallbackFunction, winAbi, (cHWND, cUint, cUINT_PTRw, cUINT_PTRw), cUINT_PTRw) val WNDPROC: (HWND * int * SysWord.word * SysWord.word -> SysWord.word) closure conversion = cFunction (* This is used to set the window proc. The result is also a window proc. *) val SetWindowLong = winCall3 (user "SetWindowLongPtrA") (cHWND, cInt, WNDPROC) cPointer val CallWindowProc = winCall5 (user "CallWindowProcA") (cPointer, cHWND, cUint, cUINT_PTRw, cUINT_PTRw) cUINT_PTRw in val mainWinProc = mainWinProc and removeCallback = removeCallback fun windowCallback (call: HWND * Message * 'a -> LRESULT * 'a, init: 'a): (HWND * int * SysWord.word * SysWord.word -> SysWord.word) = let val state = ref init fun callBack(h: HWND, uMsg:int, wParam: SysWord.word, lParam: SysWord.word): SysWord.word = let val msg = decompileMessage(uMsg, wParam, lParam) handle exn => ( print(concat["Exception with message ", Int.toString uMsg, exnMessage exn ]); WM_NULL ) val (result, newState) = call(h, msg, !state) handle exn => ( print(concat["Exception with message ", PolyML.makestring msg, exnMessage exn ]); (LRESINT 0, !state) ) in (* For a few messages we have to update the value pointed to by wParam/lParam after we've handled it. *) updateParamsFromMessage(msg, wParam, lParam); state := newState; (* If our callback returned SOME x we use that as the result, otherwise we call the default. We do it this way rather than having the caller call DefWindowProc because that would involve recompiling the message and we can't guarantee that all the parameters of the original message would be correctly set. *) case result of LRESINT res => SysWord.fromInt res | LRESHANDLE res => fromAddr(voidStarOfHandle res) end; in callBack end (* When we first set up a callback we don't know the window handle so we use null. *) fun setCallback(call, init) = setOutstanding(SOME(windowCallback(call, init))) val sendMsg = winCall4(user "SendMessageA") (cHWND, cUint, cUINT_PTRw, cUINT_PTRw) cUINT_PTRw fun subclass(w: HWND, f: HWND * Message * 'a -> LRESULT * 'a, init: 'a): (HWND * Message -> LRESULT) = let val testPoly = sendMsg(w, WMTESTPOLY, 0w0, 0w0) fun addCallback (hWnd, call: HWND * Message * 'a -> LRESULT * 'a, init: 'a): unit = setWindowList( TableEntry{ hWnd = hWnd, callBack = windowCallback(call, init) } :: getWindowList ()) val oldDefProc: callback = if SysWord.toIntX testPoly = ~1 then (* We already have our Window proc installed. *) let (* We should have a callback already installed. *) val oldCallback = getCallback w in removeCallback w; addCallback(w, f, init); oldCallback end else let (* Set up the new window proc and get the existing one. *) val oldWProc = SetWindowLong(w, ~4, mainWinProc) val defProc = fn (h, m, w, l) => CallWindowProc(oldWProc, h, m, w, l) in (* Remove any existing callback function and install the new one. *) removeCallback w; addCallback(w, f, init); defProc end in fn (hw: HWND, msg: Message) => let val (m: int, w: SysWord.word, l: SysWord.word, freeMem) = compileMessage msg val res: SysWord.word = oldDefProc(hw, m, w, l) in messageReturnFromParams(msg, w, l, res) before freeMem() end end end (* Keyboard operations on modeless dialogues are performed by isDialogMessage. We keep a list of modeless dialogues and process them in the main message loop. This also has an important function for dialogues created by FindText. They allocate memory which can't be freed until the dialogue has gone. *) local val modeless = ref [] val isDialogMessage = winCall2 (user "IsDialogMessage") (cHWND, cPointer) cBool val isWindow = winCall1 (user "IsWindow") (cHWND) cBool in fun addModelessDialogue (hWnd: HWND, doFree) = modeless := (hWnd, doFree) :: (!modeless) fun isDialogueMsg(msg: voidStar) = let (* Take this opportunity to filter any dialogues that have gone away. *) (* If this has gone away run any "free" function.*) fun filter(w, f) = if isWindow w then true (* Still there *) else (case f of NONE => () | SOME f => f(); false) in modeless := List.filter filter (!modeless); (* See if isDialogMessage returns true for any of these. *) List.foldl (fn ((w, _), b) => b orelse isDialogMessage(w, msg)) false (!modeless) end end datatype PeekMessageOptions = PM_NOREMOVE | PM_REMOVE (* TODO: We can also include PM_NOYIELD. *) val peekMsg = winCall5(user "PeekMessageA") (cPointer, cHWND, cUint, cUint, cUint) cBool fun PeekMessage(hWnd: HWND option, wMsgFilterMin: int, wMsgFilterMax: int, remove: PeekMessageOptions): MSG option = let val msg = malloc msgSize val opts = case remove of PM_REMOVE => 1 | PM_NOREMOVE => 0 val res = peekMsg(msg, getOpt(hWnd, hNull), wMsgFilterMin, wMsgFilterMax, opts) in (if not res then NONE else SOME(loadMessage msg)) before free msg end; - (* TODO: This was originally implemented before we had threads. The only reason - for continuing with it is to allow the thread to be interrupted. *) + (* This was originally implemented before we had threads and used a RTS call to + pick up the messages. *) + + val WaitMessage = winCall0 (user "WaitMessage") () cBool + local - val callWin = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val getMsg = winCall4(user "GetMessage") (cPointer, cHWND, cUint, cUint) cBool in - fun pauseForMessage(hwnd: HWND, min, max): unit = - callWin(1101, (hwnd, min, max)) - - (* We implement WaitMessage within the RTS. *) - fun WaitMessage(): bool = - (pauseForMessage(hwndNull, 0, 0); true) + fun GetMessage(hWnd: HWND option, wMsgFilterMin: int, wMsgFilterMax: int): MSG = + let + val msg = malloc msgSize + val res = getMsg(msg, getOpt(hWnd, hNull), wMsgFilterMin, wMsgFilterMax) + in + loadMessage msg before free msg + end end - (* We don't use the underlying GetMessage function because that blocks the - thread which would prevent other ML processes from running. Instead we - use PeekMessage and an RTS call which allows other threads to run. *) - fun GetMessage(hWnd: HWND option, wMsgFilterMin: int, wMsgFilterMax: int): MSG = - case PeekMessage(hWnd, wMsgFilterMin, wMsgFilterMax, PM_REMOVE) of - SOME msg => msg - | NONE => - let - val hwnd = getOpt(hWnd, hwndNull) - in - pauseForMessage(hwnd, wMsgFilterMin, wMsgFilterMax); - GetMessage(hWnd, wMsgFilterMin, wMsgFilterMax) - end - (* Wait for messages and dispatch them. It only returns when a QUIT message has been received. *) local val peekMsg = winCall5(user "PeekMessageA") (cPointer, cHWND, cUint, cUint, cUint) cBool val transMsg = winCall1(user "TranslateMessage") (cPointer) cBool val dispMsg = winCall1(user "DispatchMessageA") (cPointer) cInt in fun RunApplication() = let val msg = malloc msgSize val res = peekMsg(msg, hNull, 0, 0, 1) in if not res then (* There's no message at the moment. Wait for one. *) (free msg; WaitMessage(); RunApplication()) else case loadMessage msg of { msg = WM_QUIT{exitcode}, ...} => (free msg; exitcode) | _ => ( if isDialogueMsg msg then () else ( transMsg msg; dispMsg msg; () ); free msg; RunApplication() ) end end local val sendMsg = winCall4(user "SendMessageA") (cHWND, cUint, cUINT_PTRw, cUINT_PTRw) cUINT_PTRw in fun SendMessage(hWnd: HWND, msg: Message) = let val (msgId, wp, lp, freeMem) = compileMessage msg val reply = sendMsg(hWnd, msgId, wp, lp) in (* Update any result values and cast the results if necessary. *) messageReturnFromParams(msg, wp, lp, reply) before freeMem() end end local val postMessage = winCall4(user "PostMessageA") (cHWND, cUint, cUINT_PTRw, cUINT_PTRw) (successState "PostMessage") in fun PostMessage(hWnd: HWND, msg: Message) = let val (msgId, wp, lp, _) = compileMessage msg (* This could result in a memory leak. *) in postMessage(hWnd, msgId, wp, lp) end end val HWND_BROADCAST: HWND = handleOfVoidStar(sysWord2VoidStar 0wxffff) val PostQuitMessage = winCall1 (user "PostQuitMessage") cInt cVoid val RegisterWindowMessage = winCall1 (user "RegisterWindowMessageA") (cString) cUint val InSendMessage = winCall0 (user "InSendMessage") () cBool val GetInputState = winCall0 (user "GetInputState") () cBool local val getMessagePos = winCall0 (user "GetMessagePos") () cDWORDw in fun GetMessagePos(): POINT = let val r = getMessagePos () in { x = Word.toInt(LOWORD r), y = Word.toInt(HIWORD r) } end end val GetMessageTime = Time.fromMilliseconds o LargeInt.fromInt o winCall0 (user "GetMessageTime") () cLong datatype QueueStatus = QS_KEY | QS_MOUSEMOVE | QS_MOUSEBUTTON | QS_POSTMESSAGE | QS_TIMER | QS_PAINT | QS_SENDMESSAGE | QS_HOTKEY | QS_ALLPOSTMESSAGE local val tab = [ (QS_KEY, 0wx0001), (QS_MOUSEMOVE, 0wx0002), (QS_MOUSEBUTTON, 0wx0004), (QS_POSTMESSAGE, 0wx0008), (QS_TIMER, 0wx0010), (QS_PAINT, 0wx0020), (QS_SENDMESSAGE, 0wx0040), (QS_HOTKEY, 0wx0080), (QS_ALLPOSTMESSAGE, 0wx0100) ] in val (fromQS, toQS) = tableSetLookup(tab, NONE) end val QS_MOUSE = [QS_MOUSEMOVE, QS_MOUSEBUTTON] val QS_INPUT = QS_KEY :: QS_MOUSE val QS_ALLEVENTS = QS_POSTMESSAGE :: QS_TIMER :: QS_PAINT :: QS_HOTKEY :: QS_INPUT val QS_ALLINPUT = QS_SENDMESSAGE :: QS_ALLEVENTS local val getQueueStatus = winCall1 (user "GetQueueStatus") (cUintw) cDWORDw in fun GetQueueStatus flags = let val res = getQueueStatus(fromQS flags) in (* The RTS uses PeekMessage internally so the "new messages" value in the LOWORD is meaningless. *) toQS(Word32.fromLargeWord(Word.toLargeWord(HIWORD(res)))) end end (* BroadcastSystemMessage DispatchMessage GetMessageExtraInfo InSendMessageEx - NT 5.0 and Windows 98 PostThreadMessage ReplyMessage SendAsyncProc SendMessageCallback SendMessageTimeout SendNotifyMessage SetMessageExtraInfo TranslateMessage Obsolete Functions PostAppMessage SetMessageQueue *) end end; diff --git a/polyml.pyp b/polyml.pyp index b39f8397..1846bcb0 100644 --- a/polyml.pyp +++ b/polyml.pyp @@ -1,240 +1,240 @@ + - diff --git a/winconfig.h b/winconfig.h index 9a00dbc8..897f0fae 100644 --- a/winconfig.h +++ b/winconfig.h @@ -1,748 +1,749 @@ /* Hand-generated config file for Windows. */ #ifndef CONF_H_INCLUDED #define CONF_H_INCLUDED /* Define if building universal (internal helper macro) */ #undef AC_APPLE_UNIVERSAL_BUILD /* Define to one of `_getb67', `GETB67', `getb67' for Cray-2 and Cray-YMP systems. This function is required for `alloca.c' support on those systems. */ #undef CRAY_STACKSEG_END /* Define to 1 if using `alloca.c'. */ #undef C_ALLOCA /* Define to the type of elements in the array set by `getgroups'. Usually this is either `int' or `gid_t'. */ #undef GETGROUPS_T /* Define to 1 if the `getpgrp' function requires zero arguments. */ #undef GETPGRP_VOID /* Define to 1 if you have `alloca', as a function or macro. */ #undef HAVE_ALLOCA #define HAVE_ALLOCA 1 /* Define to 1 if you have and it should be used (not on Ultrix). */ #undef HAVE_ALLOCA_H /* Define to 1 if you have the header file. */ #undef HAVE_ASM_ELF_H /* Define to 1 if you have the header file. */ #undef HAVE_ASSERT_H #define HAVE_ASSERT_H 1 /* Define to 1 if you have the `ctermid' function. */ #undef HAVE_CTERMID /* Define to 1 if you have the header file. */ #undef HAVE_CTYPE_H #define HAVE_CTYPE_H 1 /* Define to 1 if you have the declaration of `fpsetmask', and to 0 if you don't. */ #undef HAVE_DECL_FPSETMASK /* Define to 1 if you have the header file. */ #undef HAVE_DIRECT_H #define HAVE_DIRECT_H 1 /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_DIRENT_H /* Define to 1 if you have the header file. */ #undef HAVE_DLFCN_H /* Define to 1 if you have the `dlopen' function. */ #undef HAVE_DLOPEN /* Define to 1 if you have the `dtoa' function. */ #undef HAVE_DTOA /* Define to 1 if you have and header files. */ #undef HAVE_ELF_ABI_H /* Define to 1 if you have the header file. */ #undef HAVE_ELF_H /* Define to 1 if you have the header file. */ #undef HAVE_ERRNO_H #define HAVE_ERRNO_H 1 /* Define to 1 if you have the header file. */ #undef HAVE_EXCPT_H #define HAVE_EXCPT_H 1 /* Define to 1 if you have the header file. */ #undef HAVE_FCNTL_H #define HAVE_FCNTL_H 1 /* Define to 1 if you have the header file. */ #undef HAVE_FENV_H #if (defined(_MSC_VER) && (_MSC_VER >= 1800)) // Defined in VS 2013 #define HAVE_FENV_H 1 #endif /* Define to 1 if you have the header file. */ #undef HAVE_FLOAT_H #define HAVE_FLOAT_H 1 /* Define to 1 if you have the header file. */ #undef HAVE_FPU_CONTROL_H /* Define to 1 if your system has a working `getgroups' function. */ #undef HAVE_GETGROUPS /* Define to 1 if you have the `getpagesize' function. */ #undef HAVE_GETPAGESIZE /* Define to 1 if you have the gmp.h header file */ #undef HAVE_GMP_H /* Define to 1 if you have the `gmtime_r' function. */ #undef HAVE_GMTIME_R /* Define to 1 if you have .note.GNU-stack support in the assembler. */ #undef HAVE_GNU_STACK /* Define to 1 if you have the header file. */ #undef HAVE_GRP_H /* Define to 1 if you have the header file. */ #undef HAVE_IEEEFP_H /* Define to 1 if the system has the type `IMAGE_FILE_HEADER'. */ #undef HAVE_IMAGE_FILE_HEADER #define HAVE_IMAGE_FILE_HEADER 1 /* Define to 1 if the system has the type `intptr_t'. */ #undef HAVE_INTPTR_T /* Define to 1 if you have the header file. */ #undef HAVE_INTTYPES_H // This was present in VS 2013 but not 2015. /* Define to 1 if you have the header file. */ #undef HAVE_IO_H #define HAVE_IO_H 1 /* Define to 1 if you have the `gcc' library (-lgcc). */ #undef HAVE_LIBGCC /* Define to 1 if you have the `gcc_s' library (-lgcc_s). */ #undef HAVE_LIBGCC_S /* Define to 1 if you have the `gdi32' library (-lgdi32). */ #undef HAVE_LIBGDI32 #define HAVE_LIBGDI32 1 /* Define to 1 if you have libgmp */ #undef HAVE_LIBGMP /* Define to 1 if you have the `pthread' library (-lpthread). */ #undef HAVE_LIBPTHREAD /* Define to 1 if you have the `stdc++' library (-lstdc++). */ #undef HAVE_LIBSTDC__ /* Define to 1 if you have the `ws2_32' library (-lws2_32). */ #undef HAVE_LIBWS2_32 #define HAVE_LIBWS2_32 1 /* Define to 1 if you have the `X11' library (-lX11). */ #undef HAVE_LIBX11 /* Define to 1 if you have the `Xext' library (-lXext). */ #undef HAVE_LIBXEXT /* Define to 1 if you have the `Xm' library (-lXm). */ #undef HAVE_LIBXM /* Define to 1 if you have the `Xt' library (-lXt). */ #undef HAVE_LIBXT /* Define to 1 if you have the header file. */ #undef HAVE_LIMITS_H +#define HAVE_LIMITS_H 1 /* Define to 1 if you have the header file. */ #undef HAVE_LOCALE_H #define HAVE_LOCALE_H 1 /* Define to 1 if you have the `localtime_r' function. */ #undef HAVE_LOCALTIME_R /* Define to 1 if the system has the type `long long'. */ #undef HAVE_LONG_LONG #define HAVE_LONG_LONG 1 /* Define to 1 if you have the header file. */ #undef HAVE_MACHINE_RELOC_H /* Define to 1 if you have the header file. */ #undef HAVE_MACH_O_RELOC_H /* Define to 1 if you have the header file. */ #undef HAVE_MALLOC_H #define HAVE_MALLOC_H 1 /* Define to 1 if you have the header file. */ #undef HAVE_MATH_H #define HAVE_MATH_H 1 /* Define to 1 if `gregs' is a member of `mcontext_t'. */ #undef HAVE_MCONTEXT_T_GREGS /* Define to 1 if `mc_esp' is a member of `mcontext_t'. */ #undef HAVE_MCONTEXT_T_MC_ESP /* Define to 1 if `regs' is a member of `mcontext_t'. */ #undef HAVE_MCONTEXT_T_REGS /* Define to 1 if you have the header file. */ #undef HAVE_MEMORY_H #define HAVE_MEMORY_H 1 /* Define to 1 if you have the `mkstemp' function. */ #undef HAVE_MKSTEMP /* Define to 1 if you have the `mmap' function. */ #undef HAVE_MMAP /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_NDIR_H /* Define to 1 if you have the header file. */ #undef HAVE_NETDB_H /* Define to 1 if you have the header file. */ #undef HAVE_NETINET_IN_H /* Define to 1 if you have the header file. */ #undef HAVE_NETINET_TCP_H /* Define to 1 if you have the PE/COFF types. */ #undef HAVE_PECOFF #define HAVE_PECOFF 1 /* Define to 1 if you have the header file. */ #undef HAVE_POLL_H /* Define to 1 if you have the header file. */ #undef HAVE_PTHREAD_H /* Define to 1 if you have the header file. */ #undef HAVE_PWD_H /* Define to 1 if you have the header file. */ #undef HAVE_SEMAPHORE_H /* Define to 1 if you have the `sigaltstack' function. */ #undef HAVE_SIGALTSTACK /* Define to 1 if the system has the type `sighandler_t'. */ #undef HAVE_SIGHANDLER_T /* Define to 1 if you have the header file. */ #undef HAVE_SIGINFO_H /* Define to 1 if you have the header file. */ #undef HAVE_SIGNAL_H #define HAVE_SIGNAL_H 1 /* Define to 1 if the system has the type `sig_t'. */ #undef HAVE_SIG_T /* Define to 1 if the system has the type `socklen_t'. */ #undef HAVE_SOCKLEN_T /* Define to 1 if the system has the type `ssize_t'. */ #undef HAVE_SSIZE_T /* Define to 1 if the system has the type `stack_t'. */ #undef HAVE_STACK_T /* Define to 1 if `stat' has the bug that it succeeds when given the zero-length file name argument. */ #undef HAVE_STAT_EMPTY_STRING_BUG /* Define to 1 if you have the header file. */ #undef HAVE_STDARG_H /* Define to 1 if stdbool.h conforms to C99. */ #undef HAVE_STDBOOL_H /* Define to 1 if you have the header file. */ #undef HAVE_STDDEF_H #define HAVE_STDDEF_H 1 /* Define to 1 if you have the header file. */ #undef HAVE_STDINT_H #define HAVE_STDINT_H 1 /* Define to 1 if you have the header file. */ #undef HAVE_STDIO_H #define HAVE_STDIO_H 1 /* Define to 1 if you have the header file. */ #undef HAVE_STDLIB_H #define HAVE_STDLIB_H 1 /* Define to 1 if you have the header file. */ #undef HAVE_STRINGS_H /* Define to 1 if you have the header file. */ #undef HAVE_STRING_H #define HAVE_STRING_H /* Define to 1 if you have the `strtod' function. */ #undef HAVE_STRTOD #define HAVE_STRTOD 1 /* Define to 1 if `ss' is a member of `struct mcontext'. */ #undef HAVE_STRUCT_MCONTEXT_SS /* Define to 1 if the system has the type `struct sigcontext'. */ #undef HAVE_STRUCT_SIGCONTEXT /* Define to 1 if `sun_len' is a member of `struct sockaddr_un'. */ #undef HAVE_STRUCT_SOCKADDR_UN_SUN_LEN /* Define to 1 if `st_atim' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_ATIM /* Define to 1 if `st_atimensec' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_ATIMENSEC /* Define to 1 if `st_atimespec' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_ATIMESPEC /* Define to 1 if `st_atime_n' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_ATIME_N /* Define to 1 if `st_uatime' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_UATIME /* Define to 1 if `ss' is a member of `struct __darwin_mcontext32'. */ #undef HAVE_STRUCT___DARWIN_MCONTEXT32_SS /* Define to 1 if `__ss' is a member of `struct __darwin_mcontext32'. */ #undef HAVE_STRUCT___DARWIN_MCONTEXT32___SS /* Define to 1 if `ss' is a member of `struct __darwin_mcontext64'. */ #undef HAVE_STRUCT___DARWIN_MCONTEXT64_SS /* Define to 1 if `__ss' is a member of `struct __darwin_mcontext64'. */ #undef HAVE_STRUCT___DARWIN_MCONTEXT64___SS /* Define to 1 if `ss' is a member of `struct __darwin_mcontext'. */ #undef HAVE_STRUCT___DARWIN_MCONTEXT_SS /* Define to 1 if `__ss' is a member of `struct __darwin_mcontext'. */ #undef HAVE_STRUCT___DARWIN_MCONTEXT___SS /* Define to 1 if you have the `sysctl' function. */ #undef HAVE_SYSCTL /* Define to 1 if you have the `sysctlbyname' function. */ #undef HAVE_SYSCTLBYNAME /* Define to 1 if the system has the type `SYSTEM_LOGICAL_PROCESSOR_INFORMATION'. */ #undef HAVE_SYSTEM_LOGICAL_PROCESSOR_INFORMATION #define HAVE_SYSTEM_LOGICAL_PROCESSOR_INFORMATION 1 /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_SYS_DIR_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_ELF_386_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_ELF_AMD64_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_ELF_SPARC_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_ERRNO_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_FILE_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_FILIO_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_IOCTL_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_MMAN_H /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_SYS_NDIR_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_PARAM_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_RESOURCE_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SELECT_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SIGNAL_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SOCKET_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SOCKIO_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_STAT_H #define HAVE_SYS_STAT_H 1 /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SYSCTL_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SYSTEMINFO_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TERMIOS_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TIMES_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TIME_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TYPES_H #define HAVE_SYS_TYPES_H 1 /* Define to 1 if you have the header file. */ #undef HAVE_SYS_UIO_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_UN_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_UTSNAME_H /* Define to 1 if you have that is POSIX.1 compatible. */ #undef HAVE_SYS_WAIT_H /* Define to 1 if you have the `tcdrain' function. */ #undef HAVE_TCDRAIN /* Define to 1 if you have the header file. */ #undef HAVE_TCHAR_H #define HAVE_TCHAR_H 1 /* Define to 1 if you have the header file. */ #undef HAVE_TERMIOS_H /* Define to 1 if you have the header file. */ #undef HAVE_TIME_H #define HAVE_TIME_H 1 /* Define to 1 if you have the header file. */ #undef HAVE_UCONTEXT_H /* Define to 1 if the system has the type `ucontext_t'. */ #undef HAVE_UCONTEXT_T /* Define to 1 if the system has the type `uintptr_t'. */ #undef HAVE_UINTPTR_T /* Define to 1 if you have the header file. */ #undef HAVE_UNISTD_H /* Define to 1 if you have the header file. */ #undef HAVE_VALUES_H /* Define to 1 if you have the header file. */ #undef HAVE_WINDOWS_H #define HAVE_WINDOWS_H 1 /* Define to 1 if you have the header file. */ #undef HAVE_X11_XLIB_H /* Define to 1 if you have the header file. */ #undef HAVE_XM_XM_H /* Define to 1 if the system has the type `_Bool'. */ #undef HAVE__BOOL /* These are commented out. They may be defined in the project settings. */ /* Define if the host is an ARM (64-bit) */ /*#undef HOSTARCHITECTURE_AARCH64*/ /* Define if the host is an Alpha (64-bit) */ /*#undef HOSTARCHITECTURE_ALPHA*/ /* Define if the host is an ARM (32-bit) */ /*#undef HOSTARCHITECTURE_ARM*/ /* Define if the host is an HP PA-RISC (32-bit) */ /*#undef HOSTARCHITECTURE_HPPA*/ /* Define if the host is an Itanium */ /*#undef HOSTARCHITECTURE_IA64*/ /* Define if the host is a Motorola 68000 */ /*#undef HOSTARCHITECTURE_M68K*/ /* Define if the host is a MIPS (32-bit) */ /*#undef HOSTARCHITECTURE_MIPS*/ /* Define if the host is a MIPS (64-bit) */ /*#undef HOSTARCHITECTURE_MIPS64*/ /* Define if the host is a PowerPC (32-bit) */ /*#undef HOSTARCHITECTURE_PPC*/ /* Define if the host is a PowerPC (64-bit) */ /*#undef HOSTARCHITECTURE_PPC64*/ /* Define if the host is a RISC-V (32-bit) */ /*#undef HOSTARCHITECTURE_RISCV32*/ /* Define if the host is a RISC-V (64-bit) */ /*#undef HOSTARCHITECTURE_RISCV64*/ /* Define if the host is an S/390 (32-bit) */ /*#undef HOSTARCHITECTURE_S390*/ /* Define if the host is an S/390 (64-bit) */ /*#undef HOSTARCHITECTURE_S390X*/ /* Define if the host is a SuperH (32-bit) */ /*#undef HOSTARCHITECTURE_SH*/ /* Define if the host is a Sparc (32-bit) */ /*#undef HOSTARCHITECTURE_SPARC*/ /* Define if the host is a Sparc (64-bit) */ /*#undef HOSTARCHITECTURE_SPARC64*/ /* Define if the host is an X86 (32-bit ABI, 64-bit processor) */ /*#undef HOSTARCHITECTURE_X32*/ /* Define if the host is a Sparc (32-bit) */ /*#undef HOSTARCHITECTURE_SPARC*/ /* Define if the host is an X86 (32-bit) */ /*#undef HOSTARCHITECTURE_X86*/ /* Define if the host is an X86 (64-bit) */ /*#undef HOSTARCHITECTURE_X86_64*/ /* Define if using the interpreter */ /*#undef INTERPRETED*/ /* Define to 1 if `lstat' dereferences a symlink specified with a trailing slash. */ #undef LSTAT_FOLLOWS_SLASHED_SYMLINK /* Define to the sub-directory where libtool stores uninstalled libraries. */ #undef LT_OBJDIR /* Name of package */ #undef PACKAGE /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT /* Define to the full name of this package. */ #undef PACKAGE_NAME /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME /* Define to the home page for this package. */ #undef PACKAGE_URL /* Define to the version of this package. */ #undef PACKAGE_VERSION /* Define to the type of arg 1 for `select'. */ #undef SELECT_TYPE_ARG1 /* Define to the type of args 2, 3 and 4 for `select'. */ #undef SELECT_TYPE_ARG234 /* Define to the type of arg 5 for `select'. */ #undef SELECT_TYPE_ARG5 /* The size of `double', as computed by sizeof. */ #define SIZEOF_DOUBLE 8 /* The size of `float', as computed by sizeof. */ #define SIZEOF_FLOAT 4 /* The size of `int', as computed by sizeof. */ // N.B. This is 4 on both 32-bit and 64-bit #define SIZEOF_INT 4 /* The size of `long', as computed by sizeof. */ // N.B. This is 4 on both 32-bit and 64-bit #define SIZEOF_LONG 4 /* The size of `void*', as computed by sizeof. */ #undef SIZEOF_VOIDP #ifdef _WIN64 #define SIZEOF_VOIDP 8 #else #define SIZEOF_VOIDP 4 #endif // Size of long long // N.B. This is 8 on both 32-bit and 64-bit #define SIZEOF_LONG_LONG 8 /* If using the C implementation of alloca, define if you know the direction of stack growth for your system; otherwise it will be automatically deduced at runtime. STACK_DIRECTION > 0 => grows toward higher addresses STACK_DIRECTION < 0 => grows toward lower addresses STACK_DIRECTION = 0 => direction of growth unknown */ #undef STACK_DIRECTION /* Define to 1 if you have the ANSI C header files. */ #undef STDC_HEADERS /* Defined if external symbols are prefixed by underscores */ #undef SYMBOLS_REQUIRE_UNDERSCORE #ifdef _WIN64 # undef SYMBOLS_REQUIRE_UNDERSCORE #else # define SYMBOLS_REQUIRE_UNDERSCORE 1 #endif /* Define to 1 if you can safely include both and . */ #undef TIME_WITH_SYS_TIME /* Define to 1 if your declares `struct tm'. */ #undef TM_IN_SYS_TIME /* Version number of package */ #undef VERSION /* Define if the X-Windows interface should be built */ #undef WITH_XWINDOWS /* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most significant byte first (like Motorola and SPARC, unlike Intel). */ #if defined AC_APPLE_UNIVERSAL_BUILD # if defined __BIG_ENDIAN__ # define WORDS_BIGENDIAN 1 # endif #else # ifndef WORDS_BIGENDIAN # undef WORDS_BIGENDIAN # endif #endif /* Enable large inode numbers on Mac OS X 10.5. */ #ifndef _DARWIN_USE_64_BIT_INODE # define _DARWIN_USE_64_BIT_INODE 1 #endif /* Number of bits in a file offset, on hosts where this is settable. */ #undef _FILE_OFFSET_BITS /* Define for large files, on AIX-style hosts. */ #undef _LARGE_FILES /* Define for Solaris 2.5.1 so the uint32_t typedef from , , or is not used. If the typedef were allowed, the #define below would cause a syntax error. */ #undef _UINT32_T /* Define for Solaris 2.5.1 so the uint64_t typedef from , , or is not used. If the typedef were allowed, the #define below would cause a syntax error. */ #undef _UINT64_T /* Define to empty if `const' does not conform to ANSI C. */ #undef const /* Define to `int' if doesn't define. */ #undef gid_t #define gid_t int /* Define to the type of a signed integer type of width exactly 16 bits if such a type exists and the standard includes do not define it. */ #undef int16_t /* Define to the type of a signed integer type of width exactly 32 bits if such a type exists and the standard includes do not define it. */ #undef int32_t /* Define to the type of a signed integer type of width exactly 64 bits if such a type exists and the standard includes do not define it. */ #undef int64_t /* Define to the type of a signed integer type wide enough to hold a pointer, if such a type exists, and if the system does not define it. */ #undef intptr_t /* Define to `int' if does not define. */ #undef mode_t #define mode_t int /* Define to `long int' if does not define. */ #undef off_t /* Define to `int' if does not define. */ #undef pid_t #define pid_t int /* Define to `unsigned int' if does not define. */ #undef size_t /* Define to `int' if does not define. */ // There is an SSIZE_T #undef ssize_t #if defined(_MSC_VER) #include typedef SSIZE_T ssize_t; #endif /* Define to `int' if doesn't define. */ #undef uid_t #define uid_t int /* Define to the type of an unsigned integer type of width exactly 16 bits if such a type exists and the standard includes do not define it. */ #undef uint16_t /* Define to the type of an unsigned integer type of width exactly 32 bits if such a type exists and the standard includes do not define it. */ #undef uint32_t /* Define to the type of an unsigned integer type of width exactly 64 bits if such a type exists and the standard includes do not define it. */ #undef uint64_t /* Define to the type of an unsigned integer type wide enough to hold a pointer, if such a type exists, and if the system does not define it. */ #undef uintptr_t #endif \ No newline at end of file