diff --git a/Tests/Succeed/Test190.ML b/Tests/Succeed/Test190.ML index 1bbbad3a..aa17b17c 100644 --- a/Tests/Succeed/Test190.ML +++ b/Tests/Succeed/Test190.ML @@ -1,18 +1,18 @@ (* After a Posix fork there is only one thread in the child. There could be a GC before any exec so this is a check that it works. *) case #lookupStruct (PolyML.globalNameSpace) "Posix" of SOME _ => () | NONE => raise NotApplicable; let open Posix.Process in case fork() of NONE => ( PolyML.fullGC(); - exit 0w0 + OS.Process.terminate OS.Process.success (* terminate not exit *) ) | SOME pid => waitpid(W_CHILD pid, []) end; diff --git a/Tests/Succeed/Test194.ML b/Tests/Succeed/Test194.ML new file mode 100644 index 00000000..73e85155 --- /dev/null +++ b/Tests/Succeed/Test194.ML @@ -0,0 +1,42 @@ +(* Phil Clayton's example in issue 138. This caused exponential blow-up because of inlining. *) + +fun C f = + fn + SOME n => f n + | NONE => f 0 + +infixr 1 &&&> +fun (f &&&> g) h (a, b) = f (fn a' => g (fn b' => h (a', b')) b) a; + +fun test f = + ( + C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + &&&> C + ) + f +; diff --git a/basis/Posix.sml b/basis/Posix.sml index 8e9aaaa9..1b190fd4 100644 --- a/basis/Posix.sml +++ b/basis/Posix.sml @@ -1,1712 +1,1708 @@ (* Title: Standard Basis Library: Posix structure and signature. Copyright David Matthews 2000, 2016-17, 2019-2020 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 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 osSpecificGeneralCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" in 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 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. - This should use Terminate rather than Finish so that C atExit routines - aren't executed either. *) + (* This is supposed to call C "exit" function so we must use PolyFinish here. *) local - val doExit: Word8.word -> unit = RunCall.rtsCallFull1 "PolyTerminate" + 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 in (* This previously used absolute times. Now uses relative. *) fun alarm t = doCall(20, t) end 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 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 doWait() end 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 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 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 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 (* 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 (* Use persistent file descriptors here. i.e. don't reset them to "invalid" if they are read into a new session. We always want that for 0, 1 and 2 but it's not clear whether that is correct for other file descriptors. Since this is a low-level function assume that the caller understands the issues. *) val wordToFD = persistentFD o SysWord.toInt end val stdin = wordToFD 0w0 (* Must be persistent. *) and stdout = wordToFD 0w1 and stderr = wordToFD 0w2 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/Statistics.ML b/basis/Statistics.ML index 94caa529..e4d8101d 100644 --- a/basis/Statistics.ML +++ b/basis/Statistics.ML @@ -1,198 +1,208 @@ (* Title: Poly/ML Statistics parser. Author: David Matthews Copyright David Matthews 2013, 2015-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 *) (* This is an interface to the statistics provided by the run-time system. For machine-independence and backwards compatibility they are encoded using ASN1 binary encodeing *) local open Asn1 datatype statistic = UnknownStat | CounterStat of { identifier: int, name: string, count: int } | SizeStat of { identifier: int, name: string, size: LargeInt.int } | TimeStat of { identifier: int, name: string, time: Time.time } | UserStat of { identifier: int, name: string, count: int } datatype component = CounterValue of int | ByteCount of LargeInt.int | Time of Time.time | UnknownComponent + + datatype gcState = MLCode | MinorGC of int | MajorGC of int | GCSharing of int | OtherState of int val emptySlice = Word8VectorSlice.full(Word8Vector.fromList []) fun convStats(v: Word8Vector.vector) = let fun parseStatistic p = case decodeItem p of SOME {tag = Application(0x1, Constructed), data, remainder} => ( case parseComponents({identifier=0, name="", value=UnknownComponent}, data) of {identifier, name, value=CounterValue v} => (CounterStat{identifier=identifier, name=name, count=v}, remainder) | _ => (UnknownStat, remainder) ) | SOME {tag = Application(0x2, Constructed), data, remainder} => ( case parseComponents({identifier=0, name="", value=UnknownComponent}, data) of {identifier, name, value=ByteCount s} => (SizeStat{identifier=identifier, name=name, size=s}, remainder) | _ => (UnknownStat, remainder) ) | SOME {tag = Application(0x3, Constructed), data, remainder} => ( case parseComponents({identifier=0, name="", value=UnknownComponent}, data) of {identifier, name, value=Time t} => (TimeStat{identifier=identifier, name=name, time=t}, remainder) | _ => (UnknownStat, remainder) ) | SOME {tag = Application(0xb, Constructed), data, remainder} => ( case parseComponents({identifier=0, name="", value=UnknownComponent}, data) of {identifier, name, value=CounterValue c} => (UserStat{identifier=identifier, name=name, count=c}, remainder) | _ => (UnknownStat, remainder) ) | SOME {remainder, ...} => (UnknownStat, remainder) | NONE => (UnknownStat, emptySlice) and parseComponents(result as {identifier, name, value }, p) = if Word8VectorSlice.length p = 0 then result else ( case decodeItem p of SOME {tag = Application(0x4, Primitive), data, remainder} => parseComponents({identifier=decodeInt data, name=name, value=value}, remainder) | SOME {tag = Application(0x5, Primitive), data, remainder} => parseComponents({name=decodeString data, identifier=identifier, value=value}, remainder) | SOME {tag = Application(0x6, Primitive), data, remainder} => parseComponents({identifier=identifier, name=name, value=CounterValue(decodeInt data)}, remainder) | SOME {tag = Application(0x7, Primitive), data, remainder} => parseComponents({identifier=identifier, name=name, value=ByteCount(decodeLargeInt data)}, remainder) | SOME {tag = Application(0x8, Constructed), data, remainder} => let fun parseTime (t, p) = if Word8VectorSlice.length p = 0 then t else ( case decodeItem p of SOME {tag = Application(0x9, Primitive), data, remainder} => parseTime(t + Time.fromSeconds(LargeInt.fromInt(decodeInt data)), remainder) | SOME {tag = Application(0xa, Primitive), data, remainder} => parseTime(t + Time.fromMicroseconds(LargeInt.fromInt(decodeInt data)), remainder) | SOME {remainder, ...} => parseTime(t, remainder) (* Unknown *) | NONE => t ) in parseComponents({identifier=identifier, name=name, value=Time(parseTime(Time.zeroTime, data))}, remainder) end | SOME {remainder, ...} => parseComponents(result, remainder) | NONE => result ) fun parseStatistics l = if Word8VectorSlice.length l = 0 then [] else let val (item, rest) = parseStatistic l val items = parseStatistics rest in item :: items end val stats = case decodeItem (Word8VectorSlice.full v) of SOME {tag = Application(0x0, Constructed), data, ...} => parseStatistics data | _ => raise Fail "Statistics not available" fun extractCounter(n, l) = case List.find (fn CounterStat{identifier, ...} => identifier = n | _ => false) l of SOME(CounterStat{ count, ...}) => count | _ => 0 and extractSize(n, l) = case List.find (fn SizeStat{identifier, ...} => identifier = n | _ => false) l of SOME(SizeStat{ size, ...}) => size | _ => 0 and extractTime(n, l) = case List.find (fn TimeStat{identifier, ...} => identifier = n | _ => false) l of SOME(TimeStat{ time, ...}) => time | _ => Time.zeroTime and extractUser(n, l) = case List.find (fn UserStat{identifier, ...} => identifier = n | _ => false) l of SOME(UserStat{ count, ...}) => count | _ => 0 in { threadsTotal = extractCounter(1, stats), threadsInML = extractCounter(2, stats), threadsWaitIO = extractCounter(3, stats), threadsWaitMutex = extractCounter(4, stats), threadsWaitCondVar = extractCounter(5, stats), threadsWaitSignal = extractCounter(6, stats), gcFullGCs = extractCounter(7, stats), gcPartialGCs = extractCounter(8, stats), sizeHeap = extractSize(9, stats), sizeHeapFreeLastGC = extractSize(10, stats), sizeHeapFreeLastFullGC = extractSize(11, stats), sizeAllocation = extractSize(12, stats), sizeAllocationFree = extractSize(13, stats), timeNonGCUser = extractTime(14, stats), timeNonGCSystem = extractTime(15, stats), timeGCUser = extractTime(16, stats), timeGCSystem = extractTime(17, stats), userCounters = Vector.tabulate(8, fn n => extractUser(n+18, stats)), gcSharePasses = extractCounter(28, stats), timeNonGCReal = extractTime(26, stats), timeGCReal = extractTime(27, stats), sizeCode = extractSize(29, stats), - sizeStacks = extractSize(30, stats) + sizeStacks = extractSize(30, stats), + gcState = + let + val pc = extractCounter(32, stats) + in + case extractCounter(31, stats) of + 0 => MLCode | 1 => MinorGC pc | 2 => MajorGC pc | 3 => GCSharing pc | _ => OtherState pc + end } end val localStats = RunCall.rtsCallFull0 "PolyGetLocalStats" and remoteStats = RunCall.rtsCallFull1 "PolyGetRemoteStats" in structure PolyML = struct open PolyML structure Statistics = struct + datatype gcState = datatype gcState fun getLocalStats() = convStats(localStats()) and getRemoteStats(pid: int) = convStats(remoteStats pid) val numUserCounters: unit -> int = RunCall.rtsCallFast0 "PolyGetUserStatsCount" val setUserCounter: int * int -> unit = RunCall.rtsCallFull2 "PolySetUserStat" end end end; diff --git a/basis/Unix.sml b/basis/Unix.sml index f04ae5b8..afe86b38 100644 --- a/basis/Unix.sml +++ b/basis/Unix.sml @@ -1,218 +1,218 @@ (* Title: Standard Basis Library: Unix structure and signature. Author: David Matthews - Copyright David Matthews 2000,2008, 2019 + Copyright David Matthews 2000,2008, 2019, 2020 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 UNIX = sig type ('a,'b) proc type signal 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 val executeInEnv : string * string list * string list -> ('a, 'b) proc val execute : string * string list -> ('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 streamsOf : (TextIO.instream, TextIO.outstream) proc -> TextIO.instream * TextIO.outstream val reap : ('a, 'b) proc -> OS.Process.status val kill : ('a, 'b) proc * signal -> unit val exit : Word8.word -> 'a end; structure Unix :> sig (* We have to copy the signature since we can't establish the connection between exit_status and Posix.Process.exit_status with a "where type". *) type ('a,'b) proc type signal = Posix.Signal.signal datatype exit_status = datatype Posix.Process.exit_status val fromStatus : OS.Process.status -> exit_status val executeInEnv : string * string list * string list -> ('a, 'b) proc val execute : string * string list -> ('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 streamsOf : (TextIO.instream, TextIO.outstream) proc -> TextIO.instream * TextIO.outstream val reap : ('a, 'b) proc -> OS.Process.status val kill : ('a, 'b) proc * signal -> unit val exit : Word8.word -> 'a end = struct type ('a,'b) proc = { pid: Posix.Process.pid, infd: Posix.IO.file_desc, outfd: Posix.IO.file_desc, (* We have to remember the result status. *) result: OS.Process.status option ref } type signal = Posix.Signal.signal datatype exit_status = datatype Posix.Process.exit_status val fromStatus = Posix.Process.fromStatus fun kill({pid, ... }: ('a, 'b) proc, signal) = Posix.Process.kill(Posix.Process.K_PROC pid, signal) (* Create a new process running a command and with pipes connecting the standard input and output. The command is supposed to be an executable and we should raise an exception if it is not. Since the exece is only done in the child we need to test whether we have an executable at the beginning. The definition does not say whether the first of the user-supplied arguments includes the command or not. Assume that only the "real" arguments are provided and pass the last component of the command name in the exece call. *) fun executeInEnv (cmd, args, env) = let open Posix (* Test first for presence of the file and then that we have correct access rights. *) val s = FileSys.stat cmd (* Raises SysErr if the file doesn't exist. *) val () = if not (FileSys.ST.isReg s) orelse not (FileSys.access(cmd, [FileSys.A_EXEC])) then raise OS.SysErr(OS.errorMsg Error.acces, SOME Error.acces) else () val toChild = IO.pipe() and fromChild = IO.pipe() in case Process.fork() of NONE => (* In the child *) (( (* Should really clean up the signals here and turn off timers. *) (* Close the unwanted ends of the pipes and set the required ends up as stdin and stdout. *) IO.close(#outfd toChild); IO.close(#infd fromChild); IO.dup2{old= #infd toChild, new=Posix.FileSys.stdin}; IO.dup2{old= #outfd fromChild, new=Posix.FileSys.stdout}; IO.close(#infd toChild); IO.close(#outfd fromChild); (* Run the command. *) Process.exece(cmd, OS.Path.file cmd :: args, env); (* If we get here the exec must have failed - terminate this process. We're supposed to set the error code to 126 in this case. *) - Process.exit 0w126 - ) handle _ => Process.exit 0w126) - + OS.Process.terminate(RunCall.unsafeCast 0w126) + ) handle _ => OS.Process.terminate(RunCall.unsafeCast 0w126) + ) | SOME pid => (* In the parent *) ( IO.close(#infd toChild); IO.close(#outfd fromChild); {pid=pid, infd= #infd fromChild, outfd= #outfd toChild, result = ref NONE} ) end fun execute (cmd, args) = executeInEnv(cmd, args, Posix.ProcEnv.environ()) local (* Internal function to get the preferred buffer size. *) val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun sys_get_buffsize (strm: OS.IO.iodesc): int = doIo(15, strm, 0) end fun textInstreamOf {infd, ...} = let val n = Posix.FileSys.fdToIOD infd val textPrimRd = LibraryIOSupport.wrapInFileDescr {fd=n, name="TextPipeInput", initBlkMode=true} val streamIo = TextIO.StreamIO.mkInstream(textPrimRd, "") in TextIO.mkInstream streamIo end fun textOutstreamOf {outfd, ...} = let val n = Posix.FileSys.fdToIOD outfd 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.StreamIO.mkOutstream(textPrimWr, IO.LINE_BUF) in TextIO.mkOutstream streamIo end fun binInstreamOf {infd, ...} = let val n = Posix.FileSys.fdToIOD infd val binPrimRd = LibraryIOSupport.wrapBinInFileDescr{fd=n, name="BinPipeInput", initBlkMode=true} val streamIo = BinIO.StreamIO.mkInstream(binPrimRd, Word8Vector.fromList []) in BinIO.mkInstream streamIo end fun binOutstreamOf {outfd, ...} = let val n = Posix.FileSys.fdToIOD outfd val buffSize = sys_get_buffsize n val binPrimWr = LibraryIOSupport.wrapBinOutFileDescr{fd=n, name="BinPipeOutput", appendMode=false, chunkSize=buffSize, initBlkMode=true} (* Construct a stream. *) val streamIo = BinIO.StreamIO.mkOutstream(binPrimWr, IO.LINE_BUF) in BinIO.mkOutstream streamIo end fun streamsOf p = (textInstreamOf p, textOutstreamOf p) (* Internal function - inverse of Posix.Process.fromStatus. *) local val doCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" in fun toStatus W_EXITED: OS.Process.status = doCall(16, (1, 0)) | toStatus(W_EXITSTATUS w) = doCall(16, (1, Word8.toInt w)) | toStatus(W_SIGNALED s) = doCall(16, (2, SysWord.toInt(Posix.Signal.toWord s))) | toStatus(W_STOPPED s) = doCall(16, (3, SysWord.toInt(Posix.Signal.toWord s))) end fun reap {result = ref(SOME r), ...} = r | reap(p as {pid, infd, outfd, result}) = let val () = Posix.IO.close infd; val () = Posix.IO.close outfd; val (_, status) = Posix.Process.waitpid(Posix.Process.W_CHILD pid, []) in (* If the process is only stopped we need to wait again. *) case status of W_STOPPED _ => reap p | _ => let val s = toStatus status in result := SOME s; s end end fun exit w = OS.Process.exit(toStatus (W_EXITSTATUS w)) end; diff --git a/config.h.in b/config.h.in index 249d60a8..75b10412 100644 --- a/config.h.in +++ b/config.h.in @@ -1,685 +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 to 1 if you have the `_ftelli64' function. */ #undef HAVE__FTELLI64 /* 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 6e449299..3864a9bc 100755 --- a/configure +++ b/configure @@ -1,25380 +1,25351 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69 for Poly/ML 5.8.1. # # 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.1' PACKAGE_STRING='Poly/ML 5.8.1' 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__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 am__quote' 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.1 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.1:";; 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.1 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.1, 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.16' 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.1' 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" { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} supports the include directive" >&5 $as_echo_n "checking whether ${MAKE-make} supports the include directive... " >&6; } cat > confinc.mk << 'END' am__doit: @echo this is the am__doit target >confinc.out .PHONY: am__doit END am__include="#" am__quote= # BSD make does it like this. echo '.include "confinc.mk" # ignored' > confmf.BSD # Other make implementations (GNU, Solaris 10, AIX) do it like this. echo 'include confinc.mk # ignored' > confmf.GNU _am_result=no for s in GNU BSD; do { echo "$as_me:$LINENO: ${MAKE-make} -f confmf.$s && cat confinc.out" >&5 (${MAKE-make} -f confmf.$s && cat confinc.out) >&5 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } case $?:`cat confinc.out 2>/dev/null` in #( '0:this is the am__doit target') : case $s in #( BSD) : am__include='.include' am__quote='"' ;; #( *) : am__include='include' am__quote='' ;; esac ;; #( *) : ;; esac if test "$am__include" != "#"; then _am_result="yes ($s style)" break fi done rm -f confinc.* confmf.* { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${_am_result}" >&5 $as_echo "${_am_result}" >&6; } # 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 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 +for ac_header in sys/elf_SPARC.h sys/elf_386.h sys/elf_amd64.h asm/elf.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 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 for ac_func in _ftelli64 do : ac_fn_c_check_func "$LINENO" "_ftelli64" "ac_cv_func__ftelli64" if test "x$ac_cv_func__ftelli64" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE__FTELLI64 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.1, 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.1 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" MAKE="${MAKE-make}" # 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. # TODO: see whether this extra hack can be removed once we start # requiring Autoconf 2.70 or later. case $CONFIG_FILES in #( *\'*) : eval set x "$CONFIG_FILES" ;; #( *) : set x $CONFIG_FILES ;; #( *) : ;; esac shift # Used to flag and report bootstrapping failures. am_rc=0 for am_mf do # Strip MF so we end up with the name of the file. am_mf=`$as_echo "$am_mf" | sed -e 's/:.*$//'` # Check whether this is an Automake generated Makefile which includes # dependency-tracking related rules and includes. # Grep'ing the whole file directly is not great: AIX grep has a line # limit of 2048, but all sed's we know have understand at least 4000. sed -n 's,^am--depfiles:.*,X,p' "$am_mf" | grep X >/dev/null 2>&1 \ || continue am_dirpart=`$as_dirname -- "$am_mf" || $as_expr X"$am_mf" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$am_mf" : 'X\(//\)[^/]' \| \ X"$am_mf" : 'X\(//\)$' \| \ X"$am_mf" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$am_mf" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` am_filepart=`$as_basename -- "$am_mf" || $as_expr X/"$am_mf" : '.*/\([^/][^/]*\)/*$' \| \ X"$am_mf" : 'X\(//\)$' \| \ X"$am_mf" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$am_mf" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` { echo "$as_me:$LINENO: cd "$am_dirpart" \ && sed -e '/# am--include-marker/d' "$am_filepart" \ | $MAKE -f - am--depfiles" >&5 (cd "$am_dirpart" \ && sed -e '/# am--include-marker/d' "$am_filepart" \ | $MAKE -f - am--depfiles) >&5 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } || am_rc=$? done if test $am_rc -ne 0; 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 $? "Something went wrong bootstrapping makefile fragments for automatic dependency tracking. Try re-running configure with the '--disable-dependency-tracking' option to at least be able to build the package (albeit without support for automatic dependency tracking). See \`config.log' for more details" "$LINENO" 5; } fi { am_dirpart=; unset am_dirpart;} { am_filepart=; unset am_filepart;} { am_mf=; unset am_mf;} { am_rc=; unset am_rc;} rm -f conftest-deps.mk } ;; "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 78d1282f..f5f14e18 100644 --- a/configure.ac +++ b/configure.ac @@ -1,621 +1,610 @@ # -*- Autoconf -*- # Process this file with autoconf to produce a configure script. AC_INIT([Poly/ML],[5.8.1],[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 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([sys/elf_SPARC.h sys/elf_386.h sys/elf_amd64.h asm/elf.h machine/reloc.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]) AC_CHECK_FUNCS([_ftelli64]) # 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/Makefile.am b/libpolyml/Makefile.am index b2ecd7bc..13e6e913 100644 --- a/libpolyml/Makefile.am +++ b/libpolyml/Makefile.am @@ -1,164 +1,165 @@ AUTOMAKE_OPTIONS=foreign moduledir = @moduledir@ AM_CPPFLAGS = $(CFLAGS) $(OSFLAG) $(GIT_VERSION) -Wall -DMODULEDIR=\"$(moduledir)\" AM_CFLAGS = $(CFLAGS) $(OSFLAG) $(GIT_VERSION) -Wall -fno-strict-aliasing AM_ASFLAGS = $(OSFLAG) AM_CCASFLAGS = $(OSFLAG) lib_LTLIBRARIES = libpolyml.la libpolyml_la_LDFLAGS = -version-info 11:0:0 DIST_SUBDIRS = libffi if INTERNAL_LIBFFI SUBDIRS = libffi libpolyml_la_LIBADD = libffi/libffi_convenience.la endif if NO_UNDEFINED # Force all references to be defined to build the DLL. libpolyml_la_LDFLAGS += -no-undefined endif # Select the architecture-specific modules if ARCHI386 ARCHSOURCE = x86_dep.cpp x86assembly_gas32.S else if ARCHINTERPRET ARCHSOURCE = interpret.cpp else if ARCHINTERPRET64 ARCHSOURCE = interpret.cpp else if ARCHX86_64 ARCHSOURCE = x86_dep.cpp x86assembly_gas64.S else if ARCHX8632IN64 ARCHSOURCE = x86_dep.cpp x86assembly_gas64.S else endif endif endif endif endif # Select the object-format-specific modules if EXPPECOFF EXPORTSOURCE = pecoffexport.cpp else if EXPELF EXPORTSOURCE = elfexport.cpp else if EXPMACHO EXPORTSOURCE = machoexport.cpp endif endif endif if NATIVE_WINDOWS -OSSOURCE = winstartup.cpp winbasicio.cpp winguiconsole.cpp windows_specific.cpp +OSSOURCE = winstartup.cpp winbasicio.cpp winguiconsole.cpp windows_specific.cpp osmemwin.cpp else -OSSOURCE = basicio.cpp unix_specific.cpp +OSSOURCE = basicio.cpp unix_specific.cpp osmemunix.cpp endif noinst_HEADERS = \ arb.h \ basicio.h \ bitmap.h \ check_objects.h \ diagnostics.h \ elfexport.h \ errors.h \ exporter.h \ gc.h \ gctaskfarm.h \ + gc_progress.h \ globals.h \ heapsizing.h \ int_opcodes.h \ io_internal.h \ locking.h \ machine_dep.h \ machoexport.h \ memmgr.h \ mpoly.h \ network.h \ noreturn.h \ objsize.h \ osmem.h \ os_specific.h \ pecoffexport.h \ pexport.h \ PolyControl.h \ poly_specific.h \ polyffi.h \ polystring.h \ process_env.h \ processes.h \ profiling.h \ realconv.h \ reals.h \ rts_module.h \ rtsentry.h \ run_time.h \ savestate.h \ save_vec.h \ scanaddrs.h \ sharedata.h \ sighandler.h \ statistics.h \ sys.h \ timing.h \ version.h \ winguiconsole.h \ winstartup.h \ xcall_numbers.h \ xwindows.h libpolyml_la_SOURCES = \ arb.cpp \ bitmap.cpp \ check_objects.cpp \ diagnostics.cpp \ errors.cpp \ exporter.cpp \ gc.cpp \ gc_check_weak_ref.cpp \ gc_copy_phase.cpp \ gc_mark_phase.cpp \ + gc_progress.cpp \ gc_share_phase.cpp \ gc_update_phase.cpp \ gctaskfarm.cpp \ heapsizing.cpp \ locking.cpp \ memmgr.cpp \ mpoly.cpp \ network.cpp \ objsize.cpp \ - osmem.cpp \ pexport.cpp \ poly_specific.cpp \ polyffi.cpp \ polystring.cpp \ process_env.cpp \ processes.cpp \ profiling.cpp \ quick_gc.cpp \ realconv.cpp \ reals.cpp \ rts_module.cpp \ rtsentry.cpp \ run_time.cpp \ save_vec.cpp \ savestate.cpp \ scanaddrs.cpp \ sharedata.cpp \ sighandler.cpp \ statistics.cpp \ timing.cpp \ xwindows.cpp \ $(ARCHSOURCE) $(EXPORTSOURCE) $(OSSOURCE) pkgconfigdir = $(libdir)/pkgconfig pkgconfig_DATA = polyml.pc diff --git a/libpolyml/Makefile.in b/libpolyml/Makefile.in index 5b6acab0..4411bb84 100644 --- a/libpolyml/Makefile.in +++ b/libpolyml/Makefile.in @@ -1,1222 +1,1232 @@ # Makefile.in generated by automake 1.16.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994-2018 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ VPATH = @srcdir@ am__is_gnu_make = { \ if test -z '$(MAKELEVEL)'; then \ false; \ elif test -n '$(MAKE_HOST)'; then \ true; \ elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ true; \ else \ false; \ fi; \ } am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ *) echo "am__make_running_with_option: internal error: invalid" \ "target option '$${target_option-}' specified" >&2; \ exit 1;; \ esac; \ has_opt=no; \ sane_makeflags=$$MAKEFLAGS; \ if $(am__is_gnu_make); then \ sane_makeflags=$$MFLAGS; \ else \ case $$MAKEFLAGS in \ *\\[\ \ ]*) \ bs=\\; \ sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ esac; \ fi; \ skip_next=no; \ strip_trailopt () \ { \ flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ }; \ for flg in $$sane_makeflags; do \ test $$skip_next = yes && { skip_next=no; continue; }; \ case $$flg in \ *=*|--*) continue;; \ -*I) strip_trailopt 'I'; skip_next=yes;; \ -*I?*) strip_trailopt 'I';; \ -*O) strip_trailopt 'O'; skip_next=yes;; \ -*O?*) strip_trailopt 'O';; \ -*l) strip_trailopt 'l'; skip_next=yes;; \ -*l?*) strip_trailopt 'l';; \ -[dEDm]) skip_next=yes;; \ -[JT]) skip_next=yes;; \ esac; \ case $$flg in \ *$$target_option*) has_opt=yes; break;; \ esac; \ done; \ test $$has_opt = yes am__make_dryrun = (target_option=n; $(am__make_running_with_option)) am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ # Force all references to be defined to build the DLL. @NO_UNDEFINED_TRUE@am__append_1 = -no-undefined subdir = libpolyml ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \ $(top_srcdir)/m4/ltdl.m4 $(top_srcdir)/m4/ltoptions.m4 \ $(top_srcdir)/m4/ltsugar.m4 $(top_srcdir)/m4/ltversion.m4 \ $(top_srcdir)/m4/lt~obsolete.m4 $(top_srcdir)/m4/pkg.m4 \ $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) DIST_COMMON = $(srcdir)/Makefile.am $(noinst_HEADERS) \ $(am__DIST_COMMON) mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/config.h CONFIG_CLEAN_FILES = polyml.pc CONFIG_CLEAN_VPATH_FILES = am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; am__vpath_adj = case $$p in \ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ *) f=$$p;; \ esac; am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; am__install_max = 40 am__nobase_strip_setup = \ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` am__nobase_strip = \ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" am__nobase_list = $(am__nobase_strip_setup); \ for p in $$list; do echo "$$p $$p"; done | \ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ if (++n[$$2] == $(am__install_max)) \ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ END { for (dir in files) print dir, files[dir] }' am__base_list = \ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' am__uninstall_files_from_dir = { \ test -z "$$files" \ || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \ || { echo " ( cd '$$dir' && rm -f" $$files ")"; \ $(am__cd) "$$dir" && rm -f $$files; }; \ } am__installdirs = "$(DESTDIR)$(libdir)" "$(DESTDIR)$(pkgconfigdir)" LTLIBRARIES = $(lib_LTLIBRARIES) @INTERNAL_LIBFFI_TRUE@libpolyml_la_DEPENDENCIES = \ @INTERNAL_LIBFFI_TRUE@ libffi/libffi_convenience.la am__libpolyml_la_SOURCES_DIST = arb.cpp bitmap.cpp check_objects.cpp \ diagnostics.cpp errors.cpp exporter.cpp gc.cpp \ gc_check_weak_ref.cpp gc_copy_phase.cpp gc_mark_phase.cpp \ - gc_share_phase.cpp gc_update_phase.cpp gctaskfarm.cpp \ - heapsizing.cpp locking.cpp memmgr.cpp mpoly.cpp network.cpp \ - objsize.cpp osmem.cpp pexport.cpp poly_specific.cpp \ + gc_progress.cpp gc_share_phase.cpp gc_update_phase.cpp \ + gctaskfarm.cpp heapsizing.cpp locking.cpp memmgr.cpp mpoly.cpp \ + network.cpp objsize.cpp pexport.cpp poly_specific.cpp \ polyffi.cpp polystring.cpp process_env.cpp processes.cpp \ profiling.cpp quick_gc.cpp realconv.cpp reals.cpp \ rts_module.cpp rtsentry.cpp run_time.cpp save_vec.cpp \ savestate.cpp scanaddrs.cpp sharedata.cpp sighandler.cpp \ statistics.cpp timing.cpp xwindows.cpp x86_dep.cpp \ x86assembly_gas64.S interpret.cpp x86assembly_gas32.S \ machoexport.cpp elfexport.cpp pecoffexport.cpp basicio.cpp \ - unix_specific.cpp winstartup.cpp winbasicio.cpp \ - winguiconsole.cpp windows_specific.cpp + unix_specific.cpp osmemunix.cpp winstartup.cpp winbasicio.cpp \ + winguiconsole.cpp windows_specific.cpp osmemwin.cpp @ARCHI386_FALSE@@ARCHINTERPRET64_FALSE@@ARCHINTERPRET_FALSE@@ARCHX8632IN64_TRUE@@ARCHX86_64_FALSE@am__objects_1 = x86_dep.lo \ @ARCHI386_FALSE@@ARCHINTERPRET64_FALSE@@ARCHINTERPRET_FALSE@@ARCHX8632IN64_TRUE@@ARCHX86_64_FALSE@ x86assembly_gas64.lo @ARCHI386_FALSE@@ARCHINTERPRET64_FALSE@@ARCHINTERPRET_FALSE@@ARCHX86_64_TRUE@am__objects_1 = x86_dep.lo \ @ARCHI386_FALSE@@ARCHINTERPRET64_FALSE@@ARCHINTERPRET_FALSE@@ARCHX86_64_TRUE@ x86assembly_gas64.lo @ARCHI386_FALSE@@ARCHINTERPRET64_TRUE@@ARCHINTERPRET_FALSE@am__objects_1 = interpret.lo @ARCHI386_FALSE@@ARCHINTERPRET_TRUE@am__objects_1 = interpret.lo @ARCHI386_TRUE@am__objects_1 = x86_dep.lo x86assembly_gas32.lo @EXPELF_FALSE@@EXPMACHO_TRUE@@EXPPECOFF_FALSE@am__objects_2 = \ @EXPELF_FALSE@@EXPMACHO_TRUE@@EXPPECOFF_FALSE@ machoexport.lo @EXPELF_TRUE@@EXPPECOFF_FALSE@am__objects_2 = elfexport.lo @EXPPECOFF_TRUE@am__objects_2 = pecoffexport.lo -@NATIVE_WINDOWS_FALSE@am__objects_3 = basicio.lo unix_specific.lo +@NATIVE_WINDOWS_FALSE@am__objects_3 = basicio.lo unix_specific.lo \ +@NATIVE_WINDOWS_FALSE@ osmemunix.lo @NATIVE_WINDOWS_TRUE@am__objects_3 = winstartup.lo winbasicio.lo \ -@NATIVE_WINDOWS_TRUE@ winguiconsole.lo windows_specific.lo +@NATIVE_WINDOWS_TRUE@ winguiconsole.lo windows_specific.lo \ +@NATIVE_WINDOWS_TRUE@ osmemwin.lo am_libpolyml_la_OBJECTS = arb.lo bitmap.lo check_objects.lo \ diagnostics.lo errors.lo exporter.lo gc.lo \ gc_check_weak_ref.lo gc_copy_phase.lo gc_mark_phase.lo \ - gc_share_phase.lo gc_update_phase.lo gctaskfarm.lo \ - heapsizing.lo locking.lo memmgr.lo mpoly.lo network.lo \ - objsize.lo osmem.lo pexport.lo poly_specific.lo polyffi.lo \ + gc_progress.lo gc_share_phase.lo gc_update_phase.lo \ + gctaskfarm.lo heapsizing.lo locking.lo memmgr.lo mpoly.lo \ + network.lo objsize.lo pexport.lo poly_specific.lo polyffi.lo \ polystring.lo process_env.lo processes.lo profiling.lo \ quick_gc.lo realconv.lo reals.lo rts_module.lo rtsentry.lo \ run_time.lo save_vec.lo savestate.lo scanaddrs.lo sharedata.lo \ sighandler.lo statistics.lo timing.lo xwindows.lo \ $(am__objects_1) $(am__objects_2) $(am__objects_3) libpolyml_la_OBJECTS = $(am_libpolyml_la_OBJECTS) AM_V_lt = $(am__v_lt_@AM_V@) am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@) am__v_lt_0 = --silent am__v_lt_1 = libpolyml_la_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CXX $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=link $(CXXLD) $(AM_CXXFLAGS) \ $(CXXFLAGS) $(libpolyml_la_LDFLAGS) $(LDFLAGS) -o $@ AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) am__v_P_0 = false am__v_P_1 = : AM_V_GEN = $(am__v_GEN_@AM_V@) am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) am__v_GEN_0 = @echo " GEN " $@; am__v_GEN_1 = AM_V_at = $(am__v_at_@AM_V@) am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir) depcomp = $(SHELL) $(top_srcdir)/depcomp am__maybe_remake_depfiles = depfiles am__depfiles_remade = ./$(DEPDIR)/arb.Plo ./$(DEPDIR)/basicio.Plo \ ./$(DEPDIR)/bitmap.Plo ./$(DEPDIR)/check_objects.Plo \ ./$(DEPDIR)/diagnostics.Plo ./$(DEPDIR)/elfexport.Plo \ ./$(DEPDIR)/errors.Plo ./$(DEPDIR)/exporter.Plo \ ./$(DEPDIR)/gc.Plo ./$(DEPDIR)/gc_check_weak_ref.Plo \ ./$(DEPDIR)/gc_copy_phase.Plo ./$(DEPDIR)/gc_mark_phase.Plo \ - ./$(DEPDIR)/gc_share_phase.Plo ./$(DEPDIR)/gc_update_phase.Plo \ - ./$(DEPDIR)/gctaskfarm.Plo ./$(DEPDIR)/heapsizing.Plo \ - ./$(DEPDIR)/interpret.Plo ./$(DEPDIR)/locking.Plo \ - ./$(DEPDIR)/machoexport.Plo ./$(DEPDIR)/memmgr.Plo \ - ./$(DEPDIR)/mpoly.Plo ./$(DEPDIR)/network.Plo \ - ./$(DEPDIR)/objsize.Plo ./$(DEPDIR)/osmem.Plo \ + ./$(DEPDIR)/gc_progress.Plo ./$(DEPDIR)/gc_share_phase.Plo \ + ./$(DEPDIR)/gc_update_phase.Plo ./$(DEPDIR)/gctaskfarm.Plo \ + ./$(DEPDIR)/heapsizing.Plo ./$(DEPDIR)/interpret.Plo \ + ./$(DEPDIR)/locking.Plo ./$(DEPDIR)/machoexport.Plo \ + ./$(DEPDIR)/memmgr.Plo ./$(DEPDIR)/mpoly.Plo \ + ./$(DEPDIR)/network.Plo ./$(DEPDIR)/objsize.Plo \ + ./$(DEPDIR)/osmemunix.Plo ./$(DEPDIR)/osmemwin.Plo \ ./$(DEPDIR)/pecoffexport.Plo ./$(DEPDIR)/pexport.Plo \ ./$(DEPDIR)/poly_specific.Plo ./$(DEPDIR)/polyffi.Plo \ ./$(DEPDIR)/polystring.Plo ./$(DEPDIR)/process_env.Plo \ ./$(DEPDIR)/processes.Plo ./$(DEPDIR)/profiling.Plo \ ./$(DEPDIR)/quick_gc.Plo ./$(DEPDIR)/realconv.Plo \ ./$(DEPDIR)/reals.Plo ./$(DEPDIR)/rts_module.Plo \ ./$(DEPDIR)/rtsentry.Plo ./$(DEPDIR)/run_time.Plo \ ./$(DEPDIR)/save_vec.Plo ./$(DEPDIR)/savestate.Plo \ ./$(DEPDIR)/scanaddrs.Plo ./$(DEPDIR)/sharedata.Plo \ ./$(DEPDIR)/sighandler.Plo ./$(DEPDIR)/statistics.Plo \ ./$(DEPDIR)/timing.Plo ./$(DEPDIR)/unix_specific.Plo \ ./$(DEPDIR)/winbasicio.Plo ./$(DEPDIR)/windows_specific.Plo \ ./$(DEPDIR)/winguiconsole.Plo ./$(DEPDIR)/winstartup.Plo \ ./$(DEPDIR)/x86_dep.Plo ./$(DEPDIR)/x86assembly_gas32.Plo \ ./$(DEPDIR)/x86assembly_gas64.Plo ./$(DEPDIR)/xwindows.Plo am__mv = mv -f CPPASCOMPILE = $(CCAS) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) \ $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CCASFLAGS) $(CCASFLAGS) LTCPPASCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=compile $(CCAS) $(DEFS) \ $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ $(AM_CCASFLAGS) $(CCASFLAGS) AM_V_CPPAS = $(am__v_CPPAS_@AM_V@) am__v_CPPAS_ = $(am__v_CPPAS_@AM_DEFAULT_V@) am__v_CPPAS_0 = @echo " CPPAS " $@; am__v_CPPAS_1 = CXXCOMPILE = $(CXX) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) \ $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CXXFLAGS) $(CXXFLAGS) LTCXXCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CXX $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=compile $(CXX) $(DEFS) \ $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ $(AM_CXXFLAGS) $(CXXFLAGS) AM_V_CXX = $(am__v_CXX_@AM_V@) am__v_CXX_ = $(am__v_CXX_@AM_DEFAULT_V@) am__v_CXX_0 = @echo " CXX " $@; am__v_CXX_1 = CXXLD = $(CXX) CXXLINK = $(LIBTOOL) $(AM_V_lt) --tag=CXX $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=link $(CXXLD) $(AM_CXXFLAGS) \ $(CXXFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o $@ AM_V_CXXLD = $(am__v_CXXLD_@AM_V@) am__v_CXXLD_ = $(am__v_CXXLD_@AM_DEFAULT_V@) am__v_CXXLD_0 = @echo " CXXLD " $@; am__v_CXXLD_1 = COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) LTCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) \ $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ $(AM_CFLAGS) $(CFLAGS) AM_V_CC = $(am__v_CC_@AM_V@) am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@) am__v_CC_0 = @echo " CC " $@; am__v_CC_1 = CCLD = $(CC) LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ $(AM_LDFLAGS) $(LDFLAGS) -o $@ AM_V_CCLD = $(am__v_CCLD_@AM_V@) am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@) am__v_CCLD_0 = @echo " CCLD " $@; am__v_CCLD_1 = SOURCES = $(libpolyml_la_SOURCES) DIST_SOURCES = $(am__libpolyml_la_SOURCES_DIST) RECURSIVE_TARGETS = all-recursive check-recursive cscopelist-recursive \ ctags-recursive dvi-recursive html-recursive info-recursive \ install-data-recursive install-dvi-recursive \ install-exec-recursive install-html-recursive \ install-info-recursive install-pdf-recursive \ install-ps-recursive install-recursive installcheck-recursive \ installdirs-recursive pdf-recursive ps-recursive \ tags-recursive uninstall-recursive am__can_run_installinfo = \ case $$AM_UPDATE_INFO_DIR in \ n|no|NO) false;; \ *) (install-info --version) >/dev/null 2>&1;; \ esac DATA = $(pkgconfig_DATA) HEADERS = $(noinst_HEADERS) RECURSIVE_CLEAN_TARGETS = mostlyclean-recursive clean-recursive \ distclean-recursive maintainer-clean-recursive am__recursive_targets = \ $(RECURSIVE_TARGETS) \ $(RECURSIVE_CLEAN_TARGETS) \ $(am__extra_recursive_targets) AM_RECURSIVE_TARGETS = $(am__recursive_targets:-recursive=) TAGS CTAGS \ distdir distdir-am am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) # Read a list of newline-separated strings from the standard input, # and print each of them once, without duplicates. Input order is # *not* preserved. am__uniquify_input = $(AWK) '\ BEGIN { nonempty = 0; } \ { items[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in items) print i; }; } \ ' # Make sure the list of sources is unique. This is necessary because, # e.g., the same source file might be shared among _SOURCES variables # for different programs/libraries. am__define_uniq_tagged_files = \ list='$(am__tagged_files)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags am__DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/polyml.pc.in \ $(top_srcdir)/depcomp DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) am__relativize = \ dir0=`pwd`; \ sed_first='s,^\([^/]*\)/.*$$,\1,'; \ sed_rest='s,^[^/]*/*,,'; \ sed_last='s,^.*/\([^/]*\)$$,\1,'; \ sed_butlast='s,/*[^/]*$$,,'; \ while test -n "$$dir1"; do \ first=`echo "$$dir1" | sed -e "$$sed_first"`; \ if test "$$first" != "."; then \ if test "$$first" = ".."; then \ dir2=`echo "$$dir0" | sed -e "$$sed_last"`/"$$dir2"; \ dir0=`echo "$$dir0" | sed -e "$$sed_butlast"`; \ else \ first2=`echo "$$dir2" | sed -e "$$sed_first"`; \ if test "$$first2" = "$$first"; then \ dir2=`echo "$$dir2" | sed -e "$$sed_rest"`; \ else \ dir2="../$$dir2"; \ fi; \ dir0="$$dir0"/"$$first"; \ fi; \ fi; \ dir1=`echo "$$dir1" | sed -e "$$sed_rest"`; \ done; \ reldir="$$dir2" ACLOCAL = @ACLOCAL@ ALLOCA = @ALLOCA@ AMTAR = @AMTAR@ AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ AR = @AR@ AS = @AS@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CC = @CC@ CCAS = @CCAS@ CCASDEPMODE = @CCASDEPMODE@ CCASFLAGS = @CCASFLAGS@ CCDEPMODE = @CCDEPMODE@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CXX = @CXX@ CXXCPP = @CXXCPP@ CXXDEPMODE = @CXXDEPMODE@ CXXFLAGS = @CXXFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFS = @DEFS@ DEPDIR = @DEPDIR@ DLLTOOL = @DLLTOOL@ DSYMUTIL = @DSYMUTIL@ DUMPBIN = @DUMPBIN@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ FFI_CFLAGS = @FFI_CFLAGS@ FFI_LIBS = @FFI_LIBS@ FGREP = @FGREP@ GIT_VERSION = @GIT_VERSION@ GREP = @GREP@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LD = @LD@ LDFLAGS = @LDFLAGS@ LIBOBJS = @LIBOBJS@ LIBS = @LIBS@ LIBTOOL = @LIBTOOL@ LIPO = @LIPO@ LN_S = @LN_S@ LTLIBOBJS = @LTLIBOBJS@ LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ MAINT = @MAINT@ MAKEINFO = @MAKEINFO@ MANIFEST_TOOL = @MANIFEST_TOOL@ MKDIR_P = @MKDIR_P@ NM = @NM@ NMEDIT = @NMEDIT@ OBJDUMP = @OBJDUMP@ OBJEXT = @OBJEXT@ OSFLAG = @OSFLAG@ OTOOL = @OTOOL@ OTOOL64 = @OTOOL64@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ PKG_CONFIG = @PKG_CONFIG@ PKG_CONFIG_LIBDIR = @PKG_CONFIG_LIBDIR@ PKG_CONFIG_PATH = @PKG_CONFIG_PATH@ POW_LIB = @POW_LIB@ RANLIB = @RANLIB@ SED = @SED@ SET_MAKE = @SET_MAKE@ SHELL = @SHELL@ STRIP = @STRIP@ VERSION = @VERSION@ WINDRES = @WINDRES@ XMKMF = @XMKMF@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_AR = @ac_ct_AR@ ac_ct_CC = @ac_ct_CC@ ac_ct_CXX = @ac_ct_CXX@ ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ am__include = @am__include@ am__leading_dot = @am__leading_dot@ am__quote = @am__quote@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build = @build@ build_alias = @build_alias@ build_cpu = @build_cpu@ build_os = @build_os@ build_vendor = @build_vendor@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ dependentlibs = @dependentlibs@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ gitinstalled = @gitinstalled@ host = @host@ host_alias = @host_alias@ host_cpu = @host_cpu@ host_os = @host_os@ host_vendor = @host_vendor@ htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ moduledir = @moduledir@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ polyc_CFLAGS = @polyc_CFLAGS@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ runstatedir = @runstatedir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ subdirs = @subdirs@ sys_symbol_underscore = @sys_symbol_underscore@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ AUTOMAKE_OPTIONS = foreign AM_CPPFLAGS = $(CFLAGS) $(OSFLAG) $(GIT_VERSION) -Wall -DMODULEDIR=\"$(moduledir)\" AM_CFLAGS = $(CFLAGS) $(OSFLAG) $(GIT_VERSION) -Wall -fno-strict-aliasing AM_ASFLAGS = $(OSFLAG) AM_CCASFLAGS = $(OSFLAG) lib_LTLIBRARIES = libpolyml.la libpolyml_la_LDFLAGS = -version-info 11:0:0 $(am__append_1) DIST_SUBDIRS = libffi @INTERNAL_LIBFFI_TRUE@SUBDIRS = libffi @INTERNAL_LIBFFI_TRUE@libpolyml_la_LIBADD = libffi/libffi_convenience.la @ARCHI386_FALSE@@ARCHINTERPRET64_FALSE@@ARCHINTERPRET_FALSE@@ARCHX8632IN64_TRUE@@ARCHX86_64_FALSE@ARCHSOURCE = x86_dep.cpp x86assembly_gas64.S @ARCHI386_FALSE@@ARCHINTERPRET64_FALSE@@ARCHINTERPRET_FALSE@@ARCHX86_64_TRUE@ARCHSOURCE = x86_dep.cpp x86assembly_gas64.S @ARCHI386_FALSE@@ARCHINTERPRET64_TRUE@@ARCHINTERPRET_FALSE@ARCHSOURCE = interpret.cpp @ARCHI386_FALSE@@ARCHINTERPRET_TRUE@ARCHSOURCE = interpret.cpp # Select the architecture-specific modules @ARCHI386_TRUE@ARCHSOURCE = x86_dep.cpp x86assembly_gas32.S @EXPELF_FALSE@@EXPMACHO_TRUE@@EXPPECOFF_FALSE@EXPORTSOURCE = machoexport.cpp @EXPELF_TRUE@@EXPPECOFF_FALSE@EXPORTSOURCE = elfexport.cpp # Select the object-format-specific modules @EXPPECOFF_TRUE@EXPORTSOURCE = pecoffexport.cpp -@NATIVE_WINDOWS_FALSE@OSSOURCE = basicio.cpp unix_specific.cpp -@NATIVE_WINDOWS_TRUE@OSSOURCE = winstartup.cpp winbasicio.cpp winguiconsole.cpp windows_specific.cpp +@NATIVE_WINDOWS_FALSE@OSSOURCE = basicio.cpp unix_specific.cpp osmemunix.cpp +@NATIVE_WINDOWS_TRUE@OSSOURCE = winstartup.cpp winbasicio.cpp winguiconsole.cpp windows_specific.cpp osmemwin.cpp noinst_HEADERS = \ arb.h \ basicio.h \ bitmap.h \ check_objects.h \ diagnostics.h \ elfexport.h \ errors.h \ exporter.h \ gc.h \ gctaskfarm.h \ + gc_progress.h \ globals.h \ heapsizing.h \ int_opcodes.h \ io_internal.h \ locking.h \ machine_dep.h \ machoexport.h \ memmgr.h \ mpoly.h \ network.h \ noreturn.h \ objsize.h \ osmem.h \ os_specific.h \ pecoffexport.h \ pexport.h \ PolyControl.h \ poly_specific.h \ polyffi.h \ polystring.h \ process_env.h \ processes.h \ profiling.h \ realconv.h \ reals.h \ rts_module.h \ rtsentry.h \ run_time.h \ savestate.h \ save_vec.h \ scanaddrs.h \ sharedata.h \ sighandler.h \ statistics.h \ sys.h \ timing.h \ version.h \ winguiconsole.h \ winstartup.h \ xcall_numbers.h \ xwindows.h libpolyml_la_SOURCES = \ arb.cpp \ bitmap.cpp \ check_objects.cpp \ diagnostics.cpp \ errors.cpp \ exporter.cpp \ gc.cpp \ gc_check_weak_ref.cpp \ gc_copy_phase.cpp \ gc_mark_phase.cpp \ + gc_progress.cpp \ gc_share_phase.cpp \ gc_update_phase.cpp \ gctaskfarm.cpp \ heapsizing.cpp \ locking.cpp \ memmgr.cpp \ mpoly.cpp \ network.cpp \ objsize.cpp \ - osmem.cpp \ pexport.cpp \ poly_specific.cpp \ polyffi.cpp \ polystring.cpp \ process_env.cpp \ processes.cpp \ profiling.cpp \ quick_gc.cpp \ realconv.cpp \ reals.cpp \ rts_module.cpp \ rtsentry.cpp \ run_time.cpp \ save_vec.cpp \ savestate.cpp \ scanaddrs.cpp \ sharedata.cpp \ sighandler.cpp \ statistics.cpp \ timing.cpp \ xwindows.cpp \ $(ARCHSOURCE) $(EXPORTSOURCE) $(OSSOURCE) pkgconfigdir = $(libdir)/pkgconfig pkgconfig_DATA = polyml.pc all: all-recursive .SUFFIXES: .SUFFIXES: .S .cpp .lo .o .obj $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ && { if test -f $@; then exit 0; else break; fi; }; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign libpolyml/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --foreign libpolyml/Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles)'; \ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(am__aclocal_m4_deps): polyml.pc: $(top_builddir)/config.status $(srcdir)/polyml.pc.in cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ install-libLTLIBRARIES: $(lib_LTLIBRARIES) @$(NORMAL_INSTALL) @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \ list2=; for p in $$list; do \ if test -f $$p; then \ list2="$$list2 $$p"; \ else :; fi; \ done; \ test -z "$$list2" || { \ echo " $(MKDIR_P) '$(DESTDIR)$(libdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(libdir)" || exit 1; \ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 '$(DESTDIR)$(libdir)'"; \ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 "$(DESTDIR)$(libdir)"; \ } uninstall-libLTLIBRARIES: @$(NORMAL_UNINSTALL) @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \ for p in $$list; do \ $(am__strip_dir) \ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f '$(DESTDIR)$(libdir)/$$f'"; \ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f "$(DESTDIR)$(libdir)/$$f"; \ done clean-libLTLIBRARIES: -test -z "$(lib_LTLIBRARIES)" || rm -f $(lib_LTLIBRARIES) @list='$(lib_LTLIBRARIES)'; \ locs=`for p in $$list; do echo $$p; done | \ sed 's|^[^/]*$$|.|; s|/[^/]*$$||; s|$$|/so_locations|' | \ sort -u`; \ test -z "$$locs" || { \ echo rm -f $${locs}; \ rm -f $${locs}; \ } libpolyml.la: $(libpolyml_la_OBJECTS) $(libpolyml_la_DEPENDENCIES) $(EXTRA_libpolyml_la_DEPENDENCIES) $(AM_V_CXXLD)$(libpolyml_la_LINK) -rpath $(libdir) $(libpolyml_la_OBJECTS) $(libpolyml_la_LIBADD) $(LIBS) mostlyclean-compile: -rm -f *.$(OBJEXT) distclean-compile: -rm -f *.tab.c @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/arb.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/basicio.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bitmap.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/check_objects.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/diagnostics.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/elfexport.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/errors.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/exporter.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gc.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gc_check_weak_ref.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gc_copy_phase.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gc_mark_phase.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gc_progress.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gc_share_phase.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gc_update_phase.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gctaskfarm.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/heapsizing.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/interpret.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/locking.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/machoexport.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/memmgr.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/mpoly.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/network.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/objsize.Plo@am__quote@ # am--include-marker -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/osmem.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/osmemunix.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/osmemwin.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pecoffexport.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pexport.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/poly_specific.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/polyffi.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/polystring.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/process_env.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/processes.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/profiling.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/quick_gc.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/realconv.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/reals.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/rts_module.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/rtsentry.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/run_time.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/save_vec.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/savestate.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/scanaddrs.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/sharedata.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/sighandler.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/statistics.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/timing.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/unix_specific.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/winbasicio.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/windows_specific.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/winguiconsole.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/winstartup.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/x86_dep.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/x86assembly_gas32.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/x86assembly_gas64.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/xwindows.Plo@am__quote@ # am--include-marker $(am__depfiles_remade): @$(MKDIR_P) $(@D) @echo '# dummy' >$@-t && $(am__mv) $@-t $@ am--depfiles: $(am__depfiles_remade) .S.o: @am__fastdepCCAS_TRUE@ $(AM_V_CPPAS)$(CPPASCOMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $< @am__fastdepCCAS_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po @AMDEP_TRUE@@am__fastdepCCAS_FALSE@ $(AM_V_CPPAS)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCCAS_FALSE@ DEPDIR=$(DEPDIR) $(CCASDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCCAS_FALSE@ $(AM_V_CPPAS@am__nodep@)$(CPPASCOMPILE) -c -o $@ $< .S.obj: @am__fastdepCCAS_TRUE@ $(AM_V_CPPAS)$(CPPASCOMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ `$(CYGPATH_W) '$<'` @am__fastdepCCAS_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po @AMDEP_TRUE@@am__fastdepCCAS_FALSE@ $(AM_V_CPPAS)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCCAS_FALSE@ DEPDIR=$(DEPDIR) $(CCASDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCCAS_FALSE@ $(AM_V_CPPAS@am__nodep@)$(CPPASCOMPILE) -c -o $@ `$(CYGPATH_W) '$<'` .S.lo: @am__fastdepCCAS_TRUE@ $(AM_V_CPPAS)$(LTCPPASCOMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $< @am__fastdepCCAS_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Plo @AMDEP_TRUE@@am__fastdepCCAS_FALSE@ $(AM_V_CPPAS)source='$<' object='$@' libtool=yes @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCCAS_FALSE@ DEPDIR=$(DEPDIR) $(CCASDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCCAS_FALSE@ $(AM_V_CPPAS@am__nodep@)$(LTCPPASCOMPILE) -c -o $@ $< .cpp.o: @am__fastdepCXX_TRUE@ $(AM_V_CXX)$(CXXCOMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $< @am__fastdepCXX_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po @AMDEP_TRUE@@am__fastdepCXX_FALSE@ $(AM_V_CXX)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCXX_FALSE@ DEPDIR=$(DEPDIR) $(CXXDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCXX_FALSE@ $(AM_V_CXX@am__nodep@)$(CXXCOMPILE) -c -o $@ $< .cpp.obj: @am__fastdepCXX_TRUE@ $(AM_V_CXX)$(CXXCOMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ `$(CYGPATH_W) '$<'` @am__fastdepCXX_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po @AMDEP_TRUE@@am__fastdepCXX_FALSE@ $(AM_V_CXX)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCXX_FALSE@ DEPDIR=$(DEPDIR) $(CXXDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCXX_FALSE@ $(AM_V_CXX@am__nodep@)$(CXXCOMPILE) -c -o $@ `$(CYGPATH_W) '$<'` .cpp.lo: @am__fastdepCXX_TRUE@ $(AM_V_CXX)$(LTCXXCOMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $< @am__fastdepCXX_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Plo @AMDEP_TRUE@@am__fastdepCXX_FALSE@ $(AM_V_CXX)source='$<' object='$@' libtool=yes @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCXX_FALSE@ DEPDIR=$(DEPDIR) $(CXXDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCXX_FALSE@ $(AM_V_CXX@am__nodep@)$(LTCXXCOMPILE) -c -o $@ $< mostlyclean-libtool: -rm -f *.lo clean-libtool: -rm -rf .libs _libs install-pkgconfigDATA: $(pkgconfig_DATA) @$(NORMAL_INSTALL) @list='$(pkgconfig_DATA)'; test -n "$(pkgconfigdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(pkgconfigdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(pkgconfigdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(pkgconfigdir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(pkgconfigdir)" || exit $$?; \ done uninstall-pkgconfigDATA: @$(NORMAL_UNINSTALL) @list='$(pkgconfig_DATA)'; test -n "$(pkgconfigdir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(pkgconfigdir)'; $(am__uninstall_files_from_dir) # This directory's subdirectories are mostly independent; you can cd # into them and run 'make' without going through this Makefile. # To change the values of 'make' variables: instead of editing Makefiles, # (1) if the variable is set in 'config.status', edit 'config.status' # (which will cause the Makefiles to be regenerated when you run 'make'); # (2) otherwise, pass the desired values on the 'make' command line. $(am__recursive_targets): @fail=; \ if $(am__make_keepgoing); then \ failcom='fail=yes'; \ else \ failcom='exit 1'; \ fi; \ dot_seen=no; \ target=`echo $@ | sed s/-recursive//`; \ case "$@" in \ distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \ *) list='$(SUBDIRS)' ;; \ esac; \ for subdir in $$list; do \ echo "Making $$target in $$subdir"; \ if test "$$subdir" = "."; then \ dot_seen=yes; \ local_target="$$target-am"; \ else \ local_target="$$target"; \ fi; \ ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ || eval $$failcom; \ done; \ if test "$$dot_seen" = "no"; then \ $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \ fi; test -z "$$fail" ID: $(am__tagged_files) $(am__define_uniq_tagged_files); mkid -fID $$unique tags: tags-recursive TAGS: tags tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) set x; \ here=`pwd`; \ if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \ include_option=--etags-include; \ empty_fix=.; \ else \ include_option=--include; \ empty_fix=; \ fi; \ list='$(SUBDIRS)'; for subdir in $$list; do \ if test "$$subdir" = .; then :; else \ test ! -f $$subdir/TAGS || \ set "$$@" "$$include_option=$$here/$$subdir/TAGS"; \ fi; \ done; \ $(am__define_uniq_tagged_files); \ shift; \ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ test -n "$$unique" || unique=$$empty_fix; \ if test $$# -gt 0; then \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ "$$@" $$unique; \ else \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ $$unique; \ fi; \ fi ctags: ctags-recursive CTAGS: ctags ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) $(am__define_uniq_tagged_files); \ test -z "$(CTAGS_ARGS)$$unique" \ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ $$unique GTAGS: here=`$(am__cd) $(top_builddir) && pwd` \ && $(am__cd) $(top_srcdir) \ && gtags -i $(GTAGS_ARGS) "$$here" cscopelist: cscopelist-recursive cscopelist-am: $(am__tagged_files) list='$(am__tagged_files)'; \ case "$(srcdir)" in \ [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ *) sdir=$(subdir)/$(srcdir) ;; \ esac; \ for i in $$list; do \ if test -f "$$i"; then \ echo "$(subdir)/$$i"; \ else \ echo "$$sdir/$$i"; \ fi; \ done >> $(top_builddir)/cscope.files distclean-tags: -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags distdir: $(BUILT_SOURCES) $(MAKE) $(AM_MAKEFLAGS) distdir-am distdir-am: $(DISTFILES) @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \ if test "$$subdir" = .; then :; else \ $(am__make_dryrun) \ || test -d "$(distdir)/$$subdir" \ || $(MKDIR_P) "$(distdir)/$$subdir" \ || exit 1; \ dir1=$$subdir; dir2="$(distdir)/$$subdir"; \ $(am__relativize); \ new_distdir=$$reldir; \ dir1=$$subdir; dir2="$(top_distdir)"; \ $(am__relativize); \ new_top_distdir=$$reldir; \ echo " (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) top_distdir="$$new_top_distdir" distdir="$$new_distdir" \\"; \ echo " am__remove_distdir=: am__skip_length_check=: am__skip_mode_fix=: distdir)"; \ ($(am__cd) $$subdir && \ $(MAKE) $(AM_MAKEFLAGS) \ top_distdir="$$new_top_distdir" \ distdir="$$new_distdir" \ am__remove_distdir=: \ am__skip_length_check=: \ am__skip_mode_fix=: \ distdir) \ || exit 1; \ fi; \ done check-am: all-am check: check-recursive all-am: Makefile $(LTLIBRARIES) $(DATA) $(HEADERS) installdirs: installdirs-recursive installdirs-am: for dir in "$(DESTDIR)$(libdir)" "$(DESTDIR)$(pkgconfigdir)"; do \ test -z "$$dir" || $(MKDIR_P) "$$dir"; \ done install: install-recursive install-exec: install-exec-recursive install-data: install-data-recursive uninstall: uninstall-recursive install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-recursive install-strip: if test -z '$(STRIP)'; then \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ install; \ else \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ fi mostlyclean-generic: clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-recursive clean-am: clean-generic clean-libLTLIBRARIES clean-libtool \ mostlyclean-am distclean: distclean-recursive -rm -f ./$(DEPDIR)/arb.Plo -rm -f ./$(DEPDIR)/basicio.Plo -rm -f ./$(DEPDIR)/bitmap.Plo -rm -f ./$(DEPDIR)/check_objects.Plo -rm -f ./$(DEPDIR)/diagnostics.Plo -rm -f ./$(DEPDIR)/elfexport.Plo -rm -f ./$(DEPDIR)/errors.Plo -rm -f ./$(DEPDIR)/exporter.Plo -rm -f ./$(DEPDIR)/gc.Plo -rm -f ./$(DEPDIR)/gc_check_weak_ref.Plo -rm -f ./$(DEPDIR)/gc_copy_phase.Plo -rm -f ./$(DEPDIR)/gc_mark_phase.Plo + -rm -f ./$(DEPDIR)/gc_progress.Plo -rm -f ./$(DEPDIR)/gc_share_phase.Plo -rm -f ./$(DEPDIR)/gc_update_phase.Plo -rm -f ./$(DEPDIR)/gctaskfarm.Plo -rm -f ./$(DEPDIR)/heapsizing.Plo -rm -f ./$(DEPDIR)/interpret.Plo -rm -f ./$(DEPDIR)/locking.Plo -rm -f ./$(DEPDIR)/machoexport.Plo -rm -f ./$(DEPDIR)/memmgr.Plo -rm -f ./$(DEPDIR)/mpoly.Plo -rm -f ./$(DEPDIR)/network.Plo -rm -f ./$(DEPDIR)/objsize.Plo - -rm -f ./$(DEPDIR)/osmem.Plo + -rm -f ./$(DEPDIR)/osmemunix.Plo + -rm -f ./$(DEPDIR)/osmemwin.Plo -rm -f ./$(DEPDIR)/pecoffexport.Plo -rm -f ./$(DEPDIR)/pexport.Plo -rm -f ./$(DEPDIR)/poly_specific.Plo -rm -f ./$(DEPDIR)/polyffi.Plo -rm -f ./$(DEPDIR)/polystring.Plo -rm -f ./$(DEPDIR)/process_env.Plo -rm -f ./$(DEPDIR)/processes.Plo -rm -f ./$(DEPDIR)/profiling.Plo -rm -f ./$(DEPDIR)/quick_gc.Plo -rm -f ./$(DEPDIR)/realconv.Plo -rm -f ./$(DEPDIR)/reals.Plo -rm -f ./$(DEPDIR)/rts_module.Plo -rm -f ./$(DEPDIR)/rtsentry.Plo -rm -f ./$(DEPDIR)/run_time.Plo -rm -f ./$(DEPDIR)/save_vec.Plo -rm -f ./$(DEPDIR)/savestate.Plo -rm -f ./$(DEPDIR)/scanaddrs.Plo -rm -f ./$(DEPDIR)/sharedata.Plo -rm -f ./$(DEPDIR)/sighandler.Plo -rm -f ./$(DEPDIR)/statistics.Plo -rm -f ./$(DEPDIR)/timing.Plo -rm -f ./$(DEPDIR)/unix_specific.Plo -rm -f ./$(DEPDIR)/winbasicio.Plo -rm -f ./$(DEPDIR)/windows_specific.Plo -rm -f ./$(DEPDIR)/winguiconsole.Plo -rm -f ./$(DEPDIR)/winstartup.Plo -rm -f ./$(DEPDIR)/x86_dep.Plo -rm -f ./$(DEPDIR)/x86assembly_gas32.Plo -rm -f ./$(DEPDIR)/x86assembly_gas64.Plo -rm -f ./$(DEPDIR)/xwindows.Plo -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-tags dvi: dvi-recursive dvi-am: html: html-recursive html-am: info: info-recursive info-am: install-data-am: install-pkgconfigDATA install-dvi: install-dvi-recursive install-dvi-am: install-exec-am: install-libLTLIBRARIES install-html: install-html-recursive install-html-am: install-info: install-info-recursive install-info-am: install-man: install-pdf: install-pdf-recursive install-pdf-am: install-ps: install-ps-recursive install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-recursive -rm -f ./$(DEPDIR)/arb.Plo -rm -f ./$(DEPDIR)/basicio.Plo -rm -f ./$(DEPDIR)/bitmap.Plo -rm -f ./$(DEPDIR)/check_objects.Plo -rm -f ./$(DEPDIR)/diagnostics.Plo -rm -f ./$(DEPDIR)/elfexport.Plo -rm -f ./$(DEPDIR)/errors.Plo -rm -f ./$(DEPDIR)/exporter.Plo -rm -f ./$(DEPDIR)/gc.Plo -rm -f ./$(DEPDIR)/gc_check_weak_ref.Plo -rm -f ./$(DEPDIR)/gc_copy_phase.Plo -rm -f ./$(DEPDIR)/gc_mark_phase.Plo + -rm -f ./$(DEPDIR)/gc_progress.Plo -rm -f ./$(DEPDIR)/gc_share_phase.Plo -rm -f ./$(DEPDIR)/gc_update_phase.Plo -rm -f ./$(DEPDIR)/gctaskfarm.Plo -rm -f ./$(DEPDIR)/heapsizing.Plo -rm -f ./$(DEPDIR)/interpret.Plo -rm -f ./$(DEPDIR)/locking.Plo -rm -f ./$(DEPDIR)/machoexport.Plo -rm -f ./$(DEPDIR)/memmgr.Plo -rm -f ./$(DEPDIR)/mpoly.Plo -rm -f ./$(DEPDIR)/network.Plo -rm -f ./$(DEPDIR)/objsize.Plo - -rm -f ./$(DEPDIR)/osmem.Plo + -rm -f ./$(DEPDIR)/osmemunix.Plo + -rm -f ./$(DEPDIR)/osmemwin.Plo -rm -f ./$(DEPDIR)/pecoffexport.Plo -rm -f ./$(DEPDIR)/pexport.Plo -rm -f ./$(DEPDIR)/poly_specific.Plo -rm -f ./$(DEPDIR)/polyffi.Plo -rm -f ./$(DEPDIR)/polystring.Plo -rm -f ./$(DEPDIR)/process_env.Plo -rm -f ./$(DEPDIR)/processes.Plo -rm -f ./$(DEPDIR)/profiling.Plo -rm -f ./$(DEPDIR)/quick_gc.Plo -rm -f ./$(DEPDIR)/realconv.Plo -rm -f ./$(DEPDIR)/reals.Plo -rm -f ./$(DEPDIR)/rts_module.Plo -rm -f ./$(DEPDIR)/rtsentry.Plo -rm -f ./$(DEPDIR)/run_time.Plo -rm -f ./$(DEPDIR)/save_vec.Plo -rm -f ./$(DEPDIR)/savestate.Plo -rm -f ./$(DEPDIR)/scanaddrs.Plo -rm -f ./$(DEPDIR)/sharedata.Plo -rm -f ./$(DEPDIR)/sighandler.Plo -rm -f ./$(DEPDIR)/statistics.Plo -rm -f ./$(DEPDIR)/timing.Plo -rm -f ./$(DEPDIR)/unix_specific.Plo -rm -f ./$(DEPDIR)/winbasicio.Plo -rm -f ./$(DEPDIR)/windows_specific.Plo -rm -f ./$(DEPDIR)/winguiconsole.Plo -rm -f ./$(DEPDIR)/winstartup.Plo -rm -f ./$(DEPDIR)/x86_dep.Plo -rm -f ./$(DEPDIR)/x86assembly_gas32.Plo -rm -f ./$(DEPDIR)/x86assembly_gas64.Plo -rm -f ./$(DEPDIR)/xwindows.Plo -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-recursive mostlyclean-am: mostlyclean-compile mostlyclean-generic \ mostlyclean-libtool pdf: pdf-recursive pdf-am: ps: ps-recursive ps-am: uninstall-am: uninstall-libLTLIBRARIES uninstall-pkgconfigDATA .MAKE: $(am__recursive_targets) install-am install-strip .PHONY: $(am__recursive_targets) CTAGS GTAGS TAGS all all-am \ am--depfiles check check-am clean clean-generic \ clean-libLTLIBRARIES clean-libtool cscopelist-am ctags \ ctags-am distclean distclean-compile distclean-generic \ distclean-libtool distclean-tags distdir dvi dvi-am html \ html-am info info-am install install-am install-data \ install-data-am install-dvi install-dvi-am install-exec \ install-exec-am install-html install-html-am install-info \ install-info-am install-libLTLIBRARIES install-man install-pdf \ install-pdf-am install-pkgconfigDATA install-ps install-ps-am \ install-strip installcheck installcheck-am installdirs \ installdirs-am maintainer-clean maintainer-clean-generic \ mostlyclean mostlyclean-compile mostlyclean-generic \ mostlyclean-libtool pdf pdf-am ps ps-am tags tags-am uninstall \ uninstall-am uninstall-libLTLIBRARIES uninstall-pkgconfigDATA .PRECIOUS: Makefile # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: diff --git a/libpolyml/PolyLib.vcxproj b/libpolyml/PolyLib.vcxproj index 541c7a8f..15ec3ede 100644 --- a/libpolyml/PolyLib.vcxproj +++ b/libpolyml/PolyLib.vcxproj @@ -1,891 +1,893 @@  Debug32in64 Win32 Debug32in64 x64 Debug Win32 Int32in64Debug Win32 Int32in64Debug x64 Int32In64Release Win32 Int32In64Release x64 IntDebug Win32 IntDebug x64 IntRelease Win32 IntRelease x64 Release32in64 Win32 Release32in64 x64 Release Win32 Debug x64 Release x64 {0BA5D5B5-F85B-4C49-8A27-67186FA68922} PolyLib 10.0 DynamicLibrary true v142 Unicode DynamicLibrary true v142 Unicode DynamicLibrary true v142 Unicode DynamicLibrary true v142 Unicode DynamicLibrary false v142 true Unicode DynamicLibrary false v142 true Unicode DynamicLibrary false v142 true Unicode DynamicLibrary false v142 true Unicode DynamicLibrary true v142 Unicode DynamicLibrary true v142 Unicode DynamicLibrary true v142 Unicode DynamicLibrary true v142 Unicode DynamicLibrary false v142 true Unicode DynamicLibrary false v142 true Unicode DynamicLibrary false v142 true Unicode DynamicLibrary false v142 true Unicode .dll .dll .dll .dll .dll .dll .dll .dll .dll .dll .dll .dll .dll .dll .dll .dll Level3 Disabled true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreadedDebug true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 Disabled true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreadedDebug true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 Disabled true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreadedDebug true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 Disabled true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreadedDebug true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 Disabled true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreadedDebug true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 Disabled true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) POLYML32IN64;_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreadedDebug true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 Disabled true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreadedDebug true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 Disabled true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) POLYML32IN64;_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreadedDebug true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 MaxSpeed true true true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreaded true true true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 MaxSpeed true true true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreaded true true true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 MaxSpeed true true true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreaded true true true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 MaxSpeed true true true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreaded true true true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 MaxSpeed true true true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreaded true true true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 MaxSpeed true true true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) POLYML32IN64;_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreaded true true true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 MaxSpeed true true true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreaded true true true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 MaxSpeed true true true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) POLYML32IN64;_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreaded true true true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false true true true true true true true true true true true true true true true true + + true true false false true true false false true true false false true true false false - true true true true true true true true true true true true true true true true true true true true true true true true + true true true true false false true true false false true true true true true true Document cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm" cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm" $(IntDir)%(Filename).obj $(IntDir)%(Filename).obj cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm" cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm" $(IntDir)%(Filename).obj $(IntDir)%(Filename).obj cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm" cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm" $(IntDir)%(Filename).obj $(IntDir)%(Filename).obj cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm" cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm" $(IntDir)%(Filename).obj $(IntDir)%(Filename).obj cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm" cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm" $(IntDir)%(Filename).obj $(IntDir)%(Filename).obj cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm" cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm" $(IntDir)%(Filename).obj $(IntDir)%(Filename).obj cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm" cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm" $(IntDir)%(Filename).obj $(IntDir)%(Filename).obj cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm" cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm" $(IntDir)%(Filename).obj $(IntDir)%(Filename).obj true true true true true true true true true true true true Document cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm $(IntDir)%(Filename).obj $(IntDir)%(Filename).obj cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm $(IntDir)%(Filename).obj $(IntDir)%(Filename).obj cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm $(IntDir)%(Filename).obj $(IntDir)%(Filename).obj cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm $(IntDir)%(Filename).obj $(IntDir)%(Filename).obj cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm cl /nologo /EP /I. /D_MSC_VER /DPOLYML32IN64 "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm $(IntDir)%(Filename).obj $(IntDir)%(Filename).obj cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm $(IntDir)%(Filename).obj $(IntDir)%(Filename).obj cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm cl /nologo /EP /I. /D_MSC_VER /DPOLYML32IN64 "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm $(IntDir)%(Filename).obj $(IntDir)%(Filename).obj cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm $(IntDir)%(Filename).obj $(IntDir)%(Filename).obj {6d86bc6f-e74e-40c5-9881-f8bb606bca78} \ No newline at end of file diff --git a/libpolyml/basicio.cpp b/libpolyml/basicio.cpp index edc77d5b..dd43c068 100644 --- a/libpolyml/basicio.cpp +++ b/libpolyml/basicio.cpp @@ -1,1124 +1,1121 @@ /* Title: Basic IO. Copyright (c) 2000, 2015-2020 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(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; - } + // N.B. We use this for OS.Process.sleep with empty descriptor list. + if (maxTime < maxMillisecs) maxMillisecs = maxTime; + pollResult = poll(fdVec, nDescr, maxMillisecs); + if (pollResult < 0) errorResult = ERRORNUMBER; } POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(FirstArgument threadId, PolyWord streamVector, PolyWord bitVector, PolyWord maxMillisecs) { 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()); struct pollfd * fds = 0; 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, maxMilliseconds); processes->ThreadPauseForIO(taskData, &pollWait); if (pollWait.PollResult() < 0) raise_syscall(taskData, "poll failed", pollWait.PollError()); // Construct the result vectors. result = 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(result)->Set(i, TAGGED(res)); } } 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(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 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. No longer used - previously used for Posix.FileSys.wordToFD. */ { 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(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(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/elfexport.cpp b/libpolyml/elfexport.cpp index 38437c71..da0ea2f0 100644 --- a/libpolyml/elfexport.cpp +++ b/libpolyml/elfexport.cpp @@ -1,766 +1,780 @@ /* Title: Write out a database as an ELF object file Author: David Matthews. - Copyright (c) 2006-7, 2011, 2016-18 David C. J. Matthews + Copyright (c) 2006-7, 2011, 2016-18, 2020 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 */ #include "config.h" #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_STDDEF_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_TIME_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #ifdef HAVE_ELF_H #include #elif defined(HAVE_ELF_ABI_H) #include +#endif + +#ifdef HAVE_MACHINE_RELOC_H #include #ifndef EM_X86_64 #define EM_X86_64 EM_AMD64 #endif #if defined(HOSTARCHITECTURE_X86_64) #ifndef R_386_PC32 #define R_386_PC32 R_X86_64_PC32 #endif #ifndef R_386_32 #define R_386_32 R_X86_64_32 #endif #ifndef R_X86_64_64 #define R_X86_64_64 R_X86_64_64 #endif #endif /* HOSTARCHITECTURE_X86_64 */ #endif // Solaris seems to put processor-specific constants in separate files #ifdef HAVE_SYS_ELF_SPARC_H #include #endif #ifdef HAVE_SYS_ELF_386_H #include #endif #ifdef HAVE_SYS_ELF_AMD64_H #include #endif // Android has the ARM relocation symbol here #ifdef HAVE_ASM_ELF_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_SYS_UTSNAME_H #include #endif #include "globals.h" #include "diagnostics.h" #include "sys.h" #include "machine_dep.h" #include "gc.h" #include "mpoly.h" #include "scanaddrs.h" #include "elfexport.h" #include "run_time.h" #include "version.h" #include "polystring.h" #include "timing.h" #define sym_last_local_sym sym_data_section #if defined(HOSTARCHITECTURE_X86) # define HOST_E_MACHINE EM_386 # define HOST_DIRECT_DATA_RELOC R_386_32 # define HOST_DIRECT_FPTR_RELOC R_386_32 # define USE_RELA 0 #elif defined(HOSTARCHITECTURE_PPC) # define HOST_E_MACHINE EM_PPC # define HOST_DIRECT_DATA_RELOC R_PPC_ADDR32 # define HOST_DIRECT_FPTR_RELOC R_PPC_ADDR32 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_PPC64) # define HOST_E_MACHINE EM_PPC64 # define HOST_DIRECT_DATA_RELOC R_PPC64_ADDR64 # define HOST_DIRECT_FPTR_RELOC R_PPC64_ADDR64 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_S390) # define HOST_E_MACHINE EM_S390 # define HOST_DIRECT_DATA_RELOC R_390_32 # define HOST_DIRECT_FPTR_RELOC R_390_32 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_S390X) # define HOST_E_MACHINE EM_S390 # define HOST_DIRECT_DATA_RELOC R_390_64 # define HOST_DIRECT_FPTR_RELOC R_390_64 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_SH) # define HOST_E_MACHINE EM_SH # define HOST_DIRECT_DATA_RELOC R_SH_DIR32 # define HOST_DIRECT_FPTR_RELOC R_SH_DIR32 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_SPARC) # define HOST_E_MACHINE EM_SPARC # define HOST_DIRECT_DATA_RELOC R_SPARC_32 # define HOST_DIRECT_FPTR_RELOC R_SPARC_32 # define USE_RELA 1 /* Sparc/Solaris, at least 2.8, requires ELF32_Rela relocations. For some reason, though, it adds the value in the location being relocated (as with ELF32_Rel relocations) as well as the addend. To be safe, whenever we use an ELF32_Rela relocation we always zero the location to be relocated. */ #elif defined(HOSTARCHITECTURE_SPARC64) # define HOST_E_MACHINE EM_SPARCV9 # define HOST_DIRECT_DATA_RELOC R_SPARC_64 # define HOST_DIRECT_FPTR_RELOC R_SPARC_64 /* Use the most relaxed memory model. At link time, the most restrictive one is chosen, so it does no harm to be as permissive as possible here. */ # define HOST_E_FLAGS EF_SPARCV9_RMO # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_X86_64) /* It seems Solaris/X86-64 only supports ELF64_Rela relocations. It appears that Linux will support either so we now use Rela on X86-64. */ # define HOST_E_MACHINE EM_X86_64 # define HOST_DIRECT_DATA_RELOC R_X86_64_64 # define HOST_DIRECT_FPTR_RELOC R_X86_64_64 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_X32) # define HOST_E_MACHINE EM_X86_64 # define HOST_DIRECT_DATA_RELOC R_X86_64_32 # define HOST_DIRECT_FPTR_RELOC R_X86_64_32 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_ARM) # ifndef EF_ARM_EABI_VER4 # define EF_ARM_EABI_VER4 0x04000000 # endif // When linking ARM binaries the linker checks the ABI version. We // need to set the version to the same as the libraries. // GCC currently uses version 4. # define HOST_E_MACHINE EM_ARM # define HOST_DIRECT_DATA_RELOC R_ARM_ABS32 # define HOST_DIRECT_FPTR_RELOC R_ARM_ABS32 # define USE_RELA 0 # define HOST_E_FLAGS EF_ARM_EABI_VER4 #elif defined(HOSTARCHITECTURE_HPPA) # if defined(__hpux) # define HOST_OSABI ELFOSABI_HPUX # elif defined(__NetBSD__) # define HOST_OSABI ELFOSABI_NETBSD # elif defined(__linux__) # define HOST_OSABI ELFOSABI_GNU # endif # define HOST_E_MACHINE EM_PARISC # define HOST_DIRECT_DATA_RELOC R_PARISC_DIR32 # define HOST_DIRECT_FPTR_RELOC R_PARISC_PLABEL32 # define HOST_E_FLAGS EFA_PARISC_1_0 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_IA64) # define HOST_E_MACHINE EM_IA_64 # define HOST_DIRECT_DATA_RELOC R_IA64_DIR64LSB # define HOST_DIRECT_FPTR_RELOC R_IA64_FPTR64LSB # define HOST_E_FLAGS EF_IA_64_ABI64 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_AARCH64) # define HOST_E_MACHINE EM_AARCH64 # define HOST_DIRECT_DATA_RELOC R_AARCH64_ABS64 # define HOST_DIRECT_FPTR_RELOC R_AARCH64_ABS64 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_M68K) # define HOST_E_MACHINE EM_68K # define HOST_DIRECT_DATA_RELOC R_68K_32 # define HOST_DIRECT_FPTR_RELOC R_68K_32 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_MIPS) # define HOST_E_MACHINE EM_MIPS # define HOST_DIRECT_DATA_RELOC R_MIPS_32 # define HOST_DIRECT_FPTR_RELOC R_MIPS_32 # ifdef __PIC__ # define HOST_E_FLAGS EF_MIPS_CPIC # endif # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_MIPS64) # define HOST_E_MACHINE EM_MIPS # define HOST_DIRECT_DATA_RELOC R_MIPS_64 # define HOST_DIRECT_FPTR_RELOC R_MIPS_64 # ifdef __PIC__ # define HOST_E_FLAGS (EF_MIPS_ARCH_64 | EF_MIPS_CPIC) # else # define HOST_E_FLAGS EF_MIPS_ARCH_64 # endif # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_ALPHA) # define HOST_E_MACHINE EM_ALPHA # define HOST_DIRECT_DATA_RELOC R_ALPHA_REFQUAD # define HOST_DIRECT_FPTR_RELOC R_ALPHA_REFQUAD # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_RISCV32) || defined(HOSTARCHITECTURE_RISCV64) # define HOST_E_MACHINE EM_RISCV # if defined(HOSTARCHITECTURE_RISCV32) # define HOST_DIRECT_DATA_RELOC R_RISCV_32 # define HOST_DIRECT_FPTR_RELOC R_RISCV_32 # else # define HOST_DIRECT_DATA_RELOC R_RISCV_64 # define HOST_DIRECT_FPTR_RELOC R_RISCV_64 # endif # if defined(__riscv_float_abi_soft) # define HOST_E_FLAGS_FLOAT_ABI EF_RISCV_FLOAT_ABI_SOFT # elif defined(__riscv_float_abi_single) # define HOST_E_FLAGS_FLOAT_ABI EF_RISCV_FLOAT_ABI_SINGLE # elif defined(__riscv_float_abi_double) # define HOST_E_FLAGS_FLOAT_ABI EF_RISCV_FLOAT_ABI_DOUBLE # elif defined(__riscv_float_abi_quad) # define HOST_E_FLAGS_FLOAT_ABI EF_RISCV_FLOAT_ABI_QUAD # else # error "Unknown RISC-V float ABI" # endif # ifdef __riscv_32e # define HOST_E_FLAGS_RVE __riscv_32e # else # define HOST_E_FLAGS_RVE 0 # endif # define HOST_E_FLAGS (HOST_E_FLAGS_FLOAT_ABI | HOST_E_FLAGS_RVE) # define USE_RELA 1 #else # error "No support for exporting on this architecture" #endif // The first two symbols are special: // Zero is always special in ELF // 1 is used for the data section #define EXTRA_SYMBOLS 2 static unsigned AreaToSym(unsigned area) { return area+EXTRA_SYMBOLS; } // Section table entries enum { sect_initial = 0, sect_sectionnametable, sect_stringtable, // Data and relocation entries come in here. sect_data // Finally the symbol table }; // Add an external reference to the RTS void ELFExport::addExternalReference(void *relocAddr, const char *name, bool isFuncPtr) { externTable.makeEntry(name); // The symbol is added after the memory table entries and poly_exports writeRelocation(0, relocAddr, symbolNum++, isFuncPtr); } // Generate the address relative to the start of the segment. void ELFExport::setRelocationAddress(void *p, ElfXX_Addr *reloc) { unsigned area = findArea(p); POLYUNSIGNED offset = (char*)p - (char*)memTable[area].mtOriginalAddr; *reloc = offset; } /* Get the index corresponding to an address. */ PolyWord ELFExport::createRelocation(PolyWord p, void *relocAddr) { void *addr = p.AsAddress(); unsigned addrArea = findArea(addr); POLYUNSIGNED offset = (char*)addr - (char*)memTable[addrArea].mtOriginalAddr; return writeRelocation(offset, relocAddr, AreaToSym(addrArea), false); } PolyWord ELFExport::writeRelocation(POLYUNSIGNED offset, void *relocAddr, unsigned symbolNum, bool isFuncPtr) { #if USE_RELA ElfXX_Rela reloc; reloc.r_addend = offset; offset = 0; #else ElfXX_Rel reloc; #endif // Set the offset within the section we're scanning. setRelocationAddress(relocAddr, &reloc.r_offset); #ifdef HOSTARCHITECTURE_MIPS64 reloc.r_sym = symbolNum; reloc.r_ssym = 0; reloc.r_type = isFuncPtr ? HOST_DIRECT_FPTR_RELOC : HOST_DIRECT_DATA_RELOC; reloc.r_type2 = 0; reloc.r_type3 = 0; #else reloc.r_info = ELFXX_R_INFO(symbolNum, isFuncPtr ? HOST_DIRECT_FPTR_RELOC : HOST_DIRECT_DATA_RELOC); #endif fwrite(&reloc, sizeof(reloc), 1, exportFile); relocationCount++; return PolyWord::FromUnsigned(offset); } /* 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 ELFExport::ScanConstant(PolyObject *base, byte *addr, ScanRelocationKind code) { #ifndef POLYML32IN64 PolyObject *p = GetConstantValue(addr, code); if (p == 0) return; void *a = p; unsigned aArea = findArea(a); // We don't need a relocation if this is relative to the current segment // since the relative address will already be right. if (code == PROCESS_RELOC_I386RELATIVE && aArea == findArea(addr)) return; // Set the value at the address to the offset relative to the symbol. POLYUNSIGNED offset = (char*)a - (char*)memTable[aArea].mtOriginalAddr; switch (code) { case PROCESS_RELOC_DIRECT: // 32 or 64 bit address of target { PolyWord r = createRelocation(p, addr); POLYUNSIGNED w = r.AsUnsigned(); for (unsigned i = 0; i < sizeof(PolyWord); i++) { addr[i] = (byte)(w & 0xff); w >>= 8; } } break; #if(defined(HOSTARCHITECTURE_X86) || defined(HOSTARCHITECTURE_X86_64) || \ defined(HOSTARCHITECTURE_X32)) #ifdef HOSTARCHITECTURE_X86 #define R_PC_RELATIVE R_386_PC32 #else #define R_PC_RELATIVE R_X86_64_PC32 #endif case PROCESS_RELOC_I386RELATIVE: // 32 bit relative address { #if USE_RELA ElfXX_Rela reloc; reloc.r_addend = offset; #else ElfXX_Rel reloc; #endif setRelocationAddress(addr, &reloc.r_offset); // We seem to need to subtract 4 bytes to get the correct offset in ELF offset -= 4; reloc.r_info = ELFXX_R_INFO(AreaToSym(aArea), R_PC_RELATIVE); #if USE_RELA // Clear the field. Even though it's not supposed to be used with Rela the // Linux linker at least seems to add the value in here sometimes. memset(addr, 0, 4); #else for (unsigned i = 0; i < 4; i++) { addr[i] = (byte)(offset & 0xff); offset >>= 8; } #endif fwrite(&reloc, sizeof(reloc), 1, exportFile); relocationCount++; } break; #endif default: ASSERT(0); // Wrong type of relocation for this architecture. } #endif } unsigned long ELFExport::makeStringTableEntry(const char *str, ExportStringTable *stab) { if (str == NULL || str[0] == 0) return 0; // First entry is the null string. else return stab->makeEntry(str); } void ELFExport::writeSymbol(const char *symbolName, long value, long size, int binding, int sttype, int section) { ElfXX_Sym symbol; memset(&symbol, 0, sizeof(symbol)); // Zero unused fields symbol.st_name = makeStringTableEntry(symbolName, &symStrings); symbol.st_value = value; symbol.st_size = size; symbol.st_info = ELFXX_ST_INFO(binding, sttype); symbol.st_other = 0; symbol.st_shndx = section; fwrite(&symbol, sizeof(symbol), 1, exportFile); } // Set the file alignment. void ELFExport::alignFile(int align) { char pad[32] = {0}; // Maximum alignment int offset = ftell(exportFile); if ((offset % align) == 0) return; fwrite(&pad, align - (offset % align), 1, exportFile); } void ELFExport::createStructsRelocation(unsigned sym, size_t offset, size_t addend) { #if USE_RELA ElfXX_Rela reloc; reloc.r_addend = addend; #else ElfXX_Rel reloc; #endif reloc.r_offset = offset; #ifdef HOSTARCHITECTURE_MIPS64 reloc.r_sym = sym; reloc.r_ssym = 0; reloc.r_type = HOST_DIRECT_DATA_RELOC; reloc.r_type2 = 0; reloc.r_type3 = 0; #else reloc.r_info = ELFXX_R_INFO(sym, HOST_DIRECT_DATA_RELOC); #endif fwrite(&reloc, sizeof(reloc), 1, exportFile); relocationCount++; } void ELFExport::exportStore(void) { PolyWord *p; ElfXX_Ehdr fhdr; ElfXX_Shdr *sections = 0; - unsigned numSections = 6 + 2*memTableEntries /*- 1*/; +#ifdef __linux__ + unsigned extraSections = 1; // Extra section for .note.GNU-stack +#else + unsigned extraSections = 0; +#endif + unsigned numSections = 6 + 2*memTableEntries /*- 1*/ + extraSections; // The symbol table comes at the end. unsigned sect_symtab = sect_data + 2*memTableEntries + 2/* - 1*/; unsigned i; // External symbols start after the memory table entries and "poly_exports". symbolNum = EXTRA_SYMBOLS+memTableEntries+1; // Both the string tables have an initial null entry. symStrings.makeEntry(""); sectionStrings.makeEntry(""); // Write out initial values for the headers. These are overwritten at the end. // File header memset(&fhdr, 0, sizeof(fhdr)); fhdr.e_ident[EI_MAG0] = 0x7f; fhdr.e_ident[EI_MAG1] = 'E'; fhdr.e_ident[EI_MAG2] = 'L'; fhdr.e_ident[EI_MAG3] = 'F'; fhdr.e_ident[EI_CLASS] = ELFCLASSXX; // ELFCLASS32 or ELFCLASS64 fhdr.e_ident[EI_VERSION] = EV_CURRENT; #ifdef HOST_OSABI fhdr.e_ident[EI_OSABI] = HOST_OSABI; #endif { union { unsigned long wrd; char chrs[sizeof(unsigned long)]; } endian; endian.wrd = 1; if (endian.chrs[0] == 0) fhdr.e_ident[EI_DATA] = ELFDATA2MSB; // Big endian else fhdr.e_ident[EI_DATA] = ELFDATA2LSB; // Little endian } fhdr.e_type = ET_REL; // The machine needs to match the machine we're compiling for // even if this is actually portable code. fhdr.e_machine = HOST_E_MACHINE; #ifdef HOST_E_FLAGS fhdr.e_flags = HOST_E_FLAGS; #endif fhdr.e_version = EV_CURRENT; fhdr.e_shoff = sizeof(fhdr); // Offset to section header - immediately follows fhdr.e_ehsize = sizeof(fhdr); fhdr.e_shentsize = sizeof(ElfXX_Shdr); fhdr.e_shnum = numSections; fhdr.e_shstrndx = sect_sectionnametable; // Section name table section index; fwrite(&fhdr, sizeof(fhdr), 1, exportFile); // Write it for the moment. sections = new ElfXX_Shdr[numSections]; memset(sections, 0, sizeof(ElfXX_Shdr) * numSections); // Necessary? // Set up the section header but don't write it yet. // Section 0 - all zeros sections[sect_initial].sh_type = SHT_NULL; sections[sect_initial].sh_link = SHN_UNDEF; // Section name table. sections[sect_sectionnametable].sh_name = makeStringTableEntry(".shstrtab", §ionStrings); sections[sect_sectionnametable].sh_type = SHT_STRTAB; sections[sect_sectionnametable].sh_addralign = sizeof(char); // sections[sect_sectionnametable].sh_offset is set later // sections[sect_sectionnametable].sh_size is set later // Symbol name table. sections[sect_stringtable].sh_name = makeStringTableEntry(".strtab", §ionStrings); sections[sect_stringtable].sh_type = SHT_STRTAB; sections[sect_stringtable].sh_addralign = sizeof(char); // sections[sect_stringtable].sh_offset is set later // sections[sect_stringtable].sh_size is set later unsigned long dataName = makeStringTableEntry(".data", §ionStrings); unsigned long dataRelName = makeStringTableEntry(USE_RELA ? ".rela.data" : ".rel.data", §ionStrings); unsigned long textName = makeStringTableEntry(".text", §ionStrings); unsigned long textRelName = makeStringTableEntry(USE_RELA ? ".rela.text" : ".rel.text", §ionStrings); unsigned long rodataName = makeStringTableEntry(".rodata", §ionStrings); unsigned long rodataRelName = makeStringTableEntry(USE_RELA ? ".rela.rodata" : ".rel.rodata", §ionStrings); // Main data sections. Each one has a relocation section. for (i=0; i < memTableEntries; i++) { unsigned s = sect_data + i*2; sections[s].sh_addralign = 8; // 8-byte alignment sections[s].sh_type = SHT_PROGBITS; if (memTable[i].mtFlags & MTF_WRITEABLE) { // Mutable areas ASSERT(!(memTable[i].mtFlags & MTF_EXECUTABLE)); // Executable areas can't be writable. sections[s].sh_name = dataName; sections[s].sh_flags = SHF_WRITE | SHF_ALLOC; sections[s+1].sh_name = dataRelName; // Name of relocation section } else if (memTable[i].mtFlags & MTF_EXECUTABLE) { // Code areas are marked as executable. sections[s].sh_name = textName; sections[s].sh_flags = SHF_ALLOC | SHF_EXECINSTR; sections[s+1].sh_name = textRelName; // Name of relocation section } else { // Non-code immutable areas sections[s].sh_name = rodataName; sections[s].sh_flags = SHF_ALLOC; sections[s+1].sh_name = rodataRelName; // Name of relocation section } // sections[s].sh_size is set later // sections[s].sh_offset is set later. // sections[s].sh_size is set later. // Relocation section sections[s+1].sh_type = USE_RELA ? SHT_RELA : SHT_REL; // Contains relocation with/out explicit addends (ElfXX_Rel) sections[s+1].sh_link = sect_symtab; // Index to symbol table sections[s+1].sh_info = s; // Applies to the data section sections[s+1].sh_addralign = sizeof(long); // Align to a word sections[s+1].sh_entsize = USE_RELA ? sizeof(ElfXX_Rela) : sizeof(ElfXX_Rel); // sections[s+1].sh_offset is set later. // sections[s+1].sh_size is set later. } // Table data - Poly tables that describe the memory layout. unsigned sect_table_data = sect_data + 2*memTableEntries; sections[sect_table_data].sh_name = dataName; sections[sect_table_data].sh_type = SHT_PROGBITS; sections[sect_table_data].sh_flags = SHF_WRITE | SHF_ALLOC; sections[sect_table_data].sh_addralign = 8; // 8-byte alignment // Table relocation sections[sect_table_data+1].sh_name = dataRelName; sections[sect_table_data+1].sh_type = USE_RELA ? SHT_RELA : SHT_REL; // Contains relocation with/out explicit addends (ElfXX_Rel) sections[sect_table_data+1].sh_link = sect_symtab; // Index to symbol table sections[sect_table_data+1].sh_info = sect_table_data; // Applies to table section sections[sect_table_data+1].sh_addralign = sizeof(long); // Align to a word sections[sect_table_data+1].sh_entsize = USE_RELA ? sizeof(ElfXX_Rela) : sizeof(ElfXX_Rel); // Symbol table. sections[sect_symtab].sh_name = makeStringTableEntry(".symtab", §ionStrings); sections[sect_symtab].sh_type = SHT_SYMTAB; sections[sect_symtab].sh_link = sect_stringtable; // String table to use sections[sect_symtab].sh_addralign = sizeof(long); // Align to a word sections[sect_symtab].sh_entsize = sizeof(ElfXX_Sym); // sections[sect_symtab].sh_info is set later // sections[sect_symtab].sh_size is set later // sections[sect_symtab].sh_offset is set later +#ifdef __linux__ + // Add a .note.GNU-stack section to indicate this does not require executable stack + sections[numSections-1].sh_name = makeStringTableEntry(".note.GNU-stack", §ionStrings); + sections[numSections - 1].sh_type = SHT_PROGBITS; +#endif + // Write the relocations. for (i = 0; i < memTableEntries; i++) { unsigned relocSection = sect_data + i*2 + 1; alignFile(sections[relocSection].sh_addralign); sections[relocSection].sh_offset = ftell(exportFile); relocationCount = 0; // Create the relocation table and turn all addresses into offsets. char *start = (char*)memTable[i].mtOriginalAddr; char *end = start + memTable[i].mtLength; for (p = (PolyWord*)start; p < (PolyWord*)end; ) { p++; PolyObject *obj = (PolyObject*)p; POLYUNSIGNED length = obj->Length(); // Update any constants before processing the object // We need that for relative jumps/calls in X86/64. if (length != 0 && obj->IsCodeObject()) machineDependent->ScanConstantsWithinCode(obj, this); relocateObject(obj); p += length; } sections[relocSection].sh_size = relocationCount * (USE_RELA ? sizeof(ElfXX_Rela) : sizeof(ElfXX_Rel)); } // Relocations for "exports" and "memTable"; alignFile(sections[sect_table_data+1].sh_addralign); sections[sect_table_data+1].sh_offset = ftell(exportFile); relocationCount = 0; // TODO: This won't be needed if we put these in a separate section. POLYUNSIGNED areaSpace = 0; for (i = 0; i < memTableEntries; i++) areaSpace += memTable[i].mtLength; // Address of "memTable" within "exports". We can't use createRelocation because // the position of the relocation is not in either the mutable or the immutable area. size_t memTableOffset = sizeof(exportDescription); // It follows immediately after this. createStructsRelocation(AreaToSym(memTableEntries), offsetof(exportDescription, memTable), memTableOffset); // Address of "rootFunction" within "exports" unsigned rootAddrArea = findArea(rootFunction); size_t rootOffset = (char*)rootFunction - (char*)memTable[rootAddrArea].mtOriginalAddr; createStructsRelocation(AreaToSym(rootAddrArea), offsetof(exportDescription, rootFunction), rootOffset); // Addresses of the areas within memtable. for (i = 0; i < memTableEntries; i++) { createStructsRelocation(AreaToSym(i), sizeof(exportDescription) + i * sizeof(memoryTableEntry) + offsetof(memoryTableEntry, mtCurrentAddr), 0 /* No offset relative to base symbol*/); } sections[sect_table_data+1].sh_size = relocationCount * (USE_RELA ? sizeof(ElfXX_Rela) : sizeof(ElfXX_Rel)); // Now the symbol table. alignFile(sections[sect_symtab].sh_addralign); sections[sect_symtab].sh_offset = ftell(exportFile); writeSymbol("", 0, 0, 0, 0, 0); // Initial symbol // Write the local symbols first. writeSymbol("", 0, 0, STB_LOCAL, STT_SECTION, sect_data); // .data section // Create symbols for the address areas. AreaToSym assumes these come first. for (i = 0; i < memTableEntries; i++) { unsigned s = sect_data + i*2; char buff[50]; sprintf(buff, "area%1u", i); writeSymbol(buff, 0, 0, STB_LOCAL, STT_OBJECT, s); } // Global symbols - Exported symbol for table. writeSymbol("poly_exports", 0, sizeof(exportDescription)+sizeof(memoryTableEntry)*memTableEntries, STB_GLOBAL, STT_OBJECT, sect_table_data); // External references for (unsigned i = 0; i < externTable.stringSize; i += (unsigned)strlen(externTable.strings+i) + 1) writeSymbol(externTable.strings+i, 0, 0, STB_GLOBAL, STT_FUNC, SHN_UNDEF); sections[sect_symtab].sh_info = EXTRA_SYMBOLS+memTableEntries; // One more than last local sym sections[sect_symtab].sh_size = sizeof(ElfXX_Sym) * symbolNum; // Now the binary data. for (i = 0; i < memTableEntries; i++) { unsigned dataSection = sect_data + i*2; sections[dataSection].sh_size = memTable[i].mtLength; alignFile(sections[dataSection].sh_addralign); sections[dataSection].sh_offset = ftell(exportFile); fwrite(memTable[i].mtOriginalAddr, 1, memTable[i].mtLength, exportFile); } exportDescription exports; memset(&exports, 0, sizeof(exports)); exports.structLength = sizeof(exportDescription); exports.memTableSize = sizeof(memoryTableEntry); exports.memTableEntries = memTableEntries; exports.memTable = USE_RELA ? 0 : (memoryTableEntry *)memTableOffset; // Set the value to be the offset relative to the base of the area. We have set a relocation // already which will add the base of the area. exports.rootFunction = USE_RELA ? 0 : (void*)rootOffset; exports.timeStamp = getBuildTime(); exports.architecture = machineDependent->MachineArchitecture(); exports.rtsVersion = POLY_version_number; #ifdef POLYML32IN64 exports.originalBaseAddr = globalHeapBase; #else exports.originalBaseAddr = 0; #endif // Set the address values to zero before we write. They will always // be relative to their base symbol. for (i = 0; i < memTableEntries; i++) memTable[i].mtCurrentAddr = 0; // Now the binary data. alignFile(sections[sect_table_data].sh_addralign); sections[sect_table_data].sh_offset = ftell(exportFile); sections[sect_table_data].sh_size = sizeof(exportDescription) + memTableEntries*sizeof(memoryTableEntry); fwrite(&exports, sizeof(exports), 1, exportFile); fwrite(memTable, sizeof(memoryTableEntry), memTableEntries, exportFile); // The section name table sections[sect_sectionnametable].sh_offset = ftell(exportFile); fwrite(sectionStrings.strings, sectionStrings.stringSize, 1, exportFile); sections[sect_sectionnametable].sh_size = sectionStrings.stringSize; // The symbol name table sections[sect_stringtable].sh_offset = ftell(exportFile); fwrite(symStrings.strings, symStrings.stringSize, 1, exportFile); sections[sect_stringtable].sh_size = symStrings.stringSize; // Finally the section headers. alignFile(4); fhdr.e_shoff = ftell(exportFile); fwrite(sections, sizeof(ElfXX_Shdr) * numSections, 1, exportFile); // Rewind to rewrite the file header with the offset of the section headers. rewind(exportFile); fwrite(&fhdr, sizeof(fhdr), 1, exportFile); fclose(exportFile); exportFile = NULL; delete[]sections; } diff --git a/libpolyml/exporter.cpp b/libpolyml/exporter.cpp index 6d7ea139..034d93b1 100644 --- a/libpolyml/exporter.cpp +++ b/libpolyml/exporter.cpp @@ -1,914 +1,924 @@ /* Title: exporter.cpp - Export a function as an object or C file - Copyright (c) 2006-7, 2015, 2016-19 David C.J. Matthews + Copyright (c) 2006-7, 2015, 2016-20 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(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; + PolyObject* writeAble = 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); + writeAble = space->writeAble(newObj); 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->writeAble(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); + writeAble = space->writeAble(newObj); 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->writeAble(space->topPointer) = PolyWord::FromUnsigned(0); space->topPointer++; } #endif ASSERT(space->topPointer <= space->top && space->topPointer >= space->bottom); } - newObj->SetLengthWord(lengthWord); // copy length word + writeAble->SetLengthWord(lengthWord); // copy length word - memcpy(newObj, obj, words * sizeof(PolyWord)); + memcpy(writeAble, 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. } + else if (isCodeObj) #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); + gMem.SpaceForAddress(obj)->writeAble(obj)->SetLengthWord(ll); } +#else + gMem.SpaceForAddress(obj)->writeAble(obj)->SetForwardingPtr(newObj); #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); + gMem.SpaceForAddress(obj)->writeAble(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(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(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 } +void Exporter::createRelocation(PolyWord* pt) +{ + *gMem.SpaceForAddress(pt)->writeAble(pt) = createRelocation(*pt, pt); +} + // 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/exporter.h b/libpolyml/exporter.h index bc0a217d..02a3b6fb 100644 --- a/libpolyml/exporter.h +++ b/libpolyml/exporter.h @@ -1,120 +1,120 @@ /* Title: exporter.h - Export a function as an object or C file - Copyright (c) 2006, 2015-17 David C.J. Matthews + Copyright (c) 2006, 2015-17, 2020 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 EXPORTER_H_INCLUDED #define EXPORTER_H_INCLUDED #include "globals.h" // For PolyWord #include "../polyexports.h" // For struct _memTableEntry #ifdef HAVE_STDIO_H #include // For FILE #endif class SaveVecEntry; typedef SaveVecEntry *Handle; class TaskData; extern Handle exportNative(TaskData *mdTaskData, Handle args); extern Handle exportPortable(TaskData *mdTaskData, Handle args); // This is the base class for the exporters for the various object-code formats. class Exporter { public: Exporter(unsigned int h=0); virtual ~Exporter(); virtual void exportStore(void) = 0; // Called by the root thread to do the work. void RunExport(PolyObject *rootFunction); protected: virtual PolyWord createRelocation(PolyWord p, void *relocAddr) = 0; void relocateValue(PolyWord *pt); void relocateObject(PolyObject *p); - void createRelocation(PolyWord *pt) { *pt = createRelocation(*pt, pt); } + void createRelocation(PolyWord *pt); unsigned findArea(void *p); // Find index of area that address is in. virtual void addExternalReference(void *p, const char *entryPoint, bool isFuncPtr) {} public: FILE *exportFile; const char *errorMessage; protected: unsigned int hierarchy; struct _memTableEntry *memTable; unsigned memTableEntries; PolyObject *rootFunction; // Address of the root function. unsigned newAreas; }; // The object-code exporters all use a similar string table format // consisting of null-terminated C-strings. class ExportStringTable { public: ExportStringTable(); ~ExportStringTable(); unsigned long makeEntry(const char *str); char *strings; unsigned long stringSize, stringAvailable; }; #include "scanaddrs.h" // Because permanent immutable areas are read-only we need to // have somewhere else to hold the tomb-stones. class GraveYard { public: GraveYard() { graves = 0; } ~GraveYard(); PolyWord *graves; PolyWord *startAddr, *endAddr; }; class CopyScan: public ScanAddress { public: CopyScan(unsigned h=0); void initialise(bool isExport=true); ~CopyScan(); protected: virtual POLYUNSIGNED ScanAddressAt(PolyWord *pt); // Have to follow pointers from closures into code. virtual POLYUNSIGNED ScanCodeAddressAt(PolyObject **pt); POLYUNSIGNED ScanAddress(PolyObject **pt); public: virtual PolyObject *ScanObjectAddress(PolyObject *base); // Default sizes of the segments. uintptr_t defaultImmSize, defaultCodeSize, defaultMutSize, defaultNoOverSize; unsigned hierarchy; GraveYard *graveYard; unsigned tombs; }; extern struct _entrypts exporterEPT[]; #endif diff --git a/libpolyml/gc.cpp b/libpolyml/gc.cpp index 6fd69e4f..8a4a4b24 100644 --- a/libpolyml/gc.cpp +++ b/libpolyml/gc.cpp @@ -1,416 +1,424 @@ /* Title: Multi-Threaded Garbage Collector Copyright (c) 2010-12, 2019 David C. J. Matthews Based on the original garbage collector code Copyright 2000-2008 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 #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #include "globals.h" #include "run_time.h" #include "machine_dep.h" #include "diagnostics.h" #include "processes.h" #include "timing.h" #include "gc.h" #include "scanaddrs.h" #include "check_objects.h" #include "osmem.h" #include "bitmap.h" #include "rts_module.h" #include "memmgr.h" #include "gctaskfarm.h" #include "mpoly.h" #include "statistics.h" #include "profiling.h" #include "heapsizing.h" +#include "gc_progress.h" static GCTaskFarm gTaskFarm; // Global task farm. GCTaskFarm *gpTaskFarm = &gTaskFarm; // If the GC converts a weak ref from SOME to NONE it sets this ref. It can be // cleared by the signal handler thread. There's no need for a lock since it // is only set during GC and only cleared when not GCing. bool convertedWeak = false; /* How the garbage collector works. The GC has two phases. The minor (quick) GC is a copying collector that copies data from the allocation area into the mutable and immutable area. The major collector is started when either the mutable or the immutable area is full. The major collector uses a mark/sweep scheme. The GC has three phases: 1. Mark phase. Working from the roots; which are the the permanent mutable segments and the RTS roots (e.g. thread stacks), mark all reachable cells. Marking involves setting bits in the bitmap for reachable words. 2. Compact phase. Marked objects are copied to try to compact, upwards, the heap segments. When an object is moved the length word of the object in the old location is set as a tombstone that points to its new location. In particular this means that we cannot reuse the space where an object previously was during the compaction phase. Immutable objects are moved into immutable segments. When an object is moved to a new location the bits are set in the bitmap as though the object had been marked at that location. 3. Update phase. The roots and objects marked during the first two phases are scanned and any addresses for moved objects are updated. The lowest address used in the area then becomes the base of the area for future allocations. There is a sharing phase which may be performed before the mark phase. This merges immutable cells with the same contents with the aim of reducing the size of the live data. It is expensive so is not performed by default. Updated DCJM 12/06/12 */ static bool doGC(const POLYUNSIGNED wordsRequiredToAllocate) { gHeapSizeParameters.RecordAtStartOfMajorGC(); gHeapSizeParameters.RecordGCTime(HeapSizeParameters::GCTimeStart); globalStats.incCount(PSC_GC_FULLGC); // Remove any empty spaces. There will not normally be any except // if we have triggered a full GC as a result of detecting paging in the // minor GC but in that case we want to try to stop the system writing // out areas that are now empty. gMem.RemoveEmptyLocals(); if (debugOptions & DEBUG_GC) Log("GC: Full GC, %lu words required %" PRI_SIZET " spaces\n", wordsRequiredToAllocate, gMem.lSpaces.size()); if (debugOptions & DEBUG_HEAPSIZE) gMem.ReportHeapSizes("Full GC (before)"); // Data sharing pass. if (gHeapSizeParameters.PerformSharingPass()) { globalStats.incCount(PSC_GC_SHARING); GCSharingPhase(); } + + gcProgressBeginMajorGC(); // The GC sharing phase is treated separately + /* * There is a really weird bug somewhere. An extra bit may be set in the bitmap during * the mark phase. It seems to be related to heavy swapping activity. Duplicating the * bitmap causes it to occur only in one copy and write-protecting the bitmap apart from * when it is actually being updated does not result in a seg-fault. So far I've only * seen it on 64-bit Linux but it may be responsible for other crashes. The work-around * is to check the number of bits set in the bitmap and repeat the mark phase if it does * not match. */ for (unsigned p = 3; p > 0; p--) { for(std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *lSpace = *i; ASSERT (lSpace->top >= lSpace->upperAllocPtr); ASSERT (lSpace->upperAllocPtr >= lSpace->lowerAllocPtr); ASSERT (lSpace->lowerAllocPtr >= lSpace->bottom); // Set upper and lower limits of weak refs. lSpace->highestWeak = lSpace->bottom; lSpace->lowestWeak = lSpace->top; lSpace->fullGCLowerLimit = lSpace->top; // Put dummy objects in the unused space. This allows // us to scan over the whole of the space. gMem.FillUnusedSpace(lSpace->lowerAllocPtr, lSpace->upperAllocPtr-lSpace->lowerAllocPtr); } // Set limits of weak refs. for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { PermanentMemSpace *pSpace = *i; pSpace->highestWeak = pSpace->bottom; pSpace->lowestWeak = pSpace->top; } /* Mark phase */ GCMarkPhase(); uintptr_t bitCount = 0, markCount = 0; for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *lSpace = *i; markCount += lSpace->i_marked + lSpace->m_marked; bitCount += lSpace->bitmap.CountSetBits(lSpace->spaceSize()); } if (markCount == bitCount) break; else { // Report an error. If this happens again we crash. Log("GC: Count error mark count %lu, bitCount %lu\n", markCount, bitCount); if (p == 1) { ASSERT(markCount == bitCount); } } } for(std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *lSpace = *i; // Reset the allocation pointers. They will be set to the // limits of the retained data. #ifdef POLYML32IN64 lSpace->lowerAllocPtr = lSpace->bottom+1; // Must be odd-word aligned lSpace->lowerAllocPtr[-1] = PolyWord::FromUnsigned(0); #else lSpace->lowerAllocPtr = lSpace->bottom; #endif lSpace->upperAllocPtr = lSpace->top; } + gcProgressSetPercent(25); + if (debugOptions & DEBUG_GC) Log("GC: Check weak refs\n"); /* Detect unreferenced streams, windows etc. */ GCheckWeakRefs(); + gcProgressSetPercent(50); // Check that the heap is not overfull. We make sure the marked // mutable and immutable data is no more than 90% of the // corresponding areas. This is a very coarse adjustment. { uintptr_t iMarked = 0, mMarked = 0; uintptr_t iSpace = 0, mSpace = 0; for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *lSpace = *i; iMarked += lSpace->i_marked; mMarked += lSpace->m_marked; if (! lSpace->allocationSpace) { if (lSpace->isMutable) mSpace += lSpace->spaceSize(); else iSpace += lSpace->spaceSize(); } } // Add space if necessary and possible. while (iMarked > iSpace - iSpace/10 && gHeapSizeParameters.AddSpaceBeforeCopyPhase(false) != 0) iSpace += gMem.DefaultSpaceSize(); while (mMarked > mSpace - mSpace/10 && gHeapSizeParameters.AddSpaceBeforeCopyPhase(true) != 0) mSpace += gMem.DefaultSpaceSize(); } /* Compact phase */ GCCopyPhase(); gHeapSizeParameters.RecordGCTime(HeapSizeParameters::GCTimeIntermediate, "Copy"); + gcProgressSetPercent(75); // Update Phase. if (debugOptions & DEBUG_GC) Log("GC: Update\n"); GCUpdatePhase(); gHeapSizeParameters.RecordGCTime(HeapSizeParameters::GCTimeIntermediate, "Update"); { uintptr_t iUpdated = 0, mUpdated = 0, iMarked = 0, mMarked = 0; for(std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *lSpace = *i; iMarked += lSpace->i_marked; mMarked += lSpace->m_marked; if (lSpace->isMutable) mUpdated += lSpace->updated; else iUpdated += lSpace->updated; } ASSERT(iUpdated+mUpdated == iMarked+mMarked); } // Delete empty spaces. gMem.RemoveEmptyLocals(); if (debugOptions & DEBUG_GC_ENHANCED) { for(std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *lSpace = *i; Log("GC: %s space %p %" PRI_SIZET " free in %" PRI_SIZET " words %2.1f%% full\n", lSpace->spaceTypeString(), lSpace, lSpace->freeSpace(), lSpace->spaceSize(), ((float)lSpace->allocatedSpace()) * 100 / (float)lSpace->spaceSize()); } } // Compute values for statistics globalStats.setSize(PSS_AFTER_LAST_GC, 0); globalStats.setSize(PSS_AFTER_LAST_FULLGC, 0); globalStats.setSize(PSS_ALLOCATION, 0); globalStats.setSize(PSS_ALLOCATION_FREE, 0); for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *space = *i; uintptr_t free = space->freeSpace(); globalStats.incSize(PSS_AFTER_LAST_GC, free*sizeof(PolyWord)); globalStats.incSize(PSS_AFTER_LAST_FULLGC, free*sizeof(PolyWord)); if (space->allocationSpace) { if (space->allocatedSpace() > space->freeSpace()) // It's more than half full gMem.ConvertAllocationSpaceToLocal(space); else { globalStats.incSize(PSS_ALLOCATION, free*sizeof(PolyWord)); globalStats.incSize(PSS_ALLOCATION_FREE, free*sizeof(PolyWord)); } } #ifdef FILL_UNUSED_MEMORY memset(space->bottom, 0xaa, (char*)space->upperAllocPtr - (char*)space->bottom); #endif if (debugOptions & DEBUG_GC_ENHANCED) Log("GC: %s space %p %" PRI_SIZET " free in %" PRI_SIZET " words %2.1f%% full\n", space->spaceTypeString(), space, space->freeSpace(), space->spaceSize(), ((float)space->allocatedSpace()) * 100 / (float)space->spaceSize()); } // End of garbage collection gHeapSizeParameters.RecordGCTime(HeapSizeParameters::GCTimeEnd); // Now we've finished we can adjust the heap sizes. gHeapSizeParameters.AdjustSizeAfterMajorGC(wordsRequiredToAllocate); gHeapSizeParameters.resetMajorTimingData(); bool haveSpace = gMem.CheckForAllocation(wordsRequiredToAllocate); // Invariant: the bitmaps are completely clean. if (debugOptions & DEBUG_GC) { if (haveSpace) Log("GC: Completed successfully\n"); else Log("GC: Completed with insufficient space\n"); } if (debugOptions & DEBUG_HEAPSIZE) gMem.ReportHeapSizes("Full GC (after)"); // if (profileMode == kProfileLiveData || profileMode == kProfileLiveMutables) // printprofile(); CheckMemory(); return haveSpace; // Completed } // Create the initial heap. hsize, isize and msize are the requested heap sizes // from the user arguments in units of kbytes. // Fills in the defaults and attempts to allocate the heap. If the heap size // is too large it allocates as much as it can. The default heap size is half the // physical memory. void CreateHeap() { // Create an initial allocation space. if (gMem.CreateAllocationSpace(gMem.DefaultSpaceSize()) == 0) Exit("Insufficient memory to allocate the heap"); // Create the task farm if required if (userOptions.gcthreads != 1) { if (! gTaskFarm.Initialise(userOptions.gcthreads, 100)) Crash("Unable to initialise the GC task farm"); } // Set up the stacks for the mark phase. initialiseMarkerTables(); } // Set single threaded mode. This is only used in a child process after // Posix fork in case there is a GC before the exec. void GCSetSingleThreadAfterFork() { gpTaskFarm->SetSingleThreaded(); initialiseMarkerTables(); } class FullGCRequest: public MainThreadRequest { public: FullGCRequest(): MainThreadRequest(MTP_GCPHASEMARK) {} virtual void Perform() { doGC (0); } }; class QuickGCRequest: public MainThreadRequest { public: QuickGCRequest(POLYUNSIGNED words): MainThreadRequest(MTP_GCPHASEMARK), wordsRequired(words) {} virtual void Perform() { result = #ifndef DEBUG_ONLY_FULL_GC // If DEBUG_ONLY_FULL_GC is defined then we skip the partial GC. RunQuickGC(wordsRequired) || #endif doGC (wordsRequired); } bool result; POLYUNSIGNED wordsRequired; }; // Perform a full garbage collection. This is called either from ML via the full_gc RTS call // or from various RTS functions such as open_file to try to recover dropped file handles. void FullGC(TaskData *taskData) { FullGCRequest request; processes->MakeRootRequest(taskData, &request); if (convertedWeak) // Notify the signal thread to broadcast on the condition var when // the GC is complete. We mustn't call SignalArrived within the GC // because it locks schedLock and the main GC thread already holds schedLock. processes->SignalArrived(); } // This is the normal call when memory is exhausted and we need to garbage collect. bool QuickGC(TaskData *taskData, POLYUNSIGNED wordsRequiredToAllocate) { QuickGCRequest request(wordsRequiredToAllocate); processes->MakeRootRequest(taskData, &request); if (convertedWeak) processes->SignalArrived(); return request.result; } // Called in RunShareData. This is called as a root function void FullGCForShareCommonData(void) { doGC(0); } diff --git a/libpolyml/gc_mark_phase.cpp b/libpolyml/gc_mark_phase.cpp index 18b06448..2af92606 100644 --- a/libpolyml/gc_mark_phase.cpp +++ b/libpolyml/gc_mark_phase.cpp @@ -1,873 +1,882 @@ /* Title: Multi-Threaded Garbage Collector - Mark phase Copyright (c) 2010-12, 2015-16, 2019 David C. J. Matthews Based on the original garbage collector code Copyright 2000-2008 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 */ /* This is the first, mark, phase of the garbage collector. It detects all reachable cells in the area being collected. At the end of the phase the bit-maps associated with the areas will have ones for words belonging to cells that must be retained and zeros for words that can be reused. This is now multi-threaded. The mark phase involves setting a bit in the header of each live cell and then a pass over the memory building the bitmaps and clearing this bit. It is unfortunate that we cannot use the GC-bit that is used in forwarding pointers but we may well have forwarded pointers left over from a partially completed minor GC. Using a bit in the header avoids the need for locking since at worst it may involve two threads duplicating some marking. The code ensures that each reachable cell is marked at least once but with multiple threads a cell may be marked by more than once cell if the memory is not fully up to date. Each thread has a stack on which it remembers cells that have been marked but not fully scanned. If a thread runs out of cells of its own to scan it can pick a pointer off the stack of another thread and scan that. The original thread will still scan it some time later but it should find that the addresses in it have all been marked and it can simply pop this off. This is all done without locking. Stacks are only modified by the owning thread and when they pop anything they write zero in its place. Other threads only need to search for a zero to find if they are at the top and if they get a pointer that has already been scanned then this is safe. The only assumption made about the memory is that all the bits of a word are updated together so that a thread will always read a value that is a valid pointer. Many of the ideas are drawn from Flood, Detlefs, Shavit and Zhang 2001 "Parallel Garbage Collection for Shared Memory Multiprocessors". */ #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 "processes.h" #include "gc.h" #include "scanaddrs.h" #include "check_objects.h" #include "bitmap.h" #include "memmgr.h" #include "diagnostics.h" #include "gctaskfarm.h" #include "profiling.h" #include "heapsizing.h" #define MARK_STACK_SIZE 3000 #define LARGECACHE_SIZE 20 class MTGCProcessMarkPointers: public ScanAddress { public: MTGCProcessMarkPointers(); virtual void ScanRuntimeAddress(PolyObject **pt, RtsStrength weak); 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()); } virtual void ScanConstant(PolyObject *base, byte *addressOfConstant, ScanRelocationKind code); // ScanCodeAddressAt should never be called. POLYUNSIGNED ScanCodeAddressAt(PolyObject **pt) { ASSERT(0); return 0; } static void MarkPointersTask(GCTaskId *, void *arg1, void *arg2); static void InitStatics(unsigned threads) { markStacks = new MTGCProcessMarkPointers[threads]; nInUse = 0; nThreads = threads; } static void MarkRoots(void); static bool RescanForStackOverflow(); private: bool TestForScan(PolyWord *pt); void MarkAndTestForScan(PolyWord *pt); void Reset(); void PushToStack(PolyObject *obj, PolyWord *currentPtr = 0) { // If we don't have all the threads running we start a new one but // only once we have several items on the stack. Otherwise we // can end up creating a task that terminates almost immediately. if (nInUse >= nThreads || msp < 2 || ! ForkNew(obj)) { if (msp < MARK_STACK_SIZE) { markStack[msp++] = obj; if (currentPtr != 0) { locPtr++; if (locPtr == LARGECACHE_SIZE) locPtr = 0; largeObjectCache[locPtr].base = obj; largeObjectCache[locPtr].current = currentPtr; } } else StackOverflow(obj); } // else the new task is processing it. } static void StackOverflow(PolyObject *obj); static bool ForkNew(PolyObject *obj); PolyObject *markStack[MARK_STACK_SIZE]; unsigned msp; bool active; // For the typical small cell it's easier just to rescan from the start // but that can be expensive for large cells. This caches the offset for // large cells. static const POLYUNSIGNED largeObjectSize = 50; struct { PolyObject *base; PolyWord *current; } largeObjectCache[LARGECACHE_SIZE]; unsigned locPtr; static MTGCProcessMarkPointers *markStacks; protected: static unsigned nThreads, nInUse; static PLock stackLock; }; // There is one mark-stack for each GC thread. markStacks[0] is used by the // main thread when marking the roots and rescanning after mark-stack overflow. // Once that work is done markStacks[0] is released and is available for a // worker thread. MTGCProcessMarkPointers *MTGCProcessMarkPointers::markStacks; unsigned MTGCProcessMarkPointers::nThreads, MTGCProcessMarkPointers::nInUse; PLock MTGCProcessMarkPointers::stackLock("GC mark stack"); // It is possible to have two levels of forwarding because // we could have a cell in the allocation area that has been moved // to the immutable area and then shared with another cell. inline PolyObject *FollowForwarding(PolyObject *obj) { while (obj->ContainsForwardingPtr()) obj = obj->GetForwardingPtr(); return obj; } MTGCProcessMarkPointers::MTGCProcessMarkPointers(): msp(0), active(false), locPtr(0) { // Clear the mark stack for (unsigned i = 0; i < MARK_STACK_SIZE; i++) markStack[i] = 0; // Clear the large object cache just to be sure. for (unsigned j = 0; j < LARGECACHE_SIZE; j++) { largeObjectCache[j].base = 0; largeObjectCache[j].current = 0; } } // Clear the state at the beginning of a new GC pass. void MTGCProcessMarkPointers::Reset() { locPtr = 0; //largeObjectCache[locPtr].base = 0; // Clear the cache completely just to be safe for (unsigned j = 0; j < LARGECACHE_SIZE; j++) { largeObjectCache[j].base = 0; largeObjectCache[j].current = 0; } } // Called when the stack has overflowed. We need to include this // in the range to be rescanned. void MTGCProcessMarkPointers::StackOverflow(PolyObject *obj) { MarkableSpace *space = (MarkableSpace*)gMem.SpaceForAddress((PolyWord*)obj-1); ASSERT(space != 0 && (space->spaceType == ST_LOCAL || space->spaceType == ST_CODE)); PLocker lock(&space->spaceLock); // Have to include this in the range to rescan. if (space->fullGCRescanStart > ((PolyWord*)obj) - 1) space->fullGCRescanStart = ((PolyWord*)obj) - 1; POLYUNSIGNED n = obj->Length(); if (space->fullGCRescanEnd < ((PolyWord*)obj) + n) space->fullGCRescanEnd = ((PolyWord*)obj) + n; ASSERT(obj->LengthWord() & _OBJ_GC_MARK); // Should have been marked. if (debugOptions & DEBUG_GC_ENHANCED) Log("GC: Mark: Stack overflow. Rescan for %p\n", obj); } // Fork a new task. Because we've checked nInUse without taking the lock // we may find that we can no longer create a new task. bool MTGCProcessMarkPointers::ForkNew(PolyObject *obj) { MTGCProcessMarkPointers *marker = 0; { PLocker lock(&stackLock); if (nInUse == nThreads) return false; for (unsigned i = 0; i < nThreads; i++) { if (! markStacks[i].active) { marker = &markStacks[i]; break; } } ASSERT(marker != 0); marker->active = true; nInUse++; } bool test = gpTaskFarm->AddWork(&MTGCProcessMarkPointers::MarkPointersTask, marker, obj); ASSERT(test); return true; } // Main marking task. This is forked off initially to scan a specific object and // anything reachable from it but once that has finished it tries to find objects // on other stacks to scan. void MTGCProcessMarkPointers::MarkPointersTask(GCTaskId *, void *arg1, void *arg2) { MTGCProcessMarkPointers *marker = (MTGCProcessMarkPointers*)arg1; marker->Reset(); marker->ScanAddressesInObject((PolyObject*)arg2); while (true) { // Look for a stack that has at least one item on it. MTGCProcessMarkPointers *steal = 0; for (unsigned i = 0; i < nThreads && steal == 0; i++) { if (markStacks[i].markStack[0] != 0) steal = &markStacks[i]; } // We're finished if they're all done. if (steal == 0) break; // Look for items on this stack for (unsigned j = 0; j < MARK_STACK_SIZE; j++) { // Pick the item off the stack. // N.B. The owning thread may update this to zero // at any time. PolyObject *toSteal = steal->markStack[j]; if (toSteal == 0) break; // Nothing more on the stack // The idea here is that the original thread pushed this // because there were at least two addresses it needed to // process. It started down one branch but left the other. // Since it will have marked cells in the branch it has // followed this thread will start on the unprocessed // address(es). marker->ScanAddressesInObject(toSteal); } } PLocker lock(&stackLock); marker->active = false; // It's finished nInUse--; ASSERT(marker->markStack[0] == 0); } // Tests if this needs to be scanned. It marks it if it has not been marked // unless it has to be scanned. bool MTGCProcessMarkPointers::TestForScan(PolyWord *pt) { if ((*pt).IsTagged()) return false; // This could contain a forwarding pointer if it points into an // allocation area and has been moved by the minor GC. // We have to be a little careful. Another thread could also // be following any forwarding pointers here. However it's safe // because they will update it with the same value. PolyObject *obj = (*pt).AsObjPtr(); if (obj->ContainsForwardingPtr()) { obj = FollowForwarding(obj); *pt = obj; } MemSpace *sp = gMem.SpaceForAddress((PolyWord*)obj-1); if (sp == 0 || (sp->spaceType != ST_LOCAL && sp->spaceType != ST_CODE)) return false; // Ignore it if it points to a permanent area POLYUNSIGNED L = obj->LengthWord(); if (L & _OBJ_GC_MARK) return false; // Already marked if (debugOptions & DEBUG_GC_DETAIL) Log("GC: Mark: %p %" POLYUFMT " %u\n", obj, OBJ_OBJECT_LENGTH(L), GetTypeBits(L)); if (OBJ_IS_BYTE_OBJECT(L)) { obj->SetLengthWord(L | _OBJ_GC_MARK); // Mark it return false; // We've done as much as we need } return true; } void MTGCProcessMarkPointers::MarkAndTestForScan(PolyWord *pt) { if (TestForScan(pt)) { PolyObject *obj = (*pt).AsObjPtr(); obj->SetLengthWord(obj->LengthWord() | _OBJ_GC_MARK); } } // The initial entry to process the roots. These may be RTS addresses or addresses in // a thread stack. Also called recursively to process the addresses of constants in // code segments. This is used in situations where a scanner may return the // updated address of an object. PolyObject *MTGCProcessMarkPointers::ScanObjectAddress(PolyObject *obj) { MemSpace *sp = gMem.SpaceForAddress((PolyWord*)obj-1); if (!(sp->spaceType == ST_LOCAL || sp->spaceType == ST_CODE)) return obj; // Ignore it if it points to a permanent area // We may have a forwarding pointer if this has been moved by the // minor GC. if (obj->ContainsForwardingPtr()) + { obj = FollowForwarding(obj); + sp = gMem.SpaceForAddress((PolyWord*)obj - 1); + } ASSERT(obj->ContainsNormalLengthWord()); POLYUNSIGNED L = obj->LengthWord(); if (L & _OBJ_GC_MARK) return obj; // Already marked - obj->SetLengthWord(L | _OBJ_GC_MARK); // Mark it + sp->writeAble(obj)->SetLengthWord(L | _OBJ_GC_MARK); // Mark it if (profileMode == kProfileLiveData || (profileMode == kProfileLiveMutables && obj->IsMutable())) AddObjectProfile(obj); POLYUNSIGNED n = OBJ_OBJECT_LENGTH(L); if (debugOptions & DEBUG_GC_DETAIL) Log("GC: Mark: %p %" POLYUFMT " %u\n", obj, n, GetTypeBits(L)); if (OBJ_IS_BYTE_OBJECT(L)) return obj; // 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. if (msp != 0) PushToStack(obj); // Can't check this because it may have forwarding ptrs. else { MTGCProcessMarkPointers::ScanAddressesInObject(obj, L); // We can only check after we've processed it because if we // have addresses left over from an incomplete partial GC they // may need to forwarded. CheckObject (obj); } return obj; } // These functions are only called with pointers held by the runtime system. // Weak references can occur in the runtime system, eg. streams and windows. // Weak references are not marked and so unreferenced streams and windows // can be detected and closed. void MTGCProcessMarkPointers::ScanRuntimeAddress(PolyObject **pt, RtsStrength weak) { if (weak == STRENGTH_WEAK) return; *pt = ScanObjectAddress(*pt); CheckPointer (*pt); // Check it after any forwarding pointers have been followed. } // 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 RecursiveScan::ScanAddressesInObject. void MTGCProcessMarkPointers::ScanAddressesInObject(PolyObject *obj, POLYUNSIGNED lengthWord) { if (OBJ_IS_BYTE_OBJECT(lengthWord)) return; while (true) { ASSERT (OBJ_IS_LENGTH(lengthWord)); POLYUNSIGNED length = OBJ_OBJECT_LENGTH(lengthWord); PolyWord *baseAddr = (PolyWord*)obj; PolyWord *endWord = baseAddr + length; if (OBJ_IS_WEAKREF_OBJECT(lengthWord)) { // Special case. ASSERT(OBJ_IS_MUTABLE_OBJECT(lengthWord)); // Should be a mutable. ASSERT(OBJ_IS_WORD_OBJECT(lengthWord)); // Should be a plain object. // We need to mark the "SOME" values in this object but we don't mark // the references contained within the "SOME". // Mark every word but ignore the result. for (POLYUNSIGNED i = 0; i < length; i++) (void)MarkAndTestForScan(baseAddr+i); // We've finished with this. endWord = baseAddr; } else if (OBJ_IS_CODE_OBJECT(lengthWord)) { // Legacy: The code-generator now uses PolyCopyByteVecToClosure to allocate mutable // code cells in the code area. Previously they were allocated in the heap and copied // into the code area only when they were locked. // It's better to process the whole code object in one go. ScanAddress::ScanAddressesInObject(obj, lengthWord); endWord = baseAddr; // Finished } else if (OBJ_IS_CLOSURE_OBJECT(lengthWord)) { // The first word is the absolute address of the code ... PolyObject *codeAddr = *(PolyObject**)obj; // except that it is possible we haven't yet set it. if (((uintptr_t)codeAddr & 1) == 0) ScanObjectAddress(codeAddr); // The rest is a normal tuple. baseAddr += sizeof(PolyObject*) / sizeof(PolyWord); } // 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. PolyObject *firstWord = 0; PolyObject *secondWord = 0; PolyWord *restartAddr = 0; if (obj == largeObjectCache[locPtr].base) { baseAddr = largeObjectCache[locPtr].current; ASSERT(baseAddr > (PolyWord*)obj && baseAddr < endWord); if (locPtr == 0) locPtr = LARGECACHE_SIZE - 1; else locPtr--; } 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)) { if (firstWord == 0) firstWord = baseAddr->AsObjPtr(); else if (secondWord == 0) { // If we need to rescan because there are three or more words to do // this is the place we need to restart (or the start of the cell if it's // small). restartAddr = baseAddr; secondWord = baseAddr->AsObjPtr(); } else break; // More than two words. } } baseAddr++; } if (baseAddr != endWord) // Put this back on the stack while we process the first word PushToStack(obj, length < largeObjectSize ? 0 : restartAddr); else if (secondWord != 0) { // Mark it now because we will process it. - secondWord->SetLengthWord(secondWord->LengthWord() | _OBJ_GC_MARK); + PolyObject* writeAble = secondWord; + if (secondWord->IsCodeObject()) + writeAble = gMem.SpaceForAddress(secondWord)->writeAble(secondWord); + writeAble->SetLengthWord(secondWord->LengthWord() | _OBJ_GC_MARK); // Put this on the stack. If this is a list node we will be // pushing the tail. PushToStack(secondWord); } if (firstWord != 0) { // Mark it and process it immediately. - firstWord->SetLengthWord(firstWord->LengthWord() | _OBJ_GC_MARK); + PolyObject* writeAble = firstWord; + if (firstWord->IsCodeObject()) + writeAble = gMem.SpaceForAddress(firstWord)->writeAble(firstWord); + writeAble->SetLengthWord(firstWord->LengthWord() | _OBJ_GC_MARK); obj = firstWord; } else if (msp == 0) { markStack[msp] = 0; // Really finished return; } else { // Clear the item above the top. This really is finished. if (msp < MARK_STACK_SIZE) markStack[msp] = 0; // Pop the item from the stack but don't overwrite it yet. // This allows another thread to steal it if there really // is nothing else to do. This is only really important // for large objects. obj = markStack[--msp]; // Pop something. } lengthWord = obj->LengthWord(); } } // Process a constant within the code. This is a direct copy of ScanAddress::ScanConstant // with the addition of the locking. void MTGCProcessMarkPointers::ScanConstant(PolyObject *base, byte *addressOfConstant, ScanRelocationKind code) { // If we have newly compiled code the constants may be in the // local heap. MTGCProcessMarkPointers::ScanObjectAddress can // return an updated address for a local address if there is a // forwarding pointer. // Constants can be aligned on any byte offset so another thread // scanning the same code could see an invalid address if it read // the constant while it was being updated. We put a lock round // this just in case. MemSpace *space = gMem.SpaceForAddress(addressOfConstant); PLock *lock = 0; if (space->spaceType == ST_CODE) lock = &((CodeSpace*)space)->spaceLock; if (lock != 0) lock->Lock(); PolyObject *p = GetConstantValue(addressOfConstant, code); if (lock != 0) lock->Unlock(); if (p != 0) { PolyObject *newVal = ScanObjectAddress(p); if (newVal != p) // Update it if it has changed. { if (lock != 0) lock->Lock(); SetConstantValue(addressOfConstant, newVal, code); if (lock != 0) lock->Unlock(); } } } // Mark all the roots. This is run in the main thread and has the effect // of starting new tasks as the scanning runs. void MTGCProcessMarkPointers::MarkRoots(void) { ASSERT(nThreads >= 1); ASSERT(nInUse == 0); MTGCProcessMarkPointers *marker = &markStacks[0]; marker->Reset(); marker->active = true; nInUse = 1; // 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) marker->ScanAddressesInRegion(space->bottom, space->top); } // Scan the RTS roots. GCModules(marker); ASSERT(marker->markStack[0] == 0); // When this has finished there may well be other tasks running. PLocker lock(&stackLock); marker->active = false; nInUse--; } // This class just allows us to use ScanAddress::ScanAddressesInRegion to call // ScanAddressesInObject for each object in the region. class Rescanner: public ScanAddress { public: Rescanner(MTGCProcessMarkPointers *marker): m_marker(marker) {} virtual void ScanAddressesInObject(PolyObject *obj, POLYUNSIGNED lengthWord) { // If it has previously been marked it is known to be reachable but // the contents may not have been scanned if the stack overflowed. if (lengthWord &_OBJ_GC_MARK) m_marker->ScanAddressesInObject(obj, lengthWord); } // Have to define this. virtual PolyObject *ScanObjectAddress(PolyObject *base) { ASSERT(false); return 0; } virtual POLYUNSIGNED ScanCodeAddressAt(PolyObject **pt) { ASSERT(false); return 0; } bool ScanSpace(MarkableSpace *space); private: MTGCProcessMarkPointers *m_marker; }; // Rescan any marked objects in the area between fullGCRescanStart and fullGCRescanEnd. // N.B. We may have threads already processing other areas and they could overflow // their stacks and change fullGCRescanStart or fullGCRescanEnd. bool Rescanner::ScanSpace(MarkableSpace *space) { PolyWord *start, *end; { PLocker lock(&space->spaceLock); start = space->fullGCRescanStart; end = space->fullGCRescanEnd; space->fullGCRescanStart = space->top; space->fullGCRescanEnd = space->bottom; } if (start < end) { if (debugOptions & DEBUG_GC_ENHANCED) Log("GC: Mark: Rescanning from %p to %p\n", start, end); ScanAddressesInRegion(start, end); return true; // Require rescan } else return false; } // When the threads created by marking the roots have completed we need to check that // the mark stack has not overflowed. If it has we need to rescan. This rescanning // pass may result in a further overflow so if we find we have to rescan we repeat. bool MTGCProcessMarkPointers::RescanForStackOverflow() { ASSERT(nThreads >= 1); ASSERT(nInUse == 0); MTGCProcessMarkPointers *marker = &markStacks[0]; marker->Reset(); marker->active = true; nInUse = 1; bool rescan = false; Rescanner rescanner(marker); for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { if (rescanner.ScanSpace(*i)) rescan = true; } for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { if (rescanner.ScanSpace(*i)) rescan = true; } { PLocker lock(&stackLock); nInUse--; marker->active = false; } return rescan; } static void SetBitmaps(LocalMemSpace *space, PolyWord *pt, PolyWord *top) { while (pt < top) { #ifdef POLYML32IN64 if ((((uintptr_t)pt) & 4) == 0) { pt++; continue; } #endif PolyObject *obj = (PolyObject*)++pt; // If it has been copied by a minor collection skip it if (obj->ContainsForwardingPtr()) { obj = FollowForwarding(obj); ASSERT(obj->ContainsNormalLengthWord()); pt += obj->Length(); } else { POLYUNSIGNED L = obj->LengthWord(); POLYUNSIGNED n = OBJ_OBJECT_LENGTH(L); if (L & _OBJ_GC_MARK) { obj->SetLengthWord(L & ~(_OBJ_GC_MARK)); uintptr_t bitno = space->wordNo(pt); space->bitmap.SetBits(bitno - 1, n + 1); if (OBJ_IS_MUTABLE_OBJECT(L)) space->m_marked += n + 1; else space->i_marked += n + 1; if ((PolyWord*)obj <= space->fullGCLowerLimit) space->fullGCLowerLimit = (PolyWord*)obj-1; if (OBJ_IS_WEAKREF_OBJECT(L)) { // Add this to the limits for the containing area. PolyWord *baseAddr = (PolyWord*)obj; PolyWord *startAddr = baseAddr-1; // Must point AT length word. PolyWord *endObject = baseAddr + n; if (startAddr < space->lowestWeak) space->lowestWeak = startAddr; if (endObject > space->highestWeak) space->highestWeak = endObject; } } pt += n; } } } static void CreateBitmapsTask(GCTaskId *, void *arg1, void *arg2) { LocalMemSpace *lSpace = (LocalMemSpace *)arg1; lSpace->bitmap.ClearBits(0, lSpace->spaceSize()); SetBitmaps(lSpace, lSpace->bottom, lSpace->top); } // Parallel task to check the marks on cells in the code area and // turn them into byte areas if they are free. static void CheckMarksOnCodeTask(GCTaskId *, void *arg1, void *arg2) { CodeSpace *space = (CodeSpace*)arg1; #ifdef POLYML32IN64 PolyWord *pt = space->bottom+1; #else PolyWord *pt = space->bottom; #endif PolyWord *lastFree = 0; POLYUNSIGNED lastFreeSpace = 0; space->largestFree = 0; space->firstFree = 0; while (pt < space->top) { PolyObject *obj = (PolyObject*)(pt+1); // There should not be forwarding pointers ASSERT(obj->ContainsNormalLengthWord()); POLYUNSIGNED L = obj->LengthWord(); POLYUNSIGNED length = OBJ_OBJECT_LENGTH(L); if (L & _OBJ_GC_MARK) { // It's marked - retain it. ASSERT(L & _OBJ_CODE_OBJ); - obj->SetLengthWord(L & ~(_OBJ_GC_MARK)); // Clear the mark bit + space->writeAble(obj)->SetLengthWord(L & ~(_OBJ_GC_MARK)); // Clear the mark bit lastFree = 0; lastFreeSpace = 0; } #ifdef POLYML32IN64 else if (length == 0) { // We may have zero filler words to set the correct alignment. // Merge them into a previously free area otherwise leave // them if they're after something allocated. if (lastFree + lastFreeSpace == pt) { lastFreeSpace += length + 1; PolyObject *freeSpace = (PolyObject*)(lastFree + 1); - freeSpace->SetLengthWord(lastFreeSpace - 1, F_BYTE_OBJ); + space->writeAble(freeSpace)->SetLengthWord(lastFreeSpace - 1, F_BYTE_OBJ); } } #endif else { // Turn it into a byte area i.e. free. It may already be free. if (space->firstFree == 0) space->firstFree = pt; space->headerMap.ClearBit(pt-space->bottom); // Remove the "header" bit if (lastFree + lastFreeSpace == pt) // Merge free spaces. Speeds up subsequent scans. lastFreeSpace += length + 1; else { lastFree = pt; lastFreeSpace = length + 1; } PolyObject *freeSpace = (PolyObject*)(lastFree+1); - freeSpace->SetLengthWord(lastFreeSpace-1, F_BYTE_OBJ); + space->writeAble(freeSpace)->SetLengthWord(lastFreeSpace-1, F_BYTE_OBJ); if (lastFreeSpace > space->largestFree) space->largestFree = lastFreeSpace; } pt += length+1; } } void GCMarkPhase(void) { mainThreadPhase = MTP_GCPHASEMARK; // Clear the mark counters and set the rescan limits. for(std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *lSpace = *i; lSpace->i_marked = lSpace->m_marked = 0; lSpace->fullGCRescanStart = lSpace->top; lSpace->fullGCRescanEnd = lSpace->bottom; } for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { CodeSpace *space = *i; space->fullGCRescanStart = space->top; space->fullGCRescanEnd = space->bottom; } MTGCProcessMarkPointers::MarkRoots(); gpTaskFarm->WaitForCompletion(); // Do we have to rescan because the mark stack overflowed? bool rescan; do { rescan = MTGCProcessMarkPointers::RescanForStackOverflow(); gpTaskFarm->WaitForCompletion(); } while(rescan); gHeapSizeParameters.RecordGCTime(HeapSizeParameters::GCTimeIntermediate, "Mark"); // Turn the marks into bitmap entries. for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) gpTaskFarm->AddWorkOrRunNow(&CreateBitmapsTask, *i, 0); // Process the code areas. for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) gpTaskFarm->AddWorkOrRunNow(&CheckMarksOnCodeTask, *i, 0); gpTaskFarm->WaitForCompletion(); // Wait for completion of the bitmaps gMem.RemoveEmptyCodeAreas(); gHeapSizeParameters.RecordGCTime(HeapSizeParameters::GCTimeIntermediate, "Bitmap"); uintptr_t totalLive = 0; for(std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *lSpace = *i; if (! lSpace->isMutable) ASSERT(lSpace->m_marked == 0); totalLive += lSpace->m_marked + lSpace->i_marked; if (debugOptions & DEBUG_GC_ENHANCED) Log("GC: Mark: %s space %p: %" POLYUFMT " immutable words marked, %" POLYUFMT " mutable words marked\n", lSpace->spaceTypeString(), lSpace, lSpace->i_marked, lSpace->m_marked); } if (debugOptions & DEBUG_GC) Log("GC: Mark: Total live data %" POLYUFMT " words\n", totalLive); } // Set up the stacks. void initialiseMarkerTables() { unsigned threads = gpTaskFarm->ThreadCount(); if (threads == 0) threads = 1; MTGCProcessMarkPointers::InitStatics(threads); } diff --git a/libpolyml/gc_progress.cpp b/libpolyml/gc_progress.cpp new file mode 100644 index 00000000..1e7f779f --- /dev/null +++ b/libpolyml/gc_progress.cpp @@ -0,0 +1,74 @@ +/* + Title: gc_progress.cpp - Garbage collection progress data + + Copyright (c) 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 "statistics.h" +#include "gc_progress.h" + +// These values are coded in Statistics.ML +enum { + GCP_ML = 0, // In ML Code + GCP_MINOR, // In minor GC + GCP_MAJOR, // In major GC + GCP_SHARING, // In GC Sharing pass + GCP_OTHER // In something else that suspends ML e.g. shareCommonData +}; + + +void gcProgressReturnToML() +{ + globalStats.setCount(PSC_GC_STATE, GCP_ML); + globalStats.setCount(PSC_GC_PERCENT, 0); +} + +void gcProgressBeginMinorGC() +{ + globalStats.setCount(PSC_GC_STATE, GCP_MINOR); + globalStats.setCount(PSC_GC_PERCENT, 0); +} + +void gcProgressBeginMajorGC() +{ + globalStats.setCount(PSC_GC_STATE, GCP_MAJOR); + globalStats.setCount(PSC_GC_PERCENT, 0); +} + +void gcProgressBeginSharingGC() +{ + globalStats.setCount(PSC_GC_STATE, GCP_SHARING); + globalStats.setCount(PSC_GC_PERCENT, 0); +} + +void gcProgressBeginOtherGC() +{ + globalStats.setCount(PSC_GC_STATE, GCP_OTHER); + globalStats.setCount(PSC_GC_PERCENT, 0); +} + +void gcProgressSetPercent(unsigned pc) +{ + globalStats.setCount(PSC_GC_PERCENT, pc); +} diff --git a/mlsource/MLCompiler/CompilerVersion.sml b/libpolyml/gc_progress.h similarity index 62% copy from mlsource/MLCompiler/CompilerVersion.sml copy to libpolyml/gc_progress.h index 0935d07c..8a42f3c6 100644 --- a/mlsource/MLCompiler/CompilerVersion.sml +++ b/libpolyml/gc_progress.h @@ -1,23 +1,32 @@ -(* - Copyright (c) 2007-20 David C.J. Matthews +/* + Title: gc_progress.h - Garbage collector progress data + + Copyright (c) 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 CompilerVersion = -struct - val compilerVersion = "5.8.1 Release" - val versionNumber = 581 - val versionSuffix = Int.toString versionNumber -end; + +*/ + +#ifndef GC_PROGRESS_H_INCLUDED +#define GC_PROGRESS_H_INCLUDED + +extern void gcProgressReturnToML(); +extern void gcProgressBeginMinorGC(); +extern void gcProgressBeginMajorGC(); +extern void gcProgressBeginSharingGC(); +extern void gcProgressBeginOtherGC(); +void gcProgressSetPercent(unsigned pc); + +#endif + diff --git a/libpolyml/gc_share_phase.cpp b/libpolyml/gc_share_phase.cpp index d1ddabad..a56a1f92 100644 --- a/libpolyml/gc_share_phase.cpp +++ b/libpolyml/gc_share_phase.cpp @@ -1,987 +1,991 @@ /* 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" +#include "gc_progress.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 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); + gcProgressSetPercent((unsigned)((double)(totalVisited - postCount) / (double)totalVisited * 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; + gcProgressBeginSharingGC(); 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/interpret.cpp b/libpolyml/interpret.cpp index f56b1531..f9c0fd51 100644 --- a/libpolyml/interpret.cpp +++ b/libpolyml/interpret.cpp @@ -1,2331 +1,2334 @@ /* Title: An interpreter for a compact instruction set. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000-7 Cambridge University Technical Services Limited - Further development Copyright David C.J. Matthews 2015-18. + Further development Copyright David C.J. Matthews 2015-18, 2020. 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_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_FLOAT_H #include #endif #ifdef HAVE_MATH_H #include #endif #include // Currently just for isnan. #include "globals.h" #include "int_opcodes.h" #include "machine_dep.h" #include "sys.h" #include "profiling.h" #include "arb.h" #include "reals.h" #include "processes.h" #include "run_time.h" #include "gc.h" #include "diagnostics.h" #include "polystring.h" #include "save_vec.h" #include "memmgr.h" #include "scanaddrs.h" #if (SIZEOF_VOIDP == 8) #define IS64BITS 1 #endif #define arg1 (pc[0] + pc[1]*256) #define arg2 (pc[2] + pc[3]*256) const PolyWord True = TAGGED(1); const PolyWord False = TAGGED(0); const PolyWord Zero = TAGGED(0); #define CHECKED_REGS 2 #define UNCHECKED_REGS 0 #define EXTRA_STACK 0 // Don't need any extra - signals aren't handled on the Poly stack. /* 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) plus whatever we require for the register save area. We actually reserve slightly more than this. SPF 3/3/97 */ #define OVERFLOW_STACK_SIZE \ (50 + \ CHECKED_REGS + \ UNCHECKED_REGS + \ EXTRA_STACK) // 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)) // 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; }; class IntTaskData: public TaskData { public: IntTaskData(): interrupt_requested(false), overflowPacket(0), dividePacket(0) {} virtual void GarbageCollect(ScanAddress *process); void ScanStackAddress(ScanAddress *process, PolyWord &val, StackSpace *stack); virtual Handle EnterPolyCode(); // Start running ML // Switch to Poly and return with the io function to call. int SwitchToPoly(); virtual void SetException(poly_exn *exc); virtual void InterruptCode(); // AddTimeProfileCount is used in time profiling. virtual bool AddTimeProfileCount(SIGNALCONTEXT *context); virtual void InitStackFrame(TaskData *newTask, Handle proc, Handle arg); // These aren't implemented in the interpreted version. virtual Handle EnterCallbackFunction(Handle func, Handle args) { ASSERT(0); return 0; } // Increment or decrement the first word of the object pointed to by the // mutex argument and return the new value. virtual Handle AtomicIncrement(Handle mutexp); // Set a mutex to one. virtual void AtomicReset(Handle mutexp); // Return the minimum space occupied by the stack. Used when setting a limit. virtual uintptr_t currentStackSpace(void) const { return (this->stack->top - this->taskSp) + OVERFLOW_STACK_SIZE; } virtual void addProfileCount(POLYUNSIGNED words) { add_count(this, taskPc, words); } virtual void CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length); bool interrupt_requested; // Allocate memory on the heap. Returns with the address of the cell. Does not set the // length word or any of the data. PolyObject *allocateMemory(POLYUNSIGNED words, POLYCODEPTR &pc, PolyWord *&sp) { words++; // Add the size of the length word. // N.B. The allocation area may be empty so that both of these are zero. if (this->allocPointer >= this->allocLimit + words) { this->allocPointer -= words; return (PolyObject *)(this->allocPointer+1); } // Insufficient space. SaveInterpreterState(pc, sp); // Find some space to allocate in. Returns a pointer to the newly allocated space. // N.B. This may return zero if the heap is exhausted and it has set this // up for an exception. Generally it allocates by decrementing allocPointer // but if the required memory is large it may allocate in a separate area. PolyWord *space = processes->FindAllocationSpace(this, words, true); LoadInterpreterState(pc, sp); if (space == 0) return 0; return (PolyObject *)(space+1); } // Put a real result in a "box" PolyObject *boxDouble(double d, POLYCODEPTR &pc, PolyWord *&sp) { PolyObject *mem = this->allocateMemory(DOUBLESIZE, pc, sp); if (mem == 0) return 0; mem->SetLengthWord(DOUBLESIZE, F_BYTE_OBJ); union realdb uniondb; uniondb.dble = d; // Copy the words. Depending on the word length this may copy one or more words. for (unsigned i = 0; i < DOUBLESIZE; i++) mem->Set(i, PolyWord::FromUnsigned(uniondb.puns[i])); return mem; } // Extract a double value from a box. double unboxDouble(PolyWord p) { union realdb uniondb; for (unsigned i = 0; i < DOUBLESIZE; i++) uniondb.puns[i] = p.AsObjPtr()->Get(i).AsUnsigned(); return uniondb.dble; } // Largely copied from reals.cpp #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 unboxFloat(PolyWord p) { union flt argx; argx.i = p.AsSigned() >> FLT_SHIFT; return argx.fl; } PolyObject *boxFloat(float f, POLYCODEPTR &pc, PolyWord *&sp) { union flt argx; argx.fl = f; PolyWord p = PolyWord::FromSigned(((POLYSIGNED)argx.i << FLT_SHIFT) + 1); return p.AsObjPtr(); // Temporarily cast it to this even though it isn't really } #else // Typically for 32-bit mode. Use a boxed representation. PolyObject *boxFloat(float f, POLYCODEPTR &pc, PolyWord *&sp) { PolyObject *mem = this->allocateMemory(1, pc, sp); if (mem == 0) return 0; mem->SetLengthWord(1, F_BYTE_OBJ); union flt argx; argx.fl = f; mem->Set(0, PolyWord::FromSigned(argx.i)); return mem; } // Extract a double value from a box. float unboxFloat(PolyWord p) { union flt argx; argx.i = (int32_t)p.AsObjPtr()->Get(0).AsSigned(); return argx.fl; } #endif // Update the copies in the task object void SaveInterpreterState(POLYCODEPTR pc, PolyWord *sp) { taskPc = pc; taskSp = sp; } // Update the local state void LoadInterpreterState(POLYCODEPTR &pc, PolyWord *&sp) { pc = taskPc; sp = taskSp; } POLYCODEPTR taskPc; /* Program counter. */ PolyWord *taskSp; /* Stack pointer. */ PolyWord *hr; PolyWord exception_arg; bool raiseException; PolyWord *sl; /* Stack limit register. */ PolyObject *overflowPacket, *dividePacket; }; // This lock is used to synchronise all atomic operations. // It is not needed in the X86 version because that can use a global // memory lock. static PLock mutexLock; // Special value for return address. #define SPECIAL_PC_END_THREAD TAGGED(1) class Interpreter : public MachineDependent { public: Interpreter() {} // Create a task data object. virtual TaskData *CreateTaskData(void) { return new IntTaskData(); } virtual Architectures MachineArchitecture(void) { return MA_Interpreted; } + // The interpreted version does not need the code to have execute + // permission because it's not actually executed. + virtual bool CodeMustBeExecutable(void) { return false; } }; void IntTaskData::InitStackFrame(TaskData *parentTask, Handle proc, Handle arg) /* Initialise stack frame. */ { StackSpace *space = this->stack; StackObject *stack = (StackObject *)space->stack(); PolyObject *closure = DEREFWORDHANDLE(proc); uintptr_t stack_size = space->spaceSize(); this->taskPc = closure->Get(0).AsCodePtr(); this->exception_arg = TAGGED(0); /* Used for exception argument. */ this->taskSp = (PolyWord*)stack + stack_size; this->raiseException = false; /* Set up exception handler */ /* No previous handler so point it at itself. */ this->taskSp--; *(this->taskSp) = PolyWord::FromStackAddr(this->taskSp); *(--this->taskSp) = SPECIAL_PC_END_THREAD; /* Default return address. */ this->hr = this->taskSp; /* If this function takes an argument store it on the stack. */ if (arg != 0) *(--this->taskSp) = DEREFWORD(arg); *(--this->taskSp) = SPECIAL_PC_END_THREAD; /* Return address. */ *(--this->taskSp) = closure; /* Closure address */ // Make packets for exceptions. overflowPacket = makeExceptionPacket(parentTask, EXC_overflow); dividePacket = makeExceptionPacket(parentTask, EXC_divide); } extern "C" { typedef POLYUNSIGNED(*callFastRts0)(); typedef POLYUNSIGNED(*callFastRts1)(intptr_t); typedef POLYUNSIGNED(*callFastRts2)(intptr_t, intptr_t); typedef POLYUNSIGNED(*callFastRts3)(intptr_t, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFastRts4)(intptr_t, intptr_t, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFastRts5)(intptr_t, intptr_t, intptr_t, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFullRts0)(PolyObject *); typedef POLYUNSIGNED(*callFullRts1)(PolyObject *, intptr_t); typedef POLYUNSIGNED(*callFullRts2)(PolyObject *, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFullRts3)(PolyObject *, intptr_t, intptr_t, intptr_t); typedef double (*callRTSRtoR) (double); typedef double (*callRTSRRtoR) (double, double); typedef double (*callRTSGtoR) (intptr_t); typedef double (*callRTSRGtoR) (double, intptr_t); typedef float(*callRTSFtoF) (float); typedef float(*callRTSFFtoF) (float, float); typedef float(*callRTSGtoF) (intptr_t); typedef float(*callRTSFGtoF) (float, intptr_t); } void IntTaskData::InterruptCode() /* Stop the Poly code at a suitable place. */ /* We may get an asynchronous interrupt at any time. */ { IntTaskData *itd = (IntTaskData *)this; itd->interrupt_requested = true; } void IntTaskData::SetException(poly_exn *exc) /* Set up the stack of a process to raise an exception. */ { this->raiseException = true; *(--this->taskSp) = (PolyWord)exc; /* push exception data */ } int IntTaskData::SwitchToPoly() /* (Re)-enter the Poly code from C. */ { // These are temporary values used where one instruction jumps to // common code. POLYUNSIGNED tailCount; PolyWord *tailPtr; POLYUNSIGNED returnCount; POLYUNSIGNED storeWords; POLYUNSIGNED stackCheck; // Local values. These are copies of member variables but are used so frequently that // it is important that access should be fast. POLYCODEPTR pc; PolyWord *sp; double dv; LoadInterpreterState(pc, sp); sl = (PolyWord*)this->stack->stack() + OVERFLOW_STACK_SIZE; // We may have taken an interrupt which has set an exception. if (this->raiseException) goto RAISE_EXCEPTION; for(;;){ /* Each instruction */ // char buff[1000]; // sprintf(buff, "addr = %p sp=%p instr=%02x *sp=%p\n", pc, sp, *pc, (*sp).AsStackAddr()); // OutputDebugStringA(buff); switch(*pc++) { case INSTR_enter_int: pc++; /* Skip the argument. */ break; case INSTR_jump8false: { PolyWord u = *sp++; /* Pop argument */ if (u == True) { pc += 1; break; } /* else - false - take the jump */ } case INSTR_jump8: pc += *pc + 1; break; case INSTR_jump16false: { PolyWord u = *sp++; /* Pop argument */ if (u == True) { pc += 2; break; } /* else - false - take the jump */ } case INSTR_jump16: pc += arg1 + 2; break; case INSTR_jump32False: { PolyWord u = *sp++; /* Pop argument */ if (u == True) { pc += 4; break; } /* else - false - take the jump */ } case INSTR_jump32: { // This is a 32-bit signed quantity on both 64-bits and 32-bits. POLYSIGNED offset = pc[3] & 0x80 ? -1 : 0; offset = (offset << 8) | pc[3]; offset = (offset << 8) | pc[2]; offset = (offset << 8) | pc[1]; offset = (offset << 8) | pc[0]; pc += offset + 4; break; } case INSTR_push_handler: /* Save the old handler value. */ *(--sp) = PolyWord::FromStackAddr(this->hr); /* Push old handler */ break; case INSTR_setHandler8: /* Set up a handler */ *(--sp) = PolyWord::FromCodePtr(pc + *pc + 1); /* Address of handler */ this->hr = sp; pc += 1; break; case INSTR_setHandler16: /* Set up a handler */ *(--sp) = PolyWord::FromCodePtr(pc + arg1 + 2); /* Address of handler */ this->hr = sp; pc += 2; break; case INSTR_setHandler32: /* Set up a handler */ { POLYUNSIGNED offset = pc[0] + (pc[1] << 8) + (pc[2] << 16) + (pc[3] << 24); *(--sp) = PolyWord::FromCodePtr(pc + offset + 4); /* Address of handler */ this->hr = sp; pc += 4; break; } case INSTR_deleteHandler: /* Delete handler retaining the result. */ { PolyWord u = *sp++; sp = this->hr; sp++; // Remove handler entry point this->hr = (*sp).AsStackAddr(); // Restore old handler *sp = u; // Put back the result break; } case INSTR_case16: { // arg1 is the largest value that is in the range POLYSIGNED u = UNTAGGED(*sp++); /* Get the value */ if (u > arg1 || u < 0) pc += (arg1+2)*2; /* Out of range */ else { pc += 2; pc += /* Index */pc[u*2]+pc[u*2 + 1]*256; } break; } case INSTR_case32: { // arg1 is the number of cases i.e. one more than the largest value // This is followed by that number of 32-bit offsets. // If the value is out of range the default case is immediately after the table. POLYSIGNED u = UNTAGGED(*sp++); /* Get the value */ if (u >= arg1 || u < 0) pc += 2 + arg1 * 4; /* Out of range */ else { pc += 2; pc += /* Index */pc[u*4] + (pc[u*4+1] << 8) + (pc[u*4+2] << 16) + (pc[u*4+3] << 24); } break; } case INSTR_tail_3_b: tailCount = 3; tailPtr = sp + tailCount; sp = tailPtr + *pc; goto TAIL_CALL; case INSTR_tail_3_2: tailCount = 3; tailPtr = sp + tailCount; sp = tailPtr + 2; goto TAIL_CALL; case INSTR_tail_3_3: tailCount = 3; tailPtr = sp + tailCount; sp = tailPtr + 3; goto TAIL_CALL; case INSTR_tail_4_b: tailCount = 4; tailPtr = sp + tailCount; sp = tailPtr + *pc; goto TAIL_CALL; case INSTR_tail_b_b: tailCount = *pc; tailPtr = sp + tailCount; sp = tailPtr + pc[1]; goto TAIL_CALL; case INSTR_tail: /* Tail recursive call. */ /* Move items up the stack. */ /* There may be an overlap if the function we are calling has more args than this one. */ tailCount = arg1; tailPtr = sp + tailCount; sp = tailPtr + arg2; TAIL_CALL: /* For general case. */ if (tailCount < 2) Crash("Invalid argument\n"); for (; tailCount > 0; tailCount--) *(--sp) = *(--tailPtr); pc = (*sp++).AsCodePtr(); /* Pop the original return address. */ /* And drop through. */ case INSTR_call_closure: /* Closure call. */ { POLYCODEPTR newPc = (*sp).AsObjPtr()->Get(0).AsCodePtr(); sp--; *sp = sp[1]; /* Move closure up. */ sp[1] = PolyWord::FromCodePtr(pc); /* Save return address. */ pc = newPc; /* Get entry point. */ this->taskPc = pc; // Update in case we're profiling break; } case INSTR_return_w: returnCount = arg1; /* Get no. of args to remove. */ RETURN: /* Common code for return. */ { PolyWord result = *sp++; /* Result */ sp++; /* Remove the link/closure */ pc = (*sp++).AsCodePtr(); /* Return address */ sp += returnCount; /* Add on number of args. */ if (pc == SPECIAL_PC_END_THREAD.AsCodePtr()) exitThread(this); // This thread is exiting. *(--sp) = result; /* Result */ this->taskPc = pc; // Update in case we're profiling } break; case INSTR_return_b: returnCount = *pc; goto RETURN; case INSTR_return_0: returnCount = 0; goto RETURN; case INSTR_return_1: returnCount = 1; goto RETURN; case INSTR_return_2: returnCount = 2; goto RETURN; case INSTR_return_3: returnCount = 3; goto RETURN; case INSTR_stackSize8: stackCheck = *pc++; goto STACKCHECK; case INSTR_stackSize16: { stackCheck = arg1; pc += 2; STACKCHECK: // Check there is space on the stack if (sp - stackCheck < sl) { uintptr_t min_size = (this->stack->top - (PolyWord*)sp) + OVERFLOW_STACK_SIZE + stackCheck; SaveInterpreterState(pc, sp); CheckAndGrowStack(this, min_size); LoadInterpreterState(pc, sp); sl = (PolyWord*)this->stack->stack() + OVERFLOW_STACK_SIZE; } // Also check for interrupts if (this->interrupt_requested) { // Check for interrupts this->interrupt_requested = false; SaveInterpreterState(pc, sp); return -1; } break; } case INSTR_pad: /* No-op */ break; case INSTR_raise_ex: { RAISE_EXCEPTION: this->raiseException = false; PolyException *exn = (PolyException*)((*sp).AsObjPtr()); this->exception_arg = exn; /* Get exception data */ sp = this->hr; if (*sp == SPECIAL_PC_END_THREAD) exitThread(this); // Default handler for thread. pc = (*sp++).AsCodePtr(); this->hr = (*sp++).AsStackAddr(); break; } case INSTR_get_store_w: // Get_store is now only used for mutually recursive closures. It allocates mutable store // initialised to zero. { storeWords = arg1; pc += 2; GET_STORE: PolyObject *p = this->allocateMemory(storeWords, pc, sp); if (p == 0) goto RAISE_EXCEPTION; p->SetLengthWord(storeWords, F_MUTABLE_BIT); for(; storeWords > 0; ) p->Set(--storeWords, TAGGED(0)); /* Must initialise store! */ *(--sp) = (PolyWord)p; break; } case INSTR_get_store_2: storeWords = 2; goto GET_STORE; case INSTR_get_store_3: storeWords = 3; goto GET_STORE; case INSTR_get_store_4: storeWords = 4; goto GET_STORE; case INSTR_get_store_b: storeWords = *pc; pc++; goto GET_STORE; case INSTR_tuple_w: { storeWords = arg1; pc += 2; TUPLE: /* Common code for tupling. */ PolyObject *p = this->allocateMemory(storeWords, pc, sp); if (p == 0) goto RAISE_EXCEPTION; // Exception p->SetLengthWord(storeWords, 0); for(; storeWords > 0; ) p->Set(--storeWords, *sp++); *(--sp) = (PolyWord)p; break; } case INSTR_tuple_2: storeWords = 2; goto TUPLE; case INSTR_tuple_3: storeWords = 3; goto TUPLE; case INSTR_tuple_4: storeWords = 4; goto TUPLE; case INSTR_tuple_b: storeWords = *pc; pc++; goto TUPLE; case INSTR_local_w: { PolyWord u = sp[arg1]; *(--sp) = u; pc += 2; break; } case INSTR_indirect_w: *sp = (*sp).AsObjPtr()->Get(arg1); pc += 2; break; case INSTR_move_to_vec_w: { PolyWord u = *sp++; (*sp).AsObjPtr()->Set(arg1, u); pc += 2; break; } case INSTR_set_stack_val_w: { PolyWord u = *sp++; sp[arg1-1] = u; pc += 2; break; } case INSTR_reset_w: sp += arg1; pc += 2; break; case INSTR_reset_r_w: { PolyWord u = *sp; sp += arg1; *sp = u; pc += 2; break; } case INSTR_constAddr8: *(--sp) = *(PolyWord*)(pc + pc[0] + 1); pc += 1; break; case INSTR_constAddr16: *(--sp) = *(PolyWord*)(pc + arg1 + 2); pc += 2; break; case INSTR_constAddr32: { POLYUNSIGNED offset = pc[0] + (pc[1] << 8) + (pc[2] << 16) + (pc[3] << 24); *(--sp) = *(PolyWord*)(pc + offset + 4); pc += 4; break; } case INSTR_const_int_w: *(--sp) = TAGGED(arg1); pc += 2; break; case INSTR_jump_back8: pc -= *pc + 1; if (this->interrupt_requested) { // Check for interrupt in case we're in a loop this->interrupt_requested = false; SaveInterpreterState(pc, sp); return -1; } break; case INSTR_jump_back16: pc -= arg1 + 1; if (this->interrupt_requested) { // Check for interrupt in case we're in a loop this->interrupt_requested = false; SaveInterpreterState(pc, sp); return -1; } break; case INSTR_lock: { PolyObject *obj = (*sp).AsObjPtr(); obj->SetLengthWord(obj->LengthWord() & ~_OBJ_MUTABLE_BIT); break; } case INSTR_ldexc: *(--sp) = this->exception_arg; break; case INSTR_local_b: { PolyWord u = sp[*pc]; *(--sp) = u; pc += 1; break; } case INSTR_indirect_b: *sp = (*sp).AsObjPtr()->Get(*pc); pc += 1; break; case INSTR_move_to_vec_b: { PolyWord u = *sp++; (*sp).AsObjPtr()->Set(*pc, u); pc += 1; break; } case INSTR_set_stack_val_b: { PolyWord u = *sp++; sp[*pc-1] = u; pc += 1; break; } case INSTR_reset_b: sp += *pc; pc += 1; break; case INSTR_reset_r_b: { PolyWord u = *sp; sp += *pc; *sp = u; pc += 1; break; } case INSTR_const_int_b: *(--sp) = TAGGED(*pc); pc += 1; break; case INSTR_local_0: { PolyWord u = sp[0]; *(--sp) = u; break; } case INSTR_local_1: { PolyWord u = sp[1]; *(--sp) = u; break; } case INSTR_local_2: { PolyWord u = sp[2]; *(--sp) = u; break; } case INSTR_local_3: { PolyWord u = sp[3]; *(--sp) = u; break; } case INSTR_local_4: { PolyWord u = sp[4]; *(--sp) = u; break; } case INSTR_local_5: { PolyWord u = sp[5]; *(--sp) = u; break; } case INSTR_local_6: { PolyWord u = sp[6]; *(--sp) = u; break; } case INSTR_local_7: { PolyWord u = sp[7]; *(--sp) = u; break; } case INSTR_local_8: { PolyWord u = sp[8]; *(--sp) = u; break; } case INSTR_local_9: { PolyWord u = sp[9]; *(--sp) = u; break; } case INSTR_local_10: { PolyWord u = sp[10]; *(--sp) = u; break; } case INSTR_local_11: { PolyWord u = sp[11]; *(--sp) = u; break; } case INSTR_indirect_0: *sp = (*sp).AsObjPtr()->Get(0); break; case INSTR_indirect_1: *sp = (*sp).AsObjPtr()->Get(1); break; case INSTR_indirect_2: *sp = (*sp).AsObjPtr()->Get(2); break; case INSTR_indirect_3: *sp = (*sp).AsObjPtr()->Get(3); break; case INSTR_indirect_4: *sp = (*sp).AsObjPtr()->Get(4); break; case INSTR_indirect_5: *sp = (*sp).AsObjPtr()->Get(5); break; case INSTR_const_0: *(--sp) = Zero; break; case INSTR_const_1: *(--sp) = TAGGED(1); break; case INSTR_const_2: *(--sp) = TAGGED(2); break; case INSTR_const_3: *(--sp) = TAGGED(3); break; case INSTR_const_4: *(--sp) = TAGGED(4); break; case INSTR_const_10: *(--sp) = TAGGED(10); break; case INSTR_reset_r_1: { PolyWord u = *sp; sp += 1; *sp = u; break; } case INSTR_reset_r_2: { PolyWord u = *sp; sp += 2; *sp = u; break; } case INSTR_reset_r_3: { PolyWord u = *sp; sp += 3; *sp = u; break; } case INSTR_reset_1: sp += 1; break; case INSTR_reset_2: sp += 2; break; case INSTR_stack_container: { POLYUNSIGNED words = arg1; pc += 2; while (words-- > 0) *(--sp) = Zero; sp--; *sp = PolyWord::FromStackAddr(sp + 1); break; } case INSTR_tuple_container: /* Create a tuple from a container. */ { storeWords = arg1; PolyObject *t = this->allocateMemory(storeWords, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(storeWords, 0); for(; storeWords > 0; ) { storeWords--; t->Set(storeWords, (*sp).AsObjPtr()->Get(storeWords)); } *sp = t; pc += 2; break; } case INSTR_callFastRTS0: { callFastRts0 doCall = *(callFastRts0*)(*sp++).AsObjPtr(); POLYUNSIGNED result = doCall(); *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS1: { callFastRts1 doCall = *(callFastRts1*)(*sp++).AsObjPtr(); intptr_t rtsArg1 = (*sp++).AsSigned(); POLYUNSIGNED result = doCall(rtsArg1); *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS2: { callFastRts2 doCall = *(callFastRts2*)(*sp++).AsObjPtr(); intptr_t rtsArg2 = (*sp++).AsSigned(); // Pop off the args, last arg first. intptr_t rtsArg1 = (*sp++).AsSigned(); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2); *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS3: { callFastRts3 doCall = *(callFastRts3*)(*sp++).AsObjPtr(); intptr_t rtsArg3 = (*sp++).AsSigned(); // Pop off the args, last arg first. intptr_t rtsArg2 = (*sp++).AsSigned(); intptr_t rtsArg1 = (*sp++).AsSigned(); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3); *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS4: { callFastRts4 doCall = *(callFastRts4*)(*sp++).AsObjPtr(); intptr_t rtsArg4 = (*sp++).AsSigned(); // Pop off the args, last arg first. intptr_t rtsArg3 = (*sp++).AsSigned(); intptr_t rtsArg2 = (*sp++).AsSigned(); intptr_t rtsArg1 = (*sp++).AsSigned(); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3, rtsArg4); *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS5: { callFastRts5 doCall = *(callFastRts5*)(*sp++).AsObjPtr(); intptr_t rtsArg5 = (*sp++).AsSigned(); // Pop off the args, last arg first. intptr_t rtsArg4 = (*sp++).AsSigned(); intptr_t rtsArg3 = (*sp++).AsSigned(); intptr_t rtsArg2 = (*sp++).AsSigned(); intptr_t rtsArg1 = (*sp++).AsSigned(); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3, rtsArg4, rtsArg5); *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFullRTS0: { callFullRts0 doCall = *(callFullRts0*)(*sp++).AsObjPtr(); this->raiseException = false; SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(this->threadObject); LoadInterpreterState(pc, sp); // If this raised an exception if (this->raiseException) goto RAISE_EXCEPTION; *(--sp)= PolyWord::FromUnsigned(result); break; } case INSTR_callFullRTS1: { callFullRts1 doCall = *(callFullRts1*)(*sp++).AsObjPtr(); intptr_t rtsArg1 = (*sp++).AsSigned(); this->raiseException = false; SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(this->threadObject, rtsArg1); LoadInterpreterState(pc, sp); // If this raised an exception if (this->raiseException) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFullRTS2: { callFullRts2 doCall = *(callFullRts2*)(*sp++).AsObjPtr(); intptr_t rtsArg2 = (*sp++).AsSigned(); // Pop off the args, last arg first. intptr_t rtsArg1 = (*sp++).AsSigned(); this->raiseException = false; SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(this->threadObject, rtsArg1, rtsArg2); LoadInterpreterState(pc, sp); // If this raised an exception if (this->raiseException) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFullRTS3: { callFullRts3 doCall = *(callFullRts3*)(*sp++).AsObjPtr(); intptr_t rtsArg3 = (*sp++).AsSigned(); // Pop off the args, last arg first. intptr_t rtsArg2 = (*sp++).AsSigned(); intptr_t rtsArg1 = (*sp++).AsSigned(); this->raiseException = false; SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(this->threadObject, rtsArg1, rtsArg2, rtsArg3); LoadInterpreterState(pc, sp); // If this raised an exception if (this->raiseException) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRtoR: { // Floating point call. The call itself does not allocate but we // need to put the result into a "box". callRTSRtoR doCall = *(callRTSRtoR*)(*sp++).AsObjPtr(); PolyWord rtsArg1 = *sp++; double argument = unboxDouble(rtsArg1); // Allocate memory for the result. double result = doCall(argument); PolyObject *t = boxDouble(result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case INSTR_callFastRRtoR: { // Floating point call. PolyWord rtsCall = (*sp++).AsObjPtr()->Get(0); // Value holds address. PolyWord rtsArg2 = *sp++; PolyWord rtsArg1 = *sp++; callRTSRRtoR doCall = (callRTSRRtoR)rtsCall.AsCodePtr(); double argument1 = unboxDouble(rtsArg1); double argument2 = unboxDouble(rtsArg2); // Allocate memory for the result. double result = doCall(argument1, argument2); PolyObject *t = boxDouble(result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = t; break; } case INSTR_callFastGtoR: { // Call that takes a POLYUNSIGNED argument and returns a double. callRTSGtoR doCall = *(callRTSGtoR*)(*sp++).AsObjPtr(); intptr_t rtsArg1 = (*sp++).AsSigned(); // Allocate memory for the result. double result = doCall(rtsArg1); PolyObject *t = boxDouble(result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case INSTR_callFastRGtoR: { // Call that takes a POLYUNSIGNED argument and returns a double. PolyWord rtsCall = (*sp++).AsObjPtr()->Get(0); // Value holds address. intptr_t rtsArg2 = (*sp++).AsSigned(); PolyWord rtsArg1 = *sp++; callRTSRGtoR doCall = (callRTSRGtoR)rtsCall.AsCodePtr(); double argument1 = unboxDouble(rtsArg1); // Allocate memory for the result. double result = doCall(argument1, rtsArg2); PolyObject *t = boxDouble(result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = t; break; } case INSTR_callFastFtoF: { // Floating point call. The call itself does not allocate but we // need to put the result into a "box". PolyWord rtsCall = (*sp++).AsObjPtr()->Get(0); // Value holds address. PolyWord rtsArg1 = *sp++; callRTSFtoF doCall = (callRTSFtoF)rtsCall.AsCodePtr(); float argument = unboxFloat(rtsArg1); // Allocate memory for the result. float result = doCall(argument); PolyObject *t = boxFloat(result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = t; break; } case INSTR_callFastFFtoF: { // Floating point call. PolyWord rtsCall = (*sp++).AsObjPtr()->Get(0); // Value holds address. PolyWord rtsArg2 = *sp++; PolyWord rtsArg1 = *sp++; callRTSFFtoF doCall = (callRTSFFtoF)rtsCall.AsCodePtr(); float argument1 = unboxFloat(rtsArg1); float argument2 = unboxFloat(rtsArg2); // Allocate memory for the result. float result = doCall(argument1, argument2); PolyObject *t = boxFloat(result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = t; break; } case INSTR_callFastGtoF: { // Call that takes a POLYUNSIGNED argument and returns a double. PolyWord rtsCall = (*sp++).AsObjPtr()->Get(0); // Value holds address. intptr_t rtsArg1 = (*sp++).AsSigned(); callRTSGtoF doCall = (callRTSGtoF)rtsCall.AsCodePtr(); // Allocate memory for the result. float result = doCall(rtsArg1); PolyObject *t = boxFloat(result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = t; break; } case INSTR_callFastFGtoF: { // Call that takes a POLYUNSIGNED argument and returns a double. PolyWord rtsCall = (*sp++).AsObjPtr()->Get(0); // Value holds address. intptr_t rtsArg2 = (*sp++).AsSigned(); PolyWord rtsArg1 = *sp++; callRTSFGtoF doCall = (callRTSFGtoF)rtsCall.AsCodePtr(); float argument1 = unboxFloat(rtsArg1); // Allocate memory for the result. float result = doCall(argument1, rtsArg2); PolyObject *t = boxFloat(result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = t; break; } case INSTR_notBoolean: *sp = ((*sp) == True) ? False : True; break; case INSTR_isTagged: *sp = (*sp).IsTagged() ? True : False; break; case INSTR_cellLength: /* Return the length word. */ *sp = TAGGED((*sp).AsObjPtr()->Length()); break; case INSTR_cellFlags: { PolyObject *p = (*sp).AsObjPtr(); POLYUNSIGNED f = (p->LengthWord()) >> OBJ_PRIVATE_FLAGS_SHIFT; *sp = TAGGED(f); break; } case INSTR_clearMutable: { PolyObject *obj = (*sp).AsObjPtr(); POLYUNSIGNED lengthW = obj->LengthWord(); /* Clear the mutable bit. */ obj->SetLengthWord(lengthW & ~_OBJ_MUTABLE_BIT); *sp = Zero; break; } case INSTR_stringLength: // Now replaced by loadUntagged *sp = TAGGED(((PolyStringObject*)(*sp).AsObjPtr())->length); break; case INSTR_atomicIncr: { PLocker l(&mutexLock); PolyObject *p = (*sp).AsObjPtr(); PolyWord newValue = TAGGED(UNTAGGED(p->Get(0))+1); p->Set(0, newValue); *sp = newValue; break; } case INSTR_atomicDecr: { PLocker l(&mutexLock); PolyObject *p = (*sp).AsObjPtr(); PolyWord newValue = TAGGED(UNTAGGED(p->Get(0))-1); p->Set(0, newValue); *sp = newValue; break; } case INSTR_atomicReset: { // This is needed in the interpreted version otherwise there // is a chance that we could set the value to zero while another // thread is between getting the old value and setting it to the new value. PLocker l(&mutexLock); PolyObject *p = (*sp).AsObjPtr(); p->Set(0, TAGGED(1)); // Set this to released. *sp = TAGGED(0); // Push the unit result break; } case INSTR_longWToTagged: { // Extract the first word and return it as a tagged value. This loses the top-bit POLYUNSIGNED wx = (*sp).AsObjPtr()->Get(0).AsUnsigned(); *sp = TAGGED(wx); break; } case INSTR_signedToLongW: { // Shift the tagged value to remove the tag and put it into the first word. // The original sign bit is copied in the shift. intptr_t wx = (*sp).UnTagged(); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(intptr_t*)t = wx; *sp = (PolyWord)t; break; } case INSTR_unsignedToLongW: { // As with the above except the value is treated as an unsigned // value and the top bit is zero. uintptr_t wx = (*sp).UnTaggedUnsigned(); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wx; *sp = (PolyWord)t; break; } case INSTR_realAbs: { PolyObject *t = this->boxDouble(fabs(unboxDouble(*sp)), pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_realNeg: { PolyObject *t = this->boxDouble(-(unboxDouble(*sp)), pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_floatAbs: { PolyObject *t = this->boxFloat(fabs(unboxFloat(*sp)), pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_floatNeg: { PolyObject *t = this->boxFloat(-(unboxFloat(*sp)), pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_fixedIntToReal: { POLYSIGNED u = UNTAGGED(*sp); PolyObject *t = this->boxDouble((double)u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_fixedIntToFloat: { POLYSIGNED u = UNTAGGED(*sp); PolyObject *t = this->boxFloat((float)u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_floatToReal: { float u = unboxFloat(*sp); PolyObject *t = this->boxDouble((double)u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_equalWord: { PolyWord u = *sp++; *sp = u == (*sp) ? True : False; break; } case INSTR_lessSigned: { PolyWord u = *sp++; *sp = ((*sp).AsSigned() < u.AsSigned()) ? True : False; break; } case INSTR_lessUnsigned: { PolyWord u = *sp++; *sp = ((*sp).AsUnsigned() < u.AsUnsigned()) ? True : False; break; } case INSTR_lessEqSigned: { PolyWord u = *sp++; *sp = ((*sp).AsSigned() <= u.AsSigned()) ? True : False; break; } case INSTR_lessEqUnsigned: { PolyWord u = *sp++; *sp = ((*sp).AsUnsigned() <= u.AsUnsigned()) ? True : False; break; } case INSTR_greaterSigned: { PolyWord u = *sp++; *sp = ((*sp).AsSigned() > u.AsSigned()) ? True : False; break; } case INSTR_greaterUnsigned: { PolyWord u = *sp++; *sp = ((*sp).AsUnsigned() > u.AsUnsigned()) ? True : False; break; } case INSTR_greaterEqSigned: { PolyWord u = *sp++; *sp = ((*sp).AsSigned() >= u.AsSigned()) ? True : False; break; } case INSTR_greaterEqUnsigned: { PolyWord u = *sp++; *sp = ((*sp).AsUnsigned() >= u.AsUnsigned()) ? True : False; break; } case INSTR_fixedAdd: { PolyWord x = *sp++; PolyWord y = (*sp); POLYSIGNED t = UNTAGGED(x) + UNTAGGED(y); if (t <= MAXTAGGED && t >= -MAXTAGGED-1) *sp = TAGGED(t); else { *(--sp) = (PolyWord)overflowPacket; goto RAISE_EXCEPTION; } break; } case INSTR_fixedSub: { PolyWord x = *sp++; PolyWord y = (*sp); POLYSIGNED t = UNTAGGED(y) - UNTAGGED(x); if (t <= MAXTAGGED && t >= -MAXTAGGED-1) *sp = TAGGED(t); else { *(--sp) = (PolyWord)overflowPacket; goto RAISE_EXCEPTION; } break; } case INSTR_fixedMult: { POLYSIGNED x = UNTAGGED(*sp++); POLYSIGNED y = (*sp).AsSigned() - 1; // Just remove the tag POLYSIGNED t = x * y; if (x != 0 && t / x != y) { *(--sp) = (PolyWord)overflowPacket; goto RAISE_EXCEPTION; } *sp = PolyWord::FromSigned(t+1); // Add back the tag break; } case INSTR_fixedQuot: { // Zero and overflow are checked for in ML. POLYSIGNED u = UNTAGGED(*sp++); PolyWord y = (*sp); *sp = TAGGED(UNTAGGED(y) / u); break; } case INSTR_fixedRem: { // Zero and overflow are checked for in ML. POLYSIGNED u = UNTAGGED(*sp++); PolyWord y = (*sp); *sp = TAGGED(UNTAGGED(y) % u); break; } case INSTR_wordAdd: { PolyWord u = *sp++; // Because we're not concerned with overflow we can just add the values and subtract the tag. *sp = PolyWord::FromUnsigned((*sp).AsUnsigned() + u.AsUnsigned() - TAGGED(0).AsUnsigned()); break; } case INSTR_wordSub: { PolyWord u = *sp++; *sp = PolyWord::FromUnsigned((*sp).AsUnsigned() - u.AsUnsigned() + TAGGED(0).AsUnsigned()); break; } case INSTR_wordMult: { PolyWord u = *sp++; *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) * UNTAGGED_UNSIGNED(u)); break; } case INSTR_wordDiv: { POLYUNSIGNED u = UNTAGGED_UNSIGNED(*sp++); // Detection of zero is done in ML *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) / u); break; } case INSTR_wordMod: { POLYUNSIGNED u = UNTAGGED_UNSIGNED(*sp++); *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) % u); break; } case INSTR_wordAnd: { PolyWord u = *sp++; // Since both of these should be tagged the tag bit will be preserved. *sp = PolyWord::FromUnsigned((*sp).AsUnsigned() & u.AsUnsigned()); break; } case INSTR_wordOr: { PolyWord u = *sp++; // Since both of these should be tagged the tag bit will be preserved. *sp = PolyWord::FromUnsigned((*sp).AsUnsigned() | u.AsUnsigned()); break; } case INSTR_wordXor: { PolyWord u = *sp++; // This will remove the tag bit so it has to be reinstated. *sp = PolyWord::FromUnsigned(((*sp).AsUnsigned() ^ u.AsUnsigned()) | TAGGED(0).AsUnsigned()); break; } case INSTR_wordShiftLeft: { // ML requires shifts greater than a word to return zero. // That's dealt with at the higher level. PolyWord u = *sp++; *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) << UNTAGGED_UNSIGNED(u)); break; } case INSTR_wordShiftRLog: { PolyWord u = *sp++; *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) >> UNTAGGED_UNSIGNED(u)); break; } case INSTR_wordShiftRArith: { PolyWord u = *sp++; // Strictly speaking, C does not require that this uses // arithmetic shifting so we really ought to set the // high-order bits explicitly. *sp = TAGGED(UNTAGGED(*sp) >> UNTAGGED(u)); break; } case INSTR_allocByteMem: { // Allocate byte segment. This does not need to be initialised. POLYUNSIGNED flags = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp); PolyObject *t = this->allocateMemory(length, pc, sp); if (t == 0) goto RAISE_EXCEPTION; // Exception t->SetLengthWord(length, (byte)flags); *sp = (PolyWord)t; break; } case INSTR_lgWordEqual: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); *sp = wx == wy ? True : False; break; } case INSTR_lgWordLess: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); *sp = (wy < wx) ? True : False; break; } case INSTR_lgWordLessEq: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); *sp = (wy <= wx) ? True : False; break; } case INSTR_lgWordGreater: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); *sp = (wy > wx) ? True : False; break; } case INSTR_lgWordGreaterEq: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); *sp = (wy >= wx) ? True : False; break; } case INSTR_lgWordAdd: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy+wx; *sp = (PolyWord)t; break; } case INSTR_lgWordSub: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy-wx; *sp = (PolyWord)t; break; } case INSTR_lgWordMult: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy*wx; *sp = (PolyWord)t; break; } case INSTR_lgWordDiv: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy/wx; *sp = (PolyWord)t; break; } case INSTR_lgWordMod: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy%wx; *sp = (PolyWord)t; break; } case INSTR_lgWordAnd: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy&wx; *sp = (PolyWord)t; break; } case INSTR_lgWordOr: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy|wx; *sp = (PolyWord)t; break; } case INSTR_lgWordXor: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy^wx; *sp = (PolyWord)t; break; } case INSTR_lgWordShiftLeft: { // The shift amount is a tagged word not a boxed large word POLYUNSIGNED wx = UNTAGGED_UNSIGNED(*sp++); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy << wx; *sp = (PolyWord)t; break; } case INSTR_lgWordShiftRLog: { // The shift amount is a tagged word not a boxed large word POLYUNSIGNED wx = UNTAGGED_UNSIGNED(*sp++); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy >> wx; *sp = (PolyWord)t; break; } case INSTR_lgWordShiftRArith: { // The shift amount is a tagged word not a boxed large word POLYUNSIGNED wx = UNTAGGED_UNSIGNED(*sp++); intptr_t wy = *(intptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(intptr_t*)t = wy >> wx; *sp = (PolyWord)t; break; } case INSTR_realEqual: { double u = unboxDouble(*sp++); *sp = u == unboxDouble(*sp) ? True: False; break; } case INSTR_realLess: { double u = unboxDouble(*sp++); *sp = unboxDouble(*sp) < u ? True: False; break; } case INSTR_realLessEq: { double u = unboxDouble(*sp++); *sp = unboxDouble(*sp) <= u ? True: False; break; } case INSTR_realGreater: { double u = unboxDouble(*sp++); *sp = unboxDouble(*sp) > u ? True: False; break; } case INSTR_realGreaterEq: { double u = unboxDouble(*sp++); *sp = unboxDouble(*sp) >= u ? True: False; break; } case INSTR_realUnordered: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); *sp = (std::isnan(u) || std::isnan(v)) ? True : False; break; } case INSTR_realAdd: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); PolyObject *t = this->boxDouble(v+u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_realSub: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); PolyObject *t = this->boxDouble(v-u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_realMult: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); PolyObject *t = this->boxDouble(v*u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_realDiv: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); PolyObject *t = this->boxDouble(v/u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_floatEqual: { float u = unboxFloat(*sp++); *sp = u == unboxFloat(*sp) ? True : False; break; } case INSTR_floatLess: { float u = unboxFloat(*sp++); *sp = unboxFloat(*sp) < u ? True : False; break; } case INSTR_floatLessEq: { float u = unboxFloat(*sp++); *sp = unboxFloat(*sp) <= u ? True : False; break; } case INSTR_floatGreater: { float u = unboxFloat(*sp++); *sp = unboxFloat(*sp) > u ? True : False; break; } case INSTR_floatGreaterEq: { float u = unboxFloat(*sp++); *sp = unboxFloat(*sp) >= u ? True : False; break; } case INSTR_floatUnordered: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); *sp = (std::isnan(u) || std::isnan(v)) ? True : False; break; } case INSTR_floatAdd: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); PolyObject *t = this->boxFloat(v + u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_floatSub: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); PolyObject *t = this->boxFloat(v - u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_floatMult: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); PolyObject *t = this->boxFloat(v*u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_floatDiv: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); PolyObject *t = this->boxFloat(v / u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_realToFloat: { // Convert a double to a float. It's complicated because it depends on the rounding mode. int rMode = *pc++; int current = getrounding(); // If the rounding is 4 it means "use current rounding". // Don't call unboxDouble until we're set the rounding. GCC seems to convert it // before the actual float cast. if (rMode < 4) setrounding(rMode); double d = unboxDouble(*sp); float v = (float)d; // Convert with the appropriate rounding. setrounding(current); PolyObject *t = this->boxFloat(v, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_realToInt: dv = unboxDouble(*sp); goto realtoint; case INSTR_floatToInt: dv = (double)unboxFloat(*sp); realtoint: { // Convert a double or a float to a tagged integer. int rMode = *pc++; // We mustn't try converting a value that will overflow the conversion // but we need to be careful that we don't raise overflow incorrectly due // to rounding. if (dv > (double)(MAXTAGGED + MAXTAGGED / 2) || dv < -(double)(MAXTAGGED + MAXTAGGED / 2)) { *(--sp) = overflowPacket; goto RAISE_EXCEPTION; } POLYSIGNED p; switch (rMode) { case POLY_ROUND_TONEAREST: p = (POLYSIGNED)round(dv); break; case POLY_ROUND_DOWNWARD: p = (POLYSIGNED)floor(dv); break; case POLY_ROUND_UPWARD: p = (POLYSIGNED)ceil(dv); break; case POLY_ROUND_TOZERO: default: // Truncation is the default for C. p = (POLYSIGNED)dv; } // Check that the value can be tagged. if (p > MAXTAGGED || p < -MAXTAGGED - 1) { *(--sp) = overflowPacket; goto RAISE_EXCEPTION; } *sp = TAGGED(p); break; } case INSTR_getThreadId: *(--sp) = (PolyWord)this->threadObject; break; case INSTR_allocWordMemory: { // Allocate word segment. This must be initialised. // We mustn't pop the initialiser until after any potential GC. POLYUNSIGNED length = UNTAGGED_UNSIGNED(sp[2]); PolyObject *t = this->allocateMemory(length, pc, sp); if (t == 0) goto RAISE_EXCEPTION; PolyWord initialiser = *sp++; POLYUNSIGNED flags = UNTAGGED_UNSIGNED(*sp++); t->SetLengthWord(length, (byte)flags); *sp = (PolyWord)t; // Have to initialise the data. for (; length > 0; ) t->Set(--length, initialiser); break; } case INSTR_alloc_ref: { // Allocate a single word mutable cell. This is more common than allocWordMemory on its own. PolyObject *t = this->allocateMemory(1, pc, sp); if (t == 0) goto RAISE_EXCEPTION; PolyWord initialiser = (*sp); t->SetLengthWord(1, F_MUTABLE_BIT); t->Set(0, initialiser); *sp = (PolyWord)t; break; } case INSTR_loadMLWord: { // The values on the stack are base, index and offset. POLYUNSIGNED offset = UNTAGGED(*sp++); POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject *p = (PolyObject*)((*sp).AsCodePtr() + offset); *sp = p->Get(index); break; } case INSTR_loadMLByte: { // The values on the stack are base and index. POLYUNSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = (*sp).AsCodePtr(); *sp = TAGGED(p[index]); // Have to tag the result break; } case INSTR_loadC8: { // This is similar to loadMLByte except that the base address is a boxed large-word. // Also the index is SIGNED. POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())); *sp = TAGGED(p[index]); // Have to tag the result break; } case INSTR_loadC16: { // This and the other loads are similar to loadMLWord with separate // index and offset values. POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; POLYUNSIGNED r = ((uint16_t*)p)[index]; *sp = TAGGED(r); break; } case INSTR_loadC32: { POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; uintptr_t r = ((uint32_t*)p)[index]; #ifdef IS64BITS // This is tagged in 64-bit mode *sp = TAGGED(r); #else // But boxed in 32-bit mode. PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = r; *sp = (PolyWord)t; #endif break; } #if (defined(IS64BITS)) case INSTR_loadC64: { POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; uintptr_t r = ((uint64_t*)p)[index]; // This must be boxed. PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = r; *sp = (PolyWord)t; break; } #endif case INSTR_loadCFloat: { POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; double r = ((float*)p)[index]; // This must be boxed. PolyObject *t = this->boxDouble(r, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_loadCDouble: { POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; double r = ((double*)p)[index]; // This must be boxed. PolyObject *t = this->boxDouble(r, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_loadUntagged: { // The values on the stack are base, index and offset. POLYUNSIGNED offset = UNTAGGED(*sp++); POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject *p = (PolyObject*)((*sp).AsCodePtr() + offset); *sp = TAGGED(p->Get(index).AsUnsigned()); break; } case INSTR_storeMLWord: { PolyWord toStore = *sp++; POLYUNSIGNED offset = UNTAGGED(*sp++); POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject *p = (PolyObject*)((*sp).AsCodePtr() + offset); p->Set(index, toStore); *sp = Zero; break; } case INSTR_storeMLByte: { POLYUNSIGNED toStore = UNTAGGED(*sp++); POLYUNSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = (*sp).AsCodePtr(); p[index] = (byte)toStore; *sp = Zero; break; } case INSTR_storeC8: { // Similar to storeMLByte except that the base address is a boxed large-word. POLYUNSIGNED toStore = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())); p[index] = (byte)toStore; *sp = Zero; break; } case INSTR_storeC16: { uint16_t toStore = (uint16_t)UNTAGGED(*sp++); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; ((uint16_t*)p)[index] = toStore; *sp = Zero; break; } case INSTR_storeC32: { #ifdef IS64BITS // This is a tagged value in 64-bit mode. uint32_t toStore = (uint32_t)UNTAGGED(*sp++); #else // but a boxed value in 32-bit mode. uint32_t toStore = (uint32_t)(*(uintptr_t*)((*sp++).AsObjPtr())); #endif POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; ((uint32_t*)p)[index] = toStore; *sp = Zero; break; } #if (defined(IS64BITS)) case INSTR_storeC64: { // This is a boxed value. uint64_t toStore = *(uintptr_t*)((*sp++).AsObjPtr()); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; ((uint64_t*)p)[index] = toStore; *sp = Zero; break; } #endif case INSTR_storeCFloat: { // This is a boxed value. float toStore = (float)unboxDouble(*sp++); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; ((float*)p)[index] = toStore; *sp = Zero; break; } case INSTR_storeCDouble: { // This is a boxed value. double toStore = unboxDouble(*sp++); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; ((double*)p)[index] = toStore; *sp = Zero; break; } case INSTR_storeUntagged: { PolyWord toStore = PolyWord::FromUnsigned(UNTAGGED_UNSIGNED(*sp++)); POLYUNSIGNED offset = UNTAGGED(*sp++); POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject *p = (PolyObject*)((*sp).AsCodePtr() + offset); p->Set(index, toStore); *sp = Zero; break; } case INSTR_blockMoveWord: { // The offsets are byte counts but the the indexes are in words. POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED destOffset = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED destIndex = UNTAGGED_UNSIGNED(*sp++); PolyObject *dest = (PolyObject*)((*sp++).AsCodePtr() + destOffset); POLYUNSIGNED srcOffset = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED srcIndex = UNTAGGED_UNSIGNED(*sp++); PolyObject *src = (PolyObject*)((*sp).AsCodePtr() + srcOffset); for (POLYUNSIGNED u = 0; u < length; u++) dest->Set(destIndex+u, src->Get(srcIndex+u)); *sp = Zero; break; } case INSTR_blockMoveByte: { POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED destOffset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR dest = (*sp++).AsCodePtr(); POLYUNSIGNED srcOffset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR src = (*sp).AsCodePtr(); memcpy(dest+destOffset, src+srcOffset, length); *sp = Zero; break; } case INSTR_blockEqualByte: { POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED arg2Offset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR arg2Ptr = (*sp++).AsCodePtr(); POLYUNSIGNED arg1Offset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR arg1Ptr = (*sp).AsCodePtr(); *sp = memcmp(arg1Ptr+arg1Offset, arg2Ptr+arg2Offset, length) == 0 ? True : False; break; } case INSTR_blockCompareByte: { POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED arg2Offset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR arg2Ptr = (*sp++).AsCodePtr(); POLYUNSIGNED arg1Offset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR arg1Ptr = (*sp).AsCodePtr(); int result = memcmp(arg1Ptr+arg1Offset, arg2Ptr+arg2Offset, length); *sp = result == 0 ? TAGGED(0) : result < 0 ? TAGGED(-1) : TAGGED(1); break; } default: Crash("Unknown instruction %x\n", pc[-1]); } /* switch */ } /* for */ return 0; } /* MD_switch_to_poly */ void IntTaskData::GarbageCollect(ScanAddress *process) { TaskData::GarbageCollect(process); overflowPacket = process->ScanObjectAddress(overflowPacket); dividePacket = process->ScanObjectAddress(dividePacket); if (stack != 0) { StackSpace *stackSpace = stack; PolyWord *stackPtr = this->taskSp; // The exception arg if any ScanStackAddress(process, this->exception_arg, stackSpace); // Now the values on the stack. for (PolyWord *q = stackPtr; q < stackSpace->top; q++) ScanStackAddress(process, *q, stackSpace); } } // Process a value within the stack. void IntTaskData::ScanStackAddress(ScanAddress *process, PolyWord &val, StackSpace *stack) { if (! val.IsDataPtr()) return; MemSpace *space = gMem.LocalSpaceForAddress(val.AsStackAddr()-1); if (space != 0) val = process->ScanObjectAddress(val.AsObjPtr()); } // Copy a stack void IntTaskData::CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length) { /* Moves a stack, updating all references within the stack */ PolyWord *old_base = (PolyWord *)old_stack; PolyWord *new_base = (PolyWord*)new_stack; PolyWord *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; PolyWord *oldSp = this->taskSp; this->taskSp = oldSp + offset; this->hr = this->hr + offset; /* Skip the unused part of the stack. */ uintptr_t i = oldSp - old_base; ASSERT(i <= old_length); i = old_length - i; PolyWord *old = oldSp; PolyWord *newp = this->taskSp; while (i--) { // ASSERT(old >= old_base && old < old_base+old_length); // ASSERT(newp >= new_base && newp < new_base+new_length); PolyWord old_word = *old++; if (old_word.IsTagged() || old_word.AsStackAddr() < old_base || old_word.AsStackAddr() >= old_top) *newp++ = old_word; else *newp++ = PolyWord::FromStackAddr(old_word.AsStackAddr() + offset); } ASSERT(old == ((PolyWord*)old_stack) + old_length); ASSERT(newp == ((PolyWord*)new_stack) + new_length); } Handle IntTaskData::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. ASSERT(0); // Callbacks aren't implemented default: Crash("Unknown io operation %d\n", ioFunction); } } catch (IOException &) { } } } // As far as possible we want locking and unlocking an ML mutex to be fast so // we try to implement the code in the assembly code using appropriate // interlocked instructions. That does mean that if we need to lock and // unlock an ML mutex in this code we have to use the same, machine-dependent, // code to do it. These are defaults that are used where there is no // machine-specific code. static Handle ProcessAtomicIncrement(TaskData *taskData, Handle mutexp) { PLocker l(&mutexLock); PolyObject *p = DEREFHANDLE(mutexp); // A thread can only call this once so the values will be short PolyWord newValue = TAGGED(UNTAGGED(p->Get(0))+1); p->Set(0, newValue); return taskData->saveVec.push(newValue); } // Release a mutex. We need to lock the mutex to ensure we don't // reset it in the time between one of atomic operations reading // and writing the mutex. static Handle ProcessAtomicReset(TaskData *taskData, Handle mutexp) { PLocker l(&mutexLock); DEREFHANDLE(mutexp)->Set(0, TAGGED(1)); // Set this to released. return taskData->saveVec.push(TAGGED(0)); // Push the unit result } Handle IntTaskData::AtomicIncrement(Handle mutexp) { return ProcessAtomicIncrement(this, mutexp); } void IntTaskData::AtomicReset(Handle mutexp) { (void)ProcessAtomicReset(this, mutexp); } bool IntTaskData::AddTimeProfileCount(SIGNALCONTEXT *context) { if (taskPc != 0) { // See if the PC we've got is an ML code address. MemSpace *space = gMem.SpaceForAddress(taskPc); if (space != 0 && (space->spaceType == ST_CODE || space->spaceType == ST_PERMANENT)) { add_count(this, taskPc, 1); return true; } } return false; } static Interpreter interpreterObject; MachineDependent *machineDependent = &interpreterObject; diff --git a/libpolyml/machine_dep.h b/libpolyml/machine_dep.h index 1d8bc7ae..963ab492 100644 --- a/libpolyml/machine_dep.h +++ b/libpolyml/machine_dep.h @@ -1,61 +1,66 @@ /* Title: machine_dep.h - exports signature for machine_dep.c Copyright (c) 2000 Cambridge University Technical Services Limited + Further development Copyright 2020 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. + 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 _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 Architectures MachineArchitecture(void) = 0; + + // The interpreted version does not need the code to have execute + // permission because it's not actually executed. + virtual bool CodeMustBeExecutable(void) { return true; } }; extern MachineDependent *machineDependent; #endif /* _MACHINE_DEP_H */ diff --git a/libpolyml/memmgr.cpp b/libpolyml/memmgr.cpp index 950d4486..37abbf56 100644 --- a/libpolyml/memmgr.cpp +++ b/libpolyml/memmgr.cpp @@ -1,1365 +1,1379 @@ /* Title: memmgr.cpp Memory segment manager Copyright (c) 2006-7, 2011-12, 2016-18 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 #include #include #include "globals.h" #include "memmgr.h" #include "osmem.h" #include "scanaddrs.h" #include "bitmap.h" #include "mpoly.h" #include "diagnostics.h" #include "statistics.h" #include "processes.h" +#include "machine_dep.h" #ifdef POLYML32IN64 // This contains the address of the base of the heap. PolyWord *globalHeapBase, *globalCodeBase; #endif // heap resizing policy option requested on command line unsigned heapsizingOption = 0; MemSpace::MemSpace(OSMem *alloc): SpaceTree(true) { spaceType = ST_PERMANENT; isMutable = false; bottom = 0; top = 0; isCode = false; allocator = alloc; + shadowSpace = 0; } MemSpace::~MemSpace() { if (allocator != 0 && bottom != 0) - allocator->Free(bottom, (char*)top - (char*)bottom); + { + if (isCode) + allocator->FreeCodeArea(bottom, shadowSpace, (char*)top - (char*)bottom); + else allocator->FreeDataArea(bottom, (char*)top - (char*)bottom); + } } MarkableSpace::MarkableSpace(OSMem *alloc): MemSpace(alloc), spaceLock("Local space") { } LocalMemSpace::LocalMemSpace(OSMem *alloc): MarkableSpace(alloc) { spaceType = ST_LOCAL; upperAllocPtr = lowerAllocPtr = 0; for (unsigned i = 0; i < NSTARTS; i++) start[i] = 0; start_index = 0; i_marked = m_marked = updated = 0; allocationSpace = false; } bool LocalMemSpace::InitSpace(PolyWord *heapSpace, uintptr_t size, bool mut) { isMutable = mut; bottom = heapSpace; top = bottom + size; // Initialise all the fields. The partial GC in particular relies on this. upperAllocPtr = partialGCTop = fullGCRescanStart = fullGCLowerLimit = lowestWeak = top; lowerAllocPtr = partialGCScan = partialGCRootBase = partialGCRootTop = fullGCRescanEnd = highestWeak = bottom; #ifdef POLYML32IN64 // The address must be on an odd-word boundary so that after the length // word is put in the actual cell address is on an even-word boundary. lowerAllocPtr[0] = PolyWord::FromUnsigned(0); lowerAllocPtr = bottom + 1; #endif spaceOwner = 0; allocationSpace = false; // Bitmap for the space. return bitmap.Create(size); } MemMgr::MemMgr(): allocLock("Memmgr alloc"), codeBitmapLock("Code bitmap") { nextIndex = 0; reservedSpace = 0; nextAllocator = 0; defaultSpaceSize = 0; spaceBeforeMinorGC = 0; spaceForHeap = 0; currentAllocSpace = currentHeapSize = 0; defaultSpaceSize = 1024 * 1024 / sizeof(PolyWord); // 1Mbyte segments. spaceTree = new SpaceTreeTree; } MemMgr::~MemMgr() { delete(spaceTree); // Have to do this before we delete the spaces. for (std::vector::iterator i = pSpaces.begin(); i < pSpaces.end(); i++) delete(*i); for (std::vector::iterator i = lSpaces.begin(); i < lSpaces.end(); i++) delete(*i); for (std::vector::iterator i = eSpaces.begin(); i < eSpaces.end(); i++) delete(*i); for (std::vector::iterator i = sSpaces.begin(); i < sSpaces.end(); i++) delete(*i); for (std::vector::iterator i = cSpaces.begin(); i < cSpaces.end(); i++) delete(*i); } bool MemMgr::Initialise() { #ifdef POLYML32IN64 // Allocate a single 16G area but with no access. void *heapBase; - if (!osHeapAlloc.Initialise((size_t)16 * 1024 * 1024 * 1024, &heapBase)) + if (!osHeapAlloc.Initialise(OSMem::UsageData, (size_t)16 * 1024 * 1024 * 1024, &heapBase)) return false; globalHeapBase = (PolyWord*)heapBase; // Allocate a 4 gbyte area for the stacks. // It's important that the stack and code areas have addresses with // non-zero top 32-bits. - if (!osStackAlloc.Initialise((size_t)4 * 1024 * 1024 * 1024)) + if (!osStackAlloc.Initialise(OSMem::UsageStack, (size_t)4 * 1024 * 1024 * 1024)) return false; // Allocate a 2G area for the code. void *codeBase; - if (!osCodeAlloc.Initialise((size_t)2 * 1024 * 1024 * 1024, &codeBase)) + if (!osCodeAlloc.Initialise(machineDependent->CodeMustBeExecutable() ? OSMem::UsageExecutableCode : OSMem::UsageData, + (size_t)2 * 1024 * 1024 * 1024, &codeBase)) return false; globalCodeBase = (PolyWord*)codeBase; return true; #else - return osHeapAlloc.Initialise() && osStackAlloc.Initialise() && osCodeAlloc.Initialise(); + return osHeapAlloc.Initialise(OSMem::UsageData) && osStackAlloc.Initialise(OSMem::UsageStack) && + osCodeAlloc.Initialise(machineDependent->CodeMustBeExecutable() ? OSMem::UsageExecutableCode : OSMem::UsageData); #endif } // Create and initialise a new local space and add it to the table. LocalMemSpace* MemMgr::NewLocalSpace(uintptr_t size, bool mut) { try { LocalMemSpace *space = new LocalMemSpace(&osHeapAlloc); // Before trying to allocate the heap temporarily allocate the // reserved space. This ensures that this much space will always // be available for C stacks and the C++ heap. void *reservation = 0; size_t rSpace = reservedSpace*sizeof(PolyWord); if (reservedSpace != 0) { - reservation = osHeapAlloc.Allocate(rSpace, PERMISSION_READ); - if (reservation == 0) { + reservation = osHeapAlloc.AllocateDataArea(rSpace); + if (reservation == NULL) { // Insufficient space for the reservation. Can't allocate this local space. if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New local %smutable space: insufficient reservation space\n", mut ? "": "im"); delete space; return 0; } } // Allocate the heap itself. size_t iSpace = size * sizeof(PolyWord); - PolyWord *heapSpace = - (PolyWord*)osHeapAlloc.Allocate(iSpace, PERMISSION_READ | PERMISSION_WRITE); + PolyWord* heapSpace = (PolyWord*)osHeapAlloc.AllocateDataArea(iSpace); // The size may have been rounded up to a block boundary. size = iSpace / sizeof(PolyWord); bool success = heapSpace != 0 && space->InitSpace(heapSpace, size, mut) && AddLocalSpace(space); - if (reservation != 0) osHeapAlloc.Free(reservation, rSpace); + if (reservation != 0) osHeapAlloc.FreeDataArea(reservation, rSpace); if (success) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New local %smutable space %p, size=%luk words, bottom=%p, top=%p\n", mut ? "": "im", space, space->spaceSize()/1024, space->bottom, space->top); currentHeapSize += space->spaceSize(); globalStats.setSize(PSS_TOTAL_HEAP, currentHeapSize * sizeof(PolyWord)); return space; } // If something went wrong. delete space; if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New local %smutable space: insufficient space\n", mut ? "": "im"); return 0; } catch (std::bad_alloc&) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New local %smutable space: \"new\" failed\n", mut ? "": "im"); return 0; } } // Create a local space for initial allocation. LocalMemSpace *MemMgr::CreateAllocationSpace(uintptr_t size) { LocalMemSpace *result = NewLocalSpace(size, true); if (result) { result->allocationSpace = true; currentAllocSpace += result->spaceSize(); globalStats.incSize(PSS_ALLOCATION, result->spaceSize()*sizeof(PolyWord)); globalStats.incSize(PSS_ALLOCATION_FREE, result->freeSpace()*sizeof(PolyWord)); } return result; } // If an allocation space has a lot of data left in it after a GC, particularly // a single large object we should turn it into a local area. void MemMgr::ConvertAllocationSpaceToLocal(LocalMemSpace *space) { ASSERT(space->allocationSpace); space->allocationSpace = false; // Currently it is left as a mutable area but if the contents are all // immutable e.g. a large vector it could be better to turn it into an // immutable area. currentAllocSpace -= space->spaceSize(); } // Add a local memory space to the table. bool MemMgr::AddLocalSpace(LocalMemSpace *space) { // Add to the table. // Update the B-tree. try { AddTree(space); // The entries in the local table are ordered so that the copy phase of the full // GC simply has to copy to an entry earlier in the table. Immutable spaces come // first, followed by mutable spaces and finally allocation spaces. if (space->allocationSpace) lSpaces.push_back(space); // Just add at the end else if (space->isMutable) { // Add before the allocation spaces std::vector::iterator i = lSpaces.begin(); while (i != lSpaces.end() && ! (*i)->allocationSpace) i++; lSpaces.insert(i, space); } else { // Immutable space: Add before the mutable spaces std::vector::iterator i = lSpaces.begin(); while (i != lSpaces.end() && ! (*i)->isMutable) i++; lSpaces.insert(i, space); } } catch (std::bad_alloc&) { RemoveTree(space); return false; } return true; } // Create an entry for a permanent space. PermanentMemSpace* MemMgr::NewPermanentSpace(PolyWord *base, uintptr_t words, unsigned flags, unsigned index, unsigned hierarchy /*= 0*/) { try { PermanentMemSpace *space = new PermanentMemSpace(0/* Not freed */); space->bottom = base; space->topPointer = space->top = space->bottom + words; space->spaceType = ST_PERMANENT; space->isMutable = flags & MTF_WRITEABLE ? true : false; space->noOverwrite = flags & MTF_NO_OVERWRITE ? true : false; space->byteOnly = flags & MTF_BYTES ? true : false; space->isCode = flags & MTF_EXECUTABLE ? true : false; space->index = index; space->hierarchy = hierarchy; if (index >= nextIndex) nextIndex = index+1; // Extend the permanent memory table and add this space to it. try { AddTree(space); pSpaces.push_back(space); } catch (std::exception&) { RemoveTree(space); delete space; return 0; } return space; } catch (std::bad_alloc&) { return 0; } } PermanentMemSpace *MemMgr::AllocateNewPermanentSpace(uintptr_t byteSize, unsigned flags, unsigned index, unsigned hierarchy) { try { OSMem *alloc = flags & MTF_EXECUTABLE ? &osCodeAlloc : &osHeapAlloc; PermanentMemSpace *space = new PermanentMemSpace(alloc); - unsigned int perms = PERMISSION_READ | PERMISSION_WRITE; - if (flags & MTF_EXECUTABLE) perms |= PERMISSION_EXEC; size_t actualSize = byteSize; - PolyWord *base = (PolyWord*)alloc->Allocate(actualSize, perms); + PolyWord* base; + void* newShadow=0; + if (flags & MTF_EXECUTABLE) + base = (PolyWord*)alloc->AllocateCodeArea(actualSize, newShadow); + else base = (PolyWord*)alloc->AllocateDataArea(actualSize); if (base == 0) { delete(space); return 0; } space->bottom = base; + space->shadowSpace = (PolyWord*)newShadow; space->topPointer = space->top = space->bottom + actualSize/sizeof(PolyWord); space->spaceType = ST_PERMANENT; space->isMutable = flags & MTF_WRITEABLE ? true : false; space->noOverwrite = flags & MTF_NO_OVERWRITE ? true : false; space->byteOnly = flags & MTF_BYTES ? true : false; space->isCode = flags & MTF_EXECUTABLE ? true : false; space->index = index; space->hierarchy = hierarchy; if (index >= nextIndex) nextIndex = index + 1; // Extend the permanent memory table and add this space to it. try { AddTree(space); pSpaces.push_back(space); } catch (std::exception&) { RemoveTree(space); delete space; return 0; } return space; } catch (std::bad_alloc&) { return 0; } } bool MemMgr::CompletePermanentSpaceAllocation(PermanentMemSpace *space) { // Remove write access unless it is mutable. // Don't remove write access unless this is top-level. Share-data assumes only hierarchy 0 is write-protected. if (!space->isMutable && space->hierarchy == 0) { if (space->isCode) - osCodeAlloc.SetPermissions(space->bottom, (char*)space->top - (char*)space->bottom, - PERMISSION_READ | PERMISSION_EXEC); - else osHeapAlloc.SetPermissions(space->bottom, (char*)space->top - (char*)space->bottom, PERMISSION_READ); + osCodeAlloc.DisableWriteForCode(space->bottom, space->shadowSpace, (char*)space->top - (char*)space->bottom); + else osHeapAlloc.EnableWrite(false, space->bottom, (char*)space->top - (char*)space->bottom); } return true; } // Delete a local space and remove it from the table. void MemMgr::DeleteLocalSpace(std::vector::iterator &iter) { LocalMemSpace *sp = *iter; if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Deleted local %s space %p at %p size %zu\n", sp->spaceTypeString(), sp, sp->bottom, sp->spaceSize()); currentHeapSize -= sp->spaceSize(); globalStats.setSize(PSS_TOTAL_HEAP, currentHeapSize * sizeof(PolyWord)); if (sp->allocationSpace) currentAllocSpace -= sp->spaceSize(); RemoveTree(sp); delete(sp); iter = lSpaces.erase(iter); } // Remove local areas that are now empty after a GC. // It isn't clear if we always want to do this. void MemMgr::RemoveEmptyLocals() { for (std::vector::iterator i = lSpaces.begin(); i < lSpaces.end(); ) { LocalMemSpace *space = *i; if (space->isEmpty()) DeleteLocalSpace(i); else i++; } } // Create and initialise a new export space and add it to the table. PermanentMemSpace* MemMgr::NewExportSpace(uintptr_t size, bool mut, bool noOv, bool code) { try { OSMem *alloc = code ? &osCodeAlloc : &osHeapAlloc; PermanentMemSpace *space = new PermanentMemSpace(alloc); space->spaceType = ST_EXPORT; space->isMutable = mut; space->noOverwrite = noOv; space->isCode = code; space->index = nextIndex++; // Allocate the memory itself. size_t iSpace = size*sizeof(PolyWord); - space->bottom = - (PolyWord*)alloc->Allocate(iSpace, PERMISSION_READ|PERMISSION_WRITE|PERMISSION_EXEC); + if (code) + { + void* shadow; + space->bottom = (PolyWord*)alloc->AllocateCodeArea(iSpace, shadow); + if (space->bottom != 0) + space->shadowSpace = (PolyWord*)shadow; + } + else space->bottom = (PolyWord*)alloc->AllocateDataArea(iSpace); if (space->bottom == 0) { delete space; if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New export %smutable space: insufficient space\n", mut ? "" : "im"); return 0; } // The size may have been rounded up to a block boundary. size = iSpace/sizeof(PolyWord); space->top = space->bottom + size; space->topPointer = space->bottom; #ifdef POLYML32IN64 // The address must be on an odd-word boundary so that after the length // word is put in the actual cell address is on an even-word boundary. - space->topPointer[0] = PolyWord::FromUnsigned(0); + space->writeAble(space->topPointer)[0] = PolyWord::FromUnsigned(0); space->topPointer = space->bottom + 1; #endif if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New export %smutable %s%sspace %p, size=%luk words, bottom=%p, top=%p\n", mut ? "" : "im", noOv ? "no-overwrite " : "", code ? "code " : "", space, space->spaceSize() / 1024, space->bottom, space->top); // Add to the table. try { AddTree(space); eSpaces.push_back(space); } catch (std::exception&) { RemoveTree(space); delete space; if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New export %smutable space: Adding to tree failed\n", mut ? "" : "im"); return 0; } return space; } catch (std::bad_alloc&) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New export %smutable space: \"new\" failed\n", mut ? "" : "im"); return 0; } } void MemMgr::DeleteExportSpaces(void) { for (std::vector::iterator i = eSpaces.begin(); i < eSpaces.end(); i++) { PermanentMemSpace *space = *i; RemoveTree(space); delete(space); } eSpaces.clear(); } // If we have saved the state rather than exported a function we turn the exported // spaces into permanent ones, removing existing permanent spaces at the same or // lower level. bool MemMgr::PromoteExportSpaces(unsigned hierarchy) { // Save permanent spaces at a lower hierarchy. Others are converted into // local spaces. Most or all items will have been copied from these spaces // into an export space but there could be items reachable only from the stack. std::vector::iterator i = pSpaces.begin(); while (i != pSpaces.end()) { PermanentMemSpace *pSpace = *i; if (pSpace->hierarchy < hierarchy) i++; else { try { // Turn this into a local space or a code space // Remove this from the tree - AddLocalSpace will make an entry for the local version. RemoveTree(pSpace); if (pSpace->isCode) { // Enable write access. Permanent spaces are read-only. - osCodeAlloc.SetPermissions(pSpace->bottom, (char*)pSpace->top - (char*)pSpace->bottom, - PERMISSION_READ | PERMISSION_WRITE | PERMISSION_EXEC); - CodeSpace *space = new CodeSpace(pSpace->bottom, pSpace->spaceSize(), &osCodeAlloc); + // osCodeAlloc.SetPermissions(pSpace->bottom, (char*)pSpace->top - (char*)pSpace->bottom, + // PERMISSION_READ | PERMISSION_WRITE | PERMISSION_EXEC); + CodeSpace *space = new CodeSpace(pSpace->bottom, pSpace->shadowSpace, pSpace->spaceSize(), &osCodeAlloc); if (! space->headerMap.Create(space->spaceSize())) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Unable to create header map for state space %p\n", pSpace); return false; } if (!AddCodeSpace(space)) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Unable to convert saved state space %p into code space\n", pSpace); return false; } if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Converted saved state space %p into code space %p\n", pSpace, space); // Set the bits in the header map. for (PolyWord *ptr = space->bottom; ptr < space->top; ) { PolyObject *obj = (PolyObject*)(ptr+1); // We may have forwarded this if this has been // copied to the exported area. Restore the original length word. if (obj->ContainsForwardingPtr()) { #ifdef POLYML32IN64 PolyObject *forwardedTo = obj; // This is relative to globalCodeBase not globalHeapBase while (forwardedTo->ContainsForwardingPtr()) forwardedTo = (PolyObject*)(globalCodeBase + ((forwardedTo->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); #else PolyObject *forwardedTo = obj->FollowForwardingChain(); #endif obj->SetLengthWord(forwardedTo->LengthWord()); } // Set the "start" bit if this is allocated. It will be a byte seg if not. if (obj->IsCodeObject()) space->headerMap.SetBit(ptr-space->bottom); ASSERT(!obj->IsClosureObject()); ptr += obj->Length() + 1; } } else { // Enable write access. Permanent spaces are read-only. - osHeapAlloc.SetPermissions(pSpace->bottom, (char*)pSpace->top - (char*)pSpace->bottom, - PERMISSION_READ | PERMISSION_WRITE); +// osHeapAlloc.SetPermissions(pSpace->bottom, (char*)pSpace->top - (char*)pSpace->bottom, +// PERMISSION_READ | PERMISSION_WRITE); LocalMemSpace *space = new LocalMemSpace(&osHeapAlloc); space->top = pSpace->top; // Space is allocated in local areas from the top down. This area is full and // all data is in the old generation. The area can be recovered by a full GC. space->bottom = space->upperAllocPtr = space->lowerAllocPtr = space->fullGCLowerLimit = pSpace->bottom; space->isMutable = pSpace->isMutable; space->isCode = false; if (! space->bitmap.Create(space->top-space->bottom) || ! AddLocalSpace(space)) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Unable to convert saved state space %p into local space\n", pSpace); return false; } if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Converted saved state space %p into local %smutable space %p\n", pSpace, pSpace->isMutable ? "im": "", space); currentHeapSize += space->spaceSize(); globalStats.setSize(PSS_TOTAL_HEAP, currentHeapSize * sizeof(PolyWord)); } i = pSpaces.erase(i); } catch (std::bad_alloc&) { return false; } } } // Save newly exported spaces. for(std::vector::iterator j = eSpaces.begin(); j < eSpaces.end(); j++) { PermanentMemSpace *space = *j; space->hierarchy = hierarchy; // Set the hierarchy of the new spaces. space->spaceType = ST_PERMANENT; // Put a dummy object to fill up the unused space. if (space->topPointer != space->top) - FillUnusedSpace(space->topPointer, space->top - space->topPointer); + FillUnusedSpace(space->writeAble(space->topPointer), space->top - space->topPointer); // Put in a dummy object to fill the rest of the space. pSpaces.push_back(space); } eSpaces.clear(); return true; } // Before we import a hierarchical saved state we need to turn any previously imported // spaces into local spaces. bool MemMgr::DemoteImportSpaces() { return PromoteExportSpaces(1); // Only truly permanent spaces are retained. } // Return the space for a given index PermanentMemSpace *MemMgr::SpaceForIndex(unsigned index) { for (std::vector::iterator i = pSpaces.begin(); i < pSpaces.end(); i++) { PermanentMemSpace *space = *i; if (space->index == index) return space; } return NULL; } // In several places we assume that segments are filled with valid // objects. This fills unused memory with one or more "byte" objects. void MemMgr::FillUnusedSpace(PolyWord *base, uintptr_t words) { PolyWord *pDummy = base+1; while (words > 0) { #ifdef POLYML32IN64 // Make sure that any dummy object we insert is properly aligned. if (((uintptr_t)pDummy) & 4) { *pDummy++ = PolyWord::FromUnsigned(0); words--; continue; } #endif POLYUNSIGNED oSize; // If the space is larger than the maximum object size // we will need several objects. if (words > MAX_OBJECT_SIZE) oSize = MAX_OBJECT_SIZE; else oSize = (POLYUNSIGNED)(words-1); // Make this a byte object so it's always skipped. ((PolyObject*)pDummy)->SetLengthWord(oSize, F_BYTE_OBJ); words -= oSize+1; pDummy += oSize+1; } } // Allocate an area of the heap of at least minWords and at most maxWords. // This is used both when allocating single objects (when minWords and maxWords // are the same) and when allocating heap segments. If there is insufficient // space to satisfy the minimum it will return 0. PolyWord *MemMgr::AllocHeapSpace(uintptr_t minWords, uintptr_t &maxWords, bool doAllocation) { PLocker locker(&allocLock); // We try to distribute the allocations between the memory spaces // so that at the next GC we don't have all the most recent cells in // one space. The most recent cells will be more likely to survive a // GC so distibuting them improves the load balance for a multi-thread GC. nextAllocator++; if (nextAllocator > gMem.lSpaces.size()) nextAllocator = 0; unsigned j = nextAllocator; for (std::vector::iterator i = lSpaces.begin(); i < lSpaces.end(); i++) { if (j >= gMem.lSpaces.size()) j = 0; LocalMemSpace *space = gMem.lSpaces[j++]; if (space->allocationSpace) { uintptr_t available = space->freeSpace(); if (available > 0 && available >= minWords) { // Reduce the maximum value if we had less than that. if (available < maxWords) maxWords = available; #ifdef POLYML32IN64 // If necessary round down to an even boundary if (maxWords & 1) { maxWords--; space->lowerAllocPtr[maxWords] = PolyWord::FromUnsigned(0); } #endif PolyWord *result = space->lowerAllocPtr; // Return the address. if (doAllocation) space->lowerAllocPtr += maxWords; // Allocate it. #ifdef POLYML32IN64 ASSERT((uintptr_t)result & 4); // Must be odd-word aligned #endif return result; } } } // There isn't space in the existing areas - can we create a new area? // The reason we don't have enough space could simply be that we want to // allocate an object larger than the default space size. Try deleting // some other spaces to bring currentAllocSpace below spaceBeforeMinorGC - minWords. if (minWords > defaultSpaceSize && minWords < spaceBeforeMinorGC) RemoveExcessAllocation(spaceBeforeMinorGC - minWords); if (currentAllocSpace/* + minWords */ < spaceBeforeMinorGC) { // i.e. the current allocation space is less than the space allowed for the minor GC // but it may be that allocating this object will take us over the limit. We allow // that to happen so that we can successfully allocate very large objects even if // we have a new GC very shortly. uintptr_t spaceSize = defaultSpaceSize; #ifdef POLYML32IN64 // When we create the allocation space we take one word so that the first // length word is on an odd-word boundary. We need to allow for that otherwise // we may have available < minWords. if (minWords >= spaceSize) spaceSize = minWords+1; // If we really want a large space. #else if (minWords > spaceSize) spaceSize = minWords; // If we really want a large space. #endif LocalMemSpace *space = CreateAllocationSpace(spaceSize); if (space == 0) return 0; // Can't allocate it // Allocate our space in this new area. uintptr_t available = space->freeSpace(); ASSERT(available >= minWords); if (available < maxWords) { maxWords = available; #ifdef POLYML32IN64 // If necessary round down to an even boundary if (maxWords & 1) { maxWords--; space->lowerAllocPtr[maxWords] = PolyWord::FromUnsigned(0); } #endif } PolyWord *result = space->lowerAllocPtr; // Return the address. if (doAllocation) space->lowerAllocPtr += maxWords; // Allocate it. #ifdef POLYML32IN64 ASSERT((uintptr_t)result & 4); // Must be odd-word aligned #endif return result; } return 0; // There isn't space even for the minimum. } -CodeSpace::CodeSpace(PolyWord *start, uintptr_t spaceSize, OSMem *alloc): MarkableSpace(alloc) +CodeSpace::CodeSpace(PolyWord *start, PolyWord *shadow, uintptr_t spaceSize, OSMem *alloc): MarkableSpace(alloc) { bottom = start; + shadowSpace = shadow; top = start+spaceSize; isMutable = true; // Make it mutable just in case. This will cause it to be scanned. isCode = true; spaceType = ST_CODE; #ifdef POLYML32IN64 // Dummy word so that the cell itself, after the length word, is on an 8-byte boundary. - *start = PolyWord::FromUnsigned(0); + writeAble(start)[0] = PolyWord::FromUnsigned(0); largestFree = spaceSize - 2; firstFree = start+1; #else largestFree = spaceSize - 1; firstFree = start; #endif } CodeSpace *MemMgr::NewCodeSpace(uintptr_t size) { // Allocate a new area and add it at the end of the table. CodeSpace *allocSpace = 0; // Allocate a new mutable, code space. N.B. This may round up "actualSize". size_t actualSize = size * sizeof(PolyWord); + void* shadow; PolyWord *mem = - (PolyWord*)osCodeAlloc.Allocate(actualSize, - PERMISSION_READ | PERMISSION_WRITE | PERMISSION_EXEC); + (PolyWord*)osCodeAlloc.AllocateCodeArea(actualSize, shadow); if (mem != 0) { try { - allocSpace = new CodeSpace(mem, actualSize / sizeof(PolyWord), &osCodeAlloc); + allocSpace = new CodeSpace(mem, (PolyWord*)shadow, actualSize / sizeof(PolyWord), &osCodeAlloc); + allocSpace->shadowSpace = (PolyWord*)shadow; if (!allocSpace->headerMap.Create(allocSpace->spaceSize())) { delete allocSpace; allocSpace = 0; } else if (!AddCodeSpace(allocSpace)) { delete allocSpace; allocSpace = 0; } else if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New code space %p allocated at %p size %lu\n", allocSpace, allocSpace->bottom, allocSpace->spaceSize()); // Put in a byte cell to mark the area as unallocated. - FillUnusedSpace(allocSpace->firstFree, allocSpace->top- allocSpace->firstFree); + FillUnusedSpace(allocSpace->writeAble(allocSpace->firstFree), allocSpace->top- allocSpace->firstFree); } catch (std::bad_alloc&) { } if (allocSpace == 0) { - osCodeAlloc.Free(mem, actualSize); + osCodeAlloc.FreeCodeArea(mem, shadow, actualSize); mem = 0; } } return allocSpace; } // Allocate memory for a piece of code. This needs to be both mutable and executable, // at least for native code. The interpreted version need not (should not?) make the // area executable. It will not be executed until the mutable bit has been cleared. // Once code is allocated it is not GCed or moved. // initCell is a byte cell that is copied into the new code area. PolyObject* MemMgr::AllocCodeSpace(POLYUNSIGNED requiredSize) { PLocker locker(&codeSpaceLock); // Search the code spaces until we find a free area big enough. size_t i = 0; while (true) { if (i != cSpaces.size()) { CodeSpace *space = cSpaces[i]; if (space->largestFree >= requiredSize) { POLYUNSIGNED actualLargest = 0; while (space->firstFree < space->top) { PolyObject *obj = (PolyObject*)(space->firstFree+1); // Skip over allocated areas or free areas that are too small. if (obj->IsCodeObject() || obj->Length() < 8) space->firstFree += obj->Length()+1; else break; } PolyWord *pt = space->firstFree; while (pt < space->top) { PolyObject *obj = (PolyObject*)(pt+1); POLYUNSIGNED length = obj->Length(); if (obj->IsByteObject()) { if (length >= requiredSize) { // Free and large enough PolyWord *next = pt+requiredSize+1; POLYUNSIGNED spare = length - requiredSize; #ifdef POLYML32IN64 // Maintain alignment. if (((requiredSize + 1) & 1) && spare != 0) { - *next++ = PolyWord::FromUnsigned(0); + space->writeAble(next++)[0] = PolyWord::FromUnsigned(0); spare--; } #endif if (spare != 0) - FillUnusedSpace(next, spare); + FillUnusedSpace(space->writeAble(next), spare); space->isMutable = true; // Set this - it ensures the area is scanned on GC. space->headerMap.SetBit(pt-space->bottom); // Set the "header" bit // Set the length word of the code area and copy the byte cell in. // The code bit must be set before the lock is released to ensure // another thread doesn't reuse this. - obj->SetLengthWord(requiredSize, F_CODE_OBJ|F_MUTABLE_BIT); + space->writeAble(obj)->SetLengthWord(requiredSize, F_CODE_OBJ|F_MUTABLE_BIT); return obj; } else if (length >= actualLargest) actualLargest = length+1; } pt += length+1; } // Reached the end without finding what we wanted. Update the largest size. space->largestFree = actualLargest; } i++; // Next area } else { // Allocate a new area and add it at the end of the table. uintptr_t spaceSize = requiredSize + 1; #ifdef POLYML32IN64 // We need to allow for the extra alignment word otherwise we // may allocate less than we need. spaceSize += 1; #endif CodeSpace *allocSpace = NewCodeSpace(spaceSize); if (allocSpace == 0) return 0; // Try a GC. globalStats.incSize(PSS_CODE_SPACE, allocSpace->spaceSize() * sizeof(PolyWord)); } } } // Remove code areas that are completely empty. This is probably better than waiting to reuse them. // It's particularly important if we reload a saved state because the code areas for old saved states // are made into local code areas just in case they are currently in use or reachable. void MemMgr::RemoveEmptyCodeAreas() { for (std::vector::iterator i = cSpaces.begin(); i != cSpaces.end(); ) { CodeSpace *space = *i; PolyObject *start = (PolyObject *)(space->bottom+1); if (start->IsByteObject() && start->Length() == space->spaceSize()-1) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Deleted code space %p at %p size %zu\n", space, space->bottom, space->spaceSize()); globalStats.decSize(PSS_CODE_SPACE, space->spaceSize() * sizeof(PolyWord)); // We have an empty cell that fills the whole space. RemoveTree(space); delete(space); i = cSpaces.erase(i); } else i++; } } // Add a code space to the tables. Used both for newly compiled code and also demoted saved spaces. bool MemMgr::AddCodeSpace(CodeSpace *space) { try { AddTree(space); cSpaces.push_back(space); } catch (std::exception&) { RemoveTree(space); return false; } return true; } // Check that we have sufficient space for an allocation to succeed. // Called from the GC to ensure that we will not get into an infinite // loop trying to allocate, failing and garbage-collecting again. bool MemMgr::CheckForAllocation(uintptr_t words) { uintptr_t allocated = 0; return AllocHeapSpace(words, allocated, false) != 0; } // Adjust the allocation area by removing free areas so that the total // size of the allocation area is less than the required value. This // is used after the quick GC and also if we need to allocate a large // object. void MemMgr::RemoveExcessAllocation(uintptr_t words) { // First remove any non-standard allocation areas. for (std::vector::iterator i = lSpaces.begin(); i < lSpaces.end();) { LocalMemSpace *space = *i; if (space->allocationSpace && space->isEmpty() && space->spaceSize() != defaultSpaceSize) DeleteLocalSpace(i); else i++; } for (std::vector::iterator i = lSpaces.begin(); currentAllocSpace > words && i < lSpaces.end(); ) { LocalMemSpace *space = *i; if (space->allocationSpace && space->isEmpty()) DeleteLocalSpace(i); else i++; } } // Return number of words free in all allocation spaces. uintptr_t MemMgr::GetFreeAllocSpace() { uintptr_t freeSpace = 0; PLocker lock(&allocLock); for (std::vector::iterator i = lSpaces.begin(); i < lSpaces.end(); i++) { LocalMemSpace *space = *i; if (space->allocationSpace) freeSpace += space->freeSpace(); } return freeSpace; } StackSpace *MemMgr::NewStackSpace(uintptr_t size) { PLocker lock(&stackSpaceLock); try { StackSpace *space = new StackSpace(&osStackAlloc); size_t iSpace = size*sizeof(PolyWord); - space->bottom = - (PolyWord*)osStackAlloc.Allocate(iSpace, PERMISSION_READ|PERMISSION_WRITE); + space->bottom = (PolyWord*)osStackAlloc.AllocateDataArea(iSpace); if (space->bottom == 0) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New stack space: insufficient space\n"); delete space; return 0; } // The size may have been rounded up to a block boundary. size = iSpace/sizeof(PolyWord); space->top = space->bottom + size; space->spaceType = ST_STACK; space->isMutable = true; // Add the stack space to the tree. This ensures that operations such as // LocalSpaceForAddress will work for addresses within the stack. We can // get them in the RTS with functions such as quot_rem and exception stack. // It's not clear whether they really appear in the GC. try { AddTree(space); sSpaces.push_back(space); } catch (std::exception&) { RemoveTree(space); delete space; return 0; } if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New stack space %p allocated at %p size %lu\n", space, space->bottom, space->spaceSize()); globalStats.incSize(PSS_STACK_SPACE, space->spaceSize() * sizeof(PolyWord)); return space; } catch (std::bad_alloc&) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New stack space: \"new\" failed\n"); return 0; } } // If checkmem is given write protect the immutable areas except during a GC. void MemMgr::ProtectImmutable(bool on) { if (debugOptions & DEBUG_CHECK_OBJECTS) { for (std::vector::iterator i = lSpaces.begin(); i < lSpaces.end(); i++) { LocalMemSpace *space = *i; if (!space->isMutable) { - if (space->isCode) - osCodeAlloc.SetPermissions(space->bottom, (char*)space->top - (char*)space->bottom, - on ? PERMISSION_READ | PERMISSION_EXEC : PERMISSION_READ | PERMISSION_EXEC | PERMISSION_WRITE); - else osHeapAlloc.SetPermissions(space->bottom, (char*)space->top - (char*)space->bottom, - on ? PERMISSION_READ : PERMISSION_READ | PERMISSION_WRITE); + if (!space->isCode) + osHeapAlloc.EnableWrite(!on, space->bottom, (char*)space->top - (char*)space->bottom); } } } } bool MemMgr::GrowOrShrinkStack(TaskData *taskData, uintptr_t newSize) { StackSpace *space = taskData->stack; size_t iSpace = newSize*sizeof(PolyWord); - PolyWord *newSpace = (PolyWord*)osStackAlloc.Allocate(iSpace, PERMISSION_READ|PERMISSION_WRITE); + + PolyWord *newSpace = (PolyWord*)osStackAlloc.AllocateDataArea(iSpace); if (newSpace == 0) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Unable to change size of stack %p from %lu to %lu: insufficient space\n", space, space->spaceSize(), newSize); return false; } // The size may have been rounded up to a block boundary. newSize = iSpace/sizeof(PolyWord); try { AddTree(space, newSpace, newSpace+newSize); } catch (std::bad_alloc&) { RemoveTree(space, newSpace, newSpace+newSize); delete space; return 0; } taskData->CopyStackFrame(space->stack(), space->spaceSize(), (StackObject*)newSpace, newSize); if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Size of stack %p changed from %lu to %lu at %p\n", space, space->spaceSize(), newSize, newSpace); globalStats.incSize(PSS_STACK_SPACE, (newSize - space->spaceSize()) * sizeof(PolyWord)); RemoveTree(space); // Remove it BEFORE freeing the space - another thread may allocate it PolyWord *oldBottom = space->bottom; size_t oldSize = (char*)space->top - (char*)space->bottom; space->bottom = newSpace; // Switch this before freeing - We could get a profile trap during the free space->top = newSpace+newSize; - osStackAlloc.Free(oldBottom, oldSize); + osStackAlloc.FreeDataArea(oldBottom, oldSize); return true; } // Delete a stack when a thread has finished. // This can be called by an ML thread so needs an interlock. bool MemMgr::DeleteStackSpace(StackSpace *space) { PLocker lock(&stackSpaceLock); for (std::vector::iterator i = sSpaces.begin(); i < sSpaces.end(); i++) { if (*i == space) { globalStats.decSize(PSS_STACK_SPACE, space->spaceSize() * sizeof(PolyWord)); RemoveTree(space); delete space; sSpaces.erase(i); if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Deleted stack space %p at %p size %zu\n", space, space->bottom, space->spaceSize()); return true; } } ASSERT(false); // It should always be in the table. return false; } SpaceTreeTree::SpaceTreeTree(): SpaceTree(false) { for (unsigned i = 0; i < 256; i++) tree[i] = 0; } SpaceTreeTree::~SpaceTreeTree() { for (unsigned i = 0; i < 256; i++) { if (tree[i] && ! tree[i]->isSpace) delete(tree[i]); } } // Add and remove entries in the space tree. void MemMgr::AddTree(MemSpace *space, PolyWord *startS, PolyWord *endS) { // It isn't clear we need to lock here but it's probably sensible. PLocker lock(&spaceTreeLock); AddTreeRange(&spaceTree, space, (uintptr_t)startS, (uintptr_t)endS); } void MemMgr::RemoveTree(MemSpace *space, PolyWord *startS, PolyWord *endS) { PLocker lock(&spaceTreeLock); RemoveTreeRange(&spaceTree, space, (uintptr_t)startS, (uintptr_t)endS); } void MemMgr::AddTreeRange(SpaceTree **tt, MemSpace *space, uintptr_t startS, uintptr_t endS) { if (*tt == 0) *tt = new SpaceTreeTree; ASSERT(! (*tt)->isSpace); SpaceTreeTree *t = (SpaceTreeTree*)*tt; const unsigned shift = (sizeof(void*)-1) * 8; // Takes the high-order byte uintptr_t r = startS >> shift; ASSERT(r < 256); const uintptr_t s = endS == 0 ? 256 : endS >> shift; ASSERT(s >= r && s <= 256); if (r == s) // Wholly within this entry AddTreeRange(&(t->tree[r]), space, startS << 8, endS << 8); else { // Deal with any remainder at the start. if ((r << shift) != startS) { AddTreeRange(&(t->tree[r]), space, startS << 8, 0 /*End of range*/); r++; } // Whole entries. while (r < s) { ASSERT(t->tree[r] == 0); t->tree[r] = space; r++; } // Remainder at the end. if ((s << shift) != endS) AddTreeRange(&(t->tree[r]), space, 0, endS << 8); } } // Remove an entry from the tree for a range. Strictly speaking we don't need the // space argument here but it's useful as a check. // This may be called to remove a partially installed structure if we have // run out of space in AddTreeRange. void MemMgr::RemoveTreeRange(SpaceTree **tt, MemSpace *space, uintptr_t startS, uintptr_t endS) { SpaceTreeTree *t = (SpaceTreeTree*)*tt; if (t == 0) return; // This can only occur if we're recovering. ASSERT(! t->isSpace); const unsigned shift = (sizeof(void*)-1) * 8; uintptr_t r = startS >> shift; const uintptr_t s = endS == 0 ? 256 : endS >> shift; if (r == s) RemoveTreeRange(&(t->tree[r]), space, startS << 8, endS << 8); else { // Deal with any remainder at the start. if ((r << shift) != startS) { RemoveTreeRange(&(t->tree[r]), space, startS << 8, 0); r++; } // Whole entries. while (r < s) { ASSERT(t->tree[r] == space || t->tree[r] == 0 /* Recovery only */); t->tree[r] = 0; r++; } // Remainder at the end. if ((s << shift) != endS) RemoveTreeRange(&(t->tree[r]), space, 0, endS << 8); } // See if the whole vector is now empty. for (unsigned j = 0; j < 256; j++) { if (t->tree[j]) return; // It's not empty - we're done. } delete(t); *tt = 0; } uintptr_t MemMgr::AllocatedInAlloc() { uintptr_t inAlloc = 0; for (std::vector::iterator i = lSpaces.begin(); i < lSpaces.end(); i++) { LocalMemSpace *sp = *i; if (sp->allocationSpace) inAlloc += sp->allocatedSpace(); } return inAlloc; } // Report heap sizes and occupancy before and after GC void MemMgr::ReportHeapSizes(const char *phase) { uintptr_t alloc = 0, nonAlloc = 0, inAlloc = 0, inNonAlloc = 0; for (std::vector::iterator i = lSpaces.begin(); i < lSpaces.end(); i++) { LocalMemSpace *sp = *i; if (sp->allocationSpace) { alloc += sp->spaceSize(); inAlloc += sp->allocatedSpace(); } else { nonAlloc += sp->spaceSize(); inNonAlloc += sp->allocatedSpace(); } } Log("Heap: %s Major heap used ", phase); LogSize(inNonAlloc); Log(" of "); LogSize(nonAlloc); Log(" (%1.0f%%). Alloc space used ", (float)inNonAlloc / (float)nonAlloc * 100.0F); LogSize(inAlloc); Log(" of "); LogSize(alloc); Log(" (%1.0f%%). Total space ", (float)inAlloc / (float)alloc * 100.0F); LogSize(spaceForHeap); Log(" %1.0f%% full.\n", (float)(inAlloc + inNonAlloc) / (float)spaceForHeap * 100.0F); Log("Heap: Local spaces %" PRI_SIZET ", permanent spaces %" PRI_SIZET ", code spaces %" PRI_SIZET ", stack spaces %" PRI_SIZET "\n", lSpaces.size(), pSpaces.size(), cSpaces.size(), sSpaces.size()); uintptr_t cTotal = 0, cOccupied = 0; for (std::vector::iterator c = cSpaces.begin(); c != cSpaces.end(); c++) { cTotal += (*c)->spaceSize(); PolyWord *pt = (*c)->bottom; while (pt < (*c)->top) { pt++; PolyObject *obj = (PolyObject*)pt; if (obj->ContainsForwardingPtr()) { #ifdef POLYML32IN64 // This is relative to globalCodeBase not globalHeapBase while (obj->ContainsForwardingPtr()) obj = (PolyObject*)(globalCodeBase + ((obj->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); #else obj = obj->FollowForwardingChain(); #endif pt += obj->Length(); } else { if (obj->IsCodeObject()) cOccupied += obj->Length() + 1; pt += obj->Length(); } } } Log("Heap: Code area: total "); LogSize(cTotal); Log(" occupied: "); LogSize(cOccupied); Log("\n"); uintptr_t stackSpace = 0; for (std::vector::iterator s = sSpaces.begin(); s != sSpaces.end(); s++) { stackSpace += (*s)->spaceSize(); } Log("Heap: Stack area: total "); LogSize(stackSpace); Log("\n"); } // Profiling - Find a code object or return zero if not found. // This can be called on a "user" thread. PolyObject *MemMgr::FindCodeObject(const byte *addr) { MemSpace *space = SpaceForAddress(addr); if (space == 0) return 0; Bitmap *profMap = 0; if (! space->isCode) return 0; if (space->spaceType == ST_CODE) { CodeSpace *cSpace = (CodeSpace*)space; profMap = &cSpace->headerMap; } else if (space->spaceType == ST_PERMANENT) { PermanentMemSpace *pSpace = (PermanentMemSpace*)space; profMap = &pSpace->profileCode; } else return 0; // Must be in code or permanent code. // For the permanent areas the header maps are created and initialised on demand. if (! profMap->Created()) { PLocker lock(&codeBitmapLock); if (! profMap->Created()) // Second check now we've got the lock. { // Create the bitmap. If it failed just say "not in this area" if (! profMap->Create(space->spaceSize())) return 0; // Set the first bit before releasing the lock. profMap->SetBit(0); } } // A bit is set if it is a length word. while ((uintptr_t)addr & (sizeof(POLYUNSIGNED)-1)) addr--; // Make it word aligned PolyWord *wordAddr = (PolyWord*)addr; // Work back to find the first set bit before this. // Normally we will find one but if we're looking up a value that // is actually an integer it might be in a piece of code that is now free. uintptr_t bitOffset = profMap->FindLastSet(wordAddr - space->bottom); if (space->spaceType == ST_CODE) { PolyWord *ptr = space->bottom+bitOffset; if (ptr >= space->top) return 0; // This will find the last non-free code cell or the first cell. // Return zero if the value was not actually in the cell or it wasn't code. PolyObject *obj = (PolyObject*)(ptr+1); #ifdef POLYML32IN64 PolyObject *lastObj = obj; // This is relative to globalCodeBase not globalHeapBase. while (lastObj->ContainsForwardingPtr()) lastObj = (PolyObject*)(globalCodeBase + ((lastObj->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); #else PolyObject *lastObj = obj->FollowForwardingChain(); #endif // We normally replace forwarding pointers but when scanning to update // addresses after a saved state we may not have yet done that. if (wordAddr > ptr && wordAddr < ptr + 1 + lastObj->Length() && lastObj->IsCodeObject()) return obj; else return 0; } // Permanent area - the bits are set on demand. // Now work forward, setting any bits if necessary. We don't need a lock // because this is monotonic. for (;;) { PolyWord *ptr = space->bottom+bitOffset; if (ptr >= space->top) return 0; PolyObject *obj = (PolyObject*)(ptr+1); ASSERT(obj->ContainsNormalLengthWord()); if (wordAddr > ptr && wordAddr < ptr + obj->Length()) return obj; bitOffset += obj->Length()+1; profMap->SetBit(bitOffset); } return 0; } // Remove profiling bitmaps from permanent areas to free up memory. void MemMgr::RemoveProfilingBitmaps() { for (std::vector::iterator i = pSpaces.begin(); i < pSpaces.end(); i++) (*i)->profileCode.Destroy(); } #ifdef POLYML32IN64DEBUG POLYOBJECTPTR PolyWord::AddressToObjectPtr(void *address) { ASSERT(address >= globalHeapBase); uintptr_t offset = (PolyWord*)address - globalHeapBase; ASSERT(offset <= 0x7fffffff); // Currently limited to 8Gbytes ASSERT((offset & 1) == 0); return (POLYOBJECTPTR)offset; } #endif MemMgr gMem; // The one and only memory manager object diff --git a/libpolyml/memmgr.h b/libpolyml/memmgr.h index 0efdb33f..2bcc968e 100644 --- a/libpolyml/memmgr.h +++ b/libpolyml/memmgr.h @@ -1,404 +1,423 @@ /* Title: memmgr.h Memory segment manager Copyright (c) 2006-8, 2010-12, 2016-18 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 MEMMGR_H #define MEMMGR_H #include "bitmap.h" #include "locking.h" #include "osmem.h" #include // utility conversion macros #define Words_to_K(w) (w*sizeof(PolyWord))/1024 #define Words_to_M(w) (w*sizeof(PolyWord))/(1<<20) #define B_to_M(b) (b/(1<<20)) class ScanAddress; class GCTaskId; class TaskData; typedef enum { ST_PERMANENT, // Permanent areas are part of the object code // Also loaded saved state. ST_LOCAL, // Local heaps contain volatile data ST_EXPORT, // Temporary export area ST_STACK, // ML Stack for a thread ST_CODE // Code created in the current run } SpaceType; // B-tree used in SpaceForAddress. Leaves are MemSpaces. class SpaceTree { public: SpaceTree(bool is): isSpace(is) { } virtual ~SpaceTree() {} bool isSpace; }; // A non-leaf node in the B-tree class SpaceTreeTree: public SpaceTree { public: SpaceTreeTree(); virtual ~SpaceTreeTree(); SpaceTree *tree[256]; }; // Base class for the various memory spaces. class MemSpace: public SpaceTree { protected: MemSpace(OSMem *alloc); virtual ~MemSpace(); public: SpaceType spaceType; bool isMutable; bool isCode; PolyWord *bottom; // Bottom of area PolyWord *top; // Top of area. OSMem *allocator; // Used to free the area. May be null. - + + PolyWord *shadowSpace; // Extra writable area for code if necessary + uintptr_t spaceSize(void)const { return top-bottom; } // No of words // These next two are used in the GC to limit scanning for // weak refs. PolyWord *lowestWeak, *highestWeak; // Used when printing debugging info virtual const char *spaceTypeString() { return isMutable ? "mutable" : "immutable"; } + // Return the writeable address if this is in read-only code. + byte* writeAble(byte* p) { + if (shadowSpace != 0) + return (p - (byte*)bottom + (byte*)shadowSpace); + else return p; + } + + PolyWord* writeAble(PolyWord* p) { + if (shadowSpace != 0) + return (p - bottom + shadowSpace); + else return p; + } + + PolyObject* writeAble(PolyObject* p) { + return (PolyObject*)writeAble((PolyWord *) p); + } + friend class MemMgr; }; // Permanent memory space. Either linked into the executable program or // loaded from a saved state file. class PermanentMemSpace: public MemSpace { protected: PermanentMemSpace(OSMem *alloc): MemSpace(alloc), index(0), hierarchy(0), noOverwrite(false), byteOnly(false), topPointer(0) {} public: unsigned index; // An identifier for the space. Used when saving and loading. unsigned hierarchy; // The hierarchy number: 0=from executable, 1=top level saved state, ... bool noOverwrite; // Don't save this in deeper hierarchies. bool byteOnly; // Only contains byte data - no need to scan for addresses. // When exporting or saving state we copy data into a new area. // This area grows upwards unlike the local areas that grow down. PolyWord *topPointer; Bitmap shareBitmap; // Used in sharedata Bitmap profileCode; // Used when profiling friend class MemMgr; }; #define NSTARTS 10 // Markable spaces are used as the base class for local heap // spaces and code spaces. class MarkableSpace: public MemSpace { protected: MarkableSpace(OSMem *alloc); virtual ~MarkableSpace() {} public: PolyWord *fullGCRescanStart; // Upper and lower limits for rescan during mark phase. PolyWord *fullGCRescanEnd; PLock spaceLock; // Lock used to protect forwarding pointers }; // Local areas can be garbage collected. class LocalMemSpace: public MarkableSpace { protected: LocalMemSpace(OSMem *alloc); virtual ~LocalMemSpace() {} bool InitSpace(PolyWord *heapPtr, uintptr_t size, bool mut); public: // Allocation. The minor GC allocates at the bottom of the areas while the // major GC and initial allocations are made at the top. The reason for this // is that it's only possible to scan objects from the bottom up and the minor // GC combines scanning with allocation whereas the major GC compacts from the // bottom into the top of an area. PolyWord *upperAllocPtr; // Allocation pointer. Objects are allocated AFTER this. PolyWord *lowerAllocPtr; // Allocation pointer. Objects are allocated BEFORE this. PolyWord *fullGCLowerLimit;// Lowest object in area before copying. PolyWord *partialGCTop; // Value of upperAllocPtr before the current partial GC. PolyWord *partialGCScan; // Scan pointer used in minor GC PolyWord *partialGCRootBase; // Start of the root objects. PolyWord *partialGCRootTop;// Value of lowerAllocPtr after the roots have been copied. GCTaskId *spaceOwner; // The thread that "owns" this space during a GC. Bitmap bitmap; /* bitmap with one bit for each word in the GC area. */ PLock bitmapLock; // Lock used in GC sharing pass. bool allocationSpace; // True if this is (mutable) space for initial allocation uintptr_t start[NSTARTS]; /* starting points for bit searches. */ unsigned start_index; /* last index used to index start array */ uintptr_t i_marked; /* count of immutable words marked. */ uintptr_t m_marked; /* count of mutable words marked. */ uintptr_t updated; /* count of words updated. */ uintptr_t allocatedSpace(void)const // Words allocated { return (top-upperAllocPtr) + (lowerAllocPtr-bottom); } uintptr_t freeSpace(void)const // Words free { return upperAllocPtr-lowerAllocPtr; } #ifdef POLYML32IN64 // We will generally set a zero cell for alignment. bool isEmpty(void)const { return allocatedSpace() <= 1; } #else bool isEmpty(void)const { return allocatedSpace() == 0; } #endif virtual const char *spaceTypeString() { return allocationSpace ? "allocation" : MemSpace::spaceTypeString(); } // Used when converting to and from bit positions in the bitmap uintptr_t wordNo(PolyWord *pt) { return pt - bottom; } PolyWord *wordAddr(uintptr_t bitno) { return bottom + bitno; } friend class MemMgr; }; class StackObject; // Abstract - Architecture specific // Stack spaces. These are managed by the thread module class StackSpace: public MemSpace { public: StackSpace(OSMem *alloc): MemSpace(alloc) { } StackObject *stack()const { return (StackObject *)bottom; } }; // Code Space. These contain local code created by the compiler. class CodeSpace: public MarkableSpace { public: - CodeSpace(PolyWord *start, uintptr_t spaceSize, OSMem *alloc); + CodeSpace(PolyWord *start, PolyWord *shadow, uintptr_t spaceSize, OSMem *alloc); Bitmap headerMap; // Map to find the headers during GC or profiling. uintptr_t largestFree; // The largest free space in the area PolyWord *firstFree; // The start of the first free space in the area. }; class MemMgr { public: MemMgr(); ~MemMgr(); bool Initialise(); // Create a local space for initial allocation. LocalMemSpace *CreateAllocationSpace(uintptr_t size); // Create and initialise a new local space and add it to the table. LocalMemSpace *NewLocalSpace(uintptr_t size, bool mut); // Create an entry for a permanent space. PermanentMemSpace *NewPermanentSpace(PolyWord *base, uintptr_t words, unsigned flags, unsigned index, unsigned hierarchy = 0); // Create a permanent space but allocate memory for it. // Sets bottom and top to the actual memory size. PermanentMemSpace *AllocateNewPermanentSpace(uintptr_t byteSize, unsigned flags, unsigned index, unsigned hierarchy = 0); // Called after an allocated permanent area has been filled in. bool CompletePermanentSpaceAllocation(PermanentMemSpace *space); // Delete a local space. Takes the iterator position in lSpaces and returns the // iterator after deletion. void DeleteLocalSpace(std::vector::iterator &iter); // Allocate an area of the heap of at least minWords and at most maxWords. // This is used both when allocating single objects (when minWords and maxWords // are the same) and when allocating heap segments. If there is insufficient // space to satisfy the minimum it will return 0. Updates "maxWords" with // the space actually allocated PolyWord *AllocHeapSpace(uintptr_t minWords, uintptr_t &maxWords, bool doAllocation = true); PolyWord *AllocHeapSpace(uintptr_t words) { uintptr_t allocated = words; return AllocHeapSpace(words, allocated); } CodeSpace *NewCodeSpace(uintptr_t size); // Allocate space for code. This is initially mutable to allow the code to be built. PolyObject *AllocCodeSpace(POLYUNSIGNED size); // Check that a subsequent allocation will succeed. Called from the GC to ensure bool CheckForAllocation(uintptr_t words); // If an allocation space has a lot of data left in it, particularly a single // large object we should turn it into a local area. void ConvertAllocationSpaceToLocal(LocalMemSpace *space); // Allocate space for the initial stack for a thread. The caller must // initialise the new stack. Returns 0 if allocation fails. StackSpace *NewStackSpace(uintptr_t size); // Adjust the space for a stack. Returns true if it succeeded. If it failed // it leaves the stack untouched. bool GrowOrShrinkStack(TaskData *taskData, uintptr_t newSize); // Delete a stack when a thread has finished. bool DeleteStackSpace(StackSpace *space); // Create and delete export spaces PermanentMemSpace *NewExportSpace(uintptr_t size, bool mut, bool noOv, bool code); void DeleteExportSpaces(void); bool PromoteExportSpaces(unsigned hierarchy); // Turn export spaces into permanent spaces. bool DemoteImportSpaces(void); // Turn previously imported spaces into local. PermanentMemSpace *SpaceForIndex(unsigned index); // Return the space for a given index // As a debugging check, write protect the immutable areas apart from during the GC. void ProtectImmutable(bool on); // Find a space that contains a given address. This is called for every cell // during a GC so needs to be fast., // N.B. This must be called on an address at the beginning or within the cell. // Generally that means with a pointer to the length word. Pointing at the // first "data" word may give the wrong result if the length is zero. MemSpace *SpaceForAddress(const void *pt) const { uintptr_t t = (uintptr_t)pt; SpaceTree *tr = spaceTree; // Each level of the tree is either a leaf or a vector of trees. unsigned j = sizeof(void *)*8; for (;;) { if (tr == 0 || tr->isSpace) return (MemSpace*)tr; j -= 8; tr = ((SpaceTreeTree*)tr)->tree[(t >> j) & 0xff]; } return 0; } // Find a local address for a space. // N.B. The argument should generally be the length word. See // comment on SpaceForAddress. LocalMemSpace *LocalSpaceForAddress(const void *pt) const { MemSpace *s = SpaceForAddress(pt); if (s != 0 && s->spaceType == ST_LOCAL) return (LocalMemSpace*)s; else return 0; } void SetReservation(uintptr_t words) { reservedSpace = words; } // In several places we assume that segments are filled with valid // objects. This fills unused memory with one or more "byte" objects. void FillUnusedSpace(PolyWord *base, uintptr_t words); // Return number of words of free space for stats. uintptr_t GetFreeAllocSpace(); // Remove unused local areas. void RemoveEmptyLocals(); // Remove unused code areas. void RemoveEmptyCodeAreas(); // Remove unused allocation areas to reduce the space below the limit. void RemoveExcessAllocation(uintptr_t words); void RemoveExcessAllocation() { RemoveExcessAllocation(spaceBeforeMinorGC); } // Table for permanent spaces std::vector pSpaces; // Table for local spaces std::vector lSpaces; // Table for export spaces std::vector eSpaces; // Table for stack spaces std::vector sSpaces; PLock stackSpaceLock; // Table for code spaces std::vector cSpaces; PLock codeSpaceLock; // Storage manager lock. PLock allocLock; // Lock for creating new bitmaps for code profiling PLock codeBitmapLock; unsigned nextIndex; // Used when allocating new permanent spaces. uintptr_t SpaceBeforeMinorGC() const { return spaceBeforeMinorGC; } uintptr_t SpaceForHeap() const { return spaceForHeap; } void SetSpaceBeforeMinorGC(uintptr_t minorSize) { spaceBeforeMinorGC = minorSize; } void SetSpaceForHeap(uintptr_t heapSize) { spaceForHeap = heapSize; } uintptr_t CurrentAllocSpace() { return currentAllocSpace; } uintptr_t AllocatedInAlloc(); uintptr_t CurrentHeapSize() { return currentHeapSize; } uintptr_t DefaultSpaceSize() const { return defaultSpaceSize; } void ReportHeapSizes(const char *phase); // Profiling - Find a code object or return zero if not found. PolyObject *FindCodeObject(const byte *addr); // Profiling - Free bitmaps to indicate start of an object. void RemoveProfilingBitmaps(); private: bool AddLocalSpace(LocalMemSpace *space); bool AddCodeSpace(CodeSpace *space); uintptr_t reservedSpace; unsigned nextAllocator; // The default size in words when creating new segments. uintptr_t defaultSpaceSize; // The number of words that can be used for initial allocation. uintptr_t spaceBeforeMinorGC; // The number of words that can be used for the heap uintptr_t spaceForHeap; // The current sizes of the allocation space and the total heap size. uintptr_t currentAllocSpace, currentHeapSize; // LocalSpaceForAddress is a hot-spot so we use a B-tree to convert addresses; SpaceTree *spaceTree; PLock spaceTreeLock; void AddTree(MemSpace *space) { AddTree(space, space->bottom, space->top); } void RemoveTree(MemSpace *space) { RemoveTree(space, space->bottom, space->top); } void AddTree(MemSpace *space, PolyWord *startS, PolyWord *endS); void RemoveTree(MemSpace *space, PolyWord *startS, PolyWord *endS); void AddTreeRange(SpaceTree **t, MemSpace *space, uintptr_t startS, uintptr_t endS); void RemoveTreeRange(SpaceTree **t, MemSpace *space, uintptr_t startS, uintptr_t endS); OSMem osHeapAlloc, osStackAlloc, osCodeAlloc; }; extern MemMgr gMem; #endif diff --git a/libpolyml/osmem.cpp b/libpolyml/osmem.cpp deleted file mode 100644 index 0f4050b2..00000000 --- a/libpolyml/osmem.cpp +++ /dev/null @@ -1,394 +0,0 @@ -/* - Title: osomem.cpp - Interface to OS memory management - - Copyright (c) 2006, 2017-18 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_SYS_TYPES_H -#include -#endif - -#ifdef HAVE_SYS_MMAN_H -#include -#endif - -#ifdef HAVE_ASSERT_H -#include -#define ASSERT(x) assert(x) -#else -#define ASSERT(x) -#endif - -#include "osmem.h" -#include "bitmap.h" -#include "locking.h" - -// Linux prefers MAP_ANONYMOUS to MAP_ANON -#ifndef MAP_ANON -#ifdef MAP_ANONYMOUS -#define MAP_ANON MAP_ANONYMOUS -#endif -#endif - - -#ifdef POLYML32IN64 - -bool OSMem::Initialise(size_t space /* = 0 */, void **pBase /* = 0 */) -{ - pageSize = PageSize(); - memBase = (char*)ReserveHeap(space); - if (memBase == 0) - return 0; - - if (pBase != 0) *pBase = memBase; - - // Create a bitmap with a bit for each page. - if (!pageMap.Create(space / pageSize)) - return false; - lastAllocated = space / pageSize; // Beyond the last page in the area - // Set the last bit in the area so that we don't use it. - // This is effectively a work-around for a problem with the heap. - // If we have a zero-sized cell at the end of the memory its address is - // going to be zero. This causes problems with forwarding pointers. - // There may be better ways of doing this. - pageMap.SetBit(space / pageSize - 1); - return true; -} - -void *OSMem::Allocate(size_t &space, unsigned permissions) -{ - char *baseAddr; - { - PLocker l(&bitmapLock); - uintptr_t pages = (space + pageSize - 1) / pageSize; - // Round up to an integral number of pages. - space = pages * pageSize; - // Find some space - while (pageMap.TestBit(lastAllocated - 1)) // Skip the wholly allocated area. - lastAllocated--; - uintptr_t free = pageMap.FindFree(0, lastAllocated, pages); - if (free == lastAllocated) - return 0; // Can't find the space. - pageMap.SetBits(free, pages); - // TODO: Do we need to zero this? It may have previously been set. - baseAddr = memBase + free * pageSize; - } - return CommitPages(baseAddr, space, permissions); -} - -bool OSMem::Free(void *p, size_t space) -{ - char *addr = (char*)p; - uintptr_t offset = (addr - memBase) / pageSize; - if (!UncommitPages(p, space)) - return false; - uintptr_t pages = space / pageSize; - { - PLocker l(&bitmapLock); - pageMap.ClearBits(offset, pages); - if (offset + pages > lastAllocated) // We allocate from the top down. - lastAllocated = offset + pages; - } - return true; -} -#endif - -#if (defined(HAVE_MMAP) && defined(MAP_ANON)) -// We don't use autoconf's test for mmap here because that tests for -// file mapping. Instead the test simply tests for the presence of an mmap -// function. -// We also insist that the OS supports MAP_ANON or MAP_ANONYMOUS. Older -// versions of Solaris required the use of /dev/zero instead. We don't -// support that. - -#ifdef HAVE_UNISTD_H -#include -#endif - -#ifdef HAVE_SYS_PARAM_H -#include -#endif - -// How do we get the page size? -#ifndef HAVE_GETPAGESIZE -#ifdef _SC_PAGESIZE -#define getpagesize() sysconf(_SC_PAGESIZE) -#else -// If this fails we're stuck -#define getpagesize() PAGESIZE -#endif -#endif - -#ifdef SOLARIS -#define FIXTYPE (caddr_t) -#else -#define FIXTYPE -#endif - -static int ConvertPermissions(unsigned perm) -{ - int res = 0; - if (perm & PERMISSION_READ) - res |= PROT_READ; - if (perm & PERMISSION_WRITE) - res |= PROT_WRITE; - if (perm & PERMISSION_EXEC) - res |= PROT_EXEC; - return res; -} - -#ifdef POLYML32IN64 -// Unix-specific implementation of the subsidiary functions. - -size_t OSMem::PageSize() -{ - return getpagesize(); -} - -void *OSMem::ReserveHeap(size_t space) -{ - return mmap(0, space, PROT_NONE, MAP_PRIVATE | MAP_ANON, -1, 0); -} - -bool OSMem::UnreserveHeap(void *p, size_t space) -{ - return munmap(FIXTYPE p, space) == 0; -} - -void *OSMem::CommitPages(void *baseAddr, size_t space, unsigned permissions) -{ - if (mmap(baseAddr, space, ConvertPermissions(permissions), MAP_FIXED|MAP_PRIVATE|MAP_ANON, -1, 0) == MAP_FAILED) - return 0; - msync(baseAddr, space, MS_SYNC|MS_INVALIDATE); - - return baseAddr; -} - -bool OSMem::UncommitPages(void *p, size_t space) -{ - // Remap the pages as new entries. This should remove the old versions. - if (mmap(p, space, PROT_NONE, MAP_FIXED|MAP_PRIVATE|MAP_ANON, -1, 0) == MAP_FAILED) - return false; - msync(p, space, MS_SYNC|MS_INVALIDATE); - return true; -} - -bool OSMem::SetPermissions(void *p, size_t space, unsigned permissions) -{ - int res = mprotect(FIXTYPE p, space, ConvertPermissions(permissions)); - return res != -1; -} - -#else - -bool OSMem::Initialise(size_t space /* = 0 */, void **pBase /* = 0 */) -{ - pageSize = getpagesize(); - return true; -} - -// Allocate space and return a pointer to it. The size is the minimum -// size requested and it is updated with the actual space allocated. -// Returns NULL if it cannot allocate the space. -void *OSMem::Allocate(size_t &space, unsigned permissions) -{ - int prot = ConvertPermissions(permissions); - // Round up to an integral number of pages. - space = (space + pageSize-1) & ~(pageSize-1); - int fd = -1; // This value is required by FreeBSD. Linux doesn't care - void *result = mmap(0, space, prot, MAP_PRIVATE|MAP_ANON, fd, 0); - // Convert MAP_FAILED (-1) into NULL - if (result == MAP_FAILED) - return 0; - return result; -} - -// Release the space previously allocated. This must free the whole of -// the segment. The space must be the size actually allocated. -bool OSMem::Free(void *p, size_t space) -{ - return munmap(FIXTYPE p, space) == 0; -} - -// Adjust the permissions on a segment. This must apply to the -// whole of a segment. -bool OSMem::SetPermissions(void *p, size_t space, unsigned permissions) -{ - int res = mprotect(FIXTYPE p, space, ConvertPermissions(permissions)); - return res != -1; -} - -#endif - -#elif defined(_WIN32) -// Use Windows memory management. -#include - -static int ConvertPermissions(unsigned perm) -{ - if (perm & PERMISSION_WRITE) - { - // Write. Always includes read permission. - if (perm & PERMISSION_EXEC) - return PAGE_EXECUTE_READWRITE; - else - return PAGE_READWRITE; - } - else if (perm & PERMISSION_EXEC) - { - // Execute but not write. - if (perm & PERMISSION_READ) - return PAGE_EXECUTE_READ; - else - return PAGE_EXECUTE; // Execute only - } - else if(perm & PERMISSION_READ) - return PAGE_READONLY; - else - return PAGE_NOACCESS; -} - -#ifdef POLYML32IN64 - -// Windows-specific implementations of the subsidiary functions. -size_t OSMem::PageSize() -{ - // Get the page size and round up to that multiple. - SYSTEM_INFO sysInfo; - GetSystemInfo(&sysInfo); - // Get the page size. Put it in a size_t variable otherwise the rounding - // up of "space" may go wrong on 64-bits. - return sysInfo.dwPageSize; -} - -void *OSMem::ReserveHeap(size_t space) -{ - void *memBase = VirtualAlloc(0, space, MEM_RESERVE, PAGE_NOACCESS); - if (memBase == 0) return 0; - // We need the heap to be such that the top 32-bits are non-zero. - if ((uintptr_t)memBase >= ((uintptr_t)1 << 32)) - return memBase; - // Allocate again. - void *newSpace = ReserveHeap(space); - UnreserveHeap(memBase, space); // Free the old area that isn't suitable. - // Return what we got, or zero if it failed. - return newSpace; -} - -bool OSMem::UnreserveHeap(void *p, size_t space) -{ - return VirtualFree(p, 0, MEM_RELEASE) == TRUE; -} - -void *OSMem::CommitPages(void *baseAddr, size_t space, unsigned permissions) -{ - return VirtualAlloc(baseAddr, space, MEM_COMMIT, ConvertPermissions(permissions)); -} - -bool OSMem::UncommitPages(void *baseAddr, size_t space) -{ - return VirtualFree(baseAddr, space, MEM_DECOMMIT) == TRUE; -} - -bool OSMem::SetPermissions(void *p, size_t space, unsigned permissions) -{ - DWORD oldProtect; - return VirtualProtect(p, space, ConvertPermissions(permissions), &oldProtect) == TRUE; -} - -#else - -bool OSMem::Initialise(size_t space /* = 0 */, void **pBase /* = 0 */) -{ - // Get the page size and round up to that multiple. - SYSTEM_INFO sysInfo; - GetSystemInfo(&sysInfo); - // Get the page size. Put it in a size_t variable otherwise the rounding - // up of "space" may go wrong on 64-bits. - pageSize = sysInfo.dwPageSize; - return true; -} - -// Allocate space and return a pointer to it. The size is the minimum -// size requested and it is updated with the actual space allocated. -// Returns NULL if it cannot allocate the space. -void *OSMem::Allocate(size_t &space, unsigned permissions) -{ - space = (space + pageSize - 1) & ~(pageSize - 1); - DWORD options = MEM_RESERVE | MEM_COMMIT; - return VirtualAlloc(0, space, options, ConvertPermissions(permissions)); -} - -// Release the space previously allocated. This must free the whole of -// the segment. The space must be the size actually allocated. -bool OSMem::Free(void *p, size_t space) -{ - return VirtualFree(p, 0, MEM_RELEASE) == TRUE; -} - -// Adjust the permissions on a segment. This must apply to the -// whole of a segment. -bool OSMem::SetPermissions(void *p, size_t space, unsigned permissions) -{ - DWORD oldProtect; - return VirtualProtect(p, space, ConvertPermissions(permissions), &oldProtect) == TRUE; -} - -#endif - -#else - -#ifdef HAVE_STDLIB_H -#include -#endif - -#ifdef HAVE_MALLOC_H -#include -#endif - -#ifdef POLYML32IN64 -#error "32 bit in 64-bits requires either mmap or VirtualAlloc" -#endif - -// Use calloc to allocate the memory. Using calloc ensures the memory is -// zeroed and is compatible with the other allocators. -void *OSMem::Allocate(size_t &bytes, unsigned permissions) -{ - return calloc(bytes, 1); -} - -bool OSMem::Free(void *p, size_t/*space*/) -{ - free(p); - return true; -} - -// We can't do this if we don't have mprotect. -bool OSMem::SetPermissions(void *p, size_t space, unsigned permissions) -{ - return true; // Let's hope this is all right. -} - -#endif diff --git a/libpolyml/osmem.h b/libpolyml/osmem.h index bbbaa10f..4d8fb551 100644 --- a/libpolyml/osmem.h +++ b/libpolyml/osmem.h @@ -1,86 +1,105 @@ /* Title: osomem.h - Interface to OS memory management - Copyright (c) 2006, 2017-18 David C.J. Matthews + Copyright (c) 2006, 2017-18, 2020 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 OS_MEM_H_INCLUDED #define OS_MEM_H_INCLUDED // We need size_t so include these two here. #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef POLYML32IN64 #include "bitmap.h" -#include "locking.h" #endif +#include "locking.h" + + // This class provides access to the memory management provided by the // operating system. It would be nice if we could always use malloc and // free for this but we need to have execute permission on the code // objects. -#define PERMISSION_READ 1 -#define PERMISSION_WRITE 2 -#define PERMISSION_EXEC 4 +class OSMem { -class OSMem -{ public: - OSMem() {} - ~OSMem() {} - bool Initialise(size_t space = 0, void **pBase = 0); + OSMem(); + virtual ~OSMem(); + + enum _MemUsage { + UsageData, // Data or code in the interpreted version + UsageStack, // Stack + UsageExecutableCode // Code in the native code versions. + }; + + bool Initialise(enum _MemUsage usage, size_t space = 0, void** pBase = 0); // Allocate space and return a pointer to it. The size is the minimum // size requested in bytes and it is updated with the actual space allocated. // Returns NULL if it cannot allocate the space. - void *Allocate(size_t &bytes, unsigned permissions); + void *AllocateDataArea(size_t& bytes); // Release the space previously allocated. This must free the whole of // the segment. The space must be the size actually allocated. - bool Free(void *p, size_t space); + bool FreeDataArea(void* p, size_t space); + + // Enable/disable writing. This must apply to the whole of a segment. + // Only for data areas. + bool EnableWrite(bool enable, void* p, size_t space); - // Adjust the permissions on a segment. This must apply to the - // whole of a segment. - bool SetPermissions(void *p, size_t space, unsigned permissions); + // Allocate code area. Some systems will not allow both write and execute permissions + // on the same page. On those systems we have to allocate two regions of shared memory, + // one with read+execute permission and the other with read+write. + void *AllocateCodeArea(size_t& bytes, void*& shadowArea); + + // Free the allocated areas. + bool FreeCodeArea(void* codeAddr, void* dataAddr, size_t space); + + // Remove write access. This is used after the permanent code area has been created + // either from importing a portable export file or copying the area in 32-in-64. + bool DisableWriteForCode(void* codeAddr, void* dataAddr, size_t space); protected: size_t pageSize; + enum _MemUsage memUsage; -#ifdef POLYML32IN64 - size_t PageSize(); - void *ReserveHeap(size_t space); - bool UnreserveHeap(void *baseAddr, size_t space); - void *CommitPages(void *baseAddr, size_t space, unsigned permissions); - bool UncommitPages(void *baseAddr, size_t space); +#ifndef _WIN32 + // If we need to use dual areas because WRITE+EXECUTE permission is not allowed. + int shadowFd; + PLock allocLock; + size_t allocPtr; +#endif +#ifdef POLYML32IN64 Bitmap pageMap; uintptr_t lastAllocated; - char *memBase; + char* memBase, *shadowBase; PLock bitmapLock; - #endif + }; #endif diff --git a/libpolyml/osmemunix.cpp b/libpolyml/osmemunix.cpp new file mode 100644 index 00000000..16c3bf98 --- /dev/null +++ b/libpolyml/osmemunix.cpp @@ -0,0 +1,484 @@ +/* + Title: osomem.cpp - Interface to OS memory management - Unix version + + Copyright (c) 2006, 2017-18, 2020 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" +#else +#error "No configuration file" +#endif + +#if defined __linux__ && !defined _GNU_SOURCE +// _GNU_SOURCE must be defined before #include to get O_TEMPFILE etc. +#define _GNU_SOURCE 1 +#endif + +#ifdef HAVE_SYS_TYPES_H +#include +#endif + +#ifdef HAVE_SYS_MMAN_H +#include +#endif + +#ifdef HAVE_ASSERT_H +#include +#define ASSERT(x) assert(x) +#else +#define ASSERT(x) +#endif + +#ifdef HAVE_UNISTD_H +#include +#endif + +#ifdef HAVE_SYS_PARAM_H +#include +#endif + +#ifdef HAVE_ERRNO_H +#include +#endif + +#ifdef HAVE_STDLIB_H +#include +#endif + +#ifdef HAVE_SYS_STAT_H +#include +#endif + +#ifdef HAVE_FCNTL_H +#include +#endif + +// Linux prefers MAP_ANONYMOUS to MAP_ANON +#ifndef MAP_ANON +#ifdef MAP_ANONYMOUS +#define MAP_ANON MAP_ANONYMOUS +#endif +#endif + +// Assume that mmap is supported. If it isn't we can't run. + +#include "osmem.h" +#include "bitmap.h" +#include "locking.h" +#include "polystring.h" // For TempCString + +// How do we get the page size? +#ifndef HAVE_GETPAGESIZE +#ifdef _SC_PAGESIZE +#define getpagesize() sysconf(_SC_PAGESIZE) +#else +// If this fails we're stuck +#define getpagesize() PAGESIZE +#endif +#endif + +#ifdef SOLARIS +#define FIXTYPE (caddr_t) +#else +#define FIXTYPE +#endif + +// Open a temporary file, unlink it and return the file descriptor. +static int openTmpFile(const char* dirName) +{ +#ifdef O_TMPFILE + int flags = 0; +#ifdef O_CLOEXEC + flags |= O_CLOEXEC; +#endif + int tfd = open(dirName, flags | O_TMPFILE | O_RDWR | O_EXCL, 0700); + if (tfd != -1) + return tfd; +#endif + const char* template_subdir = "/mlMapXXXXXX"; + TempString buff((char*)malloc(strlen(dirName) + strlen(template_subdir) + 1)); + if (buff == 0) return -1; // Unable to allocate + strcpy(buff, dirName); + strcat(buff, template_subdir); + int fd = mkstemp(buff); + if (fd == -1) return -1; + unlink(buff); + return fd; +} + +static int createTemporaryFile() +{ + char *tmpDir = getenv("TMPDIR"); + int fd; + if (tmpDir != NULL) + { + fd = openTmpFile(tmpDir); + if (fd != -1) return fd; + } +#ifdef P_tmpdir + fd = openTmpFile(P_tmpdir); + if (fd != -1) return fd; +#endif + fd = openTmpFile("/tmp"); + if (fd != -1) return fd; + fd = openTmpFile("/var/tmp"); + if (fd != -1) return fd; + + return -1; +} + +#ifdef POLYML32IN64 +OSMem::OSMem() +{ + memBase = 0; + shadowFd = -1; +} + +OSMem::~OSMem() +{ +} + +bool OSMem::Initialise(enum _MemUsage usage, size_t space /* = 0 */, void** pBase /* = 0 */) +{ + memUsage = usage; + pageSize = getpagesize(); + bool simpleMmap; + if (usage != UsageExecutableCode) simpleMmap = true; + else + { + // Can we allocate memory with write+execute? + void *test = mmap(0, pageSize, PROT_READ|PROT_WRITE|PROT_EXEC, MAP_PRIVATE|MAP_ANON, -1, 0); + if (test != MAP_FAILED) + { + munmap(FIXTYPE test, pageSize); + simpleMmap = true; + } + else simpleMmap = false; + } + + if (simpleMmap) + { + // Don't require shadow area. Can use mmap + memBase = (char*)mmap(0, space, PROT_NONE, MAP_PRIVATE | MAP_ANON, -1, 0); + if (memBase == MAP_FAILED) return false; + // We need the heap to be such that the top 32-bits are non-zero. + if ((uintptr_t)memBase < ((uintptr_t)1 << 32)) + { + // Allocate again. + void* newSpace = mmap(0, space, PROT_NONE, MAP_PRIVATE | MAP_ANON, -1, 0); + munmap(FIXTYPE memBase, space); // Free the old area that isn't suitable. + // Return what we got, or zero if it failed. + memBase = (char*)newSpace; + } + shadowBase = memBase; + } + else + { + // More difficult - require file mapping + shadowFd = createTemporaryFile(); + if (shadowFd == -1) return false; + if (ftruncate(shadowFd, space) == -1) return false; + void *readWrite = mmap(0, space, PROT_NONE, MAP_SHARED, shadowFd, 0); + if (readWrite == MAP_FAILED) return 0; + memBase = (char*)mmap(0, space, PROT_NONE, MAP_SHARED, shadowFd, 0); + if (memBase == MAP_FAILED) + { + munmap(FIXTYPE readWrite, space); + return false; + } + // This should be above 32-bits. + ASSERT((uintptr_t)memBase >= ((uintptr_t)1 << 32)); + shadowBase = (char*)readWrite; + } + + if (pBase != 0) *pBase = memBase; + + // Create a bitmap with a bit for each page. + if (!pageMap.Create(space / pageSize)) + return false; + lastAllocated = space / pageSize; // Beyond the last page in the area + // Set the last bit in the area so that we don't use it. + // This is effectively a work-around for a problem with the heap. + // If we have a zero-sized cell at the end of the memory its address is + // going to be zero. This causes problems with forwarding pointers. + // There may be better ways of doing this. + pageMap.SetBit(space / pageSize - 1); + return true; +} + +void* OSMem::AllocateDataArea(size_t& space) +{ + char* baseAddr; + { + PLocker l(&bitmapLock); + uintptr_t pages = (space + pageSize - 1) / pageSize; + // Round up to an integral number of pages. + space = pages * pageSize; + // Find some space + while (pageMap.TestBit(lastAllocated - 1)) // Skip the wholly allocated area. + lastAllocated--; + uintptr_t free = pageMap.FindFree(0, lastAllocated, pages); + if (free == lastAllocated) + return 0; // Can't find the space. + pageMap.SetBits(free, pages); + // TODO: Do we need to zero this? It may have previously been set. + baseAddr = memBase + free * pageSize; + } + int prot = PROT_READ | PROT_WRITE; + int flags = MAP_FIXED | MAP_PRIVATE | MAP_ANON; +#ifdef MAP_STACK + if (memUsage == UsageStack) flags |= MAP_STACK; // OpenBSD seems to require this +#endif + if (mmap(baseAddr, space, prot, flags, -1, 0) == MAP_FAILED) + return 0; + msync(baseAddr, space, MS_SYNC | MS_INVALIDATE); + return baseAddr; +} + +bool OSMem::FreeDataArea(void* p, size_t space) +{ + char* addr = (char*)p; + uintptr_t offset = (addr - memBase) / pageSize; + // Remap the pages as new entries. This should remove the old versions. + if (mmap(p, space, PROT_NONE, MAP_FIXED | MAP_PRIVATE | MAP_ANON, -1, 0) == MAP_FAILED) + return false; + msync(p, space, MS_SYNC | MS_INVALIDATE); + uintptr_t pages = space / pageSize; + { + PLocker l(&bitmapLock); + pageMap.ClearBits(offset, pages); + if (offset + pages > lastAllocated) // We allocate from the top down. + lastAllocated = offset + pages; + } + return true; +} + +void* OSMem::AllocateCodeArea(size_t& space, void*& shadowArea) +{ + uintptr_t offset; + { + PLocker l(&bitmapLock); + uintptr_t pages = (space + pageSize - 1) / pageSize; + // Round up to an integral number of pages. + space = pages * pageSize; + // Find some space + while (pageMap.TestBit(lastAllocated - 1)) // Skip the wholly allocated area. + lastAllocated--; + uintptr_t free = pageMap.FindFree(0, lastAllocated, pages); + if (free == lastAllocated) + return 0; // Can't find the space. + pageMap.SetBits(free, pages); + offset = free * pageSize; + } + + if (shadowFd == -1) + { + char *baseAddr = memBase + offset; + int prot = PROT_READ | PROT_WRITE; + if (memUsage == UsageExecutableCode) prot |= PROT_EXEC; + if (mmap(baseAddr, space, prot, MAP_FIXED | MAP_PRIVATE | MAP_ANON, -1, 0) == MAP_FAILED) + return 0; + msync(baseAddr, space, MS_SYNC | MS_INVALIDATE); + shadowArea = baseAddr; + return baseAddr; + } + else + { + char *baseAddr = memBase + offset; + char *readWriteArea = shadowBase + offset; + if (mmap(baseAddr, space, PROT_READ|PROT_EXEC, MAP_FIXED | MAP_SHARED, shadowFd, offset) == MAP_FAILED) + return 0; + msync(baseAddr, space, MS_SYNC | MS_INVALIDATE); + if (mmap(readWriteArea, space, PROT_READ|PROT_WRITE, MAP_FIXED | MAP_SHARED, shadowFd, offset) == MAP_FAILED) + return 0; + msync(readWriteArea, space, MS_SYNC | MS_INVALIDATE); + shadowArea = readWriteArea; + return baseAddr; + } +} + +bool OSMem::FreeCodeArea(void* codeAddr, void* dataAddr, size_t space) +{ + // Free areas by mapping them with PROT_NONE. + uintptr_t offset = ((char*)codeAddr - memBase) / pageSize; + if (shadowFd == -1) + { + mmap(codeAddr, space, PROT_NONE, MAP_FIXED | MAP_PRIVATE | MAP_ANON, -1, 0); + msync(codeAddr, space, MS_SYNC | MS_INVALIDATE); + } + else + { + + mmap(codeAddr, space, PROT_NONE, MAP_SHARED, shadowFd, offset); + msync(codeAddr, space, MS_SYNC | MS_INVALIDATE); + mmap(dataAddr, space, PROT_NONE, MAP_SHARED, shadowFd, offset); + msync(dataAddr, space, MS_SYNC | MS_INVALIDATE); + } + uintptr_t pages = space / pageSize; + { + PLocker l(&bitmapLock); + pageMap.ClearBits(offset, pages); + if (offset + pages > lastAllocated) // We allocate from the top down. + lastAllocated = offset + pages; + } + return true; +} + +bool OSMem::EnableWrite(bool enable, void* p, size_t space) +{ + int res = mprotect(FIXTYPE p, space, enable ? PROT_READ|PROT_WRITE: PROT_READ); + return res != -1; +} + +bool OSMem::DisableWriteForCode(void* codeAddr, void* dataAddr, size_t space) +{ + int prot = PROT_READ; + if (memUsage == UsageExecutableCode) prot |= PROT_EXEC; + int res = mprotect(FIXTYPE codeAddr, space, prot); + return res != -1; +} + +#else + +// Native address versions + +OSMem::OSMem() +{ + allocPtr = 0; + shadowFd = -1; +} + +OSMem::~OSMem() +{ + if (shadowFd != -1) close(shadowFd); +} + +bool OSMem::Initialise(enum _MemUsage usage, size_t space /* = 0 */, void **pBase /* = 0 */) +{ + memUsage = usage; + pageSize = getpagesize(); + if (usage != UsageExecutableCode) return true; + // Can we allocate memory with write+execute? + void *test = mmap(0, pageSize, PROT_READ|PROT_WRITE|PROT_EXEC, MAP_PRIVATE|MAP_ANON, -1, 0); + if (test != MAP_FAILED) + { + // Don't require shadow area + munmap(FIXTYPE test, pageSize); + return true; + } + if (errno != ENOTSUP && errno != EACCES) // Fails with ENOTSUPP on OpenBSD and EACCES in SELinux. + return false; + // Check that read-write works. + test = mmap(0, pageSize, PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANON, -1, 0); + if (test == MAP_FAILED) + return false; // There's a problem. + munmap(FIXTYPE test, pageSize); + // Need to create a file descriptor for mapping. + shadowFd = createTemporaryFile(); + if (shadowFd != -1) return true; + return false; +} + +// Allocate space and return a pointer to it. The size is the minimum +// size requested and it is updated with the actual space allocated. +// Returns NULL if it cannot allocate the space. +void *OSMem::AllocateDataArea(size_t &space) +{ + // Round up to an integral number of pages. + space = (space + pageSize-1) & ~(pageSize-1); + int fd = -1; // This value is required by FreeBSD. Linux doesn't care + int flags = MAP_PRIVATE | MAP_ANON; +#ifdef MAP_STACK + if (memUsage == UsageStack) flags |= MAP_STACK; // OpenBSD seems to require this +#endif + void *result = mmap(0, space, PROT_READ|PROT_WRITE, flags, fd, 0); + // Convert MAP_FAILED (-1) into NULL + if (result == MAP_FAILED) + return 0; + return result; +} + +// Release the space previously allocated. This must free the whole of +// the segment. The space must be the size actually allocated. +bool OSMem::FreeDataArea(void *p, size_t space) +{ + return munmap(FIXTYPE p, space) == 0; +} + +bool OSMem::EnableWrite(bool enable, void* p, size_t space) +{ + int res = mprotect(FIXTYPE p, space, enable ? PROT_READ|PROT_WRITE: PROT_READ); + return res != -1; +} + +void *OSMem::AllocateCodeArea(size_t &space, void*& shadowArea) +{ + // Round up to an integral number of pages. + space = (space + pageSize-1) & ~(pageSize-1); + + if (shadowFd == -1) + { + int fd = -1; // This value is required by FreeBSD. Linux doesn't care + int prot = PROT_READ | PROT_WRITE; + if (memUsage == UsageExecutableCode) prot |= PROT_EXEC; + void *result = mmap(0, space, prot, MAP_PRIVATE|MAP_ANON, fd, 0); + // Convert MAP_FAILED (-1) into NULL + if (result == MAP_FAILED) + return 0; + shadowArea = result; + return result; + } + + // Have to use dual areas. + size_t allocAt; + { + PLocker lock(&allocLock); + allocAt = allocPtr; + allocPtr += space; + } + if (ftruncate(shadowFd, allocAt + space) == -1) + return 0; + void *readExec = mmap(0, space, PROT_READ|PROT_EXEC, MAP_SHARED, shadowFd, allocAt); + if (readExec == MAP_FAILED) + return 0; + void *readWrite = mmap(0, space, PROT_READ|PROT_WRITE, MAP_SHARED, shadowFd, allocAt); + if (readWrite == MAP_FAILED) + { + munmap(FIXTYPE readExec, space); + return 0; + } + shadowArea = readWrite; + return readExec; +} + +bool OSMem::FreeCodeArea(void *codeArea, void *dataArea, size_t space) +{ + bool freeCode = munmap(FIXTYPE codeArea, space) == 0; + if (codeArea == dataArea) return freeCode; + return (munmap(FIXTYPE dataArea, space) == 0) & freeCode; +} + +bool OSMem::DisableWriteForCode(void* codeAddr, void* dataAddr, size_t space) +{ + int prot = PROT_READ; + if (memUsage == UsageExecutableCode) prot |= PROT_EXEC; + int res = mprotect(FIXTYPE codeAddr, space, prot); + return res != -1; +} + +#endif diff --git a/libpolyml/osmemwin.cpp b/libpolyml/osmemwin.cpp new file mode 100644 index 00000000..3aced6a4 --- /dev/null +++ b/libpolyml/osmemwin.cpp @@ -0,0 +1,256 @@ +/* + Title: osomem.cpp - Interface to OS memory management - Windows version + + Copyright (c) 2006, 2017-18, 2020 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 + +#include "osmem.h" +#include "bitmap.h" +#include "locking.h" + +// Use Windows memory management. +#include + +#ifdef POLYML32IN64 +OSMem::OSMem() +{ + memBase = 0; +} + +OSMem::~OSMem() +{ +} + +bool OSMem::Initialise(enum _MemUsage usage, size_t space /* = 0 */, void** pBase /* = 0 */) +{ + memUsage = usage; + // Get the page size and round up to that multiple. + SYSTEM_INFO sysInfo; + GetSystemInfo(&sysInfo); + // Get the page size. Put it in a size_t variable otherwise the rounding + // up of "space" may go wrong on 64-bits. + pageSize = sysInfo.dwPageSize; + + memBase = (char*)VirtualAlloc(0, space, MEM_RESERVE, PAGE_NOACCESS); + if (memBase == 0) return 0; + // We need the heap to be such that the top 32-bits are non-zero. + if ((uintptr_t)memBase < ((uintptr_t)1 << 32)) + { + // Allocate again. + void* newSpace = VirtualAlloc(0, space, MEM_RESERVE, PAGE_NOACCESS); + VirtualFree(memBase, 0, MEM_RELEASE); // Free the old area that isn't suitable. + // Return what we got, or zero if it failed. + memBase = (char*)newSpace; + } + + if (pBase != 0) *pBase = memBase; + + // Create a bitmap with a bit for each page. + if (!pageMap.Create(space / pageSize)) + return false; + lastAllocated = space / pageSize; // Beyond the last page in the area + // Set the last bit in the area so that we don't use it. + // This is effectively a work-around for a problem with the heap. + // If we have a zero-sized cell at the end of the memory its address is + // going to be zero. This causes problems with forwarding pointers. + // There may be better ways of doing this. + pageMap.SetBit(space / pageSize - 1); + return true; +} + +void* OSMem::AllocateDataArea(size_t& space) +{ + char* baseAddr; + { + PLocker l(&bitmapLock); + uintptr_t pages = (space + pageSize - 1) / pageSize; + // Round up to an integral number of pages. + space = pages * pageSize; + // Find some space + while (pageMap.TestBit(lastAllocated - 1)) // Skip the wholly allocated area. + lastAllocated--; + uintptr_t free = pageMap.FindFree(0, lastAllocated, pages); + if (free == lastAllocated) + return 0; // Can't find the space. + pageMap.SetBits(free, pages); + // TODO: Do we need to zero this? It may have previously been set. + baseAddr = memBase + free * pageSize; + } + return VirtualAlloc(baseAddr, space, MEM_COMMIT, PAGE_READWRITE); +} + +bool OSMem::FreeDataArea(void* p, size_t space) +{ + char* addr = (char*)p; + uintptr_t offset = (addr - memBase) / pageSize; + if (!VirtualFree(p, space, MEM_DECOMMIT)) + return false; + uintptr_t pages = space / pageSize; + { + PLocker l(&bitmapLock); + pageMap.ClearBits(offset, pages); + if (offset + pages > lastAllocated) // We allocate from the top down. + lastAllocated = offset + pages; + } + return true; +} + +void* OSMem::AllocateCodeArea(size_t& space, void*& shadowArea) +{ + char* baseAddr; + { + PLocker l(&bitmapLock); + uintptr_t pages = (space + pageSize - 1) / pageSize; + // Round up to an integral number of pages. + space = pages * pageSize; + // Find some space + while (pageMap.TestBit(lastAllocated - 1)) // Skip the wholly allocated area. + lastAllocated--; + uintptr_t free = pageMap.FindFree(0, lastAllocated, pages); + if (free == lastAllocated) + return 0; // Can't find the space. + pageMap.SetBits(free, pages); + // TODO: Do we need to zero this? It may have previously been set. + baseAddr = memBase + free * pageSize; + } + + void* dataArea = + VirtualAlloc(baseAddr, space, MEM_COMMIT, memUsage == UsageExecutableCode ? PAGE_EXECUTE_READWRITE : PAGE_READWRITE); + shadowArea = dataArea; + return dataArea; +} + +bool OSMem::FreeCodeArea(void* codeAddr, void* dataAddr, size_t space) +{ + ASSERT(codeAddr == dataAddr); + char* addr = (char*)codeAddr; + uintptr_t offset = (addr - memBase) / pageSize; + if (! VirtualFree(codeAddr, space, MEM_DECOMMIT)) + return false; + uintptr_t pages = space / pageSize; + { + PLocker l(&bitmapLock); + pageMap.ClearBits(offset, pages); + if (offset + pages > lastAllocated) // We allocate from the top down. + lastAllocated = offset + pages; + } + return true; +} + +bool OSMem::EnableWrite(bool enable, void* p, size_t space) +{ + DWORD oldProtect; + return VirtualProtect(p, space, enable ? PAGE_READWRITE : PAGE_READONLY, &oldProtect) == TRUE; +} + +bool OSMem::DisableWriteForCode(void* codeAddr, void* dataAddr, size_t space) +{ + ASSERT(codeAddr == dataAddr); + DWORD oldProtect; + return VirtualProtect(codeAddr, space, + memUsage == UsageExecutableCode ? PAGE_EXECUTE_READ : PAGE_READONLY, &oldProtect) == TRUE; +} + +#else + +// Native address versions +OSMem::OSMem() +{ +} + +OSMem::~OSMem() +{ +} + +bool OSMem::Initialise(enum _MemUsage usage, size_t space /* = 0 */, void **pBase /* = 0 */) +{ + memUsage = usage; + // Get the page size and round up to that multiple. + SYSTEM_INFO sysInfo; + GetSystemInfo(&sysInfo); + // Get the page size. Put it in a size_t variable otherwise the rounding + // up of "space" may go wrong on 64-bits. + pageSize = sysInfo.dwPageSize; + return true; +} + +// Allocate space and return a pointer to it. The size is the minimum +// size requested and it is updated with the actual space allocated. +// Returns NULL if it cannot allocate the space. +void *OSMem::AllocateDataArea(size_t &space) +{ + space = (space + pageSize - 1) & ~(pageSize - 1); + DWORD options = MEM_RESERVE | MEM_COMMIT; + return VirtualAlloc(0, space, options, PAGE_READWRITE); +} + +// Release the space previously allocated. This must free the whole of +// the segment. The space must be the size actually allocated. +bool OSMem::FreeDataArea(void *p, size_t space) +{ + return VirtualFree(p, 0, MEM_RELEASE) == TRUE; +} + +// Adjust the permissions on a segment. This must apply to the +// whole of a segment. +bool OSMem::EnableWrite(bool enable, void* p, size_t space) +{ + DWORD oldProtect; + return VirtualProtect(p, space, enable ? PAGE_READWRITE: PAGE_READONLY, &oldProtect) == TRUE; +} + +void* OSMem::AllocateCodeArea(size_t& space, void*& shadowArea) +{ + space = (space + pageSize - 1) & ~(pageSize - 1); + DWORD options = MEM_RESERVE | MEM_COMMIT; + void * dataAddr = VirtualAlloc(0, space, options, + memUsage == UsageExecutableCode ? PAGE_EXECUTE_READWRITE : PAGE_READWRITE); + shadowArea = dataAddr; + return dataAddr; +} + +bool OSMem::FreeCodeArea(void* codeAddr, void* dataAddr, size_t space) +{ + ASSERT(codeAddr == dataAddr); + return VirtualFree(codeAddr, 0, MEM_RELEASE) == TRUE; +} + +bool OSMem::DisableWriteForCode(void* codeAddr, void* dataAddr, size_t space) +{ + ASSERT(codeAddr == dataAddr); + DWORD oldProtect; + return VirtualProtect(codeAddr, space, + memUsage == UsageExecutableCode ? PAGE_EXECUTE_READ : PAGE_READONLY, &oldProtect) == TRUE; +} + +#endif + diff --git a/libpolyml/pexport.cpp b/libpolyml/pexport.cpp index b9978e81..c86dda6c 100644 --- a/libpolyml/pexport.cpp +++ b/libpolyml/pexport.cpp @@ -1,822 +1,825 @@ /* 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); + memSpace->writeAble(memSpace->bottom)[0] = PolyWord::FromUnsigned(0); used = 1; } PolyObject *newObj = (PolyObject*)(memSpace->bottom + used + 1); - if (rounded != objWords) newObj->Set(objWords, PolyWord::FromUnsigned(0)); + if (rounded != objWords) memSpace->writeAble(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; + SpaceAlloc* alloc; if (objBits & F_MUTABLE_BIT) - p = mutSpace.NewObj(nWords); + alloc = &mutSpace; else if ((objBits & 3) == F_CODE_OBJ) - p = codeSpace.NewObj(nWords); - else p = immutSpace.NewObj(nWords); + alloc = &codeSpace; + else alloc = &immutSpace; + PolyObject* p = alloc->NewObj(nWords); if (p == 0) return false; objMap[objNo] = p; /* Put in length PolyWord and flag bits. */ - p->SetLengthWord(nWords, objBits); + alloc->memSpace->writeAble(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; + MemSpace* space = gMem.SpaceForAddress(p); + PolyObject *wr = space->writeAble(p); + byte* u = (byte*)wr; /* 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; } ch = getc(f); ASSERT(ch == '|'); /* Set the constant count. */ - p->Set(length-1, PolyWord::FromUnsigned(nWords)); + wr->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))); + wr->Set(length-1-nWords-1, PolyWord::FromUnsigned(0)); /* Profile count. */ + wr->Set(length-1-nWords-3, PolyWord::FromUnsigned(0)); /* Marker word. */ + wr->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)) + if (! ReadValue(wr, 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; + byte *toPatch = (byte*)p + offset; // Pass the execute address here. 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); + wr->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 89c7a8e9..659163e7 100644 --- a/libpolyml/poly_specific.cpp +++ b/libpolyml/poly_specific.cpp @@ -1,447 +1,449 @@ /* 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(FirstArgument threadId, PolyWord code, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetABI(); 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(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(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(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)); + else memcpy(gMem.SpaceForAddress(result)->writeAble((byte*)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(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); // 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(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); + gMem.SpaceForAddress(codeObj)->writeAble(codeObj)->SetLengthWord(segLength, F_CODE_OBJ); // 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(); + byte* writeable = gMem.SpaceForAddress(pointer)->writeAble(pointer); 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); + writeable[i-1] = (byte)(c & 255); c >>= 8; } #else for (unsigned i = 0; i < sizeof(PolyWord); i++) { - pointer[i] = (byte)(c & 255); + writeable[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); + writeable[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); + byte* writable = gMem.SpaceForAddress(pointer)->writeAble(pointer); + writable[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/processes.cpp b/libpolyml/processes.cpp index b09000d7..8d866f69 100644 --- a/libpolyml/processes.cpp +++ b/libpolyml/processes.cpp @@ -1,2197 +1,2200 @@ /* 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" +#include "gc_progress.h" extern "C" { 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(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(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadTestInterrupt(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadNumProcessors(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadNumPhysicalProcessors(); 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[] = { { "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); } 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(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) { PLocker lock(&schedLock); // 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); } // 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). PLocker lock(&schedLock); // 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(); } } 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(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) { PLocker lock(&schedLock); // 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); } } // 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 PLocker lock(&schedLock); // 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); } } 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. PLocker lock(&schedLock); 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; } } 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(FirstArgument /*threadId*/) { processesModule.BroadcastInterrupt(); return TAGGED(0).AsUnsigned(); } 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(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". PLocker lock(&schedLock); 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); } } } // 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 PLocker lock(&schedLock); ThreadUseMLMemoryWithSchedLock(taskData); } void Processes::ThreadReleaseMLMemory(TaskData *taskData) { PLocker lock(&schedLock); ThreadReleaseMLMemoryWithSchedLock(taskData); } // 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(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; + gcProgressBeginOtherGC(); // The default unless we're doing a GC. gMem.ProtectImmutable(false); // GC, sharing and export may all write to the immutable area threadRequest->Perform(); gMem.ProtectImmutable(true); mainThreadPhase = MTP_USER_CODE; + gcProgressReturnToML(); 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(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. PLocker lock(&schedLock); sigLock->Unlock(); if (sigTask != 0) { 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; 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/quick_gc.cpp b/libpolyml/quick_gc.cpp index c65730f6..181e0b7b 100644 --- a/libpolyml/quick_gc.cpp +++ b/libpolyml/quick_gc.cpp @@ -1,728 +1,730 @@ /* Title: Quick copying garbage collector - Copyright (c) 2011-12, 2016-17 David C. J. Matthews + Copyright (c) 2011-12, 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 */ /* This is a quick copying garbage collector that moves all the data out of the allocation areas and into the mutable and immutable areas. If either of these has filled up it fails and a full garbage collection must be done. */ #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_STRING_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #include "globals.h" #include "processes.h" #include "gc.h" #include "scanaddrs.h" #include "check_objects.h" #include "bitmap.h" #include "memmgr.h" #include "diagnostics.h" #include "heapsizing.h" #include "gctaskfarm.h" #include "statistics.h" +#include "gc_progress.h" // This protects access to the gMem.lSpace table. static PLock localTableLock("Minor GC tables"); static bool succeeded = true; class QuickGCScanner: public ScanAddress { public: QuickGCScanner(bool r): rootScan(r) {} virtual ~QuickGCScanner() {} // Overrides for ScanAddress class virtual POLYUNSIGNED ScanAddressAt(PolyWord *pt); virtual PolyObject *ScanObjectAddress(PolyObject *base); private: PolyObject *FindNewAddress(PolyObject *obj, POLYUNSIGNED L, LocalMemSpace *srcSpace); virtual LocalMemSpace *FindSpace(POLYUNSIGNED length, bool isMutable) = 0; protected: bool objectCopied; bool rootScan; }; class RootScanner: public QuickGCScanner { public: RootScanner(): QuickGCScanner(true), mutableSpace(0), immutableSpace(0) {} private: virtual LocalMemSpace *FindSpace(POLYUNSIGNED length, bool isMutable); LocalMemSpace *mutableSpace, *immutableSpace; }; class ThreadScanner: public QuickGCScanner { public: ThreadScanner(GCTaskId* id): QuickGCScanner(false), taskID(id), mutableSpace(0), immutableSpace(0), spaceTable(0), nOwnedSpaces(0) {} virtual ~ThreadScanner() { free(spaceTable); } void ScanOwnedAreas(void); private: virtual LocalMemSpace *FindSpace(POLYUNSIGNED length, bool isMutable); bool TakeOwnership(LocalMemSpace *space); GCTaskId *taskID; LocalMemSpace *mutableSpace, *immutableSpace; LocalMemSpace **spaceTable; unsigned nOwnedSpaces; }; // This is used when scanning code areas. If there are no mutable cells left we can clear // the mutable bit and we don't have to scan it again. class CodeCheck: public ScanAddress { public: CodeCheck(): foundMutable(false) {} virtual PolyObject *ScanObjectAddress(PolyObject *base) { return base; } virtual void ScanAddressesInObject(PolyObject *base, POLYUNSIGNED lengthWord) { if (OBJ_IS_MUTABLE_OBJECT(lengthWord)) foundMutable = true; } bool foundMutable; }; // This uses the conditional exchange instruction to check and update // the forwarding pointer. It uses a lock prefix so that if another // thread has updated it in the meantime it will not set it. // Using the assembly code provides a very small speed-up so may not // be worth-while. #if defined(_MSC_VER) && (_MSC_VER >= 1600) // In later versions of MS C we can use the intrinsic. // 1600 is Visual Studio 2010. It may well work in older versions # include # pragma intrinsic(_InterlockedCompareExchange) # if (SIZEOF_VOIDP == 8) # define InterlockedCompareExchange64 _InterlockedCompareExchange64 # else # define InterlockedCompareExchange _InterlockedCompareExchange # endif #endif #ifdef POLYML32IN64 typedef uint32_t ptrasint; #else typedef uintptr_t ptrasint; #endif static bool atomiclySetForwarding(LocalMemSpace *space, ptrasint *pt, ptrasint testVal, ptrasint update) { #ifdef _MSC_VER # if (SIZEOF_POLYWORD == 8) LONGLONG *address = (LONGLONG*)(pt-1); uintptr_t result = InterlockedCompareExchange64(address, update, testVal); return result == testVal; # else LONG *address = (LONG*)(pt-1); uintptr_t result = InterlockedCompareExchange(address, update, testVal); return result == testVal; # endif #elif((defined(HOSTARCHITECTURE_X86) || defined(HOSTARCHITECTURE_X32) || defined(POLYML32IN64)) && defined(__GNUC__)) uintptr_t result; __asm__ __volatile__ ( "lock; cmpxchgl %1,%2" :"=a"(result) :"r"(update),"m"(pt[-1]),"0"(testVal) :"memory", "cc" ); return result == testVal; #elif(defined(HOSTARCHITECTURE_X86_64) && defined(__GNUC__)) uintptr_t result; __asm__ __volatile__ ( "lock; cmpxchgq %1,%2" :"=a"(result) :"r"(update),"m"(pt[-1]),"0"(testVal) :"memory", "cc" ); return result == testVal; #else // Fallback on other targets. PLocker lock(&space->spaceLock); if (pt[-1] == testVal) { pt[-1] = update; return true; } return false; #endif } PolyObject *QuickGCScanner::FindNewAddress(PolyObject *obj, POLYUNSIGNED L, LocalMemSpace *srcSpace) { bool isMutable = OBJ_IS_MUTABLE_OBJECT(L); POLYUNSIGNED n = OBJ_OBJECT_LENGTH(L); LocalMemSpace *lSpace = FindSpace(n, isMutable); if (lSpace == 0) return 0; // Unable to move it. PolyObject *newObject = (PolyObject*)(lSpace->lowerAllocPtr+1); // It's possible that another thread may have actually copied the // object since we loaded the length word so we check it again. // If this is a mutable we must ensure that checking the forwarding // pointer here and updating it if necessary is atomic. We don't need // to do that for immutable data so there is a small chance that an // object may be copied twice. That's not a problem for immutable data. // Also lock this if it's code. This may not be necessary but code objects // are rare. Updating the addresses in code objects is complicated and // it's possible that there are assumptions somewhere that there's only one // copy. // Avoiding locking for immutables provides only a small speed-up so may not // be worth-while. if (isMutable || OBJ_IS_CODE_OBJECT(L)) { if (! atomiclySetForwarding(srcSpace, (ptrasint*)obj, L, OBJ_SET_POINTER(newObject))) { newObject = obj->GetForwardingPtr(); if (debugOptions & DEBUG_GC_DETAIL) Log("GC: Quick: %p %lu %u has already moved to %p\n", obj, n, GetTypeBits(L), newObject); objectCopied = false; return newObject; } } else { if (obj->ContainsForwardingPtr()) { newObject = obj->GetForwardingPtr(); if (debugOptions & DEBUG_GC_DETAIL) Log("GC: Quick: %p %lu %u has already moved to %p\n", obj, n, GetTypeBits(L), newObject); objectCopied = false; return newObject; } else obj->SetForwardingPtr(newObject); } lSpace->lowerAllocPtr += n+1; #ifdef POLYML32IN64 // Maintain the odd-word alignment of lowerAllocPtr if ((n & 1) == 0 && lSpace->lowerAllocPtr < lSpace->upperAllocPtr) { *lSpace->lowerAllocPtr = PolyWord::FromUnsigned(0); lSpace->lowerAllocPtr++; } #endif CopyObjectToNewAddress(obj, newObject, L); objectCopied = true; return newObject; } // When scanning the roots we want to distribute the data among the immutable and mutable areas // so that the work is distributed for the scanning threads. LocalMemSpace *RootScanner::FindSpace(POLYUNSIGNED n, bool isMutable) { LocalMemSpace *lSpace = isMutable ? mutableSpace : immutableSpace; if (lSpace != 0) { // See if there's space in the existing area. if (lSpace->freeSpace() > n /* At least n+1*/) return lSpace; } // Find the space with the largest free area. for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *sp = *i; if (sp->isMutable == isMutable && !sp->allocationSpace && (lSpace == 0 || sp->freeSpace() > lSpace->freeSpace())) lSpace = sp; } if (lSpace != 0 && lSpace->freeSpace() > n) { if (isMutable) mutableSpace = lSpace; else immutableSpace = lSpace; return lSpace; } return gHeapSizeParameters.AddSpaceInMinorGC(n+1, isMutable); } // When scanning within a thread we don't want to be searching the space table. LocalMemSpace *ThreadScanner::FindSpace(POLYUNSIGNED n, bool isMutable) { LocalMemSpace *lSpace = isMutable ? mutableSpace : immutableSpace; if (lSpace != 0) { // See if there's space in the existing area. if (lSpace->freeSpace() > n /* At least n+1*/) return lSpace; } for (unsigned i = 0; i < nOwnedSpaces; i++) { lSpace = spaceTable[i]; if (lSpace->isMutable == isMutable && ! lSpace->allocationSpace && lSpace->freeSpace() > n /* At least n+1*/) { if (n < 10) { // We use this space for further allocations unless we are trying to // allocate a "large" object. if (isMutable) mutableSpace = lSpace; else immutableSpace = lSpace; } return lSpace; } } PLocker l(&localTableLock); // Another thread may allocate a new area, reallocating gMem.lSpaces so we // we need a lock here. if (taskID != 0) { // See if we can take a space that is currently unused. for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { lSpace = *i; if (lSpace->spaceOwner == 0 && lSpace->isMutable == isMutable && ! lSpace->allocationSpace && lSpace->freeSpace() > n /* At least n+1*/) { if (debugOptions & DEBUG_GC_ENHANCED) Log("GC: Quick: Thread %p is taking ownership of space %p\n", taskID, lSpace); if (! TakeOwnership(lSpace)) return 0; return lSpace; } } } lSpace = gHeapSizeParameters.AddSpaceInMinorGC(n+1, isMutable); if (lSpace != 0 && TakeOwnership(lSpace)) return lSpace; return 0; } // Copy all the objects. POLYUNSIGNED QuickGCScanner::ScanAddressAt(PolyWord *pt) { POLYUNSIGNED n = 1; // Set up the loop to process one word at *pt pt++; while (n-- != 0) { PolyWord val = *(--pt); if (! val.IsTagged()) { LocalMemSpace *space = gMem.LocalSpaceForAddress(val.AsStackAddr()-1); // We only copy it if it is in a local allocation space and not in the // "overflow" area of data that could not copied by the last full GC. if (space != 0 && space->allocationSpace && val.AsAddress() <= space->upperAllocPtr) { // We shouldn't get code addresses since we handle code // segments separately so if this isn't an integer it must be an object address. ASSERT(OBJ_IS_DATAPTR(val)); PolyObject *obj = val.AsObjPtr(); // Load the length word without any interlock. We can't assume that // another thread won't also copy this at the same time. POLYUNSIGNED L = obj->LengthWord(); // Has it been moved already? N.B. Another thread may be in the process of // moving it so the new object may not be fully copied. if (OBJ_IS_POINTER(L)) *pt = OBJ_GET_POINTER(L); else { // We need to copy this object. PolyObject *newObject = FindNewAddress(obj, L, space); // New address of object. if (newObject == 0) { // Couldn't copy it - not enough space. succeeded = false; if (debugOptions & DEBUG_GC_DETAIL) Log("GC: Quick: Insufficient space to move %p %lu %u\n", obj, OBJ_OBJECT_LENGTH(L), GetTypeBits(L)); return 0; } *pt = newObject; // Update the pointer to the object // N.B. If another thread has just copied it "newObject" may actually // be an address in another thread's space. In that case "objectCopied" // will be false. if (debugOptions & DEBUG_GC_DETAIL) Log("GC: Quick: %p %lu %u moved to %p\n", obj, OBJ_OBJECT_LENGTH(L), GetTypeBits(L), newObject); // Stop now unless this is a simple word object we have been able to move. // Also stop if we're just scanning the roots. if (! rootScan && newObject != obj && ! OBJ_IS_MUTABLE_OBJECT(L) && GetTypeBits(L) == 0 && objectCopied) { // We can simply return zero in which case this performs a breadth-first scan. // A breadth-first scan distributes the objects through the memory so // to retain some degree of locality we try to copy some object pointed at // by this one. We work from the end back so that we follow the tail pointers // for lists. n = OBJ_OBJECT_LENGTH(L); // Object length pt = (PolyWord*)newObject + n; } } } } } // We've reached the end without finding a pointer to follow return 0; } // The initial entry to process the roots. Also used when processing the addresses // in objects that can't be handled by ScanAddressAt. PolyObject *QuickGCScanner::ScanObjectAddress(PolyObject *base) { #ifdef POLYML32IN64 // If this is a code address we can't turn it into a PolyWord. // Check that it's a local address. MemSpace *space = gMem.SpaceForAddress((PolyWord*)base - 1); ASSERT(space != 0); if (space->spaceType != ST_LOCAL) return base; #endif PolyWord val = base; // Scan this as an address. (void)QuickGCScanner::ScanAddressAt(&val); // Ignore the result of ScanAddressAt which is always zero and // just return the updated address. return val.AsObjPtr(); } // Add this to the set of spaces we own. Must be called with the // localTableLock held. bool ThreadScanner::TakeOwnership(LocalMemSpace *space) { ASSERT(space->spaceOwner == 0); LocalMemSpace **v = (LocalMemSpace**)realloc(spaceTable, (nOwnedSpaces+1)*sizeof(LocalMemSpace*)); if (v == 0) return false; spaceTable = v; space->spaceOwner = taskID; spaceTable[nOwnedSpaces++] = space; return true; } // Thread function to scan an area. It scans the addresses in the region // copying any objects from the allocation area into mutable or immutable // areas it owns. It then processes all the areas it owns until there // are no further addresses to scan. static void scanArea(GCTaskId *id, void *arg1, void *arg2) { ThreadScanner marker(id); marker.ScanAddressesInRegion((PolyWord*)arg1, (PolyWord*)arg2); marker.ScanOwnedAreas(); } void ThreadScanner::ScanOwnedAreas() { while (true) { bool allDone = true; // We're finished when there is no unscanned data in any space we own. for (unsigned k = 0; k < nOwnedSpaces && allDone; k++) { LocalMemSpace *space = spaceTable[k]; allDone = space->partialGCScan == space->lowerAllocPtr; } if (allDone) break; // Scan each area that has had data added to it. for (unsigned l = 0; l < nOwnedSpaces; l++) { LocalMemSpace *space = spaceTable[l]; // Scan the area. This may well result in more data being added while (space->partialGCScan < space->lowerAllocPtr) { // Is the queue draining? If so it's probably worth creating // some spare work. if (gpTaskFarm->Draining() && gpTaskFarm->ThreadCount() > 1) { PolyWord *mid = space->partialGCScan + (space->lowerAllocPtr - space->partialGCScan)/2; // Split the space in two. PolyWord *p = space->partialGCScan; while (p < mid) { #ifdef POLYML32IN64 if ((((uintptr_t)p) & 4) == 0) { p++; // Should be on an odd-word boundary continue; } #endif PolyObject *o = (PolyObject*)(p+1); ASSERT(o->ContainsNormalLengthWord()); p += o->Length()+1; } // Start a new task to scan the area up to the half-way point. // Because we round up to the end of the next object we may // include the whole area but that's probably better because // we may have other areas to scan. if (gpTaskFarm->AddWork(scanArea, space->partialGCScan, p)) { space->partialGCScan = p; if (space->lowerAllocPtr == space->partialGCScan) break; } } PolyObject *obj = (PolyObject*)(space->partialGCScan+1); #ifdef POLYML32IN64 if ((((uintptr_t)obj) & 4) != 0) // Should be on an even-word boundary { space->partialGCScan++; continue; } #endif ASSERT(obj->ContainsNormalLengthWord()); POLYUNSIGNED length = obj->Length(); ASSERT(space->partialGCScan+length+1 <= space->lowerAllocPtr); space->partialGCScan += length+1; if (length != 0) ScanAddressesInObject(obj); // If any thread has run out of space we should stop. if (! succeeded) return; } } } // Release the spaces we're holding in case another thread wants to use them. for (unsigned m = 0; m < nOwnedSpaces; m++) { LocalMemSpace *space = spaceTable[m]; space->spaceOwner = 0; } nOwnedSpaces = 0; } bool RunQuickGC(const POLYUNSIGNED wordsRequiredToAllocate) { // If the last minor GC took too long force a full GC. if (gHeapSizeParameters.RunMajorGCImmediately()) return false; gHeapSizeParameters.RecordGCTime(HeapSizeParameters::GCTimeStart); globalStats.incCount(PSC_GC_PARTIALGC); mainThreadPhase = MTP_GCQUICK; succeeded = true; + gcProgressBeginMinorGC(); if (debugOptions & DEBUG_GC) Log("GC: Beginning quick GC\n"); if (debugOptions & DEBUG_HEAPSIZE) gMem.ReportHeapSizes("Minor GC (before)"); uintptr_t spaceBeforeGC = 0; for(std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *lSpace = *i; ASSERT (lSpace->top >= lSpace->upperAllocPtr); ASSERT (lSpace->upperAllocPtr >= lSpace->lowerAllocPtr); ASSERT (lSpace->lowerAllocPtr >= lSpace->bottom); // Remember the top before we started this GC. It's // only relevant for mutable areas. It avoids us rescanning // objects that may have been added to the space as a result of // scanning another space. if (lSpace->isMutable) lSpace->partialGCTop = lSpace->upperAllocPtr; else lSpace->partialGCTop = lSpace->top; // If we're scanning a space this is where we start. // For immutable areas this only includes newly added // data but for mutable areas we have to scan data added // by previous partial GCs. if (lSpace->isMutable && ! lSpace->allocationSpace) lSpace->partialGCRootBase = lSpace->bottom; else lSpace->partialGCRootBase = lSpace->lowerAllocPtr; lSpace->spaceOwner = 0; // Not currently owned // Add up the space in the mutable and immutable areas if (! lSpace->allocationSpace) spaceBeforeGC += lSpace->allocatedSpace(); } // First scan the roots, copying the data into the mutable and immutable areas. RootScanner rootScan; // Scan the permanent mutable areas. This could be parallelised but it doesn't // appear to be worthwhile at the moment. for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { PermanentMemSpace *space = *i; if (space->isMutable && ! space->byteOnly) rootScan.ScanAddressesInRegion(space->bottom, space->top); } // Scan code spaces. for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { CodeSpace *space = *i; // Spaces are mutable if any object has been added to the area since the last GC. if (space->isMutable) { rootScan.ScanAddressesInRegion(space->bottom, space->top); // Check to see if any of the objects are still mutable. If they are // we are still building the code and must rescan it on the next GC. // If there aren't we don't need to unless another code object is added. CodeCheck codeCheck; codeCheck.ScanAddressesInRegion(space->bottom, space->top); space->isMutable = codeCheck.foundMutable; } } // Scan RTS addresses. This will include the thread stacks. GCModules(&rootScan); // At this point the immutable and mutable areas will have some root objects // in the space between partialGCRootBase (the old value of lowerAllocPtr) and // lowerAllocPtr. These will contain the addresses of objects in the allocation // areas. We need to scan these root objects and then any new objects we copy // until there are no objects left to scan. // We also need to scan local mutable areas since these are roots as well. // They have data between partialGCTop and top. Parallelising this appears // to be a significant gain. // We have to be careful about the pointers here. AddWorkOrRunNow begins // a thread immediately and so the scanning threads may be running while // we are still creating new tasks. To avoid tripping up we use separate // pointers to the root objects rather than using lowerAllocPtr and // partialGCScan because these can be modified by the scanning tasks. // It's also possible for new spaces to be added to the table by the scanning // tasks while we are still adding tasks. It is important that the values of // partialGCRootBase, partialGCRootTop and partialGCTop are properly initialised // for these new spaces. for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *space = *i; space->partialGCRootTop = space->lowerAllocPtr; // Top of the roots space->partialGCScan = space->lowerAllocPtr; // Start of scanning for new data. } // Now start creating tasks. From this point only a thread that owns a space // may read or modify lowerAllocPtr or partialGCScan. { unsigned l = 0; while (true) { LocalMemSpace *space; { // There is a chance that a thread that has already been forked may // allocate a new space and realloc gMem.lSpaces. We have to drop // the lock before calling AddWorkOrRunNow in case we "run now". PLocker lock(&localTableLock); if (l >= gMem.lSpaces.size()) break; space = gMem.lSpaces[l++]; } if (space->partialGCRootBase != space->partialGCRootTop) gpTaskFarm->AddWorkOrRunNow(scanArea, space->partialGCRootBase, space->partialGCRootTop); if (space->partialGCTop != space->top) gpTaskFarm->AddWorkOrRunNow(scanArea, space->partialGCTop, space->top); } } gpTaskFarm->WaitForCompletion(); uintptr_t spaceAfterGC = 0; if (succeeded) { globalStats.setSize(PSS_AFTER_LAST_GC, 0); globalStats.setSize(PSS_ALLOCATION, 0); globalStats.setSize(PSS_ALLOCATION_FREE, 0); // If it succeeded the allocation areas are now empty. for(std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *lSpace = *i; uintptr_t free; if (lSpace->allocationSpace) { #ifdef POLYML32IN64 lSpace->lowerAllocPtr = lSpace->bottom + 1; lSpace->lowerAllocPtr[-1] = PolyWord::FromUnsigned(0); #else lSpace->lowerAllocPtr = lSpace->bottom; #endif free = lSpace->freeSpace(); #ifdef FILL_UNUSED_MEMORY // This provides extra checking if we have dangling pointers memset(lSpace->bottom, 0xaa, (char*)lSpace->upperAllocPtr - (char*)lSpace->bottom); #endif globalStats.incSize(PSS_ALLOCATION, free*sizeof(PolyWord)); globalStats.incSize(PSS_ALLOCATION_FREE, free*sizeof(PolyWord)); } else free = lSpace->freeSpace(); if (debugOptions & DEBUG_GC_ENHANCED) Log("GC: %s space %p %" PRI_SIZET " free in %" PRI_SIZET " words %2.1f%% full\n", lSpace->spaceTypeString(), lSpace, lSpace->freeSpace(), lSpace->spaceSize(), ((float)lSpace->allocatedSpace()) * 100 / (float)lSpace->spaceSize()); globalStats.incSize(PSS_AFTER_LAST_GC, free*sizeof(PolyWord)); spaceAfterGC += lSpace->allocatedSpace(); } if (! gMem.CheckForAllocation(wordsRequiredToAllocate)) succeeded = false; } if (succeeded) { gHeapSizeParameters.RecordGCTime(HeapSizeParameters::GCTimeEnd); if (! gHeapSizeParameters.AdjustSizeAfterMinorGC(spaceAfterGC, spaceBeforeGC)) // Adjust the allocation size. return false; // If necessary trigger a full GC immediately gHeapSizeParameters.resetMinorTimingData(); // Remove allocation spaces that are larger than the default // and any excess over the current size of the allocation area. gMem.RemoveExcessAllocation(); if (debugOptions & DEBUG_HEAPSIZE) gMem.ReportHeapSizes("Minor GC (after)"); if (debugOptions & DEBUG_GC) Log("GC: Completed successfully\n"); CheckMemory(); } else { // There was insufficient room to copy everything. We will need to // run a full GC. gHeapSizeParameters.RecordGCTime(HeapSizeParameters::GCTimeEnd); if (debugOptions & DEBUG_GC) Log("GC: Quick GC failed\n"); } return succeeded; } diff --git a/libpolyml/savestate.cpp b/libpolyml/savestate.cpp index 340c61ad..0798a8f3 100644 --- a/libpolyml/savestate.cpp +++ b/libpolyml/savestate.cpp @@ -1,2218 +1,2223 @@ /* Title: savestate.cpp - Save and Load state Copyright (c) 2007, 2015, 2017-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_STDIO_H #include #endif #ifdef HAVE_WINDOWS_H #include // For MAX_PATH #endif #ifdef HAVE_SYS_PARAM_H #include // For MAX_PATH #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_TIME_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_STAT_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #if (defined(_WIN32)) #include #define ERRORNUMBER _doserrno #define NOMEMORY ERROR_NOT_ENOUGH_MEMORY #else typedef char TCHAR; #define _T(x) x #define _tfopen fopen #define _tcscpy strcpy #define _tcsdup strdup #define _tcslen strlen #define _fputtc fputc #define _fputts fputs #ifndef lstrcmpi #define lstrcmpi strcasecmp #endif #define ERRORNUMBER errno #define NOMEMORY ENOMEM #endif #include "globals.h" #include "savestate.h" #include "processes.h" #include "run_time.h" #include "polystring.h" #include "scanaddrs.h" #include "arb.h" #include "memmgr.h" #include "mpoly.h" // For exportTimeStamp #include "exporter.h" // For CopyScan #include "machine_dep.h" #include "osmem.h" #include "gc.h" // For FullGC. #include "timing.h" #include "rtsentry.h" #include "check_objects.h" #include "rtsentry.h" #include "../polyexports.h" // For InitHeaderFromExport #include "version.h" // For InitHeaderFromExport #ifdef _MSC_VER // Don't tell me about ISO C++ changes. #pragma warning(disable:4996) #endif extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolySaveState(PolyObject *threadId, PolyWord fileName, PolyWord depth); POLYEXTERNALSYMBOL POLYUNSIGNED PolyLoadState(PolyObject *threadId, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyShowHierarchy(PolyObject *threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyRenameParent(PolyObject *threadId, PolyWord childName, PolyWord parentName); POLYEXTERNALSYMBOL POLYUNSIGNED PolyShowParent(PolyObject *threadId, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyStoreModule(PolyObject *threadId, PolyWord name, PolyWord contents); POLYEXTERNALSYMBOL POLYUNSIGNED PolyLoadModule(PolyObject *threadId, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyLoadHierarchy(PolyObject *threadId, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetModuleDirectory(PolyObject *threadId); } // Helper class to close files on exit. class AutoClose { public: AutoClose(FILE *f = 0): m_file(f) {} ~AutoClose() { if (m_file) ::fclose(m_file); } operator FILE*() { return m_file; } FILE* operator = (FILE* p) { return (m_file = p); } private: FILE *m_file; }; // This is probably generally useful so may be moved into // a general header file. template class AutoFree { public: AutoFree(BASE p = 0): m_value(p) {} ~AutoFree() { free(m_value); } // Automatic conversions to the base type. operator BASE() { return m_value; } BASE operator = (BASE p) { return (m_value = p); } private: BASE m_value; }; #ifdef HAVE__FTELLI64 // fseek and ftell are only 32-bits in Windows. #define off_t __int64 #define fseek _fseeki64 #define ftell _ftelli64 #endif /* * Structure definitions for the saved state files. */ #define SAVEDSTATESIGNATURE "POLYSAVE" #define SAVEDSTATEVERSION 2 // File header for a saved state file. This appears as the first entry // in the file. typedef struct _savedStateHeader { // These entries are primarily to check that we have a valid // saved state file before we try to interpret anything else. char headerSignature[8]; // Should contain SAVEDSTATESIGNATURE unsigned headerVersion; // Should contain SAVEDSTATEVERSION unsigned headerLength; // Number of bytes in the header unsigned segmentDescrLength; // Number of bytes in a descriptor // These entries contain the real data. off_t segmentDescr; // Position of segment descriptor table unsigned segmentDescrCount; // Number of segment descriptors in the table off_t stringTable; // Pointer to the string table (zero if none) size_t stringTableSize; // Size of string table unsigned parentNameEntry; // Position of parent name in string table (0 if top) time_t timeStamp; // The time stamp for this file. time_t parentTimeStamp; // The time stamp for the parent. void *originalBaseAddr; // Original base address (32-in-64 only) } SavedStateHeader; // Entry for segment table. This describes the segments on the disc that // need to be loaded into memory. typedef struct _savedStateSegmentDescr { off_t segmentData; // Position of the segment data size_t segmentSize; // Size of the segment data off_t relocations; // Position of the relocation table unsigned relocationCount; // Number of entries in relocation table unsigned relocationSize; // Size of a relocation entry unsigned segmentFlags; // Segment flags (see SSF_ values) unsigned segmentIndex; // The index of this segment or the segment it overwrites void *originalAddress; // The base address when the segment was written. } SavedStateSegmentDescr; #define SSF_WRITABLE 1 // The segment contains mutable data #define SSF_OVERWRITE 2 // The segment overwrites the data (mutable) in a parent. #define SSF_NOOVERWRITE 4 // The segment must not be further overwritten #define SSF_BYTES 8 // The segment contains only byte data #define SSF_CODE 16 // The segment contains only code typedef struct _relocationEntry { // Each entry indicates a location that has to be set to an address. // The location to be set is determined by adding "relocAddress" to the base address of // this segment (the one to which these relocations apply) and the value to store // by adding "targetAddress" to the base address of the segment indicated by "targetSegment". POLYUNSIGNED relocAddress; // The (byte) offset in this segment that we will set POLYUNSIGNED targetAddress; // The value to add to the base of the destination segment unsigned targetSegment; // The base segment. 0 is IO segment. ScanRelocationKind relKind; // The kind of relocation (processor dependent). } RelocationEntry; #define SAVE(x) taskData->saveVec.push(x) /* * Hierarchy table: contains information about last loaded or saved state. */ // Pointer to list of files loaded in last load. // There's no need for a lock since the update is only made when all // the ML threads have stopped. class HierarchyTable { public: HierarchyTable(const TCHAR *file, time_t time): fileName(_tcsdup(file)), timeStamp(time) { } AutoFree fileName; time_t timeStamp; }; HierarchyTable **hierarchyTable; static unsigned hierarchyDepth; static bool AddHierarchyEntry(const TCHAR *fileName, time_t timeStamp) { // Add an entry to the hierarchy table for this file. HierarchyTable *newEntry = new HierarchyTable(fileName, timeStamp); if (newEntry == 0) return false; HierarchyTable **newTable = (HierarchyTable **)realloc(hierarchyTable, sizeof(HierarchyTable *)*(hierarchyDepth+1)); if (newTable == 0) return false; hierarchyTable = newTable; hierarchyTable[hierarchyDepth++] = newEntry; return true; } // Test whether we're overwriting a parent of ourself. #if (defined(_WIN32) || defined(__CYGWIN__)) static bool sameFile(const TCHAR *x, const TCHAR *y) { HANDLE hXFile = INVALID_HANDLE_VALUE, hYFile = INVALID_HANDLE_VALUE; bool result = false; hXFile = CreateFile(x, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (hXFile == INVALID_HANDLE_VALUE) goto closeAndExit; hYFile = CreateFile(y, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (hYFile == INVALID_HANDLE_VALUE) goto closeAndExit; BY_HANDLE_FILE_INFORMATION fileInfoX, fileInfoY; if (! GetFileInformationByHandle(hXFile, &fileInfoX)) goto closeAndExit; if (! GetFileInformationByHandle(hYFile, &fileInfoY)) goto closeAndExit; result = fileInfoX.dwVolumeSerialNumber == fileInfoY.dwVolumeSerialNumber && fileInfoX.nFileIndexLow == fileInfoY.nFileIndexLow && fileInfoX.nFileIndexHigh == fileInfoY.nFileIndexHigh; closeAndExit: if (hXFile != INVALID_HANDLE_VALUE) CloseHandle(hXFile); if (hYFile != INVALID_HANDLE_VALUE) CloseHandle(hYFile); return result; } #else static bool sameFile(const char *x, const char *y) { struct stat xStat, yStat; // If either file does not exist that's fine. if (stat(x, &xStat) != 0 || stat(y, &yStat) != 0) return false; return (xStat.st_dev == yStat.st_dev && xStat.st_ino == yStat.st_ino); } #endif /* * Saving state. */ // This class is used to create the relocations. It uses Exporter // for this but this may perhaps be too heavyweight. class SaveStateExport: public Exporter, public ScanAddress { public: SaveStateExport(unsigned int h=0): Exporter(h), relocationCount(0) {} public: virtual void exportStore(void) {} // Not used. private: // ScanAddress overrides virtual void ScanConstant(PolyObject *base, byte *addrOfConst, ScanRelocationKind code); // At the moment we should only get calls to ScanConstant. virtual PolyObject *ScanObjectAddress(PolyObject *base) { return base; } protected: void setRelocationAddress(void *p, POLYUNSIGNED *reloc); PolyWord createRelocation(PolyWord p, void *relocAddr); unsigned relocationCount; friend class SaveRequest; }; // Generate the address relative to the start of the segment. void SaveStateExport::setRelocationAddress(void *p, POLYUNSIGNED *reloc) { unsigned area = findArea(p); POLYUNSIGNED offset = (POLYUNSIGNED)((char*)p - (char*)memTable[area].mtOriginalAddr); *reloc = offset; } // Create a relocation entry for an address at a given location. PolyWord SaveStateExport::createRelocation(PolyWord p, void *relocAddr) { RelocationEntry reloc; // Set the offset within the section we're scanning. setRelocationAddress(relocAddr, &reloc.relocAddress); void *addr = p.AsAddress(); unsigned addrArea = findArea(addr); reloc.targetAddress = (POLYUNSIGNED)((char*)addr - (char*)memTable[addrArea].mtOriginalAddr); reloc.targetSegment = (unsigned)memTable[addrArea].mtIndex; reloc.relKind = PROCESS_RELOC_DIRECT; fwrite(&reloc, sizeof(reloc), 1, exportFile); relocationCount++; return p; // Don't change the contents } /* 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 SaveStateExport::ScanConstant(PolyObject *base, byte *addr, ScanRelocationKind code) { PolyObject *p = GetConstantValue(addr, code); if (p == 0) return; void *a = p; unsigned aArea = findArea(a); // We don't need a relocation if this is relative to the current segment // since the relative address will already be right. if (code == PROCESS_RELOC_I386RELATIVE && aArea == findArea(addr)) return; // Set the value at the address to the offset relative to the symbol. RelocationEntry reloc; setRelocationAddress(addr, &reloc.relocAddress); reloc.targetAddress = (POLYUNSIGNED)((char*)a - (char*)memTable[aArea].mtOriginalAddr); reloc.targetSegment = (unsigned)memTable[aArea].mtIndex; reloc.relKind = code; fwrite(&reloc, sizeof(reloc), 1, exportFile); relocationCount++; } // Request to the main thread to save data. class SaveRequest: public MainThreadRequest { public: SaveRequest(const TCHAR *name, unsigned h): MainThreadRequest(MTP_SAVESTATE), fileName(name), newHierarchy(h), errorMessage(0), errCode(0) {} virtual void Perform(); const TCHAR *fileName; unsigned newHierarchy; const char *errorMessage; int errCode; }; // This class is used to update references to objects that have moved. If // we have copied an object into the area to be exported we may still have references // to it from the stack or from RTS data structures. We have to ensure that these // are updated. // This is very similar to ProcessFixupAddress in sharedata.cpp class SaveFixupAddress: public ScanAddress { protected: virtual POLYUNSIGNED ScanAddressAt(PolyWord *pt); virtual POLYUNSIGNED ScanCodeAddressAt(PolyObject **pt) { *pt = ScanObjectAddress(*pt); return 0; } virtual PolyObject *ScanObjectAddress(PolyObject *base); public: void ScanCodeSpace(CodeSpace *space); }; POLYUNSIGNED SaveFixupAddress::ScanAddressAt(PolyWord *pt) { PolyWord val = *pt; if (val.IsDataPtr() && val != PolyWord::FromUnsigned(0)) *pt = ScanObjectAddress(val.AsObjPtr()); return 0; } // Returns the new address if the argument is the address of an object that // has moved, otherwise returns the original. PolyObject *SaveFixupAddress::ScanObjectAddress(PolyObject *obj) { if (obj->ContainsForwardingPtr()) // tombstone is a pointer to a moved object { #ifdef POLYML32IN64 MemSpace *space = gMem.SpaceForAddress((PolyWord*)obj - 1); PolyObject *newp; if (space->isCode) newp = (PolyObject*)(globalCodeBase + ((obj->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); else newp = obj->GetForwardingPtr(); #else PolyObject *newp = obj->GetForwardingPtr(); #endif ASSERT (newp->ContainsNormalLengthWord()); return newp; } ASSERT (obj->ContainsNormalLengthWord()); // object is not moved return obj; } // Fix up addresses in the code area. Unlike ScanAddressesInRegion this updates // cells that have been moved. We need to do that because we may still have // return addresses into those cells and we don't move return addresses. We // do want the code to see updated constant addresses. void SaveFixupAddress::ScanCodeSpace(CodeSpace *space) { for (PolyWord *pt = space->bottom; pt < space->top; ) { pt++; PolyObject *obj = (PolyObject*)pt; #ifdef POLYML32IN64 PolyObject *dest = obj; while (dest->ContainsForwardingPtr()) { MemSpace *space = gMem.SpaceForAddress((PolyWord*)dest - 1); if (space->isCode) dest = (PolyObject*)(globalCodeBase + ((dest->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); else dest = dest->GetForwardingPtr(); } #else PolyObject *dest = obj->FollowForwardingChain(); #endif POLYUNSIGNED length = dest->Length(); if (length != 0) ScanAddressesInObject(obj, dest->LengthWord()); pt += length; } } // Called by the root thread to actually save the state and write the file. void SaveRequest::Perform() { if (debugOptions & DEBUG_SAVING) Log("SAVE: Beginning saving state.\n"); // Check that we aren't overwriting our own parent. for (unsigned q = 0; q < newHierarchy-1; q++) { if (sameFile(hierarchyTable[q]->fileName, fileName)) { errorMessage = "File being saved is used as a parent of this file"; errCode = 0; if (debugOptions & DEBUG_SAVING) Log("SAVE: File being saved is used as a parent of this file.\n"); return; } } SaveStateExport exports; // Open the file. This could quite reasonably fail if the path is wrong. exports.exportFile = _tfopen(fileName, _T("wb")); if (exports.exportFile == NULL) { errorMessage = "Cannot open save file"; errCode = ERRORNUMBER; if (debugOptions & DEBUG_SAVING) Log("SAVE: Cannot open save file.\n"); return; } // Scan over the permanent mutable area copying all reachable data that is // not in a lower hierarchy into new permanent segments. CopyScan copyScan(newHierarchy); copyScan.initialise(false); bool success = true; try { for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { PermanentMemSpace *space = *i; if (space->isMutable && !space->noOverwrite && !space->byteOnly) { if (debugOptions & DEBUG_SAVING) Log("SAVE: Scanning permanent mutable area %p allocated at %p size %lu\n", space, space->bottom, space->spaceSize()); copyScan.ScanAddressesInRegion(space->bottom, space->top); } } } catch (MemoryException &) { success = false; if (debugOptions & DEBUG_SAVING) Log("SAVE: Scan of permanent mutable area raised memory exception.\n"); } // Copy the areas into the export object. Make sufficient space for // the largest possible number of entries. exports.memTable = new memoryTableEntry[gMem.eSpaces.size()+gMem.pSpaces.size()+1]; unsigned memTableCount = 0; // Permanent spaces at higher level. These have to have entries although // only the mutable entries will be written. for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { PermanentMemSpace *space = *i; if (space->hierarchy < newHierarchy) { memoryTableEntry *entry = &exports.memTable[memTableCount++]; 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->noOverwrite) entry->mtFlags |= MTF_NO_OVERWRITE; if (space->byteOnly) entry->mtFlags |= MTF_BYTES; } if (space->isCode) entry->mtFlags |= MTF_EXECUTABLE; } } unsigned permanentEntries = memTableCount; // Remember where new entries start. // Newly created spaces. for (std::vector::iterator i = gMem.eSpaces.begin(); i < gMem.eSpaces.end(); i++) { memoryTableEntry *entry = &exports.memTable[memTableCount++]; PermanentMemSpace *space = *i; 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->noOverwrite) entry->mtFlags |= MTF_NO_OVERWRITE; if (space->byteOnly) entry->mtFlags |= MTF_BYTES; } if (space->isCode) entry->mtFlags |= MTF_EXECUTABLE; } exports.memTableEntries = memTableCount; if (debugOptions & DEBUG_SAVING) Log("SAVE: Updating references to moved objects.\n"); // Update references to moved objects. SaveFixupAddress fixup; for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *space = *i; fixup.ScanAddressesInRegion(space->bottom, space->lowerAllocPtr); fixup.ScanAddressesInRegion(space->upperAllocPtr, space->top); } for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) fixup.ScanCodeSpace(*i); GCModules(&fixup); // Restore the length words in the code areas. // Although we've updated any pointers to the start of the code we could have return addresses // pointing to the original code. GCModules updates the stack but doesn't update return addresses. for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { CodeSpace *space = *i; for (PolyWord *pt = space->bottom; pt < space->top; ) { pt++; PolyObject *obj = (PolyObject*)pt; if (obj->ContainsForwardingPtr()) { #ifdef POLYML32IN64 PolyObject *forwardedTo = obj; while (forwardedTo->ContainsForwardingPtr()) forwardedTo = (PolyObject*)(globalCodeBase + ((forwardedTo->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); #else PolyObject *forwardedTo = obj->FollowForwardingChain(); #endif POLYUNSIGNED lengthWord = forwardedTo->LengthWord(); - obj->SetLengthWord(lengthWord); + space->writeAble(obj)->SetLengthWord(lengthWord); } pt += obj->Length(); } } // Update the global memory space table. Old segments at the same level // or lower are removed. The new segments become permanent. // Try to promote the spaces even if we've had a failure because export // spaces are deleted in ~CopyScan and we may have already copied // some objects there. if (debugOptions & DEBUG_SAVING) Log("SAVE: Promoting export spaces to permanent spaces.\n"); if (! gMem.PromoteExportSpaces(newHierarchy) || ! success) { errorMessage = "Out of Memory"; errCode = NOMEMORY; if (debugOptions & DEBUG_SAVING) Log("SAVE: Unable to promote export spaces.\n"); return; } // Remove any deeper entries from the hierarchy table. while (hierarchyDepth > newHierarchy-1) { hierarchyDepth--; delete(hierarchyTable[hierarchyDepth]); hierarchyTable[hierarchyDepth] = 0; } if (debugOptions & DEBUG_SAVING) Log("SAVE: Writing out data.\n"); // Write out the file header. SavedStateHeader saveHeader; memset(&saveHeader, 0, sizeof(saveHeader)); saveHeader.headerLength = sizeof(saveHeader); memcpy(saveHeader.headerSignature, SAVEDSTATESIGNATURE, sizeof(saveHeader.headerSignature)); saveHeader.headerVersion = SAVEDSTATEVERSION; saveHeader.segmentDescrLength = sizeof(SavedStateSegmentDescr); if (newHierarchy == 1) saveHeader.parentTimeStamp = exportTimeStamp; else { saveHeader.parentTimeStamp = hierarchyTable[newHierarchy-2]->timeStamp; saveHeader.parentNameEntry = sizeof(TCHAR); // Always the first entry. } saveHeader.timeStamp = getBuildTime(); saveHeader.segmentDescrCount = exports.memTableEntries; // One segment for each space. #ifdef POLYML32IN64 saveHeader.originalBaseAddr = globalHeapBase; #endif // Write out the header. fwrite(&saveHeader, sizeof(saveHeader), 1, exports.exportFile); // We need a segment header for each permanent area whether it is // actually in this file or not. SavedStateSegmentDescr *descrs = new SavedStateSegmentDescr [exports.memTableEntries]; for (unsigned j = 0; j < exports.memTableEntries; j++) { memoryTableEntry *entry = &exports.memTable[j]; memset(&descrs[j], 0, sizeof(SavedStateSegmentDescr)); descrs[j].relocationSize = sizeof(RelocationEntry); descrs[j].segmentIndex = (unsigned)entry->mtIndex; descrs[j].segmentSize = entry->mtLength; // Set this even if we don't write it. descrs[j].originalAddress = entry->mtOriginalAddr; if (entry->mtFlags & MTF_WRITEABLE) { descrs[j].segmentFlags |= SSF_WRITABLE; if (entry->mtFlags & MTF_NO_OVERWRITE) descrs[j].segmentFlags |= SSF_NOOVERWRITE; if (j < permanentEntries && (entry->mtFlags & MTF_NO_OVERWRITE) == 0) descrs[j].segmentFlags |= SSF_OVERWRITE; if (entry->mtFlags & MTF_BYTES) descrs[j].segmentFlags |= SSF_BYTES; } if (entry->mtFlags & MTF_EXECUTABLE) descrs[j].segmentFlags |= SSF_CODE; } // Write out temporarily. Will be overwritten at the end. saveHeader.segmentDescr = ftell(exports.exportFile); fwrite(descrs, sizeof(SavedStateSegmentDescr), exports.memTableEntries, exports.exportFile); // Write out the relocations and the data. for (unsigned k = 1 /* Not IO area */; k < exports.memTableEntries; k++) { memoryTableEntry *entry = &exports.memTable[k]; // Write out the contents if this is new or if it is a normal, overwritable // mutable area. if (k >= permanentEntries || (entry->mtFlags & (MTF_WRITEABLE|MTF_NO_OVERWRITE)) == MTF_WRITEABLE) { descrs[k].relocations = ftell(exports.exportFile); // Have to write this out. exports.relocationCount = 0; // Create the relocation table. char *start = (char*)entry->mtOriginalAddr; char *end = start + entry->mtLength; for (PolyWord *p = (PolyWord*)start; p < (PolyWord*)end; ) { p++; PolyObject *obj = (PolyObject*)p; POLYUNSIGNED length = obj->Length(); // Most relocations can be computed when the saved state is // loaded so we only write out the difficult ones: those that // occur within compiled code. // exports.relocateObject(obj); if (length != 0 && obj->IsCodeObject()) machineDependent->ScanConstantsWithinCode(obj, &exports); p += length; } descrs[k].relocationCount = exports.relocationCount; // Write out the data. descrs[k].segmentData = ftell(exports.exportFile); fwrite(entry->mtOriginalAddr, entry->mtLength, 1, exports.exportFile); } } // If this is a child we need to write a string table containing the parent name. if (newHierarchy > 1) { saveHeader.stringTable = ftell(exports.exportFile); _fputtc(0, exports.exportFile); // First byte of string table is zero _fputts(hierarchyTable[newHierarchy-2]->fileName, exports.exportFile); _fputtc(0, exports.exportFile); // A terminating null. saveHeader.stringTableSize = (_tcslen(hierarchyTable[newHierarchy-2]->fileName) + 2)*sizeof(TCHAR); } // Rewrite the header and the segment tables now they're complete. fseek(exports.exportFile, 0, SEEK_SET); fwrite(&saveHeader, sizeof(saveHeader), 1, exports.exportFile); fwrite(descrs, sizeof(SavedStateSegmentDescr), exports.memTableEntries, exports.exportFile); if (debugOptions & DEBUG_SAVING) Log("SAVE: Writing complete.\n"); // Add an entry to the hierarchy table for this file. (void)AddHierarchyEntry(fileName, saveHeader.timeStamp); delete[](descrs); CheckMemory(); } // Write a saved state file. POLYUNSIGNED PolySaveState(PolyObject *threadId, PolyWord fileName, PolyWord depth) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { TempString fileNameBuff(Poly_string_to_T_alloc(fileName)); // The value of depth is zero for top-level save so we need to add one for hierarchy. unsigned newHierarchy = get_C_unsigned(taskData, depth) + 1; if (newHierarchy > hierarchyDepth + 1) raise_fail(taskData, "Depth must be no more than the current hierarchy plus one"); // Request a full GC first. The main reason is to avoid running out of memory as a // result of repeated saves. Old export spaces are turned into local spaces and // the GC will delete them if they are completely empty FullGC(taskData); SaveRequest request(fileNameBuff, newHierarchy); processes->MakeRootRequest(taskData, &request); if (request.errorMessage) raise_syscall(taskData, request.errorMessage, request.errCode); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } /* * Loading saved state files. */ class StateLoader: public MainThreadRequest { public: StateLoader(bool isH, Handle files): MainThreadRequest(MTP_LOADSTATE), isHierarchy(isH), fileNameList(files), errorResult(0), errNumber(0) { } virtual void Perform(void); bool LoadFile(bool isInitial, time_t requiredStamp, PolyWord tail); bool isHierarchy; Handle fileNameList; const char *errorResult; // The fileName here is the last file loaded. As well as using it // to load the name can also be printed out at the end to identify the // particular file in the hierarchy that failed. AutoFree fileName; int errNumber; }; // Called by the main thread once all the ML threads have stopped. void StateLoader::Perform(void) { // Copy the first file name into the buffer. if (isHierarchy) { if (ML_Cons_Cell::IsNull(fileNameList->Word())) { errorResult = "Hierarchy list is empty"; return; } ML_Cons_Cell *p = DEREFLISTHANDLE(fileNameList); fileName = Poly_string_to_T_alloc(p->h); if (fileName == NULL) { errorResult = "Insufficient memory"; errNumber = NOMEMORY; return; } (void)LoadFile(true, 0, p->t); } else { fileName = Poly_string_to_T_alloc(fileNameList->Word()); if (fileName == NULL) { errorResult = "Insufficient memory"; errNumber = NOMEMORY; return; } (void)LoadFile(true, 0, TAGGED(0)); } } class ClearWeakByteRef: public ScanAddress { public: ClearWeakByteRef() {} virtual PolyObject *ScanObjectAddress(PolyObject *base) { return base; } virtual void ScanAddressesInObject(PolyObject *base, POLYUNSIGNED lengthWord); }; // Set the values of external references and clear the values of other weak byte refs. void ClearWeakByteRef::ScanAddressesInObject(PolyObject *base, POLYUNSIGNED lengthWord) { if (OBJ_IS_MUTABLE_OBJECT(lengthWord) && OBJ_IS_BYTE_OBJECT(lengthWord) && OBJ_IS_WEAKREF_OBJECT(lengthWord)) { POLYUNSIGNED len = OBJ_OBJECT_LENGTH(lengthWord); if (len > 0) base->Set(0, PolyWord::FromSigned(0)); setEntryPoint(base); } } // This is copied from the B-tree in MemMgr. It probably should be // merged but will do for the moment. It's intended to reduce the // cost of finding the segment for relocation. class SpaceBTree { public: SpaceBTree(bool is, unsigned i = 0) : isLeaf(is), index(i) { } virtual ~SpaceBTree() {} bool isLeaf; unsigned index; // The index if this is a leaf }; // A non-leaf node in the B-tree class SpaceBTreeTree : public SpaceBTree { public: SpaceBTreeTree(); virtual ~SpaceBTreeTree(); SpaceBTree *tree[256]; }; SpaceBTreeTree::SpaceBTreeTree() : SpaceBTree(false) { for (unsigned i = 0; i < 256; i++) tree[i] = 0; } SpaceBTreeTree::~SpaceBTreeTree() { for (unsigned i = 0; i < 256; i++) delete(tree[i]); } // This class is used to relocate addresses in areas that have been loaded. class LoadRelocate: public ScanAddress { public: LoadRelocate(bool pcc = false): processCodeConstants(pcc), originalBaseAddr(0), descrs(0), targetAddresses(0), nDescrs(0), spaceTree(0) {} ~LoadRelocate(); void RelocateObject(PolyObject *p); virtual PolyObject *ScanObjectAddress(PolyObject *base) { ASSERT(0); return base; } // Not used virtual void ScanConstant(PolyObject *base, byte *addressOfConstant, ScanRelocationKind code); void RelocateAddressAt(PolyWord *pt); PolyObject *RelocateAddress(PolyObject *obj); void AddTreeRange(SpaceBTree **t, unsigned index, uintptr_t startS, uintptr_t endS); bool processCodeConstants; PolyWord *originalBaseAddr; SavedStateSegmentDescr *descrs; PolyWord **targetAddresses; unsigned nDescrs; SpaceBTree *spaceTree; intptr_t relativeOffset; }; LoadRelocate::~LoadRelocate() { if (descrs) delete[](descrs); if (targetAddresses) delete[](targetAddresses); delete(spaceTree); } // Add an entry to the space B-tree. void LoadRelocate::AddTreeRange(SpaceBTree **tt, unsigned index, uintptr_t startS, uintptr_t endS) { if (*tt == 0) *tt = new SpaceBTreeTree; ASSERT(!(*tt)->isLeaf); SpaceBTreeTree *t = (SpaceBTreeTree*)*tt; const unsigned shift = (sizeof(void*) - 1) * 8; // Takes the high-order byte uintptr_t r = startS >> shift; ASSERT(r < 256); const uintptr_t s = endS == 0 ? 256 : endS >> shift; ASSERT(s >= r && s <= 256); if (r == s) // Wholly within this entry AddTreeRange(&(t->tree[r]), index, startS << 8, endS << 8); else { // Deal with any remainder at the start. if ((r << shift) != startS) { AddTreeRange(&(t->tree[r]), index, startS << 8, 0 /*End of range*/); r++; } // Whole entries. while (r < s) { ASSERT(t->tree[r] == 0); t->tree[r] = new SpaceBTree(true, index); r++; } // Remainder at the end. if ((s << shift) != endS) AddTreeRange(&(t->tree[r]), index, 0, endS << 8); } } // Update the addresses in a group of words. void LoadRelocate::RelocateAddressAt(PolyWord *pt) { PolyWord val = *pt; if (! val.IsTagged()) - *pt = RelocateAddress(val.AsObjPtr(originalBaseAddr)); + *gMem.SpaceForAddress(pt)->writeAble(pt) = RelocateAddress(val.AsObjPtr(originalBaseAddr)); } PolyObject *LoadRelocate::RelocateAddress(PolyObject *obj) { // Which segment is this address in? // N.B. As with SpaceForAddress we need to subtract 1 to point to the length word. uintptr_t t = (uintptr_t)((PolyWord*)obj - 1); SpaceBTree *tr = spaceTree; // Each level of the tree is either a leaf or a vector of trees. unsigned j = sizeof(void *) * 8; for (;;) { if (tr == 0) break; if (tr->isLeaf) { // It's in this segment: relocate it to the current position. unsigned i = tr->index; SavedStateSegmentDescr *descr = &descrs[i]; PolyWord *newAddress = targetAddresses[descr->segmentIndex]; ASSERT((char*)obj > descr->originalAddress && (char*)obj <= (char*)descr->originalAddress + descr->segmentSize); ASSERT(newAddress != 0); byte *setAddress = (byte*)newAddress + ((char*)obj - (char*)descr->originalAddress); return (PolyObject*)setAddress; } j -= 8; tr = ((SpaceBTreeTree*)tr)->tree[(t >> j) & 0xff]; } // This should never happen. ASSERT(0); return 0; } // This is based on Exporter::relocateObject but does the reverse. // It attempts to adjust all the addresses in the object when it has // been read in. void LoadRelocate::RelocateObject(PolyObject *p) { if (p->IsByteObject()) { } else if (p->IsCodeObject()) { POLYUNSIGNED constCount; PolyWord *cp; ASSERT(! p->IsMutable() ); p->GetConstSegmentForCode(cp, constCount); /* Now the constant area. */ for (POLYUNSIGNED i = 0; i < constCount; i++) RelocateAddressAt(&(cp[i])); // Saved states and modules have relocation entries for constants in the code. // We can't use them when loading object files in 32-in-64 so have to process the // constants here. if (processCodeConstants) { POLYUNSIGNED length = p->Length(); machineDependent->ScanConstantsWithinCode(p, p, length, this); } } else if (p->IsClosureObject()) { // The first word is the address of the code. POLYUNSIGNED length = p->Length(); *(PolyObject**)p = RelocateAddress(*(PolyObject**)p); for (POLYUNSIGNED i = sizeof(PolyObject*)/sizeof(PolyWord); i < length; i++) RelocateAddressAt(p->Offset(i)); } else /* Ordinary objects, essentially tuples. */ { POLYUNSIGNED length = p->Length(); for (POLYUNSIGNED i = 0; i < length; i++) RelocateAddressAt(p->Offset(i)); } } // Update addresses as constants within the code. void LoadRelocate::ScanConstant(PolyObject *base, byte *addressOfConstant, ScanRelocationKind code) { PolyObject *p = GetConstantValue(addressOfConstant, code, originalBaseAddr); if (p != 0) { // Relative addresses are computed by adding the CURRENT address. // We have to convert them into addresses in original space before we // can relocate them. if (code == PROCESS_RELOC_I386RELATIVE) p = (PolyObject*)((PolyWord*)p + relativeOffset); PolyObject *newValue = RelocateAddress(p); SetConstantValue(addressOfConstant, newValue, code); } } // Load a saved state file. Calls itself to handle parent files. bool StateLoader::LoadFile(bool isInitial, time_t requiredStamp, PolyWord tail) { LoadRelocate relocate; AutoFree thisFile(_tcsdup(fileName)); AutoClose loadFile(_tfopen(fileName, _T("rb"))); if ((FILE*)loadFile == NULL) { errorResult = "Cannot open load file"; errNumber = ERRORNUMBER; return false; } SavedStateHeader header; // Read the header and check the signature. if (fread(&header, sizeof(SavedStateHeader), 1, loadFile) != 1) { errorResult = "Unable to load header"; return false; } if (strncmp(header.headerSignature, SAVEDSTATESIGNATURE, sizeof(header.headerSignature)) != 0) { errorResult = "File is not a saved state"; return false; } if (header.headerVersion != SAVEDSTATEVERSION || header.headerLength != sizeof(SavedStateHeader) || header.segmentDescrLength != sizeof(SavedStateSegmentDescr)) { errorResult = "Unsupported version of saved state file"; return false; } // Check that we have the required stamp before loading any children. // If a parent has been overwritten we could get a loop. if (! isInitial && header.timeStamp != requiredStamp) { // Time-stamps don't match. errorResult = "The parent for this saved state does not match or has been changed"; return false; } // Have verified that this is a reasonable saved state file. If it isn't a // top-level file we have to load the parents first. if (header.parentNameEntry != 0) { if (isHierarchy) { // Take the file name from the list if (ML_Cons_Cell::IsNull(tail)) { errorResult = "Missing parent name in argument list"; return false; } ML_Cons_Cell *p = (ML_Cons_Cell *)tail.AsObjPtr(); fileName = Poly_string_to_T_alloc(p->h); if (fileName == NULL) { errorResult = "Insufficient memory"; errNumber = NOMEMORY; return false; } if (! LoadFile(false, header.parentTimeStamp, p->t)) return false; } else { size_t toRead = header.stringTableSize-header.parentNameEntry; size_t elems = ((toRead + sizeof(TCHAR) - 1) / sizeof(TCHAR)); // Always allow space for null terminator size_t roundedBytes = (elems + 1) * sizeof(TCHAR); TCHAR *newFileName = (TCHAR *)realloc(fileName, roundedBytes); if (newFileName == NULL) { errorResult = "Insufficient memory"; errNumber = NOMEMORY; return false; } fileName = newFileName; if (header.parentNameEntry >= header.stringTableSize /* Bad entry */ || fseek(loadFile, header.stringTable + header.parentNameEntry, SEEK_SET) != 0 || fread(fileName, 1, toRead, loadFile) != toRead) { errorResult = "Unable to read parent file name"; return false; } fileName[elems] = 0; // Should already be null-terminated, but just in case. if (! LoadFile(false, header.parentTimeStamp, TAGGED(0))) return false; } ASSERT(hierarchyDepth > 0 && hierarchyTable[hierarchyDepth-1] != 0); } else // Top-level file { if (isHierarchy && ! ML_Cons_Cell::IsNull(tail)) { // There should be no further file names if this is really the top. errorResult = "Too many file names in the list"; return false; } if (header.parentTimeStamp != exportTimeStamp) { // Time-stamp does not match executable. errorResult = "Saved state was exported from a different executable or the executable has changed"; return false; } // Any existing spaces at this level or greater must be turned // into local spaces. We may have references from the stack to objects that // have previously been imported but otherwise these spaces are no longer // needed. gMem.DemoteImportSpaces(); // Clean out the hierarchy table. for (unsigned h = 0; h < hierarchyDepth; h++) { delete(hierarchyTable[h]); hierarchyTable[h] = 0; } hierarchyDepth = 0; } // Now have a valid, matching saved state. // Load the segment descriptors. relocate.nDescrs = header.segmentDescrCount; relocate.descrs = new SavedStateSegmentDescr[relocate.nDescrs]; relocate.originalBaseAddr = (PolyWord*)header.originalBaseAddr; if (fseek(loadFile, header.segmentDescr, SEEK_SET) != 0 || fread(relocate.descrs, sizeof(SavedStateSegmentDescr), relocate.nDescrs, loadFile) != relocate.nDescrs) { errorResult = "Unable to read segment descriptors"; return false; } { unsigned maxIndex = 0; for (unsigned i = 0; i < relocate.nDescrs; i++) { if (relocate.descrs[i].segmentIndex > maxIndex) maxIndex = relocate.descrs[i].segmentIndex; relocate.AddTreeRange(&relocate.spaceTree, i, (uintptr_t)relocate.descrs[i].originalAddress, (uintptr_t)((char*)relocate.descrs[i].originalAddress + relocate.descrs[i].segmentSize-1)); } relocate.targetAddresses = new PolyWord*[maxIndex+1]; for (unsigned i = 0; i <= maxIndex; i++) relocate.targetAddresses[i] = 0; } // Read in and create the new segments first. If we have problems, // in particular if we have run out of memory, then it's easier to recover. for (unsigned i = 0; i < relocate.nDescrs; i++) { SavedStateSegmentDescr *descr = &relocate.descrs[i]; MemSpace *space = gMem.SpaceForIndex(descr->segmentIndex); if (space != NULL) relocate.targetAddresses[descr->segmentIndex] = space->bottom; if (descr->segmentData == 0) { // No data - just an entry in the index. if (space == NULL/* || descr->segmentSize != (size_t)((char*)space->top - (char*)space->bottom)*/) { errorResult = "Mismatch for existing memory space"; return false; } } else if ((descr->segmentFlags & SSF_OVERWRITE) == 0) { // New segment. if (space != NULL) { errorResult = "Segment already exists"; return false; } // Allocate memory for the new segment. unsigned mFlags = (descr->segmentFlags & SSF_WRITABLE ? MTF_WRITEABLE : 0) | (descr->segmentFlags & SSF_NOOVERWRITE ? MTF_NO_OVERWRITE : 0) | (descr->segmentFlags & SSF_BYTES ? MTF_BYTES : 0) | (descr->segmentFlags & SSF_CODE ? MTF_EXECUTABLE : 0); PermanentMemSpace *newSpace = gMem.AllocateNewPermanentSpace(descr->segmentSize, mFlags, descr->segmentIndex, hierarchyDepth + 1); if (newSpace == 0) { errorResult = "Unable to allocate memory"; return false; } PolyWord *mem = newSpace->bottom; + PolyWord* writeAble = newSpace->writeAble(mem); if (fseek(loadFile, descr->segmentData, SEEK_SET) != 0 || - fread(mem, descr->segmentSize, 1, loadFile) != 1) + fread(writeAble, descr->segmentSize, 1, loadFile) != 1) { errorResult = "Unable to read segment"; return false; } // Fill unused space to the top of the area. - gMem.FillUnusedSpace(mem+descr->segmentSize/sizeof(PolyWord), + gMem.FillUnusedSpace(writeAble +descr->segmentSize/sizeof(PolyWord), newSpace->spaceSize() - descr->segmentSize/sizeof(PolyWord)); // Leave it writable until we've done the relocations. relocate.targetAddresses[descr->segmentIndex] = mem; if (newSpace->isMutable && newSpace->byteOnly) { ClearWeakByteRef cwbr; cwbr.ScanAddressesInRegion(newSpace->bottom, newSpace->topPointer); } } } // Now read in the mutable overwrites and relocate. for (unsigned j = 0; j < relocate.nDescrs; j++) { SavedStateSegmentDescr *descr = &relocate.descrs[j]; MemSpace *space = gMem.SpaceForIndex(descr->segmentIndex); ASSERT(space != NULL); // We should have created it. if (descr->segmentFlags & SSF_OVERWRITE) { if (fseek(loadFile, descr->segmentData, SEEK_SET) != 0 || fread(space->bottom, descr->segmentSize, 1, loadFile) != 1) { errorResult = "Unable to read segment"; return false; } } // Relocation. if (descr->segmentData != 0) { // Adjust the addresses in the loaded segment. for (PolyWord *p = space->bottom; p < space->top; ) { p++; PolyObject *obj = (PolyObject*)p; POLYUNSIGNED length = obj->Length(); relocate.RelocateObject(obj); p += length; } } // Process explicit relocations. // If we get errors just skip the error and continue rather than leave // everything in an unstable state. if (descr->relocations) { if (fseek(loadFile, descr->relocations, SEEK_SET) != 0) { errorResult = "Unable to read relocation segment"; return false; } for (unsigned k = 0; k < descr->relocationCount; k++) { RelocationEntry reloc; if (fread(&reloc, sizeof(reloc), 1, loadFile) != 1) { errorResult = "Unable to read relocation segment"; return false; } MemSpace *toSpace = gMem.SpaceForIndex(reloc.targetSegment); if (toSpace == NULL) { errorResult = "Unknown space reference in relocation"; continue; } byte *setAddress = (byte*)space->bottom + reloc.relocAddress; byte *targetAddress = (byte*)toSpace->bottom + reloc.targetAddress; if (setAddress >= (byte*)space->top || targetAddress >= (byte*)toSpace->top) { errorResult = "Bad relocation"; continue; } ScanAddress::SetConstantValue(setAddress, (PolyObject*)(targetAddress), reloc.relKind); } } } // Set the final permissions. for (unsigned j = 0; j < relocate.nDescrs; j++) { SavedStateSegmentDescr *descr = &relocate.descrs[j]; - PermanentMemSpace *space = gMem.SpaceForIndex(descr->segmentIndex); - gMem.CompletePermanentSpaceAllocation(space); + if (descr->segmentData != 0) + { + PermanentMemSpace* space = gMem.SpaceForIndex(descr->segmentIndex); + gMem.CompletePermanentSpaceAllocation(space); + } } // Add an entry to the hierarchy table for this file. if (! AddHierarchyEntry(thisFile, header.timeStamp)) return false; return true; // Succeeded } static void LoadState(TaskData *taskData, bool isHierarchy, Handle hFileList) // Load a saved state or a hierarchy. // hFileList is a list if this is a hierarchy and a single name if it is not. { StateLoader loader(isHierarchy, hFileList); // Request the main thread to do the load. This may set the error string if it failed. processes->MakeRootRequest(taskData, &loader); if (loader.errorResult != 0) { if (loader.errNumber == 0) raise_fail(taskData, loader.errorResult); else { AutoFree buff((char *)malloc(strlen(loader.errorResult) + 2 + _tcslen(loader.fileName) * sizeof(TCHAR) + 1)); #if (defined(_WIN32) && defined(UNICODE)) sprintf(buff, "%s: %S", loader.errorResult, (TCHAR *)loader.fileName); #else sprintf(buff, "%s: %s", loader.errorResult, (TCHAR *)loader.fileName); #endif raise_syscall(taskData, buff, loader.errNumber); } } } // Load a saved state file and any ancestors. POLYUNSIGNED PolyLoadState(PolyObject *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 { LoadState(taskData, false, pushedArg); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } // Load hierarchy. This provides a complete list of children and parents. POLYUNSIGNED PolyLoadHierarchy(PolyObject *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 { LoadState(taskData, true, pushedArg); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } /* * Additional functions to provide information or change saved-state files. */ // These functions do not affect the global state so can be executed by // the ML threads directly. static Handle ShowHierarchy(TaskData *taskData) // Return the list of files in the hierarchy. { Handle saved = taskData->saveVec.mark(); Handle list = SAVE(ListNull); // Process this in reverse order. for (unsigned i = hierarchyDepth; i > 0; i--) { Handle value = SAVE(C_string_to_Poly(taskData, hierarchyTable[i-1]->fileName)); Handle next = alloc_and_save(taskData, sizeof(ML_Cons_Cell)/sizeof(PolyWord)); DEREFLISTHANDLE(next)->h = value->Word(); DEREFLISTHANDLE(next)->t = list->Word(); taskData->saveVec.reset(saved); list = SAVE(next->Word()); } return list; } // Show the hierarchy. POLYUNSIGNED PolyShowHierarchy(PolyObject *threadId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = ShowHierarchy(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(); } static void RenameParent(TaskData *taskData, PolyWord childName, PolyWord parentName) // Change the name of the immediate parent stored in a child { // The name of the file to modify. AutoFree fileNameBuff(Poly_string_to_T_alloc(childName)); if (fileNameBuff == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); // The new parent name to insert. AutoFree parentNameBuff(Poly_string_to_T_alloc(parentName)); if (parentNameBuff == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); AutoClose loadFile(_tfopen(fileNameBuff, _T("r+b"))); // Open for reading and writing if ((FILE*)loadFile == NULL) { AutoFree buff((char *)malloc(23 + _tcslen(fileNameBuff) * sizeof(TCHAR) + 1)); #if (defined(_WIN32) && defined(UNICODE)) sprintf(buff, "Cannot open load file: %S", (TCHAR *)fileNameBuff); #else sprintf(buff, "Cannot open load file: %s", (TCHAR *)fileNameBuff); #endif raise_syscall(taskData, buff, ERRORNUMBER); } SavedStateHeader header; // Read the header and check the signature. if (fread(&header, sizeof(SavedStateHeader), 1, loadFile) != 1) raise_fail(taskData, "Unable to load header"); if (strncmp(header.headerSignature, SAVEDSTATESIGNATURE, sizeof(header.headerSignature)) != 0) raise_fail(taskData, "File is not a saved state"); if (header.headerVersion != SAVEDSTATEVERSION || header.headerLength != sizeof(SavedStateHeader) || header.segmentDescrLength != sizeof(SavedStateSegmentDescr)) { raise_fail(taskData, "Unsupported version of saved state file"); } // Does this actually have a parent? if (header.parentNameEntry == 0) raise_fail(taskData, "File does not have a parent"); // At the moment the only entry in the string table is the parent // name so we can simply write a new one on the end of the file. // This makes the file grow slightly each time but it shouldn't be // significant. fseek(loadFile, 0, SEEK_END); header.stringTable = ftell(loadFile); // Remember where this is _fputtc(0, loadFile); // First byte of string table is zero _fputts(parentNameBuff, loadFile); _fputtc(0, loadFile); // A terminating null. header.stringTableSize = (_tcslen(parentNameBuff) + 2)*sizeof(TCHAR); // Now rewind and write the header with the revised string table. fseek(loadFile, 0, SEEK_SET); fwrite(&header, sizeof(header), 1, loadFile); } POLYUNSIGNED PolyRenameParent(PolyObject *threadId, PolyWord childName, PolyWord parentName) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { RenameParent(taskData, childName, parentName); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } static Handle ShowParent(TaskData *taskData, Handle hFileName) // Return the name of the immediate parent stored in a child { AutoFree fileNameBuff(Poly_string_to_T_alloc(hFileName->Word())); if (fileNameBuff == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); AutoClose loadFile(_tfopen(fileNameBuff, _T("rb"))); if ((FILE*)loadFile == NULL) { AutoFree buff((char *)malloc(23 + _tcslen(fileNameBuff) * sizeof(TCHAR) + 1)); if (buff == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); #if (defined(_WIN32) && defined(UNICODE)) sprintf(buff, "Cannot open load file: %S", (TCHAR *)fileNameBuff); #else sprintf(buff, "Cannot open load file: %s", (TCHAR *)fileNameBuff); #endif raise_syscall(taskData, buff, ERRORNUMBER); } SavedStateHeader header; // Read the header and check the signature. if (fread(&header, sizeof(SavedStateHeader), 1, loadFile) != 1) raise_fail(taskData, "Unable to load header"); if (strncmp(header.headerSignature, SAVEDSTATESIGNATURE, sizeof(header.headerSignature)) != 0) raise_fail(taskData, "File is not a saved state"); if (header.headerVersion != SAVEDSTATEVERSION || header.headerLength != sizeof(SavedStateHeader) || header.segmentDescrLength != sizeof(SavedStateSegmentDescr)) { raise_fail(taskData, "Unsupported version of saved state file"); } // Does this have a parent? if (header.parentNameEntry != 0) { size_t toRead = header.stringTableSize-header.parentNameEntry; size_t elems = ((toRead + sizeof(TCHAR) - 1) / sizeof(TCHAR)); // Always allow space for null terminator size_t roundedBytes = (elems + 1) * sizeof(TCHAR); AutoFree parentFileName((TCHAR *)malloc(roundedBytes)); if (parentFileName == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (header.parentNameEntry >= header.stringTableSize /* Bad entry */ || fseek(loadFile, header.stringTable + header.parentNameEntry, SEEK_SET) != 0 || fread(parentFileName, 1, toRead, loadFile) != toRead) { raise_fail(taskData, "Unable to read parent file name"); } parentFileName[elems] = 0; // Should already be null-terminated, but just in case. // Convert the name into a Poly string and then build a "Some" value. // It's possible, although silly, to have the empty string as a parent name. Handle resVal = SAVE(C_string_to_Poly(taskData, parentFileName)); Handle result = alloc_and_save(taskData, 1); DEREFHANDLE(result)->Set(0, resVal->Word()); return result; } else return SAVE(NONE_VALUE); } // Return the name of the immediate parent stored in a child POLYUNSIGNED PolyShowParent(PolyObject *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 = ShowParent(taskData, pushedArg); } 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(); } // Module system #define MODULESIGNATURE "POLYMODU" #define MODULEVERSION 2 typedef struct _moduleHeader { // These entries are primarily to check that we have a valid // saved state file before we try to interpret anything else. char headerSignature[8]; // Should contain MODULESIGNATURE unsigned headerVersion; // Should contain MODULEVERSION unsigned headerLength; // Number of bytes in the header unsigned segmentDescrLength; // Number of bytes in a descriptor // These entries contain the real data. off_t segmentDescr; // Position of segment descriptor table unsigned segmentDescrCount; // Number of segment descriptors in the table time_t timeStamp; // The time stamp for this file. time_t executableTimeStamp; // The time stamp for the parent executable. // Root uintptr_t rootSegment; POLYUNSIGNED rootOffset; } ModuleHeader; // Store a module class ModuleStorer: public MainThreadRequest { public: ModuleStorer(const TCHAR *file, Handle r): MainThreadRequest(MTP_STOREMODULE), fileName(file), root(r), errorMessage(0), errCode(0) {} virtual void Perform(); const TCHAR *fileName; Handle root; const char *errorMessage; int errCode; }; class ModuleExport: public SaveStateExport { public: ModuleExport(): SaveStateExport(1/* Everything EXCEPT the executable. */) {} virtual void exportStore(void); // Write the data out. }; void ModuleStorer::Perform() { ModuleExport exporter; #if (defined(_WIN32) && defined(UNICODE)) exporter.exportFile = _wfopen(fileName, L"wb"); #else exporter.exportFile = fopen(fileName, "wb"); #endif if (exporter.exportFile == NULL) { errorMessage = "Cannot open export file"; errCode = ERRORNUMBER; return; } // RunExport copies everything reachable from the root, except data from // the executable because we've set the hierarchy to 1, using CopyScan. // It builds the tables in the export data structure then calls exportStore // to actually write the data. if (! root->Word().IsDataPtr()) { // If we have a completely empty module the list may be null. // This needs to be dealt with at a higher level. errorMessage = "Module root is not an address"; return; } exporter.RunExport(root->WordP()); errorMessage = exporter.errorMessage; // This will be null unless there's been an error. } void ModuleExport::exportStore(void) { // What we need to do here is implement the export in a similar way to e.g. PECOFFExport::exportStore // This is copied from SaveRequest::Perform and should be common code. ModuleHeader modHeader; memset(&modHeader, 0, sizeof(modHeader)); modHeader.headerLength = sizeof(modHeader); memcpy(modHeader.headerSignature, MODULESIGNATURE, sizeof(modHeader.headerSignature)); modHeader.headerVersion = MODULEVERSION; modHeader.segmentDescrLength = sizeof(SavedStateSegmentDescr); modHeader.executableTimeStamp = exportTimeStamp; { unsigned rootArea = findArea(this->rootFunction); struct _memTableEntry *mt = &memTable[rootArea]; modHeader.rootSegment = mt->mtIndex; modHeader.rootOffset = (POLYUNSIGNED)((char*)this->rootFunction - (char*)mt->mtOriginalAddr); } modHeader.timeStamp = getBuildTime(); modHeader.segmentDescrCount = this->memTableEntries; // One segment for each space. // Write out the header. fwrite(&modHeader, sizeof(modHeader), 1, this->exportFile); SavedStateSegmentDescr *descrs = new SavedStateSegmentDescr [this->memTableEntries]; // We need an entry in the descriptor tables for each segment in the executable because // we may have relocations that refer to addresses in it. for (unsigned j = 0; j < this->memTableEntries; j++) { SavedStateSegmentDescr *thisDescr = &descrs[j]; memoryTableEntry *entry = &this->memTable[j]; memset(thisDescr, 0, sizeof(SavedStateSegmentDescr)); thisDescr->relocationSize = sizeof(RelocationEntry); thisDescr->segmentIndex = (unsigned)entry->mtIndex; thisDescr->segmentSize = entry->mtLength; // Set this even if we don't write it. thisDescr->originalAddress = entry->mtOriginalAddr; if (entry->mtFlags & MTF_WRITEABLE) { thisDescr->segmentFlags |= SSF_WRITABLE; if (entry->mtFlags & MTF_NO_OVERWRITE) thisDescr->segmentFlags |= SSF_NOOVERWRITE; if ((entry->mtFlags & MTF_NO_OVERWRITE) == 0) thisDescr->segmentFlags |= SSF_OVERWRITE; if (entry->mtFlags & MTF_BYTES) thisDescr->segmentFlags |= SSF_BYTES; } if (entry->mtFlags & MTF_EXECUTABLE) thisDescr->segmentFlags |= SSF_CODE; } // Write out temporarily. Will be overwritten at the end. modHeader.segmentDescr = ftell(this->exportFile); fwrite(descrs, sizeof(SavedStateSegmentDescr), this->memTableEntries, this->exportFile); // Write out the relocations and the data. for (unsigned k = 0; k < this->memTableEntries; k++) { SavedStateSegmentDescr *thisDescr = &descrs[k]; memoryTableEntry *entry = &this->memTable[k]; if (k >= newAreas) // Not permanent areas { thisDescr->relocations = ftell(this->exportFile); // Have to write this out. this->relocationCount = 0; // Create the relocation table. char *start = (char*)entry->mtOriginalAddr; char *end = start + entry->mtLength; for (PolyWord *p = (PolyWord*)start; p < (PolyWord*)end; ) { p++; PolyObject *obj = (PolyObject*)p; POLYUNSIGNED length = obj->Length(); // For saved states we don't include explicit relocations except // in code but it's easier if we do for modules. if (length != 0 && obj->IsCodeObject()) machineDependent->ScanConstantsWithinCode(obj, this); relocateObject(obj); p += length; } thisDescr->relocationCount = this->relocationCount; // Write out the data. thisDescr->segmentData = ftell(exportFile); fwrite(entry->mtOriginalAddr, entry->mtLength, 1, exportFile); } } // Rewrite the header and the segment tables now they're complete. fseek(exportFile, 0, SEEK_SET); fwrite(&modHeader, sizeof(modHeader), 1, exportFile); fwrite(descrs, sizeof(SavedStateSegmentDescr), this->memTableEntries, exportFile); delete[](descrs); fclose(exportFile); exportFile = NULL; } // Store a module POLYUNSIGNED PolyStoreModule(PolyObject *threadId, PolyWord name, PolyWord contents) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedContents = taskData->saveVec.push(contents); try { TempString fileName(name); ModuleStorer storer(fileName, pushedContents); processes->MakeRootRequest(taskData, &storer); if (storer.errorMessage) raise_syscall(taskData, storer.errorMessage, storer.errCode); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } // Load a module. class ModuleLoader: public MainThreadRequest { public: ModuleLoader(TaskData *taskData, const TCHAR *file): MainThreadRequest(MTP_LOADMODULE), callerTaskData(taskData), fileName(file), errorResult(NULL), errNumber(0), rootHandle(0) {} virtual void Perform(); TaskData *callerTaskData; const TCHAR *fileName; const char *errorResult; int errNumber; Handle rootHandle; }; void ModuleLoader::Perform() { AutoClose loadFile(_tfopen(fileName, _T("rb"))); if ((FILE*)loadFile == NULL) { errorResult = "Cannot open load file"; errNumber = ERRORNUMBER; return; } ModuleHeader header; // Read the header and check the signature. if (fread(&header, sizeof(ModuleHeader), 1, loadFile) != 1) { errorResult = "Unable to load header"; return; } if (strncmp(header.headerSignature, MODULESIGNATURE, sizeof(header.headerSignature)) != 0) { errorResult = "File is not a Poly/ML module"; return; } if (header.headerVersion != MODULEVERSION || header.headerLength != sizeof(ModuleHeader) || header.segmentDescrLength != sizeof(SavedStateSegmentDescr)) { errorResult = "Unsupported version of module file"; return; } if (header.executableTimeStamp != exportTimeStamp) { // Time-stamp does not match executable. errorResult = "Module was exported from a different executable or the executable has changed"; return; } LoadRelocate relocate; relocate.nDescrs = header.segmentDescrCount; relocate.descrs = new SavedStateSegmentDescr[relocate.nDescrs]; if (fseek(loadFile, header.segmentDescr, SEEK_SET) != 0 || fread(relocate.descrs, sizeof(SavedStateSegmentDescr), relocate.nDescrs, loadFile) != relocate.nDescrs) { errorResult = "Unable to read segment descriptors"; return; } { unsigned maxIndex = 0; for (unsigned i = 0; i < relocate.nDescrs; i++) if (relocate.descrs[i].segmentIndex > maxIndex) maxIndex = relocate.descrs[i].segmentIndex; relocate.targetAddresses = new PolyWord*[maxIndex+1]; for (unsigned i = 0; i <= maxIndex; i++) relocate.targetAddresses[i] = 0; } // Read in and create the new segments first. If we have problems, // in particular if we have run out of memory, then it's easier to recover. for (unsigned i = 0; i < relocate.nDescrs; i++) { SavedStateSegmentDescr *descr = &relocate.descrs[i]; MemSpace *space = gMem.SpaceForIndex(descr->segmentIndex); if (descr->segmentData == 0) { // No data - just an entry in the index. if (space == NULL/* || descr->segmentSize != (size_t)((char*)space->top - (char*)space->bottom)*/) { errorResult = "Mismatch for existing memory space"; return; } else relocate.targetAddresses[descr->segmentIndex] = space->bottom; } else { // New segment. if (space != NULL) { errorResult = "Segment already exists"; return; } // Allocate memory for the new segment. size_t actualSize = descr->segmentSize; MemSpace *space; if (descr->segmentFlags & SSF_CODE) { CodeSpace *cSpace = gMem.NewCodeSpace(actualSize); if (cSpace == 0) { errorResult = "Unable to allocate memory"; return; } space = cSpace; cSpace->firstFree = (PolyWord*)((byte*)space->bottom + descr->segmentSize); if (cSpace->firstFree != cSpace->top) gMem.FillUnusedSpace(cSpace->firstFree, cSpace->top - cSpace->firstFree); } else { LocalMemSpace *lSpace = gMem.NewLocalSpace(actualSize, descr->segmentFlags & SSF_WRITABLE); if (lSpace == 0) { errorResult = "Unable to allocate memory"; return; } space = lSpace; lSpace->lowerAllocPtr = (PolyWord*)((byte*)lSpace->bottom + descr->segmentSize); } if (fseek(loadFile, descr->segmentData, SEEK_SET) != 0 || fread(space->bottom, descr->segmentSize, 1, loadFile) != 1) { errorResult = "Unable to read segment"; return; } relocate.targetAddresses[descr->segmentIndex] = space->bottom; if (space->isMutable && (descr->segmentFlags & SSF_BYTES) != 0) { ClearWeakByteRef cwbr; cwbr.ScanAddressesInRegion(space->bottom, (PolyWord*)((byte*)space->bottom + descr->segmentSize)); } } } // Now deal with relocation. for (unsigned j = 0; j < relocate.nDescrs; j++) { SavedStateSegmentDescr *descr = &relocate.descrs[j]; PolyWord *baseAddr = relocate.targetAddresses[descr->segmentIndex]; ASSERT(baseAddr != NULL); // We should have created it. // Process explicit relocations. // If we get errors just skip the error and continue rather than leave // everything in an unstable state. if (descr->relocations) { if (fseek(loadFile, descr->relocations, SEEK_SET) != 0) errorResult = "Unable to read relocation segment"; for (unsigned k = 0; k < descr->relocationCount; k++) { RelocationEntry reloc; if (fread(&reloc, sizeof(reloc), 1, loadFile) != 1) errorResult = "Unable to read relocation segment"; byte *setAddress = (byte*)baseAddr + reloc.relocAddress; byte *targetAddress = (byte*)relocate.targetAddresses[reloc.targetSegment] + reloc.targetAddress; ScanAddress::SetConstantValue(setAddress, (PolyObject*)(targetAddress), reloc.relKind); } } } // Get the root address. Push this to the caller's save vec. If we put the // newly created areas into local memory we could get a GC as soon as we // complete this root request. { PolyWord *baseAddr = relocate.targetAddresses[header.rootSegment]; rootHandle = callerTaskData->saveVec.push((PolyObject*)((byte*)baseAddr + header.rootOffset)); } } static Handle LoadModule(TaskData *taskData, Handle args) { TempString fileName(args->Word()); ModuleLoader loader(taskData, fileName); processes->MakeRootRequest(taskData, &loader); if (loader.errorResult != 0) { if (loader.errNumber == 0) raise_fail(taskData, loader.errorResult); else { AutoFree buff((char *)malloc(strlen(loader.errorResult) + 2 + _tcslen(loader.fileName) * sizeof(TCHAR) + 1)); #if (defined(_WIN32) && defined(UNICODE)) sprintf(buff, "%s: %S", loader.errorResult, loader.fileName); #else sprintf(buff, "%s: %s", loader.errorResult, loader.fileName); #endif raise_syscall(taskData, buff, loader.errNumber); } } return loader.rootHandle; } // Load a module POLYUNSIGNED PolyLoadModule(PolyObject *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 = LoadModule(taskData, pushedArg); } 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(); } PolyObject *InitHeaderFromExport(struct _exportDescription *exports) { // Check the structure sizes stored in the export structure match the versions // used in this library. if (exports->structLength != sizeof(exportDescription) || exports->memTableSize != sizeof(memoryTableEntry) || exports->rtsVersion < FIRST_supported_version || exports->rtsVersion > LAST_supported_version) { #if (FIRST_supported_version == LAST_supported_version) Exit("The exported object file has version %0.2f but this library supports %0.2f", ((float)exports->rtsVersion) / 100.0, ((float)FIRST_supported_version) / 100.0); #else Exit("The exported object file has version %0.2f but this library supports %0.2f-%0.2f", ((float)exports->rtsVersion) / 100.0, ((float)FIRST_supported_version) / 100.0, ((float)LAST_supported_version) / 100.0); #endif } // We could also check the RTS version and the architecture. exportTimeStamp = exports->timeStamp; // Needed for load and save. memoryTableEntry *memTable = exports->memTable; #ifdef POLYML32IN64 // We need to copy this into the heap before beginning execution. // This is very like loading a saved state and the code should probably // be merged. LoadRelocate relocate(true); relocate.nDescrs = exports->memTableEntries; relocate.descrs = new SavedStateSegmentDescr[relocate.nDescrs]; relocate.targetAddresses = new PolyWord*[exports->memTableEntries]; relocate.originalBaseAddr = (PolyWord*)exports->originalBaseAddr; PolyObject *root = 0; for (unsigned i = 0; i < exports->memTableEntries; i++) { relocate.descrs[i].segmentIndex = memTable[i].mtIndex; relocate.descrs[i].originalAddress = memTable[i].mtOriginalAddr; relocate.descrs[i].segmentSize = memTable[i].mtLength; PermanentMemSpace *newSpace = gMem.AllocateNewPermanentSpace(memTable[i].mtLength, (unsigned)memTable[i].mtFlags, (unsigned)memTable[i].mtIndex); if (newSpace == 0) Exit("Unable to initialise a permanent memory space"); PolyWord *mem = newSpace->bottom; - memcpy(mem, memTable[i].mtCurrentAddr, memTable[i].mtLength); - gMem.FillUnusedSpace(mem + memTable[i].mtLength / sizeof(PolyWord), + memcpy(newSpace->writeAble(mem), memTable[i].mtCurrentAddr, memTable[i].mtLength); + PolyWord* unused = mem + memTable[i].mtLength / sizeof(PolyWord); + gMem.FillUnusedSpace(newSpace->writeAble(unused), newSpace->spaceSize() - memTable[i].mtLength / sizeof(PolyWord)); if (newSpace == 0) Exit("Unable to initialise a permanent memory space"); relocate.targetAddresses[i] = mem; relocate.AddTreeRange(&relocate.spaceTree, i, (uintptr_t)relocate.descrs[i].originalAddress, (uintptr_t)((char*)relocate.descrs[i].originalAddress + relocate.descrs[i].segmentSize - 1)); // Relocate the root function. if (exports->rootFunction >= memTable[i].mtCurrentAddr && exports->rootFunction < (char*)memTable[i].mtCurrentAddr + memTable[i].mtLength) { root = (PolyObject*)((char*)mem + ((char*)exports->rootFunction - (char*)memTable[i].mtCurrentAddr)); } } // Now relocate the addresses for (unsigned j = 0; j < exports->memTableEntries; j++) { SavedStateSegmentDescr *descr = &relocate.descrs[j]; MemSpace *space = gMem.SpaceForIndex(descr->segmentIndex); // Any relative addresses have to be corrected by adding this. relocate.relativeOffset = (PolyWord*)descr->originalAddress - space->bottom; for (PolyWord *p = space->bottom; p < space->top; ) { #ifdef POLYML32IN64 if ((((uintptr_t)p) & 4) == 0) { // Skip any padding. The length word should be on an odd-word boundary. p++; continue; } #endif p++; PolyObject *obj = (PolyObject*)p; POLYUNSIGNED length = obj->Length(); relocate.RelocateObject(obj); p += length; } } // Set the final permissions. for (unsigned j = 0; j < exports->memTableEntries; j++) { PermanentMemSpace *space = gMem.SpaceForIndex(memTable[j].mtIndex); gMem.CompletePermanentSpaceAllocation(space); } return root; #else for (unsigned i = 0; i < exports->memTableEntries; i++) { // Construct a new space for each of the entries. if (gMem.NewPermanentSpace( (PolyWord*)memTable[i].mtCurrentAddr, memTable[i].mtLength / sizeof(PolyWord), (unsigned)memTable[i].mtFlags, (unsigned)memTable[i].mtIndex) == 0) Exit("Unable to initialise a permanent memory space"); } return (PolyObject *)exports->rootFunction; #endif } // Return the system directory for modules. This is configured differently // in Unix and in Windows. POLYUNSIGNED PolyGetModuleDirectory(PolyObject *threadId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { #if (defined(MODULEDIR)) result = SAVE(C_string_to_Poly(taskData, MODULEDIR)); #elif (defined(_WIN32)) { // This registry key is configured when Poly/ML is installed using the installer. // It gives the path to the Poly/ML installation directory. We return the // Modules subdirectory. HKEY hk; if (RegOpenKeyEx(HKEY_LOCAL_MACHINE, _T("SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\PolyML.exe"), 0, KEY_QUERY_VALUE, &hk) == ERROR_SUCCESS) { DWORD valSize; if (RegQueryValueEx(hk, _T("Path"), 0, NULL, NULL, &valSize) == ERROR_SUCCESS) { #define MODULEDIR _T("Modules") TempString buff((TCHAR*)malloc(valSize + (_tcslen(MODULEDIR) + 1) * sizeof(TCHAR))); DWORD dwType; if (RegQueryValueEx(hk, _T("Path"), 0, &dwType, (LPBYTE)(LPTSTR)buff, &valSize) == ERROR_SUCCESS) { // The registry entry should end with a backslash. _tcscat(buff, MODULEDIR); result = SAVE(C_string_to_Poly(taskData, buff)); } } RegCloseKey(hk); } result = SAVE(C_string_to_Poly(taskData, "")); } #else result = SAVE(C_string_to_Poly(taskData, "")); #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(); } struct _entrypts savestateEPT[] = { { "PolySaveState", (polyRTSFunction)&PolySaveState }, { "PolyLoadState", (polyRTSFunction)&PolyLoadState }, { "PolyShowHierarchy", (polyRTSFunction)&PolyShowHierarchy }, { "PolyRenameParent", (polyRTSFunction)&PolyRenameParent }, { "PolyShowParent", (polyRTSFunction)&PolyShowParent }, { "PolyStoreModule", (polyRTSFunction)&PolyStoreModule }, { "PolyLoadModule", (polyRTSFunction)&PolyLoadModule }, { "PolyLoadHierarchy", (polyRTSFunction)&PolyLoadHierarchy }, { "PolyGetModuleDirectory", (polyRTSFunction)&PolyGetModuleDirectory }, { NULL, NULL } // End of list. }; diff --git a/libpolyml/scanaddrs.cpp b/libpolyml/scanaddrs.cpp index d6c5992c..ebdfc997 100644 --- a/libpolyml/scanaddrs.cpp +++ b/libpolyml/scanaddrs.cpp @@ -1,288 +1,291 @@ /* 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); - + // Adjust to the read-write area if necessary. + baseAddr = gMem.SpaceForAddress(baseAddr)->writeAble(baseAddr); } 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) { + MemSpace* space = gMem.SpaceForAddress(addressOfConstant); + byte* addressToWrite = space->writeAble(addressOfConstant); 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); + addressToWrite[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); + addressToWrite[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()); } } diff --git a/libpolyml/sharedata.cpp b/libpolyml/sharedata.cpp index 2ba00703..fbea3d20 100644 --- a/libpolyml/sharedata.cpp +++ b/libpolyml/sharedata.cpp @@ -1,1117 +1,1123 @@ /* Title: Share common immutable data Copyright (c) 2000 Cambridge University Technical Services Limited - and David C. J. Matthews 2006, 2010-13, 2016-17 + and David C. J. Matthews 2006, 2010-13, 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 */ #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 #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" +#include "gc_progress.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(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: std::vector depthVectorArray[FIXEDLENGTHSIZE]; POLYUNSIGNED maxVectorSize; }; ShareDataClass::ShareDataClass() { maxVectorSize = 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. for (unsigned i = 0; i < FIXEDLENGTHSIZE; i++) { for (std::vector ::iterator j = depthVectorArray[i].begin(); j < depthVectorArray[i].end(); j++) delete(*j); } } // 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. std::vector *vectorToUse = &(depthVectorArray[length < FIXEDLENGTHSIZE ? length : 0]); if (depth >= maxVectorSize) maxVectorSize = depth+1; while (vectorToUse->size() <= depth) { try { if (length != 0 && length < FIXEDLENGTHSIZE) vectorToUse->push_back(new DepthVectorWithFixedLength(length)); else vectorToUse->push_back(new DepthVectorWithVariableLength); } catch (std::bad_alloc&) { throw MemoryException(); } } (*vectorToUse)[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 + { + PolyObject* obj = ptrVector[i]; + obj = gMem.SpaceForAddress(obj)->writeAble(obj); // This could be code. + obj->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 + gMem.SpaceForAddress(obj)->writeAble(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 + gMem.SpaceForAddress(obj)->writeAble(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].size()) { DepthVector *vec = depthVectorArray[j][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].empty()) { DepthVector *v = depthVectorArray[j][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].size()) { DepthVector *v = depthVectorArray[j][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(); + gcProgressBeginOtherGC(); // Set the phase to "other" now the GC is complete. // 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(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/statistics.cpp b/libpolyml/statistics.cpp index ee07f18c..3bde3628 100644 --- a/libpolyml/statistics.cpp +++ b/libpolyml/statistics.cpp @@ -1,838 +1,885 @@ /* - Title: statics.cpp - Profiling statistics + Title: statistics.cpp - Profiling statistics - Copyright (c) 2011, 2013, 2015, 2019 David C.J. Matthews + Copyright (c) 2011, 2013, 2015, 2019, 2020 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_WINDOWS_H #include #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_MMAN_H #include #endif #ifdef HAVE_SYS_STAT_H #include #endif #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_STRING_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_STDLIB_H #include #endif +#ifdef HAVE_ERRNO_H +#include +#endif + #if defined(HAVE_MMAP) // How do we get the page size? #ifndef HAVE_GETPAGESIZE #ifdef _SC_PAGESIZE #define getpagesize() sysconf(_SC_PAGESIZE) #else // If this fails we're stuck #define getpagesize() PAGESIZE #endif #endif #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #if (defined(_WIN32)) #include #else #define _T(x) x #endif #include #ifdef max #undef max #endif #include "run_time.h" #include "sys.h" #include "save_vec.h" #include "rts_module.h" #include "timing.h" #include "polystring.h" #include "processes.h" #include "statistics.h" #include "../polystatistics.h" #include "rtsentry.h" #include "arb.h" +#include "diagnostics.h" extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetUserStatsCount(); POLYEXTERNALSYMBOL POLYUNSIGNED PolySetUserStat(PolyObject *threadId, PolyWord index, PolyWord value); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetLocalStats(PolyObject *threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetRemoteStats(PolyObject *threadId, PolyWord procId); -// POLYEXTERNALSYMBOL POLYUNSIGNED PolySpecificGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); } #define STATS_SPACE 4096 // Enough for all the statistics #define ASN1_U_BOOL 1 #define ASN1_U_INT 2 #define ASN1_U_STRING 4 #define ASN1_U_NULL 5 #define ASN1_U_ENUM 10 #define ASN1_U_SEQUENCE 16 // For the moment we don't bother to interlock access to the statistics memory. // Other processes only read the memory and at worst they may get a glitch in // the values. Statistics::Statistics(): accessLock("Statistics") { statMemory = 0; memSize = 0; newPtr = 0; for (unsigned i = 0; i < N_PS_INTS; i++) counterAddrs[i] = 0; for (unsigned j = 0; j < N_PS_TIMES; j++) timeAddrs[j].secAddr = timeAddrs[j].usecAddr = 0; for (unsigned k = 0; k < N_PS_USER; k++) userAddrs[k] = 0; memset(&gcUserTime, 0, sizeof(gcUserTime)); memset(&gcSystemTime, 0, sizeof(gcSystemTime)); memset(&gcRealTime, 0, sizeof(gcRealTime)); -#ifdef HAVE_WINDOWS_H +#ifdef _WIN32 // File mapping handle hFileMap = NULL; exportStats = true; // Actually unused #else mapFd = -1; mapFileName = 0; exportStats = false; // Don't export by default #endif memSize = 0; statMemory = 0; newPtr = 0; } -void Statistics::Init() +#ifdef _WIN32 +// In Windows we always create shared memory for the statistics. +// If this fails just create local stats. +bool Statistics::createWindowsSharedStats() { -#if (defined(_WIN32)) - // Record an initial time of day to use as the basis of real timing - GetSystemTimeAsFileTime(&startTime); -#else - gettimeofday(&startTime, NULL); -#endif -#ifdef HAVE_WINDOWS_H // Get the process ID to use in the shared memory name DWORD pid = ::GetCurrentProcessId(); TCHAR shmName[MAX_PATH]; wsprintf(shmName, _T(POLY_STATS_NAME) _T("%lu"), pid); // Create a piece of shared memory hFileMap = CreateFileMapping(INVALID_HANDLE_VALUE, NULL, PAGE_READWRITE, 0, STATS_SPACE, shmName); - if (hFileMap == NULL) return; + if (hFileMap == NULL) return false; // If it already exists it's the wrong one. if (GetLastError() == ERROR_ALREADY_EXISTS) { CloseHandle(hFileMap); hFileMap = NULL; - return; + return false; } statMemory = (unsigned char*)MapViewOfFile(hFileMap, FILE_MAP_ALL_ACCESS, 0, 0, STATS_SPACE); if (statMemory == NULL) { CloseHandle(hFileMap); hFileMap = NULL; - return; + return false; } memSize = STATS_SPACE; + return true; +} +#endif + +void Statistics::Init() +{ +#ifdef _WIN32 + // Record an initial time of day to use as the basis of real timing + GetSystemTimeAsFileTime(&startTime); + createWindowsSharedStats(); #else -#if HAVE_MMAP + // Record an initial time of day to use as the basis of real timing + gettimeofday(&startTime, NULL); + + // On Unix we need to specify --exportstats but if we do and have a problem we exit. if (exportStats) { // Create the shared memory in the user's .polyml directory int pageSize = getpagesize(); memSize = (STATS_SPACE + pageSize-1) & ~(pageSize-1); - char *homeDir = getenv("HOME"); - if (homeDir == NULL) return; - mapFileName = (char*)malloc(strlen(homeDir) + 100); - strcpy(mapFileName, homeDir); - strcat(mapFileName, "/.polyml"); - mkdir(mapFileName, 0777); // Make the directory to ensure it exists - sprintf(mapFileName + strlen(mapFileName), "/" POLY_STATS_NAME "%d", getpid()); - // Open the file. Truncates it if it already exists. That should only happen - // if a previous run with the same process id crashed. - mapFd = open(mapFileName, O_RDWR|O_CREAT, 0444); - if (mapFd == -1) return; - // Write enough of the file to fill the space. - char ch = 0; - for (size_t i = 0; i < memSize; i++) write(mapFd, &ch, 1); - statMemory = (unsigned char*)mmap(0, memSize, PROT_READ|PROT_WRITE, MAP_SHARED, mapFd, 0); - if (statMemory == MAP_FAILED) + char* polyStatsDir = getenv("POLYSTATSDIR"); + if (!polyStatsDir || !createSharedStats(polyStatsDir, "")) { - statMemory = 0; - return; + char* homeDir = getenv("HOME"); + if (homeDir == NULL) + Exit("Unable to create shared statistics - HOME is not defined"); + if (!createSharedStats(homeDir, "/.polyml")) + Exit("Unable to create shared statistics"); } } - else #endif + if (statMemory == 0) { // If we just want the statistics locally. statMemory = (unsigned char*)calloc(STATS_SPACE, sizeof(unsigned char)); if (statMemory == 0) return; + memSize = STATS_SPACE; } -#endif // Set up the ASN1 structure in the statistics area. newPtr = statMemory; *newPtr++ = POLY_STATS_C_STATISTICS; // Context tag for statistics *newPtr++ = 0x82; // Extended length, 2 bytes *newPtr++ = 0x00; // Length is initially zero *newPtr++ = 0x00; addCounter(PSC_THREADS, POLY_STATS_ID_THREADS, "ThreadCount"); addCounter(PSC_THREADS_IN_ML, POLY_STATS_ID_THREADS_IN_ML, "ThreadsInML"); addCounter(PSC_THREADS_WAIT_IO, POLY_STATS_ID_THREADS_WAIT_IO, "ThreadsInIOWait"); addCounter(PSC_THREADS_WAIT_MUTEX, POLY_STATS_ID_THREADS_WAIT_MUTEX, "ThreadsInMutexWait"); addCounter(PSC_THREADS_WAIT_CONDVAR, POLY_STATS_ID_THREADS_WAIT_CONDVAR, "ThreadsInCondVarWait"); addCounter(PSC_THREADS_WAIT_SIGNAL, POLY_STATS_ID_THREADS_WAIT_SIGNAL, "ThreadsInSignalWait"); addCounter(PSC_GC_FULLGC, POLY_STATS_ID_GC_FULLGC, "FullGCCount"); addCounter(PSC_GC_PARTIALGC, POLY_STATS_ID_GC_PARTIALGC, "PartialGCCount"); addCounter(PSC_GC_SHARING, POLY_STATS_ID_GC_SHARING, "GCSharingCount"); + addCounter(PSC_GC_STATE, POLY_STATS_ID_GC_STATE, "GCState"); + addCounter(PSC_GC_PERCENT, POLY_STATS_ID_GC_PERCENT, "GCPercent"); addSize(PSS_TOTAL_HEAP, POLY_STATS_ID_TOTAL_HEAP, "TotalHeap"); addSize(PSS_AFTER_LAST_GC, POLY_STATS_ID_AFTER_LAST_GC, "HeapAfterLastGC"); addSize(PSS_AFTER_LAST_FULLGC, POLY_STATS_ID_AFTER_LAST_FULLGC, "HeapAfterLastFullGC"); addSize(PSS_ALLOCATION, POLY_STATS_ID_ALLOCATION, "AllocationSpace"); addSize(PSS_ALLOCATION_FREE, POLY_STATS_ID_ALLOCATION_FREE, "AllocationSpaceFree"); addSize(PSS_CODE_SPACE, POLY_STATS_ID_CODE_SPACE, "CodeSpace"); addSize(PSS_STACK_SPACE, POLY_STATS_ID_STACK_SPACE, "StackSpace"); addTime(PST_NONGC_UTIME, POLY_STATS_ID_NONGC_UTIME, "NonGCUserTime"); addTime(PST_NONGC_STIME, POLY_STATS_ID_NONGC_STIME, "NonGCSystemTime"); addTime(PST_GC_UTIME, POLY_STATS_ID_GC_UTIME, "GCUserTime"); addTime(PST_GC_STIME, POLY_STATS_ID_GC_STIME, "GCSystemTime"); addTime(PST_NONGC_RTIME, POLY_STATS_ID_NONGC_RTIME, "NonGCRealTime"); addTime(PST_GC_RTIME, POLY_STATS_ID_GC_RTIME, "GCRealTime"); addUser(0, POLY_STATS_ID_USER0, "UserCounter0"); addUser(1, POLY_STATS_ID_USER1, "UserCounter1"); addUser(2, POLY_STATS_ID_USER2, "UserCounter2"); addUser(3, POLY_STATS_ID_USER3, "UserCounter3"); addUser(4, POLY_STATS_ID_USER4, "UserCounter4"); addUser(5, POLY_STATS_ID_USER5, "UserCounter5"); addUser(6, POLY_STATS_ID_USER6, "UserCounter6"); addUser(7, POLY_STATS_ID_USER7, "UserCounter7"); } +#ifndef _WIN32 +// Try to create a shared memory file in the appropriate directory. +bool Statistics::createSharedStats(const char* baseName, const char* subDirName) +{ + size_t tMapSize = strlen(baseName) + strlen(subDirName) + strlen(POLY_STATS_NAME) + 100; + TempCString tMapFileName((char*)malloc(tMapSize)); + // First construct the directory name because it may not exist. + if (subDirName[0] != 0) + { + int cx = snprintf(tMapFileName, tMapSize, "%s%s", baseName, subDirName); + if (cx < 0 || (size_t)cx >= tMapSize) + return -1; + mkdir(tMapFileName, 0777); + } + int cx = snprintf(tMapFileName, tMapSize, "%s%s/%s%d", baseName, subDirName, POLY_STATS_NAME, getpid()); + if (cx < 0 || (size_t)cx >= tMapSize) + return -1; + // Remove any existing file. We're creating with 0444 so if there's an old one + // left over from a previous crash we won't be able to reopen it. + unlink(tMapFileName); + // Open the file. + mapFd = open(tMapFileName, O_RDWR | O_CREAT, 0444); + if (mapFd == -1) return false; + if (ftruncate(mapFd, memSize) == -1) return false; + statMemory = (unsigned char*)mmap(0, memSize, PROT_READ | PROT_WRITE, MAP_SHARED, mapFd, 0); + if (statMemory == MAP_FAILED) return false; + memset(statMemory, 0, memSize); + // Set the file name to this. + mapFileName = tMapFileName; + tMapFileName = 0; + return true; +} + +#endif + void Statistics::addCounter(int cEnum, unsigned statId, const char *name) { // Tag header *newPtr++ = POLY_STATS_C_COUNTERSTAT; *newPtr++ = 0x00; // Initial length - overwritten at the end unsigned char *tagStart = newPtr; // First item - Id of this statistic - Implicit int *newPtr++ = POLY_STATS_C_IDENTIFIER; *newPtr++ = 0x01; ASSERT(statId < 128); *newPtr++ = statId; // Second item - The name size_t nameLength = strlen(name); ASSERT(nameLength < 125); *newPtr++ = POLY_STATS_C_NAME; *newPtr++ = (unsigned char)nameLength; for (unsigned i = 0; i < nameLength; i++) *newPtr++ = name[i]; // Third item - the counter itself. // This, along with the other counters, is technically incorrect // for an ASN1 integer because it should not contain more than // one zero byte. *newPtr++ = POLY_STATS_C_COUNTER_VALUE; *newPtr++ = sizeof(POLYUNSIGNED); counterAddrs[cEnum] = newPtr; // This is the address for (unsigned j = 0; j < sizeof(POLYUNSIGNED); j++) *newPtr++ = 0; // Finally set the tag length and the overall size. size_t length = newPtr - tagStart; ASSERT(length < 128); tagStart[-1] = (unsigned char)length; // Set the overall size. length = newPtr-statMemory - 4; statMemory[2] = (length >> 8) & 0xff; statMemory[3] = length & 0xff; } void Statistics::addSize(int cEnum, unsigned statId, const char *name) { // Tag header *newPtr++ = POLY_STATS_C_SIZESTAT; *newPtr++ = 0x00; // Initial length - overwritten at the end unsigned char *tagStart = newPtr; // First item - Id of this statistic - Implicit int *newPtr++ = POLY_STATS_C_IDENTIFIER; *newPtr++ = 0x01; ASSERT(statId < 128); *newPtr++ = statId; // Second item - The name size_t nameLength = strlen(name); ASSERT(nameLength < 125); *newPtr++ = POLY_STATS_C_NAME; *newPtr++ = (unsigned char)nameLength; for (unsigned i = 0; i < nameLength; i++) *newPtr++ = name[i]; // Third item - the size value itself. We have to allow one // byte extra to ensure that the value we encode is unsigned. unsigned bytes = sizeof(size_t) + 1; *newPtr++ = POLY_STATS_C_BYTE_COUNT; *newPtr++ = bytes; counterAddrs[cEnum] = newPtr; // This is the address for (unsigned j = 0; j < bytes; j++) *newPtr++ = 0; // Finally set the tag length and the overall size. size_t length = newPtr - tagStart; ASSERT(length < 128); tagStart[-1] = (unsigned char)length; // Set the overall size. length = newPtr-statMemory - 4; statMemory[2] = (length >> 8) & 0xff; statMemory[3] = length & 0xff; } void Statistics::addTime(int cEnum, unsigned statId, const char *name) { // Tag header *newPtr++ = POLY_STATS_C_TIMESTAT; *newPtr++ = 0x00; // Initial length - overwritten at the end unsigned char *tagStart = newPtr; // First item - Id of this statistic - Implicit int *newPtr++ = POLY_STATS_C_IDENTIFIER; *newPtr++ = 0x01; ASSERT(statId < 128); *newPtr++ = statId; // Second item - The name size_t nameLength = strlen(name); ASSERT(nameLength < 125); *newPtr++ = POLY_STATS_C_NAME; *newPtr++ = (unsigned char)nameLength; for (unsigned i = 0; i < nameLength; i++) *newPtr++ = name[i]; // Third item - the time. Two four byte values. *newPtr++ = POLY_STATS_C_TIME; *newPtr++ = 12; *newPtr++ = POLY_STATS_C_SECONDS; *newPtr++ = 4; timeAddrs[cEnum].secAddr = newPtr; // This is the address for (unsigned j = 0; j < 4; j++) *newPtr++ = 0; *newPtr++ = POLY_STATS_C_MICROSECS; *newPtr++ = 4; timeAddrs[cEnum].usecAddr = newPtr; // This is the address for (unsigned k = 0; k < 4; k++) *newPtr++ = 0; // Finally set the tag length and the overall size. size_t length = newPtr - tagStart; ASSERT(length < 128); tagStart[-1] = (unsigned char)length; // Set the overall size. length = newPtr-statMemory - 4; statMemory[2] = (length >> 8) & 0xff; statMemory[3] = length & 0xff; } void Statistics::addUser(int n, unsigned statId, const char *name) { // Tag header *newPtr++ = POLY_STATS_C_USERSTAT; *newPtr++ = 0x00; // Initial length - overwritten at the end unsigned char *tagStart = newPtr; // First item - Id of this statistic - Implicit int *newPtr++ = POLY_STATS_C_IDENTIFIER; *newPtr++ = 0x01; ASSERT(statId < 128); *newPtr++ = statId; // Second item - The name size_t nameLength = strlen(name); ASSERT(nameLength < 125); *newPtr++ = POLY_STATS_C_NAME; *newPtr++ = (unsigned char)nameLength; for (unsigned i = 0; i < nameLength; i++) *newPtr++ = name[i]; // Third item - the counter itself. For a user counter the value is a POLYSIGNED. *newPtr++ = POLY_STATS_C_COUNTER_VALUE; *newPtr++ = sizeof(POLYSIGNED); userAddrs[n] = newPtr; // This is the address for (unsigned j = 0; j < sizeof(POLYSIGNED); j++) *newPtr++ = 0; // Finally set the tag length and the overall size. size_t length = newPtr - tagStart; ASSERT(length < 128); tagStart[-1] = (unsigned char)length; // Set the overall size. length = newPtr-statMemory - 4; statMemory[2] = (length >> 8) & 0xff; statMemory[3] = length & 0xff; } Statistics::~Statistics() { -#ifdef HAVE_WINDOWS_H - if (statMemory != NULL) ::UnmapViewOfFile(statMemory); - if (hFileMap != NULL) ::CloseHandle(hFileMap); +#ifdef _WIN32 + if (hFileMap != NULL) + { + if (statMemory != NULL) ::UnmapViewOfFile(statMemory); + ::CloseHandle(hFileMap); + statMemory = NULL; + } #else -#if HAVE_MMAP if (mapFileName != 0) { if (statMemory != 0 && statMemory != MAP_FAILED) munmap(statMemory, memSize); if (mapFd != -1) close(mapFd); if (mapFileName != 0) unlink(mapFileName); free(mapFileName); + statMemory = NULL; } - else #endif - { + if (statMemory) free(statMemory); - } -#endif } // Counters. These are used for thread state so need interlocks void Statistics::incCount(int which) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); unsigned length = counterAddrs[which][-1]; while (length--) { if ((++counterAddrs[which][length]) != 0) break; } } } void Statistics::decCount(int which) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); unsigned length = counterAddrs[which][-1]; while (length--) { if ((counterAddrs[which][length]--) != 0) break; } } } +// This is only used for the GC progress which could really fit in a single byte. +void Statistics::setCount(int which, POLYUNSIGNED count) +{ + if (statMemory && counterAddrs[which]) + { + PLocker lock(&accessLock); + unsigned length = counterAddrs[which][-1]; + while (length--) + { + counterAddrs[which][length] = (unsigned char)(count & 0xff); + count = count >> 8; + } + } +} + // Sizes. Some of these are only set during GC so may not need interlocks size_t Statistics::getSizeWithLock(int which) { unsigned length = counterAddrs[which][-1]; size_t result = 0; for (unsigned i = 0; i < length; i++) result = (result << 8) | counterAddrs[which][i]; return result; } void Statistics::setSizeWithLock(int which, size_t s) { unsigned length = counterAddrs[which][-1]; while (length--) { counterAddrs[which][length] = (unsigned char)(s & 0xff); s = s >> 8; } } void Statistics::setSize(int which, size_t s) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); setSizeWithLock(which, s); } } void Statistics::incSize(int which, size_t s) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); setSizeWithLock(which, getSizeWithLock(which) + s); } } void Statistics::decSize(int which, size_t s) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); setSizeWithLock(which, getSizeWithLock(which) - s); } } size_t Statistics::getSize(int which) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); return getSizeWithLock(which); } else return 0; } void Statistics::setTimeValue(int which, unsigned long secs, unsigned long usecs) { if (statMemory && timeAddrs[which].secAddr && timeAddrs[which].usecAddr) { PLocker lock(&accessLock); // Necessary ??? unsigned sLength = timeAddrs[which].secAddr[-1]; while (sLength--) { timeAddrs[which].secAddr[sLength] = (unsigned char)(secs & 0xff); secs = secs >> 8; } unsigned usLength = timeAddrs[which].usecAddr[-1]; while (usLength--) { timeAddrs[which].usecAddr[usLength] = (unsigned char)(usecs & 0xff); usecs = usecs >> 8; } } } #if (defined(_WIN32)) // Native Windows void Statistics::copyGCTimes(const FILETIME &gcUtime, const FILETIME &gcStime, const FILETIME &gcRtime) { gcUserTime = gcUtime; gcSystemTime = gcStime; ULARGE_INTEGER li; li.LowPart = gcUtime.dwLowDateTime; li.HighPart = gcUtime.dwHighDateTime; setTimeValue(PST_GC_UTIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); li.LowPart = gcStime.dwLowDateTime; li.HighPart = gcStime.dwHighDateTime; setTimeValue(PST_GC_STIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); li.LowPart = gcRtime.dwLowDateTime; li.HighPart = gcRtime.dwHighDateTime; setTimeValue(PST_GC_RTIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); } #else // Unix void Statistics::copyGCTimes(const struct timeval &gcUtime, const struct timeval &gcStime, const struct timeval &gcRtime) { gcUserTime = gcUtime; gcSystemTime = gcStime; setTimeValue(PST_GC_UTIME, gcUtime.tv_sec, gcUtime.tv_usec); setTimeValue(PST_GC_STIME, gcStime.tv_sec, gcStime.tv_usec); setTimeValue(PST_GC_RTIME, gcRtime.tv_sec, gcRtime.tv_usec); } #endif // Update the statistics that are not otherwise copied. Called from the // root thread every second. void Statistics::updatePeriodicStats(size_t freeWords, unsigned threadsInML) { setSize(PSS_ALLOCATION_FREE, freeWords*sizeof(PolyWord)); #if (defined(_WIN32)) FILETIME ct, et, st, ut, rt; GetProcessTimes(GetCurrentProcess(), &ct, &et, &st, &ut); GetSystemTimeAsFileTime(&rt); subFiletimes(&st, &gcSystemTime); subFiletimes(&ut, &gcUserTime); subFiletimes(&rt, &startTime); subFiletimes(&rt, &gcRealTime); ULARGE_INTEGER li; li.LowPart = ut.dwLowDateTime; li.HighPart = ut.dwHighDateTime; setTimeValue(PST_NONGC_UTIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); li.LowPart = st.dwLowDateTime; li.HighPart = st.dwHighDateTime; setTimeValue(PST_NONGC_STIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); li.LowPart = rt.dwLowDateTime; li.HighPart = rt.dwHighDateTime; setTimeValue(PST_NONGC_RTIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); #else struct rusage usage; struct timeval tv; getrusage(RUSAGE_SELF, &usage); gettimeofday(&tv, NULL); subTimevals(&usage.ru_stime, &gcSystemTime); subTimevals(&usage.ru_utime, &gcUserTime); subTimevals(&tv, &startTime); subTimevals(&tv, &gcRealTime); setTimeValue(PST_NONGC_UTIME, usage.ru_utime.tv_sec, usage.ru_utime.tv_usec); setTimeValue(PST_NONGC_STIME, usage.ru_stime.tv_sec, usage.ru_stime.tv_usec); setTimeValue(PST_NONGC_RTIME, tv.tv_sec, tv.tv_usec); #endif if (statMemory && counterAddrs[PSC_THREADS_IN_ML]) { PLocker lock(&accessLock); unsigned length = counterAddrs[PSC_THREADS_IN_ML][-1]; while (length--) { counterAddrs[PSC_THREADS_IN_ML][length] = (unsigned char)(threadsInML & 0xff); threadsInML = threadsInML >> 8; } } } void Statistics::setUserCounter(unsigned which, POLYSIGNED value) { if (statMemory && userAddrs[which]) { PLocker lock(&accessLock); // Not really needed // The ASN1 int is big-endian unsigned length = userAddrs[which][-1]; while (length--) { userAddrs[which][length] = (unsigned char)value; value = value >> 8; } } } -Handle Statistics::returnStatistics(TaskData *taskData, unsigned char *stats) +Handle Statistics::returnStatistics(TaskData *taskData, const unsigned char *stats, size_t size) { - // Parse the ASN1 tag and length. - unsigned char *p = stats; - if (*p == POLY_STATS_C_STATISTICS) // Check and skip the tag - { - p++; - if ((*p & 0x80) == 0) - p += *p + 1; - else - { - int lengthOfLength = *p++ & 0x7f; - if (lengthOfLength != 0) - { - unsigned l = 0; - while (lengthOfLength--) - l = (l << 8) | *p++; - p += l; - } - } - } - return taskData->saveVec.push(C_string_to_Poly(taskData, (const char*)stats, p - stats)); + // Just return the memory as a string i.e. Word8Vector.vector. + return taskData->saveVec.push(C_string_to_Poly(taskData, (const char*)stats, size)); } // Copy the local statistics into the buffer Handle Statistics::getLocalStatistics(TaskData *taskData) { if (statMemory == 0) raise_exception_string(taskData, EXC_Fail, "No statistics available"); - return returnStatistics(taskData, statMemory); + return returnStatistics(taskData, statMemory, memSize); } // Get statistics for a remote instance. We don't do any locking Handle Statistics::getRemoteStatistics(TaskData *taskData, POLYUNSIGNED pid) { -#ifdef HAVE_WINDOWS_H +#ifdef _WIN32 TCHAR shmName[MAX_PATH]; - wsprintf(shmName, _T(POLY_STATS_NAME) _T("%") _T(POLYUFMT), pid); + wsprintf(shmName, _T(POLY_STATS_NAME) _T("%lu"), pid); HANDLE hRemMemory = OpenFileMapping(FILE_MAP_READ, FALSE, shmName); if (hRemMemory == NULL) raise_exception_string(taskData, EXC_Fail, "No statistics available"); unsigned char *sMem = (unsigned char *)MapViewOfFile(hRemMemory, FILE_MAP_READ, 0, 0, 0); - CloseHandle(hRemMemory); if (sMem == NULL) + { + CloseHandle(hRemMemory); raise_exception_string(taskData, EXC_Fail, "No statistics available"); - if (*sMem != POLY_STATS_C_STATISTICS) + } + // The size may not be the size of the statistics for this process + // because we may be using a different version of Poly/ML. It should + // still be properly formatted ASN1. + MEMORY_BASIC_INFORMATION memInfo; + SIZE_T buffSize = VirtualQuery(sMem, &memInfo, sizeof(memInfo)); + if (buffSize == 0) { UnmapViewOfFile(sMem); - raise_exception_string(taskData, EXC_Fail, "Statistics data malformed"); + CloseHandle(hRemMemory); + raise_exception_string(taskData, EXC_Fail, "Unable to get statistics"); } - Handle result = returnStatistics(taskData, sMem); + Handle result = returnStatistics(taskData, sMem, memInfo.RegionSize); UnmapViewOfFile(sMem); + CloseHandle(hRemMemory); return result; -#elif HAVE_MMAP - // Find the shared memory in the user's home directory - char *homeDir = getenv("HOME"); - if (homeDir == NULL) - raise_exception_string(taskData, EXC_Fail, "No statistics available"); - +#else int remMapFd = -1; - size_t remMapSize = 4096; - TempCString remMapFileName((char *)malloc(remMapSize)); - if (remMapFileName == NULL) - raise_exception_string(taskData, EXC_Fail, "No statistics available"); - - while ((snprintf(remMapFileName, remMapSize, "%s/.polyml/" POLY_STATS_NAME "%" POLYUFMT, homeDir, pid), strlen(remMapFileName) >= remMapSize - 1)) { - if (remMapSize > std::numeric_limits::max() / 2) - raise_exception_string(taskData, EXC_Fail, "No statistics available"); - remMapSize *= 2; - char *newFileName = (char *)realloc(remMapFileName, remMapSize); - if (newFileName == NULL) - raise_exception_string(taskData, EXC_Fail, "No statistics available"); - remMapFileName = newFileName; + char* polyStatsDir = getenv("POLYSTATSDIR"); + if (polyStatsDir) remMapFd = openSharedStats(polyStatsDir, "", pid); + if (remMapFd == -1) + { + char* homeDir = getenv("HOME"); + if (homeDir) remMapFd = openSharedStats(homeDir, "/.polyml", pid); } - - remMapFd = open(remMapFileName, O_RDONLY); if (remMapFd == -1) raise_exception_string(taskData, EXC_Fail, "No statistics available"); - unsigned char *sMem = (unsigned char*)mmap(0, remMapSize, PROT_READ, MAP_PRIVATE, remMapFd, 0); - if (sMem == MAP_FAILED) + + struct stat statBuf; + if (fstat(remMapFd, &statBuf) == -1) { close(remMapFd); raise_exception_string(taskData, EXC_Fail, "No statistics available"); } - // Check the tag. - if (*sMem != POLY_STATS_C_STATISTICS) + + TempCString statData((char*)malloc(statBuf.st_size)); + if (statData == NULL) { - munmap(sMem, remMapSize); close(remMapFd); - raise_exception_string(taskData, EXC_Fail, "Statistics data malformed"); + raise_exception_string(taskData, EXC_Fail, "No statistics available"); } - Handle result = returnStatistics(taskData, sMem); - munmap(sMem, remMapSize); + + ssize_t haveRead = read(remMapFd, statData, statBuf.st_size); close(remMapFd); - return result; -#else - raise_exception_string(taskData, EXC_Fail, "No statistics available"); + + if (haveRead < 0) + raise_exception_string(taskData, EXC_Fail, "No statistics available"); + + return returnStatistics(taskData, (const unsigned char*)(const char *)statData, statBuf.st_size); #endif } +#ifndef _WIN32 +// Try to open a shared statistics file +int Statistics::openSharedStats(const char* baseName, const char* subDirName, int pid) +{ + size_t remMapSize = strlen(baseName) + strlen(subDirName) + strlen(POLY_STATS_NAME) + 100; + TempCString remMapFileName((char*)malloc(remMapSize)); + int cx = snprintf(remMapFileName, remMapSize, "%s%s/%s%d", baseName, subDirName, POLY_STATS_NAME, pid); + if (cx < 0 || (size_t)cx >= remMapSize) + return -1; + // Open the file. + return open(remMapFileName, O_RDONLY); +} +#endif // Create the global statistics object. Statistics globalStats; POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetUserStatsCount() { return TAGGED(N_PS_USER).AsUnsigned(); } POLYEXTERNALSYMBOL POLYUNSIGNED PolySetUserStat(PolyObject *threadId, PolyWord indexVal, PolyWord valueVal) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { unsigned index = get_C_unsigned(taskData, indexVal); if (index >= N_PS_USER) raise_exception0(taskData, EXC_subscript); POLYSIGNED value = getPolySigned(taskData, valueVal); globalStats.setUserCounter(index, value); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetLocalStats(PolyObject *threadId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = globalStats.getLocalStatistics(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(); } POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetRemoteStats(PolyObject *threadId, PolyWord procId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = globalStats.getRemoteStatistics(taskData, getPolyUnsigned(taskData, procId)); } 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 statisticsEPT[] = { { "PolyGetUserStatsCount", (polyRTSFunction)&PolyGetUserStatsCount }, { "PolySetUserStat", (polyRTSFunction)&PolySetUserStat }, { "PolyGetLocalStats", (polyRTSFunction)&PolyGetLocalStats }, { "PolyGetRemoteStats", (polyRTSFunction)&PolyGetRemoteStats }, { NULL, NULL } // End of list. }; diff --git a/libpolyml/statistics.h b/libpolyml/statistics.h index d1c8593d..0c0e2445 100644 --- a/libpolyml/statistics.h +++ b/libpolyml/statistics.h @@ -1,140 +1,148 @@ /* Title: statics.h - Interface to profiling statistics - Copyright (c) 2011, 2015, 2019 David C.J. Matthews + Copyright (c) 2011, 2015, 2019, 2020 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 STATISTICS_INCLUDED #define STATISTICS_INCLUDED #ifdef HAVE_WINDOWS_H #include #endif #include "globals.h" #include "locking.h" #include "rts_module.h" #include "../polystatistics.h" enum { PSC_THREADS = 0, // Total number of threads PSC_THREADS_IN_ML, // Threads running ML code PSC_THREADS_WAIT_IO, // Threads waiting for IO PSC_THREADS_WAIT_MUTEX, // Threads waiting for a mutex PSC_THREADS_WAIT_CONDVAR, // Threads waiting for a condition var PSC_THREADS_WAIT_SIGNAL, // Special case - signal handling thread PSC_GC_FULLGC, // Number of full garbage collections PSC_GC_PARTIALGC, // Number of partial GCs PSC_GC_SHARING, // Number of sharing passes PSS_TOTAL_HEAP, // Total size of the local heap PSS_AFTER_LAST_GC, // Space free after last GC PSS_AFTER_LAST_FULLGC, // Space free after the last full GC PSS_ALLOCATION, // Size of allocation space PSS_ALLOCATION_FREE, // Space available in allocation area PSS_CODE_SPACE, // Space for code PSS_STACK_SPACE, // Space for stack + + PSC_GC_STATE, // Whether in GC, ML or other phase + PSC_GC_PERCENT, // How far through the GC. + N_PS_INTS }; enum { PST_NONGC_UTIME, PST_NONGC_STIME, PST_GC_UTIME, PST_GC_STIME, PST_NONGC_RTIME, PST_GC_RTIME, N_PS_TIMES }; // A few counters that can be used by the application #define N_PS_USER 8 class TaskData; class SaveVecEntry; typedef SaveVecEntry *Handle; class Statistics: RtsModule { public: Statistics(); ~Statistics(); virtual void Init(void); // Initialise after set-up Handle getLocalStatistics(TaskData *taskData); Handle getRemoteStatistics(TaskData *taskData, POLYUNSIGNED processId); void incCount(int which); void decCount(int which); + void setCount(int which, POLYUNSIGNED count); void setSize(int which, size_t s); void incSize(int which, size_t s); void decSize(int which, size_t s); size_t getSize(int which); void setUserCounter(unsigned which, POLYSIGNED value); -#if (defined(_WIN32)) +#ifdef _WIN32 // Native Windows void copyGCTimes(const FILETIME &gcUtime, const FILETIME &gcStime, const FILETIME &gcRtime); FILETIME gcUserTime, gcSystemTime, gcRealTime, startTime; #else // Unix and Cygwin void copyGCTimes(const struct timeval &gcUtime, const struct timeval &gcStime, const struct timeval &gcRtime); struct timeval gcUserTime, gcSystemTime, gcRealTime, startTime; + bool createSharedStats(const char *baseName, const char *subDirName); + int openSharedStats(const char* baseName, const char* subDirName, int pid); #endif void updatePeriodicStats(size_t freeSpace, unsigned threadsInML); bool exportStats; private: PLock accessLock; -#ifdef HAVE_WINDOWS_H +#ifdef _WIN32 // File mapping handle HANDLE hFileMap; + bool createWindowsSharedStats(); #else char *mapFileName; int mapFd; #endif size_t memSize; unsigned char *statMemory; unsigned char *newPtr; unsigned char *counterAddrs[N_PS_INTS]; struct { unsigned char *secAddr; unsigned char *usecAddr; } timeAddrs[N_PS_TIMES]; unsigned char *userAddrs[N_PS_USER]; - Handle returnStatistics(TaskData *taskData, unsigned char *stats); + Handle returnStatistics(TaskData *taskData, const unsigned char *stats, size_t size); void addCounter(int cEnum, unsigned statId, const char *name); void addSize(int cEnum, unsigned statId, const char *name); void addTime(int cEnum, unsigned statId, const char *name); void addUser(int n, unsigned statId, const char *name); size_t getSizeWithLock(int which); void setSizeWithLock(int which, size_t s); void setTimeValue(int which, unsigned long secs, unsigned long usecs); }; extern Statistics globalStats; extern struct _entrypts statisticsEPT[]; #endif // STATISTICS_INCLUDED diff --git a/libpolyml/x86_dep.cpp b/libpolyml/x86_dep.cpp index 48300ded..e0d592f7 100644 --- a/libpolyml/x86_dep.cpp +++ b/libpolyml/x86_dep.cpp @@ -1,1465 +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; + PolyObject* writeAble = gMem.SpaceForAddress(result)->writeAble(result); + byte *p = (byte*)writeAble; *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); + writeAble->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; + sp = (stackItem*)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; + sp = (stackItem*)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; + sp = (stackItem*)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; + sp = (stackItem*)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; + sp = (stackItem*)context->sc_rsp; #else // !HOSTARCHITEXTURE_X86_64 || !defined(__OpenBSD__) pc = (byte*)context->sc_pc; - sp = (PolyWord*)context->sc_sp; + sp = (stackItem*)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) // 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. { 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; + byte* wr = gMem.SpaceForAddress(pt)->writeAble(pt); for (unsigned i = 0; i < 4; i++) { - pt[i] = (byte)(newDisp & 0xff); + wr[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 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/x86assembly_gas32.S b/libpolyml/x86assembly_gas32.S index 4707d083..84b23d43 100644 --- a/libpolyml/x86assembly_gas32.S +++ b/libpolyml/x86assembly_gas32.S @@ -1,207 +1,205 @@ /* Title: Assembly code routines for the poly system. Author: David Matthews - Copyright (c) David C. J. Matthews 2000-2019 + Copyright (c) David C. J. Matthews 2000-2020 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 is the 32-bit Unix version of the assembly code file. There are separate versions of 32/64 and Windows (Intel syntax) and Unix (gas syntax). */ /* Registers used :- %%eax: First argument to function. Result of function call. %%ebx: Second argument to function. %%ecx: General register %%edx: Closure pointer in call. %%ebp: Points to memory used for extra registers %%esi: General register. %%edi: General register. %%esp: Stack pointer. */ #include "config.h" #ifdef SYMBOLS_REQUIRE_UNDERSCORE #define EXTNAME(x) _##x #else #define EXTNAME(x) x #endif # # Macro to begin the hand-coded functions # #ifdef MACOSX #define GLOBAL .globl #else #define GLOBAL .global #endif #define INLINE_ROUTINE(id) \ GLOBAL EXTNAME(id); \ EXTNAME(id): #define Fr_Size 16 /* This is the argument vector passed in to X86AsmSwitchToPoly It is used to initialise the frame. A few values are updated when ML returns. */ #define Arg_LocalMpointer 0x0 #define Arg_HandlerRegister 0x4 #define Arg_LocalMbottom 0x8 #define Arg_StackLimit 0xc #define Arg_ExceptionPacket 0x10 /* Address of packet to raise */ #define Arg_RequestCode 0x14 /* Byte: Io function to call. */ #define Arg_ReturnReason 0x16 /* Byte: Reason for returning from ML. */ #define Arg_FullRestore 0x17 /* Byte: Full/partial restore */ #define Arg_SaveCStack 0x18 /* Save C Stack pointer */ #define Arg_ThreadId 0x1c /* My thread id */ #define Arg_StackPtr 0x20 /* Stack Pointer */ #define Arg_SaveRAX 0x34 #define Arg_SaveRBX 0x38 #define Arg_SaveRCX 0x3c #define Arg_SaveRDX 0x40 #define Arg_SaveRSI 0x44 #define Arg_SaveRDI 0x48 #define Arg_SaveFP 0x4c #define RETURN_HEAP_OVERFLOW 1 #define RETURN_STACK_OVERFLOW 2 #define RETURN_STACK_OVERFLOWEX 3 #define RETURN_CALLBACK_RETURN 6 #define RETURN_CALLBACK_EXCEPTION 7 #define RETURN_KILL_SELF 9 # Mark the stack as non-executable when supported -#ifdef HAVE_GNU_STACK +#if (defined(__linux__) && defined(__ELF__)) .section .note.GNU-stack, "", @progbits #endif # # CODE STARTS HERE # .text #define CALL_EXTRA(index) \ - pushl %ecx; \ movb $index,Arg_ReturnReason(%ebp); \ - popl %ecx; \ jmp SaveFullState; /* Load the registers from the ML stack and jump to the code. This is used to start ML code. The argument is the address of the MemRegisters struct and goes into %rbp. This is the general code for switching control to ML. There are a number of cases to consider: 1. Initial entry to root function or a new thread. Needs to load EDX at least. 2. Normal return from an RTS call. Could just do a simple return. 3. Exception raised in RTS call. 4. Callback from C to an ML function. In effect this is a coroutine. Similar to 1. 5. Return from "trap" i.e. Heap/Stack overflow. Stack-overflow can result in an exception either because the stack can't be grown or because Interrupt has been raised. */ INLINE_ROUTINE(X86AsmSwitchToPoly) pushl %ebp # Standard entry sequence movl 8(%esp),%ebp # Address of argument vector pushl %ebx pushl %edi pushl %esi # Push callee-save registers subl $(Fr_Size-12),%esp # Allocate frame movl %esp,Arg_SaveCStack(%ebp) movl Arg_StackPtr(%ebp),%esp movl Arg_ExceptionPacket(%ebp),%eax cmpl $1,%eax # Did we raise an exception? jnz raisexlocal FRSTOR Arg_SaveFP(%ebp) movl Arg_SaveRAX(%ebp),%eax # Load the registers movl Arg_SaveRBX(%ebp),%ebx # Load the registers movl Arg_SaveRCX(%ebp),%ecx movl Arg_SaveRDX(%ebp),%edx movl Arg_SaveRSI(%ebp),%esi movl Arg_SaveRDI(%ebp),%edi cld # Clear this just in case ret /* Code to save the state and switch to C This saves the full register state. */ SaveFullState: movl %eax,Arg_SaveRAX(%ebp) movl %ebx,Arg_SaveRBX(%ebp) movl %ecx,Arg_SaveRCX(%ebp) movl %edx,Arg_SaveRDX(%ebp) movl %esi,Arg_SaveRSI(%ebp) movl %edi,Arg_SaveRDI(%ebp) fnsave Arg_SaveFP(%ebp) # Save FP state. Also resets the state so... fldcw Arg_SaveFP(%ebp) # ...load because we need the same rounding mode in the RTS movl %esp,Arg_StackPtr(%ebp) # Save ML stack pointer movl Arg_SaveCStack(%ebp),%esp # Restore C stack pointer addl $(Fr_Size-12),%esp popl %esi popl %edi popl %ebx popl %ebp ret INLINE_ROUTINE(X86AsmCallExtraRETURN_HEAP_OVERFLOW) CALL_EXTRA(RETURN_HEAP_OVERFLOW) INLINE_ROUTINE(X86AsmCallExtraRETURN_STACK_OVERFLOW) CALL_EXTRA(RETURN_STACK_OVERFLOW) INLINE_ROUTINE(X86AsmCallExtraRETURN_STACK_OVERFLOWEX) CALL_EXTRA(RETURN_STACK_OVERFLOWEX) /* Used when entering new code. The argument and closure are on the stack in case there is a GC before we enter the code. */ INLINE_ROUTINE(X86AsmPopArgAndClosure) popl %edx popl %eax jmp *(%edx) INLINE_ROUTINE(X86AsmRaiseException) raisexlocal: movl Arg_HandlerRegister(%ebp),%ecx # Get next handler into %rcx jmp *(%ecx) # Additional assembly code routines # RTS call to kill the current thread. INLINE_ROUTINE(X86AsmKillSelf) CALL_EXTRA(RETURN_KILL_SELF) INLINE_ROUTINE(X86AsmCallbackReturn) CALL_EXTRA(RETURN_CALLBACK_RETURN) INLINE_ROUTINE(X86AsmCallbackException) CALL_EXTRA(RETURN_CALLBACK_EXCEPTION) # This implements atomic addition in the same way as atomic_increment INLINE_ROUTINE(X86AsmAtomicIncrement) #ifndef HOSTARCHITECTURE_X86_64 movl 4(%esp),%eax #else movl %edi,%eax # On X86_64 the argument is passed in %edi #endif # Use %ecx and %eax because they are volatile (unlike %ebx on X86/64/Unix) movl $2,%ecx lock; xaddl %ecx,(%eax) addl $2,%ecx movl %ecx,%eax ret diff --git a/libpolyml/x86assembly_gas64.S b/libpolyml/x86assembly_gas64.S index d90c93b3..5723fd94 100644 --- a/libpolyml/x86assembly_gas64.S +++ b/libpolyml/x86assembly_gas64.S @@ -1,288 +1,286 @@ /* Title: Assembly code routines for the poly system. Author: David Matthews - Copyright (c) David C. J. Matthews 2000-2019 + Copyright (c) David C. J. Matthews 2000-2020 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 is the 64-bit gas version of the assembly code file. There are separate versions of 32/64 and MAMS (Intel syntax) and and GCC (gas syntax). */ /* Registers used :- %rax: First argument to function. Result of function call. %rbx: Second argument to function. %rcx: General register %rdx: Closure pointer in call. %rbp: Points to memory used for extra registers %rsi: General register. %rdi: General register. %rsp: Stack pointer. %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 */ #include "config.h" #ifdef SYMBOLS_REQUIRE_UNDERSCORE #define EXTNAME(x) _##x #else #define EXTNAME(x) x #endif #ifdef __CYGWIN__ #define _WIN32 1 #endif /* Macro to begin the hand-coded functions */ #ifdef MACOSX #define GLOBAL .globl #else #define GLOBAL .global #endif #define INLINE_ROUTINE(id) \ GLOBAL EXTNAME(id); \ EXTNAME(id): /* Extra entries on the C stack */ #define Fr_Size 64 /* Must be multiple of 16 to get alignment correct */ /* This is the argument vector passed in to X86AsmSwitchToPoly It is used to initialise the frame. A few values are updated when ML returns. */ #define Arg_LocalMpointer 0x0 #define Arg_HandlerRegister 0x8 #define Arg_LocalMbottom 0x10 #define Arg_StackLimit 0x18 #define Arg_ExceptionPacket 0x20 /* Address of packet to raise */ #define Arg_RequestCode 0x28 /* Byte: Io function to call. */ #define Arg_ReturnReason 0x2a /* Byte: Reason for returning from ML. */ #define Arg_UnusedRestore 0x2b /* Byte: Full/partial restore */ #define Arg_SaveCStack 0x30 /* Current stack base */ #define Arg_ThreadId 0x38 /* My thread id */ #define Arg_StackPtr 0x40 /* Stack Pointer */ #define Arg_SaveRAX 0x68 #define Arg_SaveRBX 0x70 #define Arg_SaveRCX 0x78 #define Arg_SaveRDX 0x80 #define Arg_SaveRSI 0x88 #define Arg_SaveRDI 0x90 #define Arg_SaveR8 0x98 #define Arg_SaveR9 0xa0 #define Arg_SaveR10 0xa8 #define Arg_SaveR11 0xb0 #define Arg_SaveR12 0xb8 #define Arg_SaveR13 0xc0 #define Arg_SaveR14 0xc8 #define Arg_SaveXMM0 0xd0 #define Arg_SaveXMM1 0xd8 #define Arg_SaveXMM2 0xe0 #define Arg_SaveXMM3 0xe8 #define Arg_SaveXMM4 0xf0 #define Arg_SaveXMM5 0xf8 #define Arg_SaveXMM6 0x100 /* IO function numbers. These are functions that are called to handle special cases in this code */ #include "sys.h" #define RETURN_HEAP_OVERFLOW 1 #define RETURN_STACK_OVERFLOW 2 #define RETURN_STACK_OVERFLOWEX 3 #define RETURN_CALLBACK_RETURN 6 #define RETURN_CALLBACK_EXCEPTION 7 #define RETURN_RAISE_OVERFLOW 8 #define RETURN_KILL_SELF 9 # Mark the stack as non-executable when supported -#ifdef HAVE_GNU_STACK +#if (defined(__linux__) && defined(__ELF__)) .section .note.GNU-stack, "", @progbits #endif # # CODE STARTS HERE # .text #define CALL_EXTRA(index) \ - pushq %rcx; \ movb $index,Arg_ReturnReason(%rbp); \ - popq %rcx; \ jmp SaveFullState; /* Load the registers from the ML stack and jump to the code. */ INLINE_ROUTINE(X86AsmSwitchToPoly) pushq %rbp # Standard entry sequence /* If we're compiling with Mingw we're using Windows calling conventions. */ #ifdef _WIN32 movq %rcx,%rbp # Argument is in %rcx #else movq %rdi,%rbp # Argument is in %rdi #endif pushq %rbx pushq %r12 pushq %r13 pushq %r14 pushq %r15 #ifdef _WIN32 pushq %rdi # Callee save in Windows pushq %rsi subq $(Fr_Size-56),%rsp # Argument is already in %rcx #else subq $(Fr_Size-40),%rsp #endif movq %rsp,Arg_SaveCStack(%rbp) movq Arg_LocalMpointer(%rbp),%r15 movq Arg_StackPtr(%rbp),%rsp # Set the new stack ptr movsd Arg_SaveXMM0(%rbp),%xmm0 # Load the registers movsd Arg_SaveXMM1(%rbp),%xmm1 movsd Arg_SaveXMM2(%rbp),%xmm2 movsd Arg_SaveXMM3(%rbp),%xmm3 movsd Arg_SaveXMM4(%rbp),%xmm4 movsd Arg_SaveXMM5(%rbp),%xmm5 movsd Arg_SaveXMM6(%rbp),%xmm6 movq Arg_SaveRBX(%rbp),%rbx movq Arg_SaveRCX(%rbp),%rcx movq Arg_SaveRDX(%rbp),%rdx movq Arg_SaveRSI(%rbp),%rsi movq Arg_SaveRDI(%rbp),%rdi movq Arg_SaveR8(%rbp),%r8 movq Arg_SaveR9(%rbp),%r9 movq Arg_SaveR10(%rbp),%r10 movq Arg_SaveR11(%rbp),%r11 movq Arg_SaveR12(%rbp),%r12 movq Arg_SaveR13(%rbp),%r13 movq Arg_SaveR14(%rbp),%r14 movq Arg_ExceptionPacket(%rbp),%rax cmpq $1,%rax # Did we raise an exception? jnz raisexLocal movq Arg_SaveRAX(%rbp),%rax cld # Clear this just in case ret /* This is exactly the same as raisex but seems to be needed to work round a PIC problem. */ raisexLocal: movq Arg_HandlerRegister(%rbp),%rcx # Get next handler into %rcx jmp *(%rcx) /* Code to save the state and switch to C This saves the full register state. */ SaveFullState: movq %rax,Arg_SaveRAX(%rbp) movq %rbx,Arg_SaveRBX(%rbp) movq %rcx,Arg_SaveRCX(%rbp) movq %rdx,Arg_SaveRDX(%rbp) movq %rsi,Arg_SaveRSI(%rbp) movq %rdi,Arg_SaveRDI(%rbp) movsd %xmm0,Arg_SaveXMM0(%rbp) movsd %xmm1,Arg_SaveXMM1(%rbp) movsd %xmm2,Arg_SaveXMM2(%rbp) movsd %xmm3,Arg_SaveXMM3(%rbp) movsd %xmm4,Arg_SaveXMM4(%rbp) movsd %xmm5,Arg_SaveXMM5(%rbp) movsd %xmm6,Arg_SaveXMM6(%rbp) movq %r8,Arg_SaveR8(%rbp) movq %r9,Arg_SaveR9(%rbp) movq %r10,Arg_SaveR10(%rbp) movq %r11,Arg_SaveR11(%rbp) movq %r12,Arg_SaveR12(%rbp) movq %r13,Arg_SaveR13(%rbp) movq %r14,Arg_SaveR14(%rbp) movq %rsp,Arg_StackPtr(%rbp) movq %r15,Arg_LocalMpointer(%rbp) # Save back heap pointer movq Arg_SaveCStack(%rbp),%rsp # Restore C stack pointer #ifdef _WIN32 addq $(Fr_Size-56),%rsp popq %rsi popq %rdi #else addq $(Fr_Size-40),%rsp #endif popq %r15 # Restore callee-save registers popq %r14 popq %r13 popq %r12 popq %rbx popq %rbp ret /* Used when entering new code. The argument and closure are on the stack in case there is a GC before we enter the code. */ INLINE_ROUTINE(X86AsmPopArgAndClosure) popq %rdx popq %rax #ifdef POLYML32IN64 jmp *(%rbx,%rdx,4) #else jmp *(%rdx) #endif # This is used if the RTS sets up an exception. It's probably no longer relevant. INLINE_ROUTINE(X86AsmRaiseException) movq Arg_HandlerRegister(%rbp),%rcx # Get next handler into %rcx jmp *(%rcx) # Additional assembly code routines # RTS call to kill the current thread. INLINE_ROUTINE(X86AsmKillSelf) CALL_EXTRA(RETURN_KILL_SELF) INLINE_ROUTINE(X86AsmCallbackReturn) CALL_EXTRA(RETURN_CALLBACK_RETURN) INLINE_ROUTINE(X86AsmCallbackException) CALL_EXTRA(RETURN_CALLBACK_EXCEPTION) INLINE_ROUTINE(X86AsmCallExtraRETURN_HEAP_OVERFLOW) CALL_EXTRA(RETURN_HEAP_OVERFLOW) INLINE_ROUTINE(X86AsmCallExtraRETURN_STACK_OVERFLOW) CALL_EXTRA(RETURN_STACK_OVERFLOW) INLINE_ROUTINE(X86AsmCallExtraRETURN_STACK_OVERFLOWEX) CALL_EXTRA(RETURN_STACK_OVERFLOWEX) # This implements atomic addition in the same way as atomic_increment INLINE_ROUTINE(X86AsmAtomicIncrement) #ifdef _WIN32 movq %rcx,%rax # On Windows the argument is passed in %rcx #else movq %rdi,%rax # On X86_64 the argument is passed in %rdi #endif # Use %rcx and %rax because they are volatile (unlike %rbx on X86/64/Unix) movq $2,%rcx #ifdef POLYML32IN64 lock xaddl %ecx,(%rax) # Rax is an absolute address but this is only a word #else lock xaddq %rcx,(%rax) #endif addq $2,%rcx movq %rcx,%rax ret diff --git a/libpolyml/x86assembly_masm32.S b/libpolyml/x86assembly_masm32.S index 2f312db7..cace143e 100644 --- a/libpolyml/x86assembly_masm32.S +++ b/libpolyml/x86assembly_masm32.S @@ -1,194 +1,192 @@ ; ; Title: Assembly code routines for the poly system. ; Author: David Matthews ; Copyright (c) David C. J. Matthews 2000-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 ; ; ; Registers used :- ; ; eax: First argument to function. Result of function call. ; ebx: Second argument to function. ; ecx: General register ; edx: Closure pointer in call. ; ebp: Points to memory used for extra registers ; esi: General register. ; edi: General register. ; esp: Stack pointer. .486 .model flat,c Fr_Size EQU 16 ; Make this a multiple of 16 ; This is the argument vector passed in to X86AsmSwitchToPoly ; It is used to initialise the frame. A few values are updated ; when ML returns. ArgVector STRUCT LocalMPointer DWORD ? HandlerRegister DWORD ? LocalMbottom DWORD ? StackLimit DWORD ? ExceptionPacket DWORD ? ; Address of packet to raise UnusedRequestCode DB ? ; Byte: Io function to call. UnusedFlag DB ? ReturnReason DB ? ; Byte: Reason for returning from ML. UnusedRestore DB ? ; SaveCStack DWORD ? ; Saved C stack pointer ThreadId DWORD ? ; My thread id StackPtr DWORD ? ; Stack pointer UnusedProgramCtr DWORD ? HeapOverFlowCall DWORD ? StackOverFlowCall DWORD ? StackOverFlowCallEx DWORD ? SaveRAX DWORD ? SaveRBX DWORD ? SaveRCX DWORD ? SaveRDX DWORD ? SaveRSI DWORD ? SaveRDI DWORD ? SaveFP WORD ? ; Actually larger ArgVector ENDS ; Codes to indicate the reason for return. RETURN_HEAP_OVERFLOW EQU 1 RETURN_STACK_OVERFLOW EQU 2 RETURN_STACK_OVERFLOWEX EQU 3 RETURN_CALLBACK_RETURN EQU 6 RETURN_CALLBACK_EXCEPTION EQU 7 RETURN_KILL_SELF EQU 9 ; ; CODE STARTS HERE ; .CODE ; Load the registers from the ML stack and jump to the code. ; This is used to start ML code. ; The argument is the address of the MemRegisters struct and goes into ebp. ; This is the general code for switching control to ML. There are a number of cases to consider: ; 1. Initial entry to root function or a new thread. Needs to load EDX at least. ; 2. Normal return from an RTS call. Could just do a simple return. ; 3. Exception raised in RTS call. ; 4. Callback from C to an ML function. In effect this is a coroutine. Similar to 1. ; 5. Return from "trap" i.e. Heap/Stack overflow. Stack-overflow can result in an exception ; either because the stack can't be grown or because Interrupt has been raised. PUBLIC X86AsmSwitchToPoly X86AsmSwitchToPoly: push ebp ; Standard entry sequence mov ebp,[8+esp] ; Address of argument vector push ebx ; Push callee-save registers push edi push esi sub esp,(Fr_size-12) ; Allocate frame mov [ArgVector.SaveCStack+ebp],esp mov esp,[ArgVector.StackPtr+ebp] mov eax,[ArgVector.ExceptionPacket+ebp] cmp eax,1 ; Did we raise an exception? jnz raisex frstor [ArgVector.SaveFP+ebp] mov eax,[ArgVector.SaveRAX+ebp] mov ebx,[ArgVector.SaveRBX+ebp] mov ecx,[ArgVector.SaveRCX+ebp] mov edx,[ArgVector.SaveRDX+ebp] mov esi,[ArgVector.SaveRSI+ebp] mov edi,[ArgVector.SaveRDI+ebp] cld ; Clear this just in case ret ; Code to save the state and switch to C ; This saves the full register state. SaveFullState: mov [ArgVector.SaveRAX+ebp],eax mov [ArgVector.SaveRBX+ebp],ebx mov [ArgVector.SaveRCX+ebp],ecx mov [ArgVector.SaveRDX+ebp],edx mov [ArgVector.SaveRSI+ebp],esi mov [ArgVector.SaveRDI+ebp],edi FNSAVE [ArgVector.SaveFP+ebp] ; Save FP state. Also resets the state so... FLDCW [ArgVector.SaveFP+ebp] ; ...load because we need the same rounding mode in the RTS mov [ArgVector.StackPtr+ebp],esp ; Save ML stack pointer mov esp,[ArgVector.SaveCStack+ebp] ; Restore C stack pointer add esp,(Fr_size-12) pop esi ; Restore saved registers pop edi pop ebx pop ebp ret ; Used when entering new code. The argument and closure are on the stack ; in case there is a GC before we enter the code. PUBLIC X86AsmPopArgAndClosure X86AsmPopArgAndClosure: pop edx pop eax jmp dword ptr [edx] ; This is used if the RTS sets up an exception. It's probably no longer relevant. PUBLIC X86AsmRaiseException X86AsmRaiseException: raisex: mov ecx,[ArgVector.HandlerRegister+ebp] jmp dword ptr [ecx] ; Define standard call macro. ; Defined as an Masm macro because there are multiple instructions. CALL_EXTRA MACRO index - push ecx mov byte ptr [ArgVector.ReturnReason+ebp],index - pop ecx jmp SaveFullState ENDM ; Terminate the current thread PUBLIC X86AsmKillSelf X86AsmKillSelf: CALL_EXTRA RETURN_KILL_SELF PUBLIC X86AsmCallbackReturn X86AsmCallbackReturn: CALL_EXTRA RETURN_CALLBACK_RETURN PUBLIC X86AsmCallbackException X86AsmCallbackException: CALL_EXTRA RETURN_CALLBACK_EXCEPTION ; This implements atomic addition in the same way as atomic_increment ; N.B. It is called from the RTS so uses C linkage conventions. PUBLIC X86AsmAtomicIncrement X86AsmAtomicIncrement: mov eax,4[esp] ; Use ecx and eax because they are volatile (unlike ebx on X86/64/Unix) mov ecx,2 lock xadd [eax],ecx add ecx,2 mov eax,ecx ret CREATE_EXTRA_CALL MACRO index PUBLIC X86AsmCallExtra&index& X86AsmCallExtra&index&: CALL_EXTRA index ENDM CREATE_EXTRA_CALL RETURN_HEAP_OVERFLOW CREATE_EXTRA_CALL RETURN_STACK_OVERFLOW CREATE_EXTRA_CALL RETURN_STACK_OVERFLOWEX END diff --git a/libpolyml/x86assembly_masm64.S b/libpolyml/x86assembly_masm64.S index c10d3ee1..7874b0f0 100644 --- a/libpolyml/x86assembly_masm64.S +++ b/libpolyml/x86assembly_masm64.S @@ -1,263 +1,261 @@ ; ; Title: Assembly code routines for the poly system. ; Author: David Matthews ; Copyright (c) David C. J. Matthews 2000-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 ; ; ; Registers used :- ; ; rax: First argument to function. Result of function call. ; rbx: Second argument to function. ; rcx: General register ; rdx: Closure pointer in call. ; rbp: Points to memory used for extra registers ; rsi: General register. ; rdi: General register. ; rsp: Stack pointer. ; 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 ; Extra entries on the C stack Fr_Size EQU 64 ; Must be multiple of 16 to get alignment correct ; This is the argument vector passed in to X86AsmSwitchToPoly ; It is used to initialise the frame. A few values are updated ; when ML returns. ArgVector STRUCT LocalMPointer QWORD ? HandlerRegister QWORD ? LocalMbottom QWORD ? StackLimit QWORD ? ExceptionPacket QWORD ? ; Address of packet to raise UnusedRequestCode DB ? ; Byte: Io function to call. UnusedFlag DB ? ReturnReason DB ? ; Byte: Reason for returning from ML. UnusedRestore DB ? ; Byte: UnusedAlign DWORD ? SaveCStack QWORD ? ; Saved C stack frame ThreadId QWORD ? ; My thread id StackPtr QWORD ? ; Stack pointer UnusedProgramCtr QWORD ? HeapOverFlowCall QWORD ? StackOverFlowCall QWORD ? StackOverFlowCallEx QWORD ? SaveRAX QWORD ? SaveRBX QWORD ? SaveRCX QWORD ? SaveRDX QWORD ? SaveRSI QWORD ? SaveRDI QWORD ? SaveR8 QWORD ? SaveR9 QWORD ? SaveR10 QWORD ? SaveR11 QWORD ? SaveR12 QWORD ? SaveR13 QWORD ? SaveR14 QWORD ? SaveXMM0 QWORD ? SaveXMM1 QWORD ? SaveXMM2 QWORD ? SaveXMM3 QWORD ? SaveXMM4 QWORD ? SaveXMM5 QWORD ? SaveXMM6 QWORD ? ArgVector ENDS RETURN_HEAP_OVERFLOW EQU 1 RETURN_STACK_OVERFLOW EQU 2 RETURN_STACK_OVERFLOWEX EQU 3 RETURN_CALLBACK_RETURN EQU 6 RETURN_CALLBACK_EXCEPTION EQU 7 RETURN_KILL_SELF EQU 9 ; ; CODE STARTS HERE ; .CODE ; Define standard call macro. CALL_EXTRA MACRO index - push rcx mov byte ptr [ArgVector.ReturnReason+rbp],index - pop rcx jmp SaveFullState ENDM ; Load the registers from the ML stack and jump to the code. ; This is used to start ML code. ; The argument is the address of the MemRegisters struct and goes into rbp. ; This is the general code for switching control to ML. There are a number of cases to consider: ; 1. Initial entry to root function or a new thread. Needs to load EDX at least. ; 2. Normal return from an RTS call. Could just do a simple return. ; 3. Exception raised in RTS call. ; 4. Callback from C to an ML function. In effect this is a coroutine. Similar to 1. ; 5. Return from "trap" i.e. Heap/Stack overflow. Stack-overflow can result in an exception ; either because the stack can't be grown or because Interrupt has been raised. ; Switch from C code to ML. This code uses the X86/64 Windows calling conventions. It ; saves the callee-save registers. ; This does not set up a correct frame because we don't want to reserve a register for ; that. RBP needs to be the original argument because we need to be able to modify ; the stack limit "register" from another thread in order to be able to interrupt ; this one. X86AsmSwitchToPoly PROC FRAME push rbp ; Standard entry sequence push rbx ; Save callee-save registers push r12 push r13 push r14 push r15 push rdi ; Callee save in Windows push rsi ; Strictly, we should also save xmm6 .endprolog mov rbp,rcx ; Move argument into rbp - this is definitely non-standard sub rsp,(Fr_size-56) mov [ArgVector.SaveCStack+rcx],rsp ; Save the C stack pointer mov r15,[ArgVector.LocalMpointer+rbp] mov rsp,[ArgVector.StackPtr+rbp] movsd xmm0,[ArgVector.SaveXMM0+rbp] movsd xmm1,[ArgVector.SaveXMM1+rbp] movsd xmm2,[ArgVector.SaveXMM2+rbp] movsd xmm3,[ArgVector.SaveXMM3+rbp] movsd xmm4,[ArgVector.SaveXMM4+rbp] movsd xmm5,[ArgVector.SaveXMM5+rbp] movsd xmm6,[ArgVector.SaveXMM6+rbp] mov rbx,[ArgVector.SaveRBX+rbp] mov rcx,[ArgVector.SaveRCX+rbp] mov rdx,[ArgVector.SaveRDX+rbp] mov rsi,[ArgVector.SaveRSI+rbp] mov rdi,[ArgVector.SaveRDI+rbp] mov r8,[ArgVector.SaveR8+rbp] mov r9,[ArgVector.SaveR9+rbp] mov r10,[ArgVector.SaveR10+rbp] mov r11,[ArgVector.SaveR11+rbp] mov r12,[ArgVector.SaveR12+rbp] mov r13,[ArgVector.SaveR13+rbp] mov r14,[ArgVector.SaveR14+rbp] mov rax,[ArgVector.ExceptionPacket+rbp] cmp rax,1 ; Did we raise an exception? jnz raisex mov rax,[ArgVector.SaveRAX+rbp] cld ; Clear this just in case ret ; Everything up to here is considered as part of the X86AsmSwitchToPoly proc X86AsmSwitchToPoly ENDP ; Code to save the state and switch to C ; This saves the full register state. SaveFullState: mov [ArgVector.SaveRAX+rbp],rax mov [ArgVector.SaveRBX+rbp],rbx mov [ArgVector.SaveRCX+rbp],rcx mov [ArgVector.SaveRDX+rbp],rdx mov [ArgVector.SaveRSI+rbp],rsi mov [ArgVector.SaveRDI+rbp],rdi movsd [ArgVector.SaveXMM0+rbp],xmm0 movsd [ArgVector.SaveXMM1+rbp],xmm1 movsd [ArgVector.SaveXMM2+rbp],xmm2 movsd [ArgVector.SaveXMM3+rbp],xmm3 movsd [ArgVector.SaveXMM4+rbp],xmm4 movsd [ArgVector.SaveXMM5+rbp],xmm5 movsd [ArgVector.SaveXMM6+rbp],xmm6 mov [ArgVector.SaveR8+rbp],r8 mov [ArgVector.SaveR9+rbp],r9 mov [ArgVector.SaveR10+rbp],r10 mov [ArgVector.SaveR11+rbp],r11 mov [ArgVector.SaveR12+rbp],r12 mov [ArgVector.SaveR13+rbp],r13 mov [ArgVector.SaveR14+rbp],r14 mov [ArgVector.StackPtr+rbp],rsp mov [ArgVector.LocalMpointer+rbp],r15 ; Save back heap pointer mov rsp,[ArgVector.SaveCStack+rbp] ; Restore C stack pointer add rsp,(Fr_size-56) pop rsi pop rdi pop r15 ; Restore callee-save registers pop r14 pop r13 pop r12 pop rbx pop rbp ret ;# Used when entering new code. The argument and closure are on the stack ;# in case there is a GC before we enter the code. PUBLIC X86AsmPopArgAndClosure X86AsmPopArgAndClosure: pop rdx pop rax #ifdef POLYML32IN64 jmp qword ptr [rbx+rdx*4] #else jmp qword ptr [rdx] #endif ;# This is used if the RTS sets up an exception. It's probably no longer relevant. PUBLIC X86AsmRaiseException X86AsmRaiseException: raisex: mov rcx,[ArgVector.HandlerRegister+rbp] jmp qword ptr [rcx] ; RTS call to kill the current thread. PUBLIC X86AsmKillSelf X86AsmKillSelf: CALL_EXTRA RETURN_KILL_SELF PUBLIC X86AsmCallbackReturn X86AsmCallbackReturn: CALL_EXTRA RETURN_CALLBACK_RETURN PUBLIC X86AsmCallbackException X86AsmCallbackException: CALL_EXTRA RETURN_CALLBACK_EXCEPTION ; This implements atomic addition in the same way as atomic_increment PUBLIC X86AsmAtomicIncrement X86AsmAtomicIncrement: mov rax,rcx ; Use rcx and rax because they are volatile (unlike rbx on X86/64/Unix) mov rcx,2 #ifdef POLYML32IN64 lock xadd [rax],ecx ;# Rax is an absolute address but this is only a word #else lock xadd [rax],rcx #endif add rcx,2 mov rax,rcx ret CREATE_EXTRA_CALL MACRO index PUBLIC X86AsmCallExtra&index& X86AsmCallExtra&index&: CALL_EXTRA index ENDM CREATE_EXTRA_CALL RETURN_HEAP_OVERFLOW CREATE_EXTRA_CALL RETURN_STACK_OVERFLOW CREATE_EXTRA_CALL RETURN_STACK_OVERFLOWEX END diff --git a/mlsource/MLCompiler/BUILTINS.sml b/mlsource/MLCompiler/BUILTINS.sml index 7ab52707..c97d5a53 100644 --- a/mlsource/MLCompiler/BUILTINS.sml +++ b/mlsource/MLCompiler/BUILTINS.sml @@ -1,109 +1,113 @@ (* Signature for built-in functions - Copyright David C. J. Matthews 2016, 2018-9 + Copyright David C. J. Matthews 2016, 2018-20 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. *) | TouchAddress (* Ensures that the cell is reachable. *) 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. *) + Values must be tagged and not pointers. *) 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 - + | PointerEq + 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 + | CheckRTSException + (* Equality of values which could be pointers or tagged values. + At the lowest level this is the same as WordComparison but + if we try to use an indexed case there must be a check that the + values are tagged. *) 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 ce4b234f..e21f54c2 100644 --- a/mlsource/MLCompiler/CODETREESIG.ML +++ b/mlsource/MLCompiler/CODETREESIG.ML @@ -1,160 +1,161 @@ (* - Copyright (c) 2012,13,15-19 David C.J. Matthews + Copyright (c) 2012,13,15-20 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 mkNot: codetree -> codetree + val mkIsShort: codetree -> codetree + val mkEqualTaggedWord: codetree * codetree -> codetree + val mkEqualPointerOrWord: codetree * codetree -> codetree + val equalTaggedWordFn: codetree + val equalPointerOrWordFn: 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 e3c9f041..e8e123d3 100644 --- a/mlsource/MLCompiler/CodeTree/BackendIntermediateCode.sml +++ b/mlsource/MLCompiler/CodeTree/BackendIntermediateCode.sml @@ -1,733 +1,735 @@ (* - Copyright (c) 2012, 2016-19 David C.J. Matthews + Copyright (c) 2012, 2016-20 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 | TouchAddress 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 + | PointerEq 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 | unaryRepr TouchAddress = "TouchAddress" 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 + | binaryRepr PointerEq = "PointerEq" 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 } | 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 | 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/BaseCodeTree.sml b/mlsource/MLCompiler/CodeTree/BaseCodeTree.sml index 35222a03..a66a7c9a 100644 --- a/mlsource/MLCompiler/CodeTree/BaseCodeTree.sml +++ b/mlsource/MLCompiler/CodeTree/BaseCodeTree.sml @@ -1,775 +1,777 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited - Modified David C. J. Matthews 2008-2010, 2013, 2015, 2017-19 + Modified David C. J. Matthews 2008-2010, 2013, 2015, 2017-20 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 + DontInline + | InlineAlways + | SmallInline (* 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 } | 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 (")")] ) ) ] ) | 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," + DontInline => "" + | InlineAlways => "inline," + | SmallInline => "small," 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(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 (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 74c3712b..c984f413 100644 --- a/mlsource/MLCompiler/CodeTree/BaseCodeTreeSig.sml +++ b/mlsource/MLCompiler/CodeTree/BaseCodeTreeSig.sml @@ -1,219 +1,220 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited - Modified David C. J. Matthews 2008-2010, 2013, 2016-19 + Modified David C. J. Matthews 2008-2010, 2013, 2016-20 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 + DontInline + | InlineAlways + | SmallInline 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 } | 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/ByteCode/INTGCODE.ML b/mlsource/MLCompiler/CodeTree/ByteCode/INTGCODE.ML index 15646f36..fe5da4e9 100644 --- a/mlsource/MLCompiler/CodeTree/ByteCode/INTGCODE.ML +++ b/mlsource/MLCompiler/CodeTree/ByteCode/INTGCODE.ML @@ -1,1157 +1,1159 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited Further development copyright David C.J. Matthews 2016-18,2020 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: Generate interpretable code for Poly system from the code tree. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) (* This generates byte-code that is interpreted by the run-time system. It is now used as a fall-back to allow Poly/ML to run on non-X86 architectures. Early versions were used as a porting aid while a native code-generator was being developed and the "enter-int" instructions that were needed for that have been retained although they no longer actually generate code. *) functor INTGCODE ( structure CODECONS : INTCODECONSSIG structure BACKENDTREE: BackendIntermediateCodeSig structure CODE_ARRAY: CODEARRAYSIG sharing CODECONS.Sharing = BACKENDTREE.Sharing = CODE_ARRAY.Sharing ) : GENCODESIG = struct open CODECONS open Address open BACKENDTREE open Misc open CODE_ARRAY val word0 = toMachineWord 0; val DummyValue : machineWord = word0; (* used as result of "raise e" etc. *) type caseForm = { cases : (backendIC * word) list, test : backendIC, caseType: caseType, default : backendIC } (* Where the result, if any, should go *) datatype whereto = NoResult (* discard result *) | ToStack (* Need a result but it can stay on the pseudo-stack *); (* Are we at the end of the function. *) datatype tail = EndOfProc | NotEnd (* Code generate a function or global declaration *) fun codegen (pt, cvec, resultClosure, numOfArgs, localCount, parameters) = let datatype decEntry = StackAddr of int | Empty val decVec = Array.array (localCount, Empty) (* Count of number of items on the stack. *) val realstackptr = ref 1 (* The closure ptr is already there *) (* Maximum size of the stack. *) val maxStack = ref 1 (* Exited - set to true if we have jumped out. *) val exited = ref false; (* Push a value onto the stack. *) fun incsp () = ( realstackptr := !realstackptr + 1; if !realstackptr > !maxStack then maxStack := !realstackptr else () ) (* An entry has been removed from the stack. *) fun decsp () = realstackptr := !realstackptr - 1; fun pushLocalStackValue addr = ( genLocal(!realstackptr + addr, cvec); incsp() ) (* Loads a local, argument or closure value; translating local stack addresses to real stack offsets. *) fun locaddr(BICLoadArgument locn) = pushLocalStackValue (numOfArgs-locn) | locaddr(BICLoadLocal locn) = ( (* positive address - on the stack. *) case Array.sub (decVec, locn) of StackAddr n => pushLocalStackValue (~ n) | _ => (* Should be on the stack, not a function. *) raise InternalError "locaddr: bad stack address" ) | locaddr(BICLoadClosure locn) = (* closure-pointer relative *) ( pushLocalStackValue ~1; (* The closure itself. *) genIndirect (locn+1, cvec) (* The value in the closure. +1 because first item is code addr. *) ) | locaddr BICLoadRecursive = pushLocalStackValue ~1 (* The closure itself - first value on the stack. *) (* generates code from the tree *) fun gencde (pt : backendIC, whereto : whereto, tailKind : tail, loopAddr) : unit = let (* Save the stack pointer value here. We may want to reset the stack. *) val oldsp = !realstackptr; (* Load the address and index value for byte operations. For ML memory operations the base is the address of an ML heap cell whereas for C operations it is a large-word box containing an address in C memory. That doesn't affect this code but the interpreter has to deal with these differently. *) fun genByteAddress{base, index, offset} = ( gencde (base, ToStack, NotEnd, loopAddr); (* Because the index and offset are both byte counts we can just add them if we need both. *) case (index, offset) of (NONE, offset) => (pushConst (toMachineWord offset, cvec); incsp()) | (SOME indexVal, 0w0) => gencde (indexVal, ToStack, NotEnd, loopAddr) | (SOME indexVal, offset) => ( gencde (indexVal, ToStack, NotEnd, loopAddr); pushConst (toMachineWord offset, cvec); genOpcode(opcode_wordAdd, cvec) ) ) (* Load the address, index value and offset for non-byte operations. Because the offset has already been scaled by the size of the operand we have to load the index and offset separately. *) fun genNonByteAddress{base, index, offset} = ( gencde (base, ToStack, NotEnd, loopAddr); case index of NONE => (pushConst (toMachineWord 0, cvec); incsp()) | SOME indexVal => gencde (indexVal, ToStack, NotEnd, loopAddr); pushConst (toMachineWord offset, cvec); incsp() ) val () = case pt of BICEval evl => genEval (evl, tailKind) | BICExtract ext => (* This may just be being used to discard a value which isn't used on this branch. *) if whereto = NoResult then () else locaddr ext | BICField {base, offset} => (gencde (base, ToStack, NotEnd, loopAddr); genIndirect (offset, cvec)) | BICLoadContainer {base, offset} => (gencde (base, ToStack, NotEnd, loopAddr); genIndirect (offset, cvec)) | BICLambda lam => genProc (lam, false, fn () => ()) | BICConstnt(w, _) => let val () = pushConst (w, cvec); in incsp () end | BICCond (testPart, thenPart, elsePart) => genCond (testPart, thenPart, elsePart, whereto, tailKind, loopAddr) | BICNewenv(decls, exp) => let (* Processes a list of entries. *) (* Mutually recursive declarations. May be either lambdas or constants. Recurse down the list pushing the addresses of the closure vectors, then unwind the recursion and fill them in. *) fun genMutualDecs [] = () | genMutualDecs ({lambda, addr, ...} :: otherDecs) = genProc (lambda, true, fn() => ( Array.update (decVec, addr, StackAddr (! realstackptr)); genMutualDecs (otherDecs) )) fun codeDecls(BICRecDecs dl) = genMutualDecs dl | codeDecls(BICDecContainer{size, addr}) = ( (* If this is a container we have to process it here otherwise it will be removed in the stack adjustment code. *) genContainer(size, cvec); (* Push the address of this container. *) realstackptr := !realstackptr + size + 1; (* Pushes N words plus the address. *) Array.update (decVec, addr, StackAddr(!realstackptr)) ) | codeDecls(BICDeclar{value, addr, ...}) = ( gencde (value, ToStack, NotEnd, loopAddr); Array.update (decVec, addr, StackAddr(!realstackptr)) ) | codeDecls(BICNullBinding exp) = gencde (exp, NoResult, NotEnd, loopAddr) in List.app codeDecls decls; gencde (exp, whereto, tailKind, loopAddr) end | BICBeginLoop {loop=body, arguments} => (* Execute the body which will contain at least one Loop instruction. There will also be path(s) which don't contain Loops and these will drop through. *) let val args = List.map #1 arguments (* Evaluate each of the arguments, pushing the result onto the stack. *) fun genLoopArg ({addr, value, ...}) = ( gencde (value, ToStack, NotEnd, loopAddr); Array.update (decVec, addr, StackAddr (!realstackptr)); !realstackptr (* Return the posn on the stack. *) ) val argIndexList = map genLoopArg args; val startSp = ! realstackptr; (* Remember the current top of stack. *) val startLoop = createLabel () val () = setLabel(startLoop, cvec) (* Start of loop *) in (* Process the body, passing the jump-back address down for the Loop instruction(s). *) gencde (body, whereto, tailKind, SOME(startLoop, startSp, argIndexList)) (* Leave the arguments on the stack. They can be cleared later if needed. *) end | BICLoop argList => (* Jump back to the enclosing BeginLoop. *) let val (startLoop, startSp, argIndexList) = case loopAddr of SOME l => l | NONE => raise InternalError "No BeginLoop for Loop instr" (* Evaluate the arguments. First push them to the stack because evaluating an argument may depend on the current value of others. Only when we've evaluated all of them can we overwrite the original argument positions. *) fun loadArgs ([], []) = !realstackptr - startSp (* The offset of all the args. *) | loadArgs (arg:: argList, _ :: argIndexList) = let (* Evaluate all the arguments. *) val () = gencde (arg, ToStack, NotEnd, NONE); val argOffset = loadArgs(argList, argIndexList); in genSetStackVal(argOffset, cvec); (* Copy the arg over. *) decsp(); (* The argument has now been popped. *) argOffset end | loadArgs _ = raise InternalError "loadArgs: Mismatched arguments"; val _: int = loadArgs(List.map #1 argList, argIndexList) in if !realstackptr <> startSp then resetStack (!realstackptr - startSp, false, cvec) (* Remove any local variables. *) else (); (* Jump back to the start of the loop. *) putBranchInstruction(Jump, startLoop, cvec) end | BICRaise exp => let val () = gencde (exp, ToStack, NotEnd, loopAddr) val () = genRaiseEx cvec; in exited := true end | BICHandle {exp, handler, exPacketAddr} => let (* Save old handler *) val () = genPushHandler cvec val () = incsp () val handlerLabel = createLabel() val () = putBranchInstruction (SetHandler, handlerLabel, cvec) val () = incsp() (* Code generate the body; "NotEnd" because we have to come back to remove the handler; "ToStack" because delHandler needs a result to carry down. *) val () = gencde (exp, ToStack, NotEnd, loopAddr) (* Now get out of the handler and restore the old one. *) val () = genOpcode(opcode_deleteHandler, cvec) val skipHandler = createLabel() val () = putBranchInstruction (Jump, skipHandler, cvec) (* Now process the handler itself. First we have to reset the stack. Note that we have to use "ToStack" again to be consistent with the stack-handling in the body-part. If we actually wanted "NoResult", the stack adjustment code at the end of gencde will take care of this. This means that I don't want to do any clever "end-of-function" optimisation either. SPF 6/1/97 *) val () = realstackptr := oldsp val () = exited := false val () = setLabel (handlerLabel, cvec) (* If we were executing machine code we must re-enter the interpreter. *) val () = genEnterIntCatch cvec (* Push the exception packet and set the address. *) val () = genLdexc cvec val () = incsp () val () = Array.update (decVec, exPacketAddr, StackAddr(!realstackptr)) val () = gencde (handler, ToStack, NotEnd, loopAddr) (* Have to remove the exception packet. *) val () = resetStack(1, true, cvec) val () = decsp() (* Finally fix-up the jump around the handler *) val () = setLabel (skipHandler, cvec) in exited := false end | BICCase ({cases, test, default, firstIndex, ...}) => let val () = gencde (test, ToStack, NotEnd, loopAddr) (* Label to jump to at the end of each case. *) val exitJump = createLabel() val () = if firstIndex = 0w0 then () else ( (* Subtract lower limit. Don't check for overflow. Instead allow large value to wrap around and check in "case" instruction. *) pushConst(toMachineWord firstIndex, cvec); genOpcode(opcode_wordSub, cvec) ) (* Generate the case instruction followed by the table of jumps. *) val nCases = List.length cases val caseLabels = genCase (nCases, cvec) val () = decsp () (* The default case, if any, follows the case statement. *) (* If we have a jump to the default set it to jump here. *) local fun fixDefault(NONE, defCase) = setLabel(defCase, cvec) | fixDefault(SOME _, _) = () in val () = ListPair.appEq fixDefault (cases, caseLabels) end val () = gencde (default, whereto, tailKind, loopAddr); val () = exited := false; fun genCases(SOME body, label) = ( (* First exit from the previous case or the default if this is the first. *) if !exited then () else putBranchInstruction(Jump, exitJump, cvec); (* Remove the result - the last case will leave it. *) case whereto of ToStack => decsp () | NoResult => (); (* Fix up the jump to come here. *) setLabel(label, cvec); exited := false; gencde (body, whereto, tailKind, loopAddr) ) | genCases(NONE, _) = () val () = ListPair.appEq genCases (cases, caseLabels) (* Finally set the exit jump to come here. *) val () = setLabel (exitJump, cvec) in exited := false end | BICTuple recList => let val size = List.length recList in (* Move the fields into the vector. *) List.app(fn v => gencde (v, ToStack, NotEnd, loopAddr)) recList; genTuple (size, cvec); realstackptr := !realstackptr - (size - 1) end | BICSetContainer{container, tuple, filter} => (* Copy the contents of a tuple into a container. If the tuple is a Tuple instruction we can avoid generating the tuple and then unpacking it and simply copy the fields that make up the tuple directly into the container. *) ( case tuple of BICTuple cl => (* Simply set the container from the values. *) let (* Load the address of the container. *) val _ = gencde (container, ToStack, NotEnd, loopAddr); fun setValues([], _, _) = () | setValues(v::tl, sourceOffset, destOffset) = if sourceOffset < BoolVector.length filter andalso BoolVector.sub(filter, sourceOffset) then ( gencde (v, ToStack, NotEnd, loopAddr); (* Move the entry into the container. This instruction pops the value to be moved but not the destination. *) genMoveToVec(destOffset, cvec); decsp(); setValues(tl, sourceOffset+1, destOffset+1) ) else setValues(tl, sourceOffset+1, destOffset) in setValues(cl, 0, 0) (* The container address is still on the stack. *) end | _ => let (* General case. *) (* First the target tuple, then the container. *) val () = gencde (tuple, ToStack, NotEnd, loopAddr) val () = gencde (container, ToStack, NotEnd, loopAddr) val last = BoolVector.foldli(fn (i, true, _) => i | (_, false, n) => n) ~1 filter fun copy (sourceOffset, destOffset) = if BoolVector.sub(filter, sourceOffset) then ( (* Duplicate the tuple address . *) genLocal(1, cvec); genIndirect(sourceOffset, cvec); genMoveToVec(destOffset, cvec); if sourceOffset = last then () else copy (sourceOffset+1, destOffset+1) ) else copy(sourceOffset+1, destOffset) in copy (0, 0) (* The container and tuple addresses are still on the stack. *) end ) | BICTagTest { test, tag, ... } => ( (* Convert this into a simple equality function. *) gencde (test, ToStack, NotEnd, loopAddr); pushConst (toMachineWord tag, cvec); genOpcode(opcode_equalWord, cvec) ) | BICGetThreadId => ( genOpcode(opcode_getThreadId, cvec); incsp() ) | BICUnary { oper, arg1 } => let open BuiltIns val () = gencde (arg1, ToStack, NotEnd, loopAddr) in case oper of NotBoolean => genOpcode(opcode_notBoolean, cvec) | IsTaggedValue => genOpcode(opcode_isTagged, cvec) | MemoryCellLength => genOpcode(opcode_cellLength, cvec) | MemoryCellFlags => genOpcode(opcode_cellFlags, cvec) | ClearMutableFlag => genOpcode(opcode_clearMutable, cvec) | AtomicIncrement => genOpcode(opcode_atomicIncr, cvec) | AtomicDecrement => genOpcode(opcode_atomicDecr, cvec) | AtomicReset => genOpcode(opcode_atomicReset, cvec) | LongWordToTagged => genOpcode(opcode_longWToTagged, cvec) | SignedToLongWord => genOpcode(opcode_signedToLongW, cvec) | UnsignedToLongWord => genOpcode(opcode_unsignedToLongW, cvec) | RealAbs PrecDouble => genOpcode(opcode_realAbs, cvec) | RealNeg PrecDouble => genOpcode(opcode_realNeg, cvec) | RealFixedInt PrecDouble => genOpcode(opcode_fixedIntToReal, cvec) | RealAbs PrecSingle => genOpcode(opcode_floatAbs, cvec) | RealNeg PrecSingle => genOpcode(opcode_floatNeg, cvec) | RealFixedInt PrecSingle => genOpcode(opcode_fixedIntToFloat, cvec) | FloatToDouble => genOpcode(opcode_floatToReal, cvec) | DoubleToFloat rnding => genDoubleToFloat(rnding, cvec) | RealToInt (PrecDouble, rnding) => genRealToInt(rnding, cvec) | RealToInt (PrecSingle, rnding) => genFloatToInt(rnding, cvec) | TouchAddress => resetStack(1, false, cvec) (* Discard this *) end | BICBinary { oper, arg1, arg2 } => let open BuiltIns val () = gencde (arg1, ToStack, NotEnd, loopAddr) val () = gencde (arg2, ToStack, NotEnd, loopAddr) in case oper of WordComparison{test=TestEqual, ...} => genOpcode(opcode_equalWord, cvec) | WordComparison{test=TestLess, isSigned=true} => genOpcode(opcode_lessSigned, cvec) | WordComparison{test=TestLessEqual, isSigned=true} => genOpcode(opcode_lessEqSigned, cvec) | WordComparison{test=TestGreater, isSigned=true} => genOpcode(opcode_greaterSigned, cvec) | WordComparison{test=TestGreaterEqual, isSigned=true} => genOpcode(opcode_greaterEqSigned, cvec) | WordComparison{test=TestLess, isSigned=false} => genOpcode(opcode_lessUnsigned, cvec) | WordComparison{test=TestLessEqual, isSigned=false} => genOpcode(opcode_lessEqUnsigned, cvec) | WordComparison{test=TestGreater, isSigned=false} => genOpcode(opcode_greaterUnsigned, cvec) | WordComparison{test=TestGreaterEqual, isSigned=false} => genOpcode(opcode_greaterEqUnsigned, cvec) | WordComparison{test=TestUnordered, ...} => raise InternalError "WordComparison: TestUnordered" + | PointerEq => genOpcode(opcode_equalWord, cvec) + | FixedPrecisionArith ArithAdd => genOpcode(opcode_fixedAdd, cvec) | FixedPrecisionArith ArithSub => genOpcode(opcode_fixedSub, cvec) | FixedPrecisionArith ArithMult => genOpcode(opcode_fixedMult, cvec) | FixedPrecisionArith ArithQuot => genOpcode(opcode_fixedQuot, cvec) | FixedPrecisionArith ArithRem => genOpcode(opcode_fixedRem, cvec) | FixedPrecisionArith ArithDiv => raise InternalError "TODO: FixedPrecisionArith ArithDiv" | FixedPrecisionArith ArithMod => raise InternalError "TODO: FixedPrecisionArith ArithMod" | WordArith ArithAdd => genOpcode(opcode_wordAdd, cvec) | WordArith ArithSub => genOpcode(opcode_wordSub, cvec) | WordArith ArithMult => genOpcode(opcode_wordMult, cvec) | WordArith ArithDiv => genOpcode(opcode_wordDiv, cvec) | WordArith ArithMod => genOpcode(opcode_wordMod, cvec) | WordArith _ => raise InternalError "WordArith - unimplemented instruction" | WordLogical LogicalAnd => genOpcode(opcode_wordAnd, cvec) | WordLogical LogicalOr => genOpcode(opcode_wordOr, cvec) | WordLogical LogicalXor => genOpcode(opcode_wordXor, cvec) | WordShift ShiftLeft => genOpcode(opcode_wordShiftLeft, cvec) | WordShift ShiftRightLogical => genOpcode(opcode_wordShiftRLog, cvec) | WordShift ShiftRightArithmetic => genOpcode(opcode_wordShiftRArith, cvec) | AllocateByteMemory => genOpcode(opcode_allocByteMem, cvec) | LargeWordComparison TestEqual => genOpcode(opcode_lgWordEqual, cvec) | LargeWordComparison TestLess => genOpcode(opcode_lgWordLess, cvec) | LargeWordComparison TestLessEqual => genOpcode(opcode_lgWordLessEq, cvec) | LargeWordComparison TestGreater => genOpcode(opcode_lgWordGreater, cvec) | LargeWordComparison TestGreaterEqual => genOpcode(opcode_lgWordGreaterEq, cvec) | LargeWordComparison TestUnordered => raise InternalError "LargeWordComparison: TestUnordered" | LargeWordArith ArithAdd => genOpcode(opcode_lgWordAdd, cvec) | LargeWordArith ArithSub => genOpcode(opcode_lgWordSub, cvec) | LargeWordArith ArithMult => genOpcode(opcode_lgWordMult, cvec) | LargeWordArith ArithDiv => genOpcode(opcode_lgWordDiv, cvec) | LargeWordArith ArithMod => genOpcode(opcode_lgWordMod, cvec) | LargeWordArith _ => raise InternalError "LargeWordArith - unimplemented instruction" | LargeWordLogical LogicalAnd => genOpcode(opcode_lgWordAnd, cvec) | LargeWordLogical LogicalOr => genOpcode(opcode_lgWordOr, cvec) | LargeWordLogical LogicalXor => genOpcode(opcode_lgWordXor, cvec) | LargeWordShift ShiftLeft => genOpcode(opcode_lgWordShiftLeft, cvec) | LargeWordShift ShiftRightLogical => genOpcode(opcode_lgWordShiftRLog, cvec) | LargeWordShift ShiftRightArithmetic => genOpcode(opcode_lgWordShiftRArith, cvec) | RealComparison (TestEqual, PrecDouble) => genOpcode(opcode_realEqual, cvec) | RealComparison (TestLess, PrecDouble) => genOpcode(opcode_realLess, cvec) | RealComparison (TestLessEqual, PrecDouble) => genOpcode(opcode_realLessEq, cvec) | RealComparison (TestGreater, PrecDouble) => genOpcode(opcode_realGreater, cvec) | RealComparison (TestGreaterEqual, PrecDouble) => genOpcode(opcode_realGreaterEq, cvec) | RealComparison (TestUnordered, PrecDouble) => genOpcode(opcode_realUnordered, cvec) | RealComparison (TestEqual, PrecSingle) => genOpcode(opcode_floatEqual, cvec) | RealComparison (TestLess, PrecSingle) => genOpcode(opcode_floatLess, cvec) | RealComparison (TestLessEqual, PrecSingle) => genOpcode(opcode_floatLessEq, cvec) | RealComparison (TestGreater, PrecSingle) => genOpcode(opcode_floatGreater, cvec) | RealComparison (TestGreaterEqual, PrecSingle) => genOpcode(opcode_floatGreaterEq, cvec) | RealComparison (TestUnordered, PrecSingle) => genOpcode(opcode_floatUnordered, cvec) | RealArith (ArithAdd, PrecDouble) => genOpcode(opcode_realAdd, cvec) | RealArith (ArithSub, PrecDouble) => genOpcode(opcode_realSub, cvec) | RealArith (ArithMult, PrecDouble) => genOpcode(opcode_realMult, cvec) | RealArith (ArithDiv, PrecDouble) => genOpcode(opcode_realDiv, cvec) | RealArith (ArithAdd, PrecSingle) => genOpcode(opcode_floatAdd, cvec) | RealArith (ArithSub, PrecSingle) => genOpcode(opcode_floatSub, cvec) | RealArith (ArithMult, PrecSingle) => genOpcode(opcode_floatMult, cvec) | RealArith (ArithDiv, PrecSingle) => genOpcode(opcode_floatDiv, cvec) | RealArith _ => raise InternalError "RealArith - unimplemented instruction" ; decsp() (* Removes one item from the stack. *) end | BICAllocateWordMemory {numWords as BICConstnt(length, _), flags as BICConstnt(flagByte, _), initial } => if isShort length andalso toShort length = 0w1 andalso isShort flagByte andalso toShort flagByte = 0wx40 then (* This is a very common case. *) ( gencde (initial, ToStack, NotEnd, loopAddr); genOpcode(opcode_alloc_ref, cvec) ) else let val () = gencde (numWords, ToStack, NotEnd, loopAddr) val () = gencde (flags, ToStack, NotEnd, loopAddr) val () = gencde (initial, ToStack, NotEnd, loopAddr) in genOpcode(opcode_allocWordMemory, cvec); decsp(); decsp() end | BICAllocateWordMemory { numWords, flags, initial } => let val () = gencde (numWords, ToStack, NotEnd, loopAddr) val () = gencde (flags, ToStack, NotEnd, loopAddr) val () = gencde (initial, ToStack, NotEnd, loopAddr) in genOpcode(opcode_allocWordMemory, cvec); decsp(); decsp() end | BICLoadOperation { kind=LoadStoreMLWord _, address={base, index=NONE, offset}} => ( (* If the index is a constant, frequently zero, we can use indirection. The offset is a byte count so has to be divided by the word size but it should always be an exact multiple. *) gencde (base, ToStack, NotEnd, loopAddr); offset mod wordSize = 0w0 orelse raise InternalError "gencde: BICLoadOperation - not word multiple"; genIndirect (Word.toInt(offset div wordSize), cvec) ) | BICLoadOperation { kind=LoadStoreMLWord _, address={base, index=SOME indexVal, offset}} => let (* Variable index. *) val () = gencde (base, ToStack, NotEnd, loopAddr) val () = gencde (indexVal, ToStack, NotEnd, loopAddr) val () = (pushConst (toMachineWord offset, cvec); incsp()) in genOpcode(opcode_loadMLWord, cvec); decsp(); decsp() end | BICLoadOperation { kind=LoadStoreMLByte _, address} => ( genByteAddress address; genOpcode(opcode_loadMLByte, cvec); decsp() ) | BICLoadOperation { kind=LoadStoreC8, address} => ( genByteAddress address; genOpcode(opcode_loadC8, cvec); decsp() ) | BICLoadOperation { kind=LoadStoreC16, address} => ( genNonByteAddress address; genOpcode(opcode_loadC16, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreC32, address} => ( genNonByteAddress address; genOpcode(opcode_loadC32, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreC64, address} => ( wordSize = 0w8 orelse raise InternalError "LoadStoreC64 but not 64-bit mode"; genNonByteAddress address; genOpcode(opcode_loadC64, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreCFloat, address} => ( genNonByteAddress address; genOpcode(opcode_loadCFloat, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreCDouble, address} => ( genNonByteAddress address; genOpcode(opcode_loadCDouble, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreUntaggedUnsigned, address} => ( genNonByteAddress address; genOpcode(opcode_loadUntagged, cvec); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreMLWord _, address={base, index=NONE, offset}, value } => let (* No index. We could almost use move_to_vec here except that it leaves the destination address on the stack instead of replacing it with "unit". *) val () = gencde (base, ToStack, NotEnd, loopAddr) val () = pushConst (toMachineWord 0, cvec) val () = incsp() val () = pushConst (toMachineWord offset, cvec) val () = incsp() val () = gencde (value, ToStack, NotEnd, loopAddr) in genOpcode(opcode_storeMLWord, cvec); decsp(); decsp(); decsp() end | BICStoreOperation { kind=LoadStoreMLWord _, address={base, index=SOME indexVal, offset}, value } => let (* Variable index *) val () = gencde (base, ToStack, NotEnd, loopAddr) val () = gencde (indexVal, ToStack, NotEnd, loopAddr) val () = pushConst (toMachineWord offset, cvec) val () = incsp() val () = gencde (value, ToStack, NotEnd, loopAddr) in genOpcode(opcode_storeMLWord, cvec); decsp(); decsp(); decsp() end | BICStoreOperation { kind=LoadStoreMLByte _, address, value } => ( genByteAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeMLByte, cvec); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreC8, address, value} => ( genByteAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeC8, cvec); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreC16, address, value} => ( genNonByteAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeC16, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreC32, address, value} => ( genNonByteAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeC32, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreC64, address, value} => ( genNonByteAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeC64, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreCFloat, address, value} => ( genNonByteAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeCFloat, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreCDouble, address, value} => ( genNonByteAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeCDouble, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreUntaggedUnsigned, address, value} => ( genNonByteAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeUntagged, cvec); decsp(); decsp(); decsp() ) | BICBlockOperation { kind=BlockOpMove{isByteMove=true}, sourceLeft, destRight, length } => ( genByteAddress sourceLeft; genByteAddress destRight; gencde (length, ToStack, NotEnd, loopAddr); genOpcode(opcode_blockMoveByte, cvec); decsp(); decsp(); decsp(); decsp() ) | BICBlockOperation { kind=BlockOpMove{isByteMove=false}, sourceLeft, destRight, length } => ( genNonByteAddress sourceLeft; genNonByteAddress destRight; gencde (length, ToStack, NotEnd, loopAddr); genOpcode(opcode_blockMoveWord, cvec); decsp(); decsp(); decsp(); decsp(); decsp(); decsp() ) | BICBlockOperation { kind=BlockOpEqualByte, sourceLeft, destRight, length } => ( genByteAddress sourceLeft; genByteAddress destRight; gencde (length, ToStack, NotEnd, loopAddr); genOpcode(opcode_blockEqualByte, cvec); decsp(); decsp(); decsp(); decsp() ) | BICBlockOperation { kind=BlockOpCompareByte, sourceLeft, destRight, length } => ( genByteAddress sourceLeft; genByteAddress destRight; gencde (length, ToStack, NotEnd, loopAddr); genOpcode(opcode_blockCompareByte, cvec); decsp(); decsp(); decsp(); decsp() ) | BICArbitrary { longCall, ... } => (* Just use the long-precision case in the interpreted version. *) ( gencde (longCall, whereto, tailKind, loopAddr) ) in (* body of gencde *) (* This ensures that there is precisely one item on the stack if whereto = ToStack and no items if whereto = NoResult. There are two points to note carefully here: (1) Negative stack adjustments are legal if we have exited. This is because matchFailFn can cut the stack back too far for its immediately enclosing expression. This is harmless because the code actually exits that expression. (2) A stack adjustment of ~1 is legal if we're generating a declaration in "ToStack" mode, because not all declarations actually generate the dummy value that we expect. This used to be handled in resetStack itself, but it's more transparent to do it here. (In addition, there was a bug in resetStack - it accumulated the stack resets, but didn't correctly accumulate these "~1" dummy value pushes.) It's all much better now. SPF 9/1/97 *) case whereto of ToStack => let val newsp = oldsp + 1; val adjustment = !realstackptr - newsp val () = if !exited orelse adjustment = 0 then () else if adjustment < ~1 then raise InternalError ("gencde: bad adjustment " ^ Int.toString adjustment) (* Hack for declarations that should push values, but don't *) else if adjustment = ~1 then pushConst (DummyValue, cvec) else resetStack (adjustment, true, cvec) in realstackptr := newsp end | NoResult => let val adjustment = !realstackptr - oldsp val () = if !exited orelse adjustment = 0 then () else if adjustment < 0 then raise InternalError ("gencde: bad adjustment " ^ Int.toString adjustment) else resetStack (adjustment, false, cvec) in realstackptr := oldsp end end (* gencde *) (* doNext is only used for mutually recursive functions where a function may not be able to fill in its closure if it does not have all the remaining declarations. *) (* TODO: This always creates the closure on the heap even when makeClosure is false. *) and genProc ({ closure=[], localCount, body, argTypes, name, ...}: bicLambdaForm, mutualDecs, doNext: unit -> unit) : unit = let (* Create a one word item for the closure. This is returned for recursive references and filled in with the address of the code when we've finished. *) val closure = makeConstantClosure() val newCode : code = codeCreate(name, parameters); (* Code-gen function. No non-local references. *) val () = codegen (body, newCode, closure, List.length argTypes, localCount, parameters); val () = pushConst(closureAsAddress closure, cvec); val () = incsp(); in if mutualDecs then doNext () else () end | genProc ({ localCount, body, name, argTypes, closure, ...}, mutualDecs, doNext) = let (* Full closure required. *) val resClosure = makeConstantClosure() val newCode = codeCreate (name, parameters) (* Code-gen function. *) val () = codegen (body, newCode, resClosure, List.length argTypes, localCount, parameters) val sizeOfClosure = List.length closure + 1; in if mutualDecs then let (* Have to make the closure now and fill it in later. *) (* This previously used genGetStore which at one time was widely used. *) val () = pushConst(toMachineWord sizeOfClosure, cvec) (* Length *) val () = pushConst(toMachineWord F_mutable, cvec) (* Flags *) val () = pushConst(toMachineWord 0, cvec) (* Initialise to zero. *) val () = genOpcode(opcode_allocWordMemory, cvec) (* Allocate the memory. *) val () = incsp () (* Put code address into closure *) val () = pushConst(codeAddressFromClosure resClosure, cvec) val () = genMoveToVec(0, cvec) val entryAddr : int = !realstackptr val () = doNext () (* Any mutually recursive functions. *) (* Push the address of the vector - If we have processed other closures the vector will no longer be on the top of the stack. *) val () = pushLocalStackValue (~ entryAddr) (* Load items for the closure. *) fun loadItems ([], _) = () | loadItems (v :: vs, addr : int) = let (* Generate an item and move it into the vector *) val () = gencde (BICExtract v, ToStack, NotEnd, NONE) val () = genMoveToVec(addr, cvec) val () = decsp () in loadItems (vs, addr + 1) end val () = loadItems (closure, 1) val () = genLock cvec (* Lock it. *) (* Remove the extra reference. *) val () = resetStack (1, false, cvec) in realstackptr := !realstackptr - 1 end else let (* Put it on the stack. *) val () = pushConst (codeAddressFromClosure resClosure, cvec) val () = incsp () val () = List.app (fn pt => gencde (BICExtract pt, ToStack, NotEnd, NONE)) closure val () = genTuple (sizeOfClosure, cvec) in realstackptr := !realstackptr - (sizeOfClosure - 1) end end and genCond (testCode, thenCode, elseCode, whereto, tailKind, loopAddr) = let val () = gencde (testCode, ToStack, NotEnd, loopAddr) val toElse = createLabel() and exitJump = createLabel() val () = putBranchInstruction(JumpFalse, toElse, cvec) val () = decsp() val () = gencde (thenCode, whereto, tailKind, loopAddr) (* Get rid of the result from the stack. If there is a result then the ``else-part'' will push it. *) val () = case whereto of ToStack => decsp () | NoResult => () val thenExited = !exited val () = if thenExited then () else putBranchInstruction (Jump, exitJump, cvec) (* start of "else part" *) val () = setLabel (toElse, cvec) val () = exited := false val () = gencde (elseCode, whereto, tailKind, loopAddr) val elseExited = !exited val () = setLabel (exitJump, cvec) in exited := (thenExited andalso elseExited) (* Only exited if both sides did. *) end (* genCond *) and genEval (eval, tailKind : tail) : unit = let val argList : backendIC list = List.map #1 (#argList eval) val argsToPass : int = List.length argList; (* Load arguments *) fun loadArgs [] = () | loadArgs (v :: vs) = let (* Push each expression onto the stack. *) val () = gencde(v, ToStack, NotEnd, NONE) in loadArgs vs end; (* Called after the args and the closure to call have been pushed onto the stack. *) fun callClosure () : unit = case tailKind of NotEnd => (* Normal call. *) genCallClosure cvec | EndOfProc => (* Tail recursive call. *) let (* Get the return address onto the top of the stack. *) val () = pushLocalStackValue 0 (* Slide the return address, closure and args over the old closure, return address and args, and reset the stack. Then jump to the closure. *) val () = genTailCall(argsToPass + 2, !realstackptr - 1 + (numOfArgs - argsToPass), cvec); (* It's "-1" not "-2", because we didn't bump the realstackptr when we pushed the return address. SPF 3/1/97 *) in exited := true end (* Have to guarantee that the expression to return the function is evaluated before the arguments. *) (* Returns true if evaluating it later is safe. *) fun safeToLeave (BICConstnt _) = true | safeToLeave (BICLambda _) = true | safeToLeave (BICExtract _) = true | safeToLeave (BICField {base, ...}) = safeToLeave base | safeToLeave (BICLoadContainer {base, ...}) = safeToLeave base | safeToLeave _ = false val () = if (case argList of [] => true | _ => safeToLeave (#function eval)) then let (* Can load the args first. *) val () = loadArgs argList in gencde (#function eval, ToStack, NotEnd, NONE) end else let (* The expression for the function is too complicated to risk leaving. It might have a side-effect and we must ensure that any side-effects it has are done before the arguments are loaded. *) val () = gencde(#function eval, ToStack, NotEnd, NONE); val () = loadArgs(argList); (* Load the function again. *) val () = genLocal(argsToPass, cvec); in incsp () end val () = callClosure () (* Call the function. *) (* Make sure we interpret when we return from the call *) val () = genEnterIntCall (cvec, argsToPass) in (* body of genEval *) realstackptr := !realstackptr - argsToPass (* Args popped by caller. *) end (* Generate the function. *) (* Assume we always want a result. There is otherwise a problem if the called routine returns a result of type void (i.e. no result) but the caller wants a result (e.g. the identity function). *) val () = gencde (pt, ToStack, EndOfProc, NONE) val () = if !exited then () else genReturn (numOfArgs, cvec); in (* body of codegen *) (* Having code-generated the body of the function, it is copied into a new data segment. *) copyCode(cvec, !maxStack, resultClosure) end (* codegen *); fun gencodeLambda({ name, body, argTypes, localCount, ...}:bicLambdaForm, parameters, closure) = let (* make the code buffer for the new function. *) val newCode : code = codeCreate (name, parameters) (* This function must have no non-local references. *) in codegen (body, newCode, closure, List.length argTypes, localCount, parameters) end local val makeEntryPoint: string -> machineWord = RunCall.rtsCallFull1 "PolyCreateEntryPointObject" fun rtsCall makeCall (entryName: string, numOfArgs, debugArgs: Universal.universal list): machineWord = let open Address val cvec = codeCreate (entryName, debugArgs) val entryPointAddr = makeEntryPoint entryName (* Each argument is at the same offset, essentially we're just shifting them *) fun genLocals 0 = () | genLocals n = (genLocal(numOfArgs +1, cvec); genLocals (n-1)) val () = genLocals numOfArgs val () = pushConst(entryPointAddr, cvec) val () = makeCall(numOfArgs, cvec) val () = genReturn (numOfArgs, cvec) val closure = makeConstantClosure() val () = copyCode(cvec, numOfArgs+1, closure) in closureAsAddress closure end in structure Foreign = struct val rtsCallFast = rtsCall genRTSCallFast and rtsCallFull = rtsCall genRTSCallFull fun rtsCallFastRealtoReal(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastRealtoReal c) (entryName, 1, debugArgs) and rtsCallFastRealRealtoReal(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastRealRealtoReal c) (entryName, 2, debugArgs) and rtsCallFastGeneraltoReal(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastGeneraltoReal c) (entryName, 1, debugArgs) and rtsCallFastRealGeneraltoReal(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastRealGeneraltoReal c) (entryName, 2, debugArgs) fun rtsCallFastFloattoFloat(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastFloattoFloat c) (entryName, 1, debugArgs) and rtsCallFastFloatFloattoFloat(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastFloatFloattoFloat c) (entryName, 2, debugArgs) and rtsCallFastGeneraltoFloat(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastGeneraltoFloat c) (entryName, 1, debugArgs) and rtsCallFastFloatGeneraltoFloat(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastFloatGeneraltoFloat c) (entryName, 2, debugArgs) end end structure Sharing = struct open BACKENDTREE.Sharing type closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/CODETREE.ML b/mlsource/MLCompiler/CodeTree/CODETREE.ML index bd4245bd..6d0bb1f9 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE.ML +++ b/mlsource/MLCompiler/CodeTree/CODETREE.ML @@ -1,587 +1,606 @@ (* - Copyright (c) 2012,13,15-19 David C.J. Matthews + Copyright (c) 2012,13,15-20 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 *) + val mkProc = Lambda o mkSimpleFunction DontInline (* Normal function *) + and mkInlproc = Lambda o mkSimpleFunction InlineAlways (* 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, + EnvSpecInlineFunction(mkSimpleFunction InlineAlways args, fn _ => raise InternalError "mkMacroProc: closure")) []) - | mkMacroProc args = Lambda(mkSimpleFunction Inline args) + | mkMacroProc args = Lambda(mkSimpleFunction InlineAlways 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 + val mkFunction = mkFunWithTypes DontInline + and mkInlineFunction = mkFunWithTypes InlineAlways 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 = 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) = + and mkEqualTaggedWord (arg1, arg2) = Binary{oper=eqWord, arg1=arg1, arg2=arg2} - val equalWordFn = (* This takes two words, not a tuple. *) + and mkEqualPointerOrWord (arg1, arg2) = + Binary{oper=PointerEq, arg1=arg1, arg2=arg2} + val equalTaggedWordFn = (* This takes two words, not a tuple. *) mkInlproc(mkBinary(eqWord, mkLoadArgument 0, mkLoadArgument 1), 2, "EqualWord()", [], 0) + and equalPointerOrWordFn = (* This takes two words, not a tuple. *) + mkInlproc(mkBinary(PointerEq, 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 + (* We don't generate the +, -, < etc operations directly here. Instead we create functions + that the basis library can use to create the final versions by applying these functions + to the arguments and an RTS function. The inline expansion system takes care of all the + optimisation. + 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) + local + val argX = mkInd(0, mkLoadArgument 0) and argY = mkInd(1, mkLoadArgument 0) + val testShort = mkCand(mkIsShort argX, mkIsShort argY) + val longCall = mkEval(mkInd(2, mkLoadArgument 0), [mkTuple[argX, argY]]) + in + + fun mkArbitraryFn (oper as ArbArith arith) = + mkInlproc( + Arbitrary{oper=oper, shortCond=testShort, arg1=argX, arg2=argY, longCall=longCall }, + 1, "Arbitrary" ^ BuiltIns.arithRepr arith ^ "()", [], 0) + | mkArbitraryFn (oper as ArbCompare test) = + (* The long function here is PolyCompareArbitrary which returns -1,0,+1 so the + result has to be compared with zero. *) + let + val comparedResult = + Binary{oper=BuiltIns.WordComparison{test=test, isSigned=true}, arg1=longCall, arg2=CodeZero} + in + mkInlproc( + Arbitrary{oper=oper, shortCond=testShort, arg1=argX, arg2=argY, longCall=comparedResult }, + 1, "Arbitrary" ^ BuiltIns.testRepr test ^ "()", [], 0) + end + end 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_CODEGEN_CONSTANT_FUNCTIONS.sml b/mlsource/MLCompiler/CodeTree/CODETREE_CODEGEN_CONSTANT_FUNCTIONS.sml index 125e8bdb..acdc4ca6 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE_CODEGEN_CONSTANT_FUNCTIONS.sml +++ b/mlsource/MLCompiler/CodeTree/CODETREE_CODEGEN_CONSTANT_FUNCTIONS.sml @@ -1,315 +1,315 @@ (* Copyright (c) 2013, 2015, 2017, 2020 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 *) (* If a function has an empty closure it can be code-generated immediately. That may allow other functions or tuples to be generated immediately as well. As well as avoiding run-time allocations this also allows the code-generator to use calls/jumps to constant addresses. *) functor CODETREE_CODEGEN_CONSTANT_FUNCTIONS ( structure BASECODETREE: BaseCodeTreeSig structure CODETREE_FUNCTIONS: CodetreeFunctionsSig structure BACKEND: CodegenTreeSig structure DEBUG: DEBUGSIG structure PRETTY : PRETTYSIG structure CODE_ARRAY: CODEARRAYSIG sharing BASECODETREE.Sharing = CODETREE_FUNCTIONS.Sharing = BACKEND.Sharing = PRETTY.Sharing = CODE_ARRAY.Sharing ): 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 = struct open BASECODETREE open CODETREE_FUNCTIONS open CODE_ARRAY open Address exception InternalError = Misc.InternalError datatype lookupVal = EnvGenLoad of loadForm | EnvGenConst of machineWord * Universal.universal list type cgContext = { lookupAddr: loadForm -> lookupVal, enterConstant: int * (machineWord * Universal.universal list) -> unit, debugArgs: Universal.universal list } (* Code-generate a function or set of mutually recursive functions that contain no free variables and run the code to return the address. This allows us to further fold the address as a constant if, for example, it is used in a tuple. *) fun codeGenerateToConstant(lambda, debugSwitches, closure) = let val () = if DEBUG.getParameter DEBUG.codetreeAfterOptTag debugSwitches then PRETTY.getCompilerOutput debugSwitches (BASECODETREE.pretty(Lambda lambda)) else () in BACKEND.codeGenerate(lambda, debugSwitches, closure) end (* If we are code-generating a function immediately we make a one-word mutable cell that will subsequently contain the address of the code. After it is locked this becomes the closure of the function. By creating it here we can turn recursive references into constant references before we actually compile the function. *) fun cgFuns ({ lookupAddr, ...}: cgContext) (Extract ext) = ( (* Look up the entry. It may now be a constant. If it isn't it may still have changed if it is a closure entry and other closure entries have been replaced by constants. *) case lookupAddr ext of EnvGenLoad load => SOME(Extract load) | EnvGenConst w => SOME(Constnt w) ) | cgFuns (context as {debugArgs, ...}) (Lambda lambda) = let val copied as { closure=resultClosure, ...} = cgLambda(context, lambda, EnvGenLoad LoadRecursive) in case resultClosure of [] => let (* Create a "closure" for the function. *) val closure = makeConstantClosure() (* Replace any recursive references by references to the closure. There may be inner functions that only make recursive calls to this. By turning the recursive references into constants we may be able to compile them immediately as well. *) val repLambda = cgLambda(context, lambda, EnvGenConst(toMachineWord closure, [])) val props = codeGenerateToConstant(repLambda, debugArgs, closure) in SOME(Constnt(toMachineWord closure, props)) end | _ => SOME(Lambda copied) end | cgFuns (context as { enterConstant, debugArgs, ...}) (Newenv(envBindings, envExp)) = let (* First expand out any mutually-recursive bindings. This ensures that if we have any RecDecs left *) val expandedBindings = List.foldr (fn (d, l) => partitionMutualBindings d @ l) [] envBindings fun processBindings(Declar{value, addr, use} :: tail) = ( (* If this is a constant put it in the table otherwise create a binding. *) case mapCodetree (cgFuns context) value of Constnt w => (enterConstant(addr, w); processBindings tail) | code => Declar{value=code, addr=addr, use=use} :: processBindings tail ) | processBindings(NullBinding c :: tail) = NullBinding(mapCodetree (cgFuns context) c) :: processBindings tail | processBindings(RecDecs[{addr, lambda, use}] :: tail) = (* Single recursive bindings - treat as simple binding *) processBindings(Declar{addr=addr, value=Lambda lambda, use = use} :: tail) | processBindings(RecDecs recdecs :: tail) = let (* We know that this forms a strongly connected component so it is only possible to code-generate the group if no function has a free-variable outside the group. Each function must have at least one free variable which is part of the group. *) fun processEntry {addr, lambda, use} = {addr=addr, lambda=cgLambda(context, lambda, EnvGenLoad LoadRecursive), use=use} val processedGroup = map processEntry recdecs (* If every free variable is another member of the group we can code-generate the group. *) local fun closureItemInGroup(LoadLocal n) = List.exists(fn{addr, ...} => n = addr) processedGroup | closureItemInGroup _ = false fun onlyInGroup{lambda={closure, ...}, ...} = List.all closureItemInGroup closure in val canCodeGen = List.all onlyInGroup processedGroup end in if canCodeGen then let open Address (* Create "closures" for each entry. Add these as constants to the table. *) fun createAndEnter {addr, ...} = let val c = makeConstantClosure() in enterConstant(addr, (Address.toMachineWord c, [])); c end val closures = List.map createAndEnter processedGroup (* Code-generate each of the lambdas and store the code in the closure. *) fun processLambda({lambda, addr, ...}, closure) = let val closureAsMachineWord = Address.toMachineWord closure val repLambda = cgLambda(context, lambda, EnvGenConst(closureAsMachineWord, [])) val props = codeGenerateToConstant(repLambda, debugArgs, closure) in (* Include any properties we may have added *) enterConstant(addr, (closureAsMachineWord, props)) end val () = ListPair.appEq processLambda (processedGroup, closures) in processBindings tail (* We've done these *) end else RecDecs processedGroup :: processBindings tail end | processBindings(Container{addr, use, size, setter} :: tail) = Container{addr=addr, use=use, size=size, setter = mapCodetree (cgFuns context) setter} :: processBindings tail | processBindings [] = [] val bindings = processBindings expandedBindings val body = mapCodetree (cgFuns context) envExp in case bindings of [] => SOME body | _ => SOME(Newenv(bindings, body)) end | cgFuns context (Tuple{ fields, isVariant }) = (* Create any constant tuples that have arisen because they contain constant functions. *) SOME((if isVariant then mkDatatype else mkTuple)(map (mapCodetree (cgFuns context)) fields)) | cgFuns _ _ = NONE and cgLambda({lookupAddr, debugArgs, ...}, { body, isInline, name, closure, argTypes, resultType, localCount, recUse}, loadRecursive) = let val cArray = Array.array(localCount, NONE) val newClosure = makeClosure() fun lookupLocal(load as LoadLocal n) = ( case Array.sub(cArray, n) of NONE => EnvGenLoad load | SOME w => EnvGenConst w ) | lookupLocal(LoadClosure n) = ( case lookupAddr(List.nth (closure, n)) of EnvGenLoad load => EnvGenLoad(addToClosure newClosure load) | c as EnvGenConst _ => c ) | lookupLocal LoadRecursive = loadRecursive | lookupLocal load = EnvGenLoad load (* Argument *) val context = { lookupAddr = lookupLocal, enterConstant = fn (n, w) => Array.update(cArray, n, SOME w), debugArgs = debugArgs } (* Process the body to deal with any sub-functions and also to bind in any constants from free variables. *) val newBody = mapCodetree (cgFuns context) body (* Build the resulting lambda. *) val resultClosure = extractClosure newClosure in { body = newBody, isInline = isInline, name = name, closure = resultClosure, argTypes = argTypes, resultType = resultType, localCount = localCount, recUse = recUse } end fun codeGenerate(original, nLocals, debugArgs) = let val cArray = Array.array(nLocals, NONE) fun lookupAddr(load as LoadLocal n) = ( case Array.sub(cArray, n) of NONE => EnvGenLoad load | SOME w => EnvGenConst w ) | lookupAddr _ = raise InternalError "lookupConstant: top-level reached" val context = { lookupAddr = lookupAddr, enterConstant = fn (n, w) => Array.update(cArray, n, SOME w), debugArgs = debugArgs } val resultCode = mapCodetree (cgFuns context) original (* Turn this into a lambda to code-generate. *) val lambda:lambdaForm = { body = resultCode, - isInline = NonInline, + isInline = DontInline, name = "", closure = [], argTypes = [(GeneralType, [])], resultType = GeneralType, localCount = nLocals, recUse = [] } val closure = makeConstantClosure() val props = BACKEND.codeGenerate(lambda, debugArgs, closure) (* The code may consist of tuples (i.e. compiled ML structures) containing a mixture of Loads, where the values are yet to be compiled, and Constants, where the code has now been compiled. We need to extract any properties from the constants and return the whole lot as tuple properties. *) fun extractProps(Constnt(_, p)) = p | extractProps(Extract ext) = ( case lookupAddr ext of EnvGenLoad _ => [] | EnvGenConst(_, p) => p ) | extractProps(Tuple{fields, ...}) = let val fieldProps = map extractProps fields in if List.all null fieldProps then [] else [Universal.tagInject CodeTags.tupleTag fieldProps] end | extractProps(Newenv(_, exp)) = extractProps exp | extractProps _ = [] val newProps = extractProps original (* Cast this as a function. It is a function with a single argument. *) val resultFunction: unit -> machineWord = RunCall.unsafeCast closure in (resultFunction, CodeTags.mergeTupleProps(newProps, props)) end structure Foreign = BACKEND.Foreign structure Sharing = struct type codetree = codetree end end; diff --git a/mlsource/MLCompiler/CodeTree/CODETREE_FUNCTIONS.sml b/mlsource/MLCompiler/CodeTree/CODETREE_FUNCTIONS.sml index 9976ba11..f91917ce 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE_FUNCTIONS.sml +++ b/mlsource/MLCompiler/CodeTree/CODETREE_FUNCTIONS.sml @@ -1,493 +1,623 @@ (* Copyright (c) 2012,13,16,18-20 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 (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 | TouchAddress => PROPWORD_NORAISE (* Treat as updating a notional reference count. *) 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) + | PointerEq => applicative 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 partitionMutualBindings(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 ([{lambda, addr, 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. *) | partitionMutualBindings 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 + 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 _ (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 + 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_LAMBDA_LIFT.sml b/mlsource/MLCompiler/CodeTree/CODETREE_LAMBDA_LIFT.sml index 3e939b97..398615cb 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE_LAMBDA_LIFT.sml +++ b/mlsource/MLCompiler/CodeTree/CODETREE_LAMBDA_LIFT.sml @@ -1,498 +1,498 @@ (* - Copyright (c) 2015 David C.J. Matthews + Copyright (c) 2015, 2020 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 *) (* Lambda-lifting. If every call point to a function can be identified we can lift the free variables as extra parameters. This avoids the need for a closure on the heap. It makes stack-closures largely redundant. The advantages of lambda-lifting over stack closures are that the containing function of a stack-closure cannot call a stack-closure with tail-recursion because the closure must remain on the stack until the function returns. Also we can lambda-lift a function even if it is used in a function that requires a full closure whereas we cannot use a stack closure for a function if the closure would be used in a full, heap closure. This pass is called after optimisation and after any functions that have empty closures have been code-generated to constants. *) functor CODETREE_LAMBDA_LIFT ( structure BASECODETREE: BaseCodeTreeSig structure CODETREE_FUNCTIONS: CodetreeFunctionsSig structure BACKEND: CodegenTreeSig structure DEBUG: DEBUGSIG structure PRETTY : PRETTYSIG structure CODE_ARRAY: CODEARRAYSIG sharing BASECODETREE.Sharing = CODETREE_FUNCTIONS.Sharing = BACKEND.Sharing = PRETTY.Sharing = CODE_ARRAY.Sharing ): CodegenTreeSig = struct open BASECODETREE open CODETREE_FUNCTIONS exception InternalError = Misc.InternalError (* First pass: identify the functions whose only use are calls. This annotates the tree by setting the "use" or any bindings or recursive uses that require a closure to [UseGeneral]. *) fun checkBody(code: codetree, closureRef: int -> unit, recursiveRef: unit -> unit, localCount) = let (* An entry for each local binding. Set to true if we find a non-call reference. *) val localsNeedClosures = BoolArray.array(localCount, false) fun markExtract(LoadLocal n) = BoolArray.update(localsNeedClosures, n, true) | markExtract LoadRecursive = recursiveRef() | markExtract(LoadClosure n) = closureRef n | markExtract(LoadArgument _) = () fun checkCode(ext as Extract load) = (markExtract load; SOME ext) (* These are loads which aren't calls. If they are functions they need closures. *) | checkCode(Eval{function as Extract _, argList, resultType}) = (* A call of a function. We don't need to mark the function as needing a closure. *) SOME( Eval{function=function, argList=map(fn (c, t) => (checkMapCode c, t)) argList, resultType=resultType}) | checkCode(Lambda lambda) = SOME(Lambda(checkLambda lambda)) | checkCode(Newenv(decs, exp)) = (* We want to add [UseGeneral] to bindings that require closures. To do that we have to process the bindings in reverse order. *) let val processedExp = checkMapCode exp (* The expression first. *) fun getFlag addr = if BoolArray.sub(localsNeedClosures, addr) then [UseGeneral] else [] fun processDecs [] = [] | processDecs ((Declar { value, addr, ...}) :: tail) = let val pTail = processDecs tail (* Tail first *) val pValue = checkMapCode value in Declar{value = pValue, addr=addr, use=getFlag addr} :: pTail end | processDecs (RecDecs l :: tail) = let val pTail = processDecs tail (* Tail first *) (* Process the lambdas. Because they're mutually recursive this may set the closure flag for others in the set. *) val pLambdas = map (fn {lambda, addr, ...} => {addr=addr, use=[], lambda=checkLambda lambda}) l (* Can now pick up the closure flags. *) val pDecs = map(fn {lambda, addr, ...} => {lambda=lambda, addr=addr, use=getFlag addr}) pLambdas in RecDecs pDecs :: pTail end | processDecs (NullBinding c :: tail) = let val pTail = processDecs tail in NullBinding(checkMapCode c) :: pTail end | processDecs (Container{ addr, size, setter,... } :: tail) = let val pTail = processDecs tail in Container{addr=addr, use=[], size=size, setter=checkMapCode setter} :: pTail end in SOME(Newenv(processDecs decs, processedExp)) end | checkCode _ = NONE and checkLambda({body, closure, localCount, name, argTypes, resultType, ...}) = (* Lambdas - check the function body and any recursive uses. *) let val recNeedsClosure = ref false fun refToRecursive() = recNeedsClosure := true fun refToClosure n = markExtract(List.nth(closure, n)) val processedBody = checkBody(body, refToClosure, refToRecursive, localCount) in - {body=processedBody, isInline=NonInline, closure=closure, localCount=localCount, name=name, + {body=processedBody, isInline=DontInline, closure=closure, localCount=localCount, name=name, argTypes=argTypes, resultType=resultType, recUse=if !recNeedsClosure then [UseGeneral] else []} end and checkMapCode code = mapCodetree checkCode code in checkMapCode code end (* Second pass: Actually do the lambda-lifting. *) datatype lift = LiftLoad of loadForm (* Usually unlifted but also for recursive calls. *) | LiftConst of codetree (* A lifted function. *) fun processBody(code: codetree, getClosure: int -> lift * loadForm list, getRecursive: unit -> loadForm list, localCount, debugArgs): codetree = let val processedLambdas: (codetree * loadForm list) option array = Array.array(localCount, NONE) fun findBinding(ext as LoadLocal n) = ( case Array.sub(processedLambdas, n) of SOME (c, l) => (LiftConst c, l) | NONE => (LiftLoad ext, []) ) | findBinding(LoadRecursive) = (LiftLoad LoadRecursive, getRecursive()) (* The code for the recursive case is always LoadRecursive but depending on whether it's been lifted or not there may be extra args. *) | findBinding(LoadClosure n) = getClosure n | findBinding(ext as LoadArgument _) = (LiftLoad ext, []) fun processCode(Eval{function=Extract ext, argList, resultType}) = let (* If this has been lifted we have to add the extra arguments. The function may also now be a constant. *) val (newFunction, extraArgs) = case findBinding ext of (LiftConst c, l) => (c, l) | (LiftLoad e, l) => (Extract e, l) (* Process the original args. There may be functions in there. *) val processedArgs = map(fn (c, t) => (processMapCode c, t)) argList in SOME(Eval{function=newFunction, argList=processedArgs @ map(fn c => (Extract c, GeneralType)) extraArgs, resultType=resultType}) end | processCode(Eval{function=Lambda(lambda as { recUse=[], ...}), argList, resultType}) = (* We have a call to a lambda. This must be a recursive function otherwise it would have been expanded inline. If the recursive references are just calls we can lambda-lift it. *) let val (fnConstnt, extraArgs) = hd(liftLambdas([(lambda, NONE)])) val processedArgs = map(fn (c, t) => (processMapCode c, t)) argList in SOME(Eval{function=fnConstnt, argList=processedArgs @ map(fn c => (Extract c, GeneralType)) extraArgs, resultType=resultType}) end | processCode(Extract ext) = ( (* A load of a binding outside a call. We need to process this to rebuild the closure but if we get a lifted function it's an error. *) case findBinding ext of (LiftLoad e, []) => SOME(Extract e) | _ => raise InternalError "Lifted function out of context" ) | processCode(Lambda lambda) = (* Bare lambda or lambda in binding where we need a closure. This can't be lambda-lifted but we still need to process the body and rebuild the closure. *) SOME(Lambda(processLambdaWithClosure lambda)) | processCode(Newenv(decs, exp)) = let fun processDecs [] = [] | processDecs ((Declar { value = Lambda (lambda as { recUse=[], ...}), addr, use=[]}) :: tail) = let (* We can lambda-lift. This results in a constant which is added to the table. We don't need an entry for the binding. *) val constntAndArgs = hd(liftLambdas[(lambda, SOME addr(*or NONE*))]) in Array.update(processedLambdas, addr, SOME constntAndArgs); processDecs tail end | processDecs ((Declar { value, addr, ...}) :: tail) = (* All other non-recursive bindings. *) Declar{value = processMapCode value, addr=addr, use=[]} :: processDecs tail | processDecs (RecDecs l :: tail) = let (* We only lambda-lift if all the functions are called. We could actually lift all those that are called and leave the others but it's probably not worth it. *) fun checkLift({lambda={recUse=[], ...}, use=[], ...}, true) = true | checkLift _ = false in if List.foldl checkLift true l then let val results = liftLambdas(map(fn{lambda, addr, ...} => (lambda, SOME addr)) l) in (* Add the code of the functions to the array. *) ListPair.appEq( fn (ca, {addr, ...}) => Array.update(processedLambdas, addr, SOME ca)) (results, l); (* And just deal with the rest of the bindings. *) processDecs tail end else let val pLambdas = map (fn {lambda, addr, ...} => {addr=addr, use=[], lambda=processLambdaWithClosure lambda}) l in RecDecs pLambdas :: processDecs tail end end | processDecs (NullBinding c :: tail) = NullBinding(processMapCode c) :: processDecs tail | processDecs (Container{ addr, size, setter,... } :: tail) = Container{addr=addr, use=[], size=size, setter=processMapCode setter} :: processDecs tail in SOME(Newenv(processDecs decs, processMapCode exp)) end | processCode _ = NONE and processLambdaWithClosure({body, closure, localCount, name, argTypes, resultType, ...}) = (* Lambdas that are not to be lifted. They may still have functions inside that can be lifted. They may also refer to functions that have been lifted. *) let (* We have to rebuild the closure. If any of the closure entries were lifted functions they are now constants but their arguments have to be added to the closure. *) val newClosure = makeClosure() fun closureRef n = let val (localFunction, extraArgs) = findBinding(List.nth(closure, n)) (* If the function is a local we have to add it to the closure. If it is a lifted function the function itself will be a constant except in the case of a recursive call. We do have to add the arguments to the closure. *) val resFunction = case localFunction of LiftLoad ext => LiftLoad(addToClosure newClosure ext) | c as LiftConst _ => c val resArgs = map(fn ext => addToClosure newClosure ext) extraArgs in (resFunction, resArgs) end val processedBody = processBody(body, closureRef, fn () => [], localCount, debugArgs) in - {body=processedBody, isInline=NonInline, closure=extractClosure newClosure, localCount=localCount, name=name, + {body=processedBody, isInline=DontInline, closure=extractClosure newClosure, localCount=localCount, name=name, argTypes=argTypes, resultType=resultType, recUse=[]} end and liftLambdas (bindings: (lambdaForm * int option) list) = (* Lambda-lift one or more functions. The general, but least common, case is a set of mutually recursive functions. More usually we have a single binding of a function or a single anonymous lambda. Lambda-lifting involves replacing the closure with arguments so it can only be used when we can identify all the call sites of the function and add the extra arguments. Because the transformed function has an empty closure (but see below for the mutually-recursive case) it can be code-generated immediately. The code then becomes a constant. There are a few complications. Although the additional, "closure" arguments are taken from the original function closure there may be changes if some of the closure entries are actually lambda-lifted functions. In that case the function may become a constant, and so not need to be included in the arguments, but the additional arguments for that function may need to be added to the closure. The other complication is recursion, especially mutual recursion. If we have references to mutually recursive functions we actually leave those references in the closure. This means that we actually code-generate mutually-recursive functions with non-empty closures but that is allowed if the references are only to other functions in the set. The code-generator sorts that out. *) let (* We need to construct a new common closure. This will be used by all the functions. *) val newClosure = makeClosure() fun closureEntry clItem = let val (localFunction, extraArgs) = findBinding clItem (* If the function is a local we have to add it to the closure. If it is a lifted function the function itself will be a constant except in the case of a recursive call. We do have to add the arguments to the closure. *) val resFunction = case localFunction of LiftLoad ext => LiftLoad(addToClosure newClosure ext) | c as LiftConst _ => c val resArgs = map(fn ext => addToClosure newClosure ext) extraArgs in (resFunction, resArgs) end local (* Check for an address which is one of the recursive set. *) val addressesUsed = List.mapPartial #2 bindings in fun isRecursive(LoadLocal n) = List.exists(fn p => p=n) addressesUsed | isRecursive _ = false end local fun closureItem ext = (* If it's a local we have to check that it's not one of our mutually recursive set. These items aren't going to be passed as arguments. *) if isRecursive ext then () else (closureEntry ext; ()) in val () = List.app(fn ({closure, ...}, _) => List.app closureItem closure) bindings end (* This composite closure is the set of additional arguments we need. *) val transClosure = extractClosure newClosure local val extraArgs = List.map(fn _ => (GeneralType, [])) transClosure val closureSize = List.length transClosure (* Process the function bodies. *) fun transformLambda({body, closure, localCount, name, argTypes, resultType, ...}, addr) = let val argSize = List.length argTypes val recArgs = List.tabulate(closureSize, fn n => LoadArgument(n+argSize)) (* References to other functions in the set are added to a residual closure. *) val residual = makeClosure() fun closureRef clItem = (* We have a reference to the (old) closure item. We need to change that to return the appropriate argument. The exception is that if we have a (recursive) reference to another function in the set we instead use an entry from the residual closure. *) let val oldClosureItem = List.nth(closure, clItem) in if isRecursive oldClosureItem then (LiftLoad(addToClosure residual oldClosureItem), recArgs) else let val (localFunction, resArgs) = closureEntry oldClosureItem fun mapToArg(LoadClosure n) = LoadArgument(n+argSize) | mapToArg _ = raise InternalError "mapToArg" (* Not a closure item. *) val resFunction = case localFunction of LiftLoad ext => LiftLoad(mapToArg ext) | c as LiftConst _ => c in (resFunction, map mapToArg resArgs) end end (* Recursive case - add the extra args. *) and recursiveRef() = recArgs val processedBody = processBody(body, closureRef, recursiveRef, localCount, debugArgs) val lambda = - {body=processedBody, isInline=NonInline, closure=extractClosure residual, + {body=processedBody, isInline=DontInline, closure=extractClosure residual, localCount=localCount, name=name, argTypes=argTypes @ extraArgs, resultType=resultType, recUse=[]} in { lambda=lambda, addr=getOpt(addr, 0), use=[] } end in val bindingsForCode = List.map transformLambda bindings end local (* We may have a single anonymous lambda. In that case we can give it address zero. *) val addresses = map (fn (_, addr) => getOpt(addr, 0)) bindings (* Create "closures" for each entry. These will be set by the code-generator to the code of each function and will become the closures we return. Put them into the table. *) val maxAddr = List.foldl(fn (addr, n) => Int.max(addr, n)) 0 addresses (* To get the constant addresses we create bindings for the functions and return a tuple with one entry for each binding. *) val extracts = List.map(Extract o LoadLocal) addresses val code = Newenv([RecDecs bindingsForCode], mkTuple extracts) (* Code-generate, "run" the code and extract the results. *) open Address val closure = CODE_ARRAY.makeConstantClosure() (* Turn this into a lambda to code-generate. *) val lambda:lambdaForm = { body = code, - isInline = NonInline, + isInline = DontInline, name = "", closure = [], argTypes = [(GeneralType, [])], resultType = GeneralType, localCount = maxAddr+1, recUse = [] } val props = BACKEND.codeGenerate(lambda, debugArgs, closure) val code: unit -> machineWord = RunCall.unsafeCast closure val codeConstnt = Constnt(code(), props) fun getItem([], _) = [] | getItem(_ :: l, n) = (mkInd(n, codeConstnt), transClosure) :: getItem(l, n+1) in (* Put in the results with the closures. *) val results = getItem(bindings, 0) end in results end and processMapCode code = mapCodetree processCode code in processMapCode code end type closureRef = CODE_ARRAY.closureRef fun codeGenerate(original: lambdaForm, debugArgs, closure) = let fun toplevel _ = raise InternalError "Top level reached" val checked = checkBody(Lambda original, toplevel, toplevel, 0) val processed = case processBody(checked, toplevel, toplevel, 0, debugArgs) of Lambda p => p | _ => raise InternalError "CODETREE_LAMBDA_LIFT:codeGenerate" in BACKEND.codeGenerate(processed, debugArgs, closure) end structure Foreign = BACKEND.Foreign structure Sharing = struct open BASECODETREE.Sharing type closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/CODETREE_OPTIMISER.sml b/mlsource/MLCompiler/CodeTree/CODETREE_OPTIMISER.sml index a5e38637..e18c4988 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE_OPTIMISER.sml +++ b/mlsource/MLCompiler/CodeTree/CODETREE_OPTIMISER.sml @@ -1,1540 +1,1414 @@ (* - Copyright (c) 2012,13,15,17-19 David C.J. Matthews + + Copyright (c) 2012,13,15,17,19-20 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 + { code: codetree, numLocals: int, maxInlineSize: 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 -> + 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 _ (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. *) + isInline = DontInline, (* 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] } + resultType = resultType, isInline = InlineAlways, 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, + isInline = InlineAlways, 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", + closure = loadThisArg, isInline = InlineAlways, 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] } + resultType = resultType, isInline = InlineAlways, 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, + name = name ^ "-", resultType = subResultType, localCount = 0, isInline = InlineAlways, argTypes = subArgTypes, recUse = [UseGeneral] } val shimOuterLambda = { body = shimInnerLambda, name = name, argTypes = argTypes, closure = [LoadLocal mainAddress], - resultType = resultType, isInline = Inline, localCount = 0, recUse = [UseGeneral] } + resultType = resultType, isInline = InlineAlways, 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, ... }, + { maxInlineSize, 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 + if isInline <> DontInline 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 + maxInlineSize = maxInlineSize } 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 + maxInlineSize = maxInlineSize } 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) + NonRecursive => (SmallInline, optBody, ! addressAllocator) | TailRecursive bv => - (Inline, + (SmallInline, replaceTailRecursiveWithLoop(optBody, argTypes, bv, addressAllocator), ! addressAllocator) | NonTailRecursive bv => if Vector.exists (fn n => n) bv - then (Inline, + then (SmallInline, liftRecursiveFunction( optBody, argTypes, bv, List.length closure, name, resultType, !addressAllocator), 0) - else (NonInline, optBody, ! addressAllocator) (* All arguments have been modified *) - | TooBig => (NonInline, optBody, ! addressAllocator) + else (DontInline, optBody, ! addressAllocator) (* All arguments have been modified *) + | TooBig => (DontInline, 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 + if isInline = DontInline 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 + if #isInline newLambda <> DontInline andalso isInline = DontInline 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 + if theseTransformed orelse List.exists (fn {lambda={isInline, ...}, ...} => isInline <> DontInline) 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=[], ... })) = + and runChecks (Lambda (lambda as { isInline=DontInline, 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" + val maxInlineSize = DEBUG.getParameter DEBUG.maxInlineSizeTag debugSwitches + 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) + val (simpCode, simpCount, simpAgain) = + SIMPLIFIER.simplifier{code=code, numLocals=nLocals, maxInlineSize=FixedInt.toInt maxInlineSize} 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 + maxInlineSize = maxInlineSize } (* 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_SIMPLIFIER.sml b/mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml index 91b9197d..abbbe4d2 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml +++ b/mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml @@ -1,1742 +1,1752 @@ (* Copyright (c) 2013, 2016-17, 2020 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 is a cut-down version of the optimiser which simplifies the code but does not apply any heuristics. It follows chained bindings, in particular through tuples, folds constants expressions involving built-in functions, expands inline functions that have previously been marked as inlineable. It does not detect small functions that can be inlined nor does it code-generate functions without free variables. *) functor CODETREE_SIMPLIFIER( 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 DEBUG: DEBUGSIG + sharing BASECODETREE.Sharing = CODETREE_FUNCTIONS.Sharing = REMOVE_REDUNDANT.Sharing ) : sig type codetree and codeBinding and envSpecial val simplifier: - codetree * int -> (codetree * codeBinding list * envSpecial) * int * bool + { code: codetree, numLocals: int, maxInlineSize: 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 = struct open BASECODETREE open Address open CODETREE_FUNCTIONS open BuiltIns exception InternalError = Misc.InternalError exception RaisedException (* The bindings are held internally as a reversed list. This is really only a check that the reversed and forward lists aren't confused. *) datatype revlist = RevList of codeBinding list type simpContext = { lookupAddr: loadForm -> envGeneral * envSpecial, enterAddr: int * (envGeneral * envSpecial) -> unit, nextAddress: unit -> int, - reprocess: bool ref + reprocess: bool ref, + maxInlineSize: int } fun envGeneralToCodetree(EnvGenLoad ext) = Extract ext | envGeneralToCodetree(EnvGenConst w) = Constnt w fun mkDec (laddr, res) = Declar{value = res, addr = laddr, use=[]} fun mkEnv([], exp) = exp | mkEnv(decs, exp as Extract(LoadLocal loadAddr)) = ( (* A common case is where we have a binding as the last item and then a load of that binding. Reduce this so other optimisations are possible. This is still something of a special case that could/should be generalised. *) case List.last decs of Declar{addr=decAddr, value, ... } => if loadAddr = decAddr then mkEnv(List.take(decs, List.length decs - 1), value) else Newenv(decs, exp) | _ => Newenv(decs, exp) ) | mkEnv(decs, exp) = Newenv(decs, exp) fun isConstnt(Constnt _) = true | isConstnt _ = false (* Wrap up the general, bindings and special value as a codetree node. The special entry is discarded except for Constnt entries which are converted to ConstntWithInline. That allows any inlineable code to be carried forward to later passes. *) fun specialToGeneral(g, RevList(b as _ :: _), s) = mkEnv(List.rev b, specialToGeneral(g, RevList [], s)) | specialToGeneral(Constnt(w, p), RevList [], s) = Constnt(w, setInline s p) | specialToGeneral(g, RevList [], _) = g (* Convert a constant to a fixed value. Used in some constant folding. *) val toFix: machineWord -> FixedInt.int = FixedInt.fromInt o Word.toIntX o toShort local val ffiSizeFloat: unit -> word = RunCall.rtsCallFast1 "PolySizeFloat" and ffiSizeDouble: unit -> word = RunCall.rtsCallFast1 "PolySizeDouble" in (* If we have a constant index value we convert that into a byte offset. We need to know the size of the item on this platform. We have to make this check when we actually compile the code because the interpreted version will generally be run on a platform different from the one the pre-built compiler was compiled on. The ML word length will be the same because we have separate pre-built compilers for 32 and 64-bit. *) fun getMultiplier (LoadStoreMLWord _) = RunCall.bytesPerWord | getMultiplier (LoadStoreMLByte _) = 0w1 | getMultiplier LoadStoreC8 = 0w1 | getMultiplier LoadStoreC16 = 0w2 | getMultiplier LoadStoreC32 = 0w4 | getMultiplier LoadStoreC64 = 0w8 | getMultiplier LoadStoreCFloat = ffiSizeFloat() | getMultiplier LoadStoreCDouble = ffiSizeDouble() | getMultiplier LoadStoreUntaggedUnsigned = RunCall.bytesPerWord end fun simplify(c, s) = mapCodetree (simpGeneral s) c (* Process the codetree to return a codetree node. This is used when we don't want the special case. *) and simpGeneral { lookupAddr, ...} (Extract ext) = let val (gen, spec) = lookupAddr ext in SOME(specialToGeneral(envGeneralToCodetree gen, RevList [], spec)) end | simpGeneral context (Newenv envArgs) = SOME(specialToGeneral(simpNewenv(envArgs, context, RevList []))) | simpGeneral context (Lambda lambda) = SOME(Lambda(#1(simpLambda(lambda, context, NONE, NONE)))) | simpGeneral context (Eval {function, argList, resultType}) = SOME(specialToGeneral(simpFunctionCall(function, argList, resultType, context, RevList[]))) (* BuiltIn0 functions can't be processed specially. *) | simpGeneral context (Unary{oper, arg1}) = SOME(specialToGeneral(simpUnary(oper, arg1, context, RevList []))) | simpGeneral context (Binary{oper, arg1, arg2}) = SOME(specialToGeneral(simpBinary(oper, arg1, arg2, context, RevList []))) | simpGeneral context (Arbitrary{oper=ArbCompare test, shortCond, arg1, arg2, longCall}) = SOME(specialToGeneral(simpArbitraryCompare(test, shortCond, arg1, arg2, longCall, context, RevList []))) | simpGeneral context (Arbitrary{oper=ArbArith arith, shortCond, arg1, arg2, longCall}) = SOME(specialToGeneral(simpArbitraryArith(arith, shortCond, arg1, arg2, longCall, context, RevList []))) | simpGeneral context (AllocateWordMemory {numWords, flags, initial}) = SOME(specialToGeneral(simpAllocateWordMemory(numWords, flags, initial, context, RevList []))) | simpGeneral context (Cond(condTest, condThen, condElse)) = SOME(specialToGeneral(simpIfThenElse(condTest, condThen, condElse, context, RevList []))) | simpGeneral context (Tuple { fields, isVariant }) = SOME(specialToGeneral(simpTuple(fields, isVariant, context, RevList []))) | simpGeneral context (Indirect{ base, offset, indKind }) = SOME(specialToGeneral(simpFieldSelect(base, offset, indKind, context, RevList []))) | simpGeneral context (SetContainer{container, tuple, filter}) = let val optCont = simplify(container, context) val (cGen, cDecs, cSpec) = simpSpecial(tuple, context, RevList []) in case cSpec of (* If the tuple is a local binding it is simpler to pick it up from the "special" entry. *) EnvSpecTuple(size, recEnv) => let val fields = List.tabulate(size, envGeneralToCodetree o #1 o recEnv) in SOME(simpPostSetContainer(optCont, Tuple{isVariant=false, fields=fields}, cDecs, filter)) end | _ => SOME(simpPostSetContainer(optCont, cGen, cDecs, filter)) end | simpGeneral (context as { enterAddr, nextAddress, reprocess, ...}) (BeginLoop{loop, arguments, ...}) = let val didReprocess = ! reprocess (* To see if we really need the loop first try simply binding the arguments and process it. It's often the case that if one or more arguments is a constant that the looping case will be eliminated. *) val withoutBeginLoop = simplify(mkEnv(List.map (Declar o #1) arguments, loop), context) fun foldLoop f n (Loop l) = f(l, n) | foldLoop f n (Newenv(_, exp)) = foldLoop f n exp | foldLoop f n (Cond(_, t, e)) = foldLoop f (foldLoop f n t) e | foldLoop f n (Handle {handler, ...}) = foldLoop f n handler | foldLoop f n (SetContainer{tuple, ...}) = foldLoop f n tuple | foldLoop _ n _ = n (* Check if the Loop instruction is there. This assumes that these are the only tail-recursive cases. *) val hasLoop = foldLoop (fn _ => true) false in if not (hasLoop withoutBeginLoop) then SOME withoutBeginLoop else let (* Reset "reprocess". It may have been set in the withoutBeginLoop that's not the code we're going to return. *) val () = reprocess := didReprocess (* We need the BeginLoop. Create new addresses for the arguments. *) fun declArg({addr, value, use, ...}, typ) = let val newAddr = nextAddress() in enterAddr(addr, (EnvGenLoad(LoadLocal newAddr), EnvSpecNone)); ({addr = newAddr, value = simplify(value, context), use = use }, typ) end (* Now look to see if the (remaining) loops have any arguments that do not change. Do this after processing because we could be eliminating other loops that may change the arguments. *) val declArgs = map declArg arguments val beginBody = simplify(loop, context) local fun argsMatch((Extract (LoadLocal argNo), _), ({addr, ...}, _)) = argNo = addr | argsMatch _ = false fun checkLoopArgs(loopArgs, checks) = let fun map3(loopA :: loopArgs, decA :: decArgs, checkA :: checkArgs) = (argsMatch(loopA, decA) andalso checkA) :: map3(loopArgs, decArgs, checkArgs) | map3 _ = [] in map3(loopArgs, declArgs, checks) end in val checkList = foldLoop checkLoopArgs (map (fn _ => true) arguments) beginBody end in if List.exists (fn l => l) checkList then let (* Turn the original arguments into bindings. *) local fun argLists(true, (arg, _), (tArgs, fArgs)) = (Declar arg :: tArgs, fArgs) | argLists(false, arg, (tArgs, fArgs)) = (tArgs, arg :: fArgs) in val (unchangedArgs, filteredDeclArgs) = ListPair.foldrEq argLists ([], []) (checkList, declArgs) end fun changeLoops (Loop loopArgs) = let val newArgs = ListPair.foldrEq(fn (false, arg, l) => arg :: l | (true, _, l) => l) [] (checkList, loopArgs) in Loop newArgs end | changeLoops(Newenv(decs, exp)) = Newenv(decs, changeLoops exp) | changeLoops(Cond(i, t, e)) = Cond(i, changeLoops t, changeLoops e) | changeLoops(Handle{handler, exp, exPacketAddr}) = Handle{handler=changeLoops handler, exp=exp, exPacketAddr=exPacketAddr} | changeLoops(SetContainer{tuple, container, filter}) = SetContainer{tuple=changeLoops tuple, container=container, filter=filter} | changeLoops code = code val beginBody = simplify(changeLoops loop, context) (* Reprocess because we've lost any special part from the arguments that haven't changed. *) val () = reprocess := true in SOME(mkEnv(unchangedArgs, BeginLoop {loop=beginBody, arguments=filteredDeclArgs})) end else SOME(BeginLoop {loop=beginBody, arguments=declArgs}) end end | simpGeneral context (TagTest{test, tag, maxTag}) = ( case simplify(test, context) of Constnt(testResult, _) => if isShort testResult andalso toShort testResult = tag then SOME CodeTrue else SOME CodeFalse | sTest => SOME(TagTest{test=sTest, tag=tag, maxTag=maxTag}) ) | simpGeneral context (LoadOperation{kind, address}) = let (* Try to move constants out of the index. *) val (genAddress, RevList decAddress) = simpAddress(address, getMultiplier kind, context) (* If the base address and index are constant and this is an immutable load we can do this at compile time. *) val result = case (genAddress, kind) of ({base=Constnt(baseAddr, _), index=NONE, offset}, LoadStoreMLWord _) => if isShort baseAddr then LoadOperation{kind=kind, address=genAddress} else let (* Ignore the "isImmutable" flag and look at the immutable status of the memory. Check that this is a word object and that the offset is within range. The code for Vector.sub, for example, raises an exception if the index is out of range but still generates the (unreachable) indexing code. *) val addr = toAddress baseAddr val wordOffset = offset div RunCall.bytesPerWord in if isMutable addr orelse not(isWords addr) orelse wordOffset >= length addr then LoadOperation{kind=kind, address=genAddress} else Constnt(toMachineWord(loadWord(addr, wordOffset)), []) end | ({base=Constnt(baseAddr, _), index=NONE, offset}, LoadStoreMLByte _) => if isShort baseAddr then LoadOperation{kind=kind, address=genAddress} else let val addr = toAddress baseAddr val wordOffset = offset div RunCall.bytesPerWord in if isMutable addr orelse not(isBytes addr) orelse wordOffset >= length addr then LoadOperation{kind=kind, address=genAddress} else Constnt(toMachineWord(loadByte(addr, offset)), []) end | ({base=Constnt(baseAddr, _), index=NONE, offset}, LoadStoreUntaggedUnsigned) => if isShort baseAddr then LoadOperation{kind=kind, address=genAddress} else let val addr = toAddress baseAddr (* We don't currently have loadWordUntagged in Address but it's only ever used to load the string length word so we can use that. *) in if isMutable addr orelse not(isBytes addr) orelse offset <> 0w0 then LoadOperation{kind=kind, address=genAddress} else Constnt(toMachineWord(String.size(RunCall.unsafeCast addr)), []) end | _ => LoadOperation{kind=kind, address=genAddress} in SOME(mkEnv(List.rev decAddress, result)) end | simpGeneral context (StoreOperation{kind, address, value}) = let val (genAddress, decAddress) = simpAddress(address, getMultiplier kind, context) val (genValue, RevList decValue, _) = simpSpecial(value, context, decAddress) in SOME(mkEnv(List.rev decValue, StoreOperation{kind=kind, address=genAddress, value=genValue})) end | simpGeneral (context as {reprocess, ...}) (BlockOperation{kind, sourceLeft, destRight, length}) = let val multiplier = case kind of BlockOpMove{isByteMove=false} => RunCall.bytesPerWord | BlockOpMove{isByteMove=true} => 0w1 | BlockOpEqualByte => 0w1 | BlockOpCompareByte => 0w1 val (genSrcAddress, RevList decSrcAddress) = simpAddress(sourceLeft, multiplier, context) val (genDstAddress, RevList decDstAddress) = simpAddress(destRight, multiplier, context) val (genLength, RevList decLength, _) = simpSpecial(length, context, RevList []) (* If we have a short length move we're better doing it as a sequence of loads and stores. This is particularly useful with string concatenation. Small here means three or less. Four and eight byte moves are handled as single instructions in the code-generator provided the alignment is correct. *) val shortLength = case genLength of Constnt(lenConst, _) => if isShort lenConst then let val l = toShort lenConst in if l <= 0w3 then SOME l else NONE end else NONE | _ => NONE val combinedDecs = List.rev decSrcAddress @ List.rev decDstAddress @ List.rev decLength val operation = case (shortLength, kind) of (SOME length, BlockOpMove{isByteMove}) => let val _ = reprocess := true (* Frequently the source will be a constant. *) val {base=baseSrc, index=indexSrc, offset=offsetSrc} = genSrcAddress and {base=baseDst, index=indexDst, offset=offsetDst} = genDstAddress (* We don't know if the source is immutable but the destination definitely isn't *) val moveKind = if isByteMove then LoadStoreMLByte{isImmutable=false} else LoadStoreMLWord{isImmutable=false} fun makeMoves offset = if offset = length then [] else NullBinding( StoreOperation{kind=moveKind, address={base=baseDst, index=indexDst, offset=offsetDst+offset*multiplier}, value=LoadOperation{kind=moveKind, address={base=baseSrc, index=indexSrc, offset=offsetSrc+offset*multiplier}}}) :: makeMoves(offset+0w1) in mkEnv(combinedDecs @ makeMoves 0w0, CodeZero (* unit result *)) end | (SOME length, BlockOpEqualByte) => (* Comparing with the null string and up to 3 characters. *) let val {base=baseSrc, index=indexSrc, offset=offsetSrc} = genSrcAddress and {base=baseDst, index=indexDst, offset=offsetDst} = genDstAddress val moveKind = LoadStoreMLByte{isImmutable=false} (* Build andalso tree to check each byte. For the null string this simply returns "true". *) fun makeComparison offset = if offset = length then CodeTrue else Cond( Binary{oper=WordComparison{test=TestEqual, isSigned=false}, arg1=LoadOperation{kind=moveKind, address={base=baseSrc, index=indexSrc, offset=offsetSrc+offset*multiplier}}, arg2=LoadOperation{kind=moveKind, address={base=baseDst, index=indexDst, offset=offsetDst+offset*multiplier}}}, makeComparison(offset+0w1), CodeFalse) in mkEnv(combinedDecs, makeComparison 0w0) end | _ => mkEnv(combinedDecs, BlockOperation{kind=kind, sourceLeft=genSrcAddress, destRight=genDstAddress, length=genLength}) in SOME operation end | simpGeneral (context as {enterAddr, nextAddress, ...}) (Handle{exp, handler, exPacketAddr}) = let (* We need to make a new binding for the exception packet. *) val expBody = simplify(exp, context) val newAddr = nextAddress() val () = enterAddr(exPacketAddr, (EnvGenLoad(LoadLocal newAddr), EnvSpecNone)) val handleBody = simplify(handler, context) in SOME(Handle{exp=expBody, handler=handleBody, exPacketAddr=newAddr}) end | simpGeneral _ _ = NONE (* Where we have an Indirect or Eval we want the argument as either a tuple or an inline function respectively if that's possible. Getting that also involves various other cases as well. Because a binding may later be used in such a context we treat any binding in that way as well. *) and simpSpecial (Extract ext, { lookupAddr, ...}, tailDecs) = let val (gen, spec) = lookupAddr ext in (envGeneralToCodetree gen, tailDecs, spec) end | simpSpecial (Newenv envArgs, context, tailDecs) = simpNewenv(envArgs, context, tailDecs) | simpSpecial (Lambda lambda, context, tailDecs) = let val (gen, spec) = simpLambda(lambda, context, NONE, NONE) in (Lambda gen, tailDecs, spec) end | simpSpecial (Eval {function, argList, resultType}, context, tailDecs) = simpFunctionCall(function, argList, resultType, context, tailDecs) | simpSpecial (Unary{oper, arg1}, context, tailDecs) = simpUnary(oper, arg1, context, tailDecs) | simpSpecial (Binary{oper, arg1, arg2}, context, tailDecs) = simpBinary(oper, arg1, arg2, context, tailDecs) | simpSpecial (Arbitrary{oper=ArbCompare test, shortCond, arg1, arg2, longCall}, context, tailDecs) = simpArbitraryCompare(test, shortCond, arg1, arg2, longCall, context, tailDecs) | simpSpecial (Arbitrary{oper=ArbArith arith, shortCond, arg1, arg2, longCall}, context, tailDecs) = simpArbitraryArith(arith, shortCond, arg1, arg2, longCall, context, tailDecs) | simpSpecial (AllocateWordMemory{numWords, flags, initial}, context, tailDecs) = simpAllocateWordMemory(numWords, flags, initial, context, tailDecs) | simpSpecial (Cond(condTest, condThen, condElse), context, tailDecs) = simpIfThenElse(condTest, condThen, condElse, context, tailDecs) | simpSpecial (Tuple { fields, isVariant }, context, tailDecs) = simpTuple(fields, isVariant, context, tailDecs) | simpSpecial (Indirect{ base, offset, indKind }, context, tailDecs) = simpFieldSelect(base, offset, indKind, context, tailDecs) | simpSpecial (c: codetree, s: simpContext, tailDecs): codetree * revlist * envSpecial = let (* Anything else - copy it and then split it into the fields. *) fun split(Newenv(l, e), RevList tailDecs) = (* Pull off bindings. *) split (e, RevList(List.rev l @ tailDecs)) | split(Constnt(m, p), tailDecs) = (Constnt(m, p), tailDecs, findInline p) | split(c, tailDecs) = (c, tailDecs, EnvSpecNone) in split(simplify(c, s), tailDecs) end (* Process a Newenv. We need to add the bindings to the context. *) and simpNewenv((envDecs: codeBinding list, envExp), context as { enterAddr, nextAddress, reprocess, ...}, tailDecs): codetree * revlist * envSpecial = let fun copyDecs ([], decs) = simpSpecial(envExp, context, decs) (* End of the list - process the result expression. *) | copyDecs ((Declar{addr, value, ...} :: vs), decs) = ( case simpSpecial(value, context, decs) of (* If this raises an exception stop here. *) vBinding as (Raise _, _, _) => vBinding | vBinding => let (* Add the declaration to the table. *) val (optV, dec) = makeNewDecl(vBinding, context) val () = enterAddr(addr, optV) in copyDecs(vs, dec) end ) | copyDecs(NullBinding v :: vs, decs) = (* Not a binding - process this and the rest.*) ( case simpSpecial(v, context, decs) of (* If this raises an exception stop here. *) vBinding as (Raise _, _, _) => vBinding | (cGen, RevList cDecs, _) => copyDecs(vs, RevList(NullBinding cGen :: cDecs)) ) | copyDecs(RecDecs mutuals :: vs, RevList decs) = (* Mutually recursive declarations. Any of the declarations may refer to any of the others. They should all be lambdas. The front end generates functions with more than one argument (either curried or tupled) as pairs of mutually recursive functions. The main function body takes its arguments on the stack (or in registers) and the auxiliary inline function, possibly nested, takes the tupled or curried arguments and calls it. If the main function is recursive it will first call the inline function which is why the pair are mutually recursive. As far as possible we want to use the main function since that uses the least memory. Specifically, if the function recurses we want the recursive call to pass all the arguments if it can. *) let (* Reorder the function so the explicitly-inlined ones come first. Their code can then be inserted into the main functions. *) local val (inlines, nonInlines) = List.partition ( - fn {lambda = { isInline=Inline, ...}, ... } => true | _ => false) mutuals + fn {lambda = { isInline=DontInline, ...}, ... } => false | _ => true) mutuals in val orderedDecs = inlines @ nonInlines end (* Go down the functions creating new addresses for them and entering them in the table. *) val addresses = map (fn {addr, ... } => let val decAddr = nextAddress() in enterAddr (addr, (EnvGenLoad(LoadLocal decAddr), EnvSpecNone)); decAddr end) orderedDecs fun processFunction({ lambda, addr, ... }, newAddr) = let val (gen, spec) = simpLambda(lambda, context, SOME addr, SOME newAddr) (* Update the entry in the table to include any inlineable function. *) val () = enterAddr (addr, (EnvGenLoad (LoadLocal newAddr), spec)) in {addr=newAddr, lambda=gen, use=[]} end val rlist = ListPair.map processFunction (orderedDecs, addresses) in (* and put these declarations onto the list. *) copyDecs(vs, RevList(List.rev(partitionMutualBindings(RecDecs rlist)) @ decs)) end | copyDecs (Container{addr, size, setter, ...} :: vs, RevList decs) = let (* Enter the new address immediately - it's needed in the setter. *) val decAddr = nextAddress() val () = enterAddr (addr, (EnvGenLoad(LoadLocal decAddr), EnvSpecNone)) val (setGen, RevList setDecs, _) = simpSpecial(setter, context, RevList []) in (* If we have inline expanded a function that sets the container we're better off eliminating the container completely. *) case setGen of SetContainer { tuple, filter, container } => let (* Check the container we're setting is the address we've made for it. *) val _ = (case container of Extract(LoadLocal a) => a = decAddr | _ => false) orelse raise InternalError "copyDecs: Container/SetContainer" val newDecAddr = nextAddress() val () = enterAddr (addr, (EnvGenLoad(LoadLocal newDecAddr), EnvSpecNone)) val tupleAddr = nextAddress() val tupleDec = Declar{addr=tupleAddr, use=[], value=tuple} val tupleLoad = mkLoadLocal tupleAddr val resultTuple = BoolVector.foldri(fn (i, true, l) => mkInd(i, tupleLoad) :: l | (_, false, l) => l) [] filter val _ = List.length resultTuple = size orelse raise InternalError "copyDecs: Container/SetContainer size" val containerDec = Declar{addr=newDecAddr, use=[], value=mkTuple resultTuple} (* TODO: We're replacing a container with what is notionally a tuple on the heap. It should be optimised away as a result of a further pass but we currently have indirections from a container for these. On the native platforms that doesn't matter but on 32-in-64 indirecting from the heap and from the stack are different. *) val _ = reprocess := true in copyDecs(vs, RevList(containerDec :: tupleDec :: setDecs @ decs)) end | _ => let (* The setDecs could refer the container itself if we've optimised this with simpPostSetContainer so we must include them within the setter and not lift them out. *) val dec = Container{addr=decAddr, use=[], size=size, setter=mkEnv(List.rev setDecs, setGen)} in copyDecs(vs, RevList(dec :: decs)) end end in copyDecs(envDecs, tailDecs) end (* Prepares a binding for entry into a look-up table. Returns the entry to put into the table together with any bindings that must be made. If the general part of the optVal is a constant we can just put the constant in the table. If it is a load (Extract) it is just renaming an existing entry so we can return it. Otherwise we have to make a new binding and return a load (Extract) entry for it. *) and makeNewDecl((Constnt w, RevList decs, spec), _) = ((EnvGenConst w, spec), RevList decs) (* No need to create a binding for a constant. *) | makeNewDecl((Extract ext, RevList decs, spec), _) = ((EnvGenLoad ext, spec), RevList decs) (* Binding is simply giving a new name to a variable - can ignore this declaration. *) | makeNewDecl((gen, RevList decs, spec), { nextAddress, ...}) = let (* Create a binding for this value. *) val newAddr = nextAddress() in ((EnvGenLoad(LoadLocal newAddr), spec), RevList(mkDec(newAddr, gen) :: decs)) end and simpLambda({body, isInline, name, argTypes, resultType, closure, localCount, ...}, - { lookupAddr, reprocess, ... }, myOldAddrOpt, myNewAddrOpt) = + { lookupAddr, reprocess, maxInlineSize, ... }, myOldAddrOpt, myNewAddrOpt) = let (* A new table for the new function. *) val oldAddrTab = Array.array (localCount, NONE) val optClosureList = makeClosure() val isNowRecursive = ref false local fun localOldAddr (LoadLocal addr) = valOf(Array.sub(oldAddrTab, addr)) | localOldAddr (ext as LoadArgument _) = (EnvGenLoad ext, EnvSpecNone) | localOldAddr (ext as LoadRecursive) = (EnvGenLoad ext, EnvSpecNone) | localOldAddr (LoadClosure addr) = let val oldEntry = List.nth(closure, addr) (* If the entry in the closure is our own address this is recursive. *) fun isRecursive(EnvGenLoad(LoadLocal a), SOME b) = if a = b then (isNowRecursive := true; true) else false | isRecursive _ = false in if isRecursive(EnvGenLoad oldEntry, myOldAddrOpt) then (EnvGenLoad LoadRecursive, EnvSpecNone) else let val newEntry = lookupAddr oldEntry val makeClosure = addToClosure optClosureList fun convertResult(genEntry, specEntry) = (* If after looking up the entry we get our new address it's recursive. *) if isRecursive(genEntry, myNewAddrOpt) then (EnvGenLoad LoadRecursive, EnvSpecNone) else let val newGeneral = case genEntry of EnvGenLoad ext => EnvGenLoad(makeClosure ext) | EnvGenConst w => EnvGenConst w (* Have to modify the environment here so that if we look up free variables we add them to the closure. *) fun convertEnv env args = convertResult(env args) val newSpecial = case specEntry of EnvSpecTuple(size, env) => EnvSpecTuple(size, convertEnv env) | EnvSpecInlineFunction(spec, env) => EnvSpecInlineFunction(spec, convertEnv env) | EnvSpecUnary _ => EnvSpecNone (* Don't pass this in *) | EnvSpecBinary _ => EnvSpecNone (* Don't pass this in *) | EnvSpecNone => EnvSpecNone in (newGeneral, newSpecial) end in convertResult newEntry end end and setTab (index, v) = Array.update (oldAddrTab, index, SOME v) in val newAddressAllocator = ref 0 fun mkAddr () = ! newAddressAllocator before newAddressAllocator := ! newAddressAllocator + 1 val newCode = simplify (body, { enterAddr = setTab, lookupAddr = localOldAddr, nextAddress=mkAddr, - reprocess = reprocess + reprocess = reprocess, + maxInlineSize = maxInlineSize }) end val closureAfterOpt = extractClosure optClosureList val localCount = ! newAddressAllocator (* If we have mutually recursive "small" functions we may turn them into recursive functions. We have to remove the "small" status from them to prevent them from being expanded inline anywhere else. The optimiser may turn them back into "small" functions if the recursion is actually tail-recursion. *) val isNowInline = case isInline of - Inline => - if ! isNowRecursive then NonInline else Inline - | NonInline => NonInline + SmallInline => + if ! isNowRecursive then DontInline else SmallInline + | InlineAlways => + (* Functions marked as inline could become recursive as a result of + other inlining. *) + if ! isNowRecursive then DontInline else InlineAlways + | DontInline => DontInline (* Clean up the function body at this point if it could be inlined. There are examples where failing to do this can blow up. This can be the result of creating both a general and special function inside an inline function. *) val cleanBody = - case isNowInline of - NonInline => newCode - | _ => REMOVE_REDUNDANT.cleanProc(newCode, [UseExport], LoadClosure, localCount) + if isNowInline = DontInline + then newCode + else REMOVE_REDUNDANT.cleanProc(newCode, [UseExport], LoadClosure, localCount) val copiedLambda: lambdaForm = { body = cleanBody, isInline = isNowInline, name = name, closure = closureAfterOpt, argTypes = argTypes, resultType = resultType, localCount = localCount, recUse = [] } + (* The optimiser checks the size of a function and decides whether it can be inlined. + However if we have expanded some other inlines inside the body it may now be too + big. In some cases we can get exponential blow-up. We check here that the + body is still small enough before allowing it to be used inline. *) val inlineCode = - case isNowInline of - NonInline => EnvSpecNone - | _ => EnvSpecInlineFunction(copiedLambda, fn addr => (EnvGenLoad(List.nth(closureAfterOpt, addr)), EnvSpecNone)) + if isInline = InlineAlways orelse + (isNowInline = SmallInline andalso + evaluateInlining(cleanBody, List.length argTypes, maxInlineSize) <> TooBig) + then EnvSpecInlineFunction(copiedLambda, fn addr => (EnvGenLoad(List.nth(closureAfterOpt, addr)), EnvSpecNone)) + else EnvSpecNone in ( copiedLambda, inlineCode ) end - and simpFunctionCall(function, argList, resultType, context as { reprocess, ...}, tailDecs) = + and simpFunctionCall(function, argList, resultType, context as { reprocess, maxInlineSize, ...}, tailDecs) = let (* Function call - This may involve inlining the function. *) (* Get the function to be called and see if it is inline or a lambda expression. *) val (genFunct, decsFunct, specFunct) = simpSpecial(function, context, tailDecs) (* We have to make a special check here that we are not passing in the function we are trying to expand. This could result in an infinitely recursive expansion. It is only going to happen in very special circumstances such as a definition of the Y combinator. If we see that we don't attempt to expand inline. It could be embedded in a tuple or the closure of a function as well as passed directly. *) val isRecursiveArg = case function of Extract extOrig => let fun containsFunction(Extract thisArg, v) = (v orelse thisArg = extOrig, FOLD_DESCEND) | containsFunction(Lambda{closure, ...}, v) = (* Only the closure, not the body *) (foldl (fn (c, w) => foldtree containsFunction w (Extract c)) v closure, FOLD_DONT_DESCEND) | containsFunction(Eval _, v) = (v, FOLD_DONT_DESCEND) (* OK if it's called *) | containsFunction(_, v) = (v, FOLD_DESCEND) in List.exists(fn (c, _) => foldtree containsFunction false c) argList end | _ => false in case (specFunct, genFunct, isRecursiveArg) of (EnvSpecInlineFunction({body=lambdaBody, localCount, argTypes, ...}, functEnv), _, false) => let val _ = List.length argTypes = List.length argList orelse raise InternalError "simpFunctionCall: argument mismatch" val () = reprocess := true (* If we expand inline we have to reprocess *) and { nextAddress, reprocess, ...} = context (* Expand a function inline, either one marked explicitly to be inlined or one detected as "small". *) (* Calling inline proc or a lambda expression which is just called. The function is replaced with a block containing declarations of the parameters. We need a new table here because the addresses we use to index it are the addresses which are local to the function. New addresses are created in the range of the surrounding function. *) val localVec = Array.array(localCount, NONE) local fun processArgs([], bindings) = ([], bindings) | processArgs((arg, _)::args, bindings) = let val (thisArg, newBindings) = makeNewDecl(simpSpecial(arg, context, bindings), context) val (otherArgs, resBindings) = processArgs(args, newBindings) in (thisArg::otherArgs, resBindings) end val (params, bindings) = processArgs(argList, decsFunct) val paramVec = Vector.fromList params in fun getParameter n = Vector.sub(paramVec, n) (* Bindings necessary for the arguments *) val copiedArgs = bindings end local fun localOldAddr(LoadLocal addr) = valOf(Array.sub(localVec, addr)) | localOldAddr(LoadArgument addr) = getParameter addr | localOldAddr(LoadClosure closureEntry) = functEnv closureEntry | localOldAddr LoadRecursive = raise InternalError "localOldAddr: LoadRecursive" fun setTabForInline (index, v) = Array.update (localVec, index, SOME v) val lambdaContext = { lookupAddr=localOldAddr, enterAddr=setTabForInline, - nextAddress=nextAddress, reprocess = reprocess + nextAddress=nextAddress, reprocess = reprocess, + maxInlineSize = maxInlineSize } in val (cGen, cDecs, cSpec) = simpSpecial(lambdaBody,lambdaContext, copiedArgs) end in (cGen, cDecs, cSpec) end | (_, gen as Constnt _, _) => (* Not inlinable - constant function. *) let val copiedArgs = map (fn (arg, argType) => (simplify(arg, context), argType)) argList val evCopiedCode = Eval {function = gen, argList = copiedArgs, resultType=resultType} in (evCopiedCode, decsFunct, EnvSpecNone) end | (_, gen, _) => (* Anything else. *) let val copiedArgs = map (fn (arg, argType) => (simplify(arg, context), argType)) argList val evCopiedCode = Eval {function = gen, argList = copiedArgs, resultType=resultType} in (evCopiedCode, decsFunct, EnvSpecNone) end end (* Special processing for the current builtIn1 operations. *) (* Constant folding for built-ins. These ought to be type-correct i.e. we should have tagged values in some cases and addresses in others. However there may be run-time tests that would ensure type-correctness and we can't be sure that they will always be folded at compile-time. e.g. we may have if isShort c then shortOp c else longOp c If c is a constant then we may try to fold both the shortOp and the longOp and one of these will be type-incorrect although never executed at run-time. *) and simpUnary(oper, arg1, context as { reprocess, ...}, tailDecs) = let val (genArg1, decArg1, specArg1) = simpSpecial(arg1, context, tailDecs) in case (oper, genArg1) of (NotBoolean, Constnt(v, _)) => ( reprocess := true; (if isShort v andalso toShort v = 0w0 then CodeTrue else CodeFalse, decArg1, EnvSpecNone) ) | (NotBoolean, genArg1) => ( (* NotBoolean: This can be the result of using Bool.not but more usually occurs as a result of other code. We don't have TestNotEqual or IsAddress so both of these use NotBoolean with TestEqual and IsTagged. Also we can insert a NotBoolean as a result of a Cond. We try to eliminate not(not a) and to push other NotBooleans down to a point where a boolean is tested. *) case specArg1 of EnvSpecUnary(NotBoolean, originalArg) => ( (* not(not a) - Eliminate. *) reprocess := true; (originalArg, decArg1, EnvSpecNone) ) | _ => (* Otherwise pass this on. It is also extracted in a Cond. *) (Unary{oper=NotBoolean, arg1=genArg1}, decArg1, EnvSpecUnary(NotBoolean, genArg1)) ) | (IsTaggedValue, Constnt(v, _)) => ( reprocess := true; (if isShort v then CodeTrue else CodeFalse, decArg1, EnvSpecNone) ) | (IsTaggedValue, genArg1) => ( (* We use this to test for nil values and if we have constructed a record (or possibly a function) it can't be null. *) case specArg1 of EnvSpecTuple _ => (CodeFalse, decArg1, EnvSpecNone) before reprocess := true | EnvSpecInlineFunction _ => (CodeFalse, decArg1, EnvSpecNone) before reprocess := true | _ => (Unary{oper=oper, arg1=genArg1}, decArg1, EnvSpecNone) ) | (MemoryCellLength, Constnt(v, _)) => ( reprocess := true; (if isShort v then CodeZero else Constnt(toMachineWord(Address.length(toAddress v)), []), decArg1, EnvSpecNone) ) | (MemoryCellFlags, Constnt(v, _)) => ( reprocess := true; (if isShort v then CodeZero else Constnt(toMachineWord(Address.flags(toAddress v)), []), decArg1, EnvSpecNone) ) | (LongWordToTagged, Constnt(v, _)) => ( reprocess := true; (Constnt(toMachineWord(Word.fromLargeWord(RunCall.unsafeCast v)), []), decArg1, EnvSpecNone) ) | (LongWordToTagged, genArg1) => ( (* If we apply LongWordToTagged to an argument we have created with UnsignedToLongWord we can return the original argument. *) case specArg1 of EnvSpecUnary(UnsignedToLongWord, originalArg) => ( reprocess := true; (originalArg, decArg1, EnvSpecNone) ) | _ => (Unary{oper=LongWordToTagged, arg1=genArg1}, decArg1, EnvSpecNone) ) | (SignedToLongWord, Constnt(v, _)) => ( reprocess := true; (Constnt(toMachineWord(Word.toLargeWordX(RunCall.unsafeCast v)), []), decArg1, EnvSpecNone) ) | (UnsignedToLongWord, Constnt(v, _)) => ( reprocess := true; (Constnt(toMachineWord(Word.toLargeWord(RunCall.unsafeCast v)), []), decArg1, EnvSpecNone) ) | (UnsignedToLongWord, genArg1) => (* Add the operation as the special entry. It can then be recognised by LongWordToTagged. *) (Unary{oper=oper, arg1=genArg1}, decArg1, EnvSpecUnary(UnsignedToLongWord, genArg1)) | _ => (Unary{oper=oper, arg1=genArg1}, decArg1, EnvSpecNone) end and simpBinary(oper, arg1, arg2, context as {reprocess, ...}, tailDecs) = let val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(arg1, context, tailDecs) val (genArg2, decArgs, _ (*specArg2*)) = simpSpecial(arg2, context, decArg1) in case (oper, genArg1, genArg2) of (WordComparison{test, isSigned}, Constnt(v1, _), Constnt(v2, _)) => - if (case test of TestEqual => false | _ => not(isShort v1) orelse not(isShort v2)) + if not(isShort v1) orelse not(isShort v2) (* E.g. arbitrary precision on unreachable path. *) then (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) else let val () = reprocess := true val testResult = case (test, isSigned) of (* TestEqual can be applied to addresses. *) - (TestEqual, _) => RunCall.pointerEq(v1, v2) + (TestEqual, _) => toShort v1 = toShort v2 | (TestLess, false) => toShort v1 < toShort v2 | (TestLessEqual, false) => toShort v1 <= toShort v2 | (TestGreater, false) => toShort v1 > toShort v2 | (TestGreaterEqual, false) => toShort v1 >= toShort v2 | (TestLess, true) => toFix v1 < toFix v2 | (TestLessEqual, true) => toFix v1 <= toFix v2 | (TestGreater, true) => toFix v1 > toFix v2 | (TestGreaterEqual, true) => toFix v1 >= toFix v2 | (TestUnordered, _) => raise InternalError "WordComparison: TestUnordered" in (if testResult then CodeTrue else CodeFalse, decArgs, EnvSpecNone) end + + | (PointerEq, Constnt(v1, _), Constnt(v2, _)) => + ( + reprocess := true; + (if RunCall.pointerEq(v1, v2) then CodeTrue else CodeFalse, decArgs, EnvSpecNone) + ) | (FixedPrecisionArith arithOp, Constnt(v1, _), Constnt(v2, _)) => if not(isShort v1) orelse not(isShort v2) then (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) else let val () = reprocess := true val v1S = toFix v1 and v2S = toFix v2 fun asConstnt v = Constnt(toMachineWord v, []) val raiseOverflow = Raise(Constnt(toMachineWord Overflow, [])) val raiseDiv = Raise(Constnt(toMachineWord Div, [])) (* ?? There's usually an explicit test. *) val resultCode = case arithOp of ArithAdd => (asConstnt(v1S+v2S) handle Overflow => raiseOverflow) | ArithSub => (asConstnt(v1S-v2S) handle Overflow => raiseOverflow) | ArithMult => (asConstnt(v1S*v2S) handle Overflow => raiseOverflow) | ArithQuot => (asConstnt(FixedInt.quot(v1S,v2S)) handle Overflow => raiseOverflow | Div => raiseDiv) | ArithRem => (asConstnt(FixedInt.rem(v1S,v2S)) handle Overflow => raiseOverflow | Div => raiseDiv) | ArithDiv => (asConstnt(FixedInt.div(v1S,v2S)) handle Overflow => raiseOverflow | Div => raiseDiv) | ArithMod => (asConstnt(FixedInt.mod(v1S,v2S)) handle Overflow => raiseOverflow | Div => raiseDiv) in (resultCode, decArgs, EnvSpecNone) end (* Addition and subtraction of zero. These can arise as a result of inline expansion of more general functions. *) | (FixedPrecisionArith ArithAdd, arg1, Constnt(v2, _)) => if isShort v2 andalso toShort v2 = 0w0 then (arg1, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (FixedPrecisionArith ArithAdd, Constnt(v1, _), arg2) => if isShort v1 andalso toShort v1 = 0w0 then (arg2, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (FixedPrecisionArith ArithSub, arg1, Constnt(v2, _)) => if isShort v2 andalso toShort v2 = 0w0 then (arg1, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (WordArith arithOp, Constnt(v1, _), Constnt(v2, _)) => if not(isShort v1) orelse not(isShort v2) then (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) else let val () = reprocess := true val v1S = toShort v1 and v2S = toShort v2 fun asConstnt v = Constnt(toMachineWord v, []) val resultCode = case arithOp of ArithAdd => asConstnt(v1S+v2S) | ArithSub => asConstnt(v1S-v2S) | ArithMult => asConstnt(v1S*v2S) | ArithQuot => raise InternalError "WordArith: ArithQuot" | ArithRem => raise InternalError "WordArith: ArithRem" | ArithDiv => asConstnt(v1S div v2S) | ArithMod => asConstnt(v1S mod v2S) in (resultCode, decArgs, EnvSpecNone) end | (WordArith ArithAdd, arg1, Constnt(v2, _)) => if isShort v2 andalso toShort v2 = 0w0 then (arg1, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (WordArith ArithAdd, Constnt(v1, _), arg2) => if isShort v1 andalso toShort v1 = 0w0 then (arg2, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (WordArith ArithSub, arg1, Constnt(v2, _)) => if isShort v2 andalso toShort v2 = 0w0 then (arg1, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (WordLogical logOp, Constnt(v1, _), Constnt(v2, _)) => if not(isShort v1) orelse not(isShort v2) then (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) else let val () = reprocess := true val v1S = toShort v1 and v2S = toShort v2 fun asConstnt v = Constnt(toMachineWord v, []) val resultCode = case logOp of LogicalAnd => asConstnt(Word.andb(v1S,v2S)) | LogicalOr => asConstnt(Word.orb(v1S,v2S)) | LogicalXor => asConstnt(Word.xorb(v1S,v2S)) in (resultCode, decArgs, EnvSpecNone) end | (WordLogical logop, arg1, Constnt(v2, _)) => (* Return the zero if we are anding with zero otherwise the original arg *) if isShort v2 andalso toShort v2 = 0w0 then (case logop of LogicalAnd => CodeZero | _ => arg1, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (WordLogical logop, Constnt(v1, _), arg2) => if isShort v1 andalso toShort v1 = 0w0 then (case logop of LogicalAnd => CodeZero | _ => arg2, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) (* TODO: Constant folding of shifts. *) | _ => (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) end (* Arbitrary precision operations. This is a sort of mixture of a built-in and a conditional. *) - and simpArbitraryCompare(TestEqual, shortCond, arg1, arg2, longCall, context, tailDecs) = - (* Equality is a special case and is only there to ensure that it is not accidentally converted into - an indexed case further down. We must leave it as it is. *) - let - val (genCond, decCond, _ (*specArg1*)) = simpSpecial(shortCond, context, tailDecs) - val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(arg1, context, decCond) - val (genArg2, decArgs, _ (*specArg2*)) = simpSpecial(arg2, context, decArg1) - in - case (genArg1, genArg2) of - (Constnt(v1, _), Constnt(v2, _)) => - let - val a1: LargeInt.int = RunCall.unsafeCast v1 - and a2: LargeInt.int = RunCall.unsafeCast v2 - in - (if a1 = a2 then CodeTrue else CodeFalse, decArgs, EnvSpecNone) - end - | _ => - (Arbitrary{oper=ArbCompare TestEqual, shortCond=genCond, arg1=genArg1, arg2=genArg2, longCall=simplify(longCall, context)}, - decArgs, EnvSpecNone) - end + and simpArbitraryCompare(TestEqual, _, _, _, _, _, _) = + (* We no longer generate this for equality. General equality for arbitrary precision + uses a combination of PointerEq and byte comparison. *) + raise InternalError "simpArbitraryCompare: TestEqual" | simpArbitraryCompare(test, shortCond, arg1, arg2, longCall, context as {reprocess, ...}, tailDecs) = let val (genCond, decCond, _ (*specArg1*)) = simpSpecial(shortCond, context, tailDecs) val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(arg1, context, decCond) val (genArg2, decArgs, _ (*specArg2*)) = simpSpecial(arg2, context, decArg1) val posFlags = Address.F_bytes and negFlags = Word8.orb(Address.F_bytes, Address.F_negative) in (* Fold any constant/constant operations but more importantly, if we have variable/constant operations where the constant is short we can avoid using the full arbitrary precision call by just looking at the sign bit. *) case (genCond, genArg1, genArg2) of (_, Constnt(v1, _), Constnt(v2, _)) => let val a1: LargeInt.int = RunCall.unsafeCast v1 and a2: LargeInt.int = RunCall.unsafeCast v2 val testResult = case test of TestLess => a1 < a2 | TestGreater => a1 > a2 | TestLessEqual => a1 <= a2 | TestGreaterEqual => a1 >= a2 | _ => raise InternalError "simpArbitraryCompare: Unimplemented function" in (if testResult then CodeTrue else CodeFalse, decArgs, EnvSpecNone) end | (Constnt(c1, _), _, _) => + (* The condition is "isShort X andalso isShort Y". This will have been reduced + to a constant false or true if either (a) either argument is long or + (b) both arguments are short.*) if isShort c1 andalso toShort c1 = 0w0 then (* One argument is definitely long - generate the long form. *) - (Binary{oper=WordComparison{test=test, isSigned=true}, arg1=simplify(longCall, context), arg2=CodeZero}, - decArgs, EnvSpecNone) + (simplify(longCall, context), decArgs, EnvSpecNone) else (* Both arguments are short. That should mean they're constants. *) (Binary{oper=WordComparison{test=test, isSigned=true}, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) before reprocess := true + | (_, genArg1, cArg2 as Constnt _) => let (* The constant must be short otherwise the test would be false. *) val isNeg = case test of TestLess => true | TestLessEqual => true | _ => false (* Translate i < c into if isShort i then toShort i < c else isNegative i *) val newCode = Cond(Unary{oper=BuiltIns.IsTaggedValue, arg1=genArg1}, Binary { oper = BuiltIns.WordComparison{test=test, isSigned=true}, arg1 = genArg1, arg2 = cArg2 }, Binary { oper = BuiltIns.WordComparison{test=TestEqual, isSigned=false}, arg1=Unary { oper = MemoryCellFlags, arg1=genArg1 }, arg2=Constnt(toMachineWord(if isNeg then negFlags else posFlags), [])} ) in (newCode, decArgs, EnvSpecNone) end | (_, cArg1 as Constnt _, genArg2) => let (* We're testing c < i so the test is if isShort i then c < toShort i else isPositive i *) val isPos = case test of TestLess => true | TestLessEqual => true | _ => false val newCode = Cond(Unary{oper=BuiltIns.IsTaggedValue, arg1=genArg2}, Binary { oper = BuiltIns.WordComparison{test=test, isSigned=true}, arg1 = cArg1, arg2 = genArg2 }, Binary { oper = BuiltIns.WordComparison{test=TestEqual, isSigned=false}, arg1=Unary { oper = MemoryCellFlags, arg1=genArg2 }, arg2=Constnt(toMachineWord(if isPos then posFlags else negFlags), [])} ) in (newCode, decArgs, EnvSpecNone) end | _ => (Arbitrary{oper=ArbCompare test, shortCond=genCond, arg1=genArg1, arg2=genArg2, longCall=simplify(longCall, context)}, decArgs, EnvSpecNone) end and simpArbitraryArith(arith, shortCond, arg1, arg2, longCall, context, tailDecs) = let (* arg1 and arg2 are the arguments. shortCond is the condition that must be satisfied in order to use the short precision operation i.e. each argument must be short. *) val (genCond, decCond, _ (*specArg1*)) = simpSpecial(shortCond, context, tailDecs) val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(arg1, context, decCond) val (genArg2, decArgs, _ (*specArg2*)) = simpSpecial(arg2, context, decArg1) in case (genArg1, genArg2, genCond) of (Constnt(v1, _), Constnt(v2, _), _) => let val a1: LargeInt.int = RunCall.unsafeCast v1 and a2: LargeInt.int = RunCall.unsafeCast v2 (*val _ = print ("Fold arbitrary precision: " ^ PolyML.makestring(arith, a1, a2) ^ "\n")*) in case arith of ArithAdd => (Constnt(toMachineWord(a1+a2), []), decArgs, EnvSpecNone) | ArithSub => (Constnt(toMachineWord(a1-a2), []), decArgs, EnvSpecNone) | ArithMult => (Constnt(toMachineWord(a1*a2), []), decArgs, EnvSpecNone) | _ => raise InternalError "simpArbitraryArith: Unimplemented function" end | (_, _, Constnt(c1, _)) => if isShort c1 andalso toShort c1 = 0w0 then (* One argument is definitely long - generate the long form. *) (simplify(longCall, context), decArgs, EnvSpecNone) else (Arbitrary{oper=ArbArith arith, shortCond=genCond, arg1=genArg1, arg2=genArg2, longCall=simplify(longCall, context)}, decArgs, EnvSpecNone) | _ => (Arbitrary{oper=ArbArith arith, shortCond=genCond, arg1=genArg1, arg2=genArg2, longCall=simplify(longCall, context)}, decArgs, EnvSpecNone) end and simpAllocateWordMemory(numWords, flags, initial, context, tailDecs) = let val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(numWords, context, tailDecs) val (genArg2, decArg2, _ (*specArg2*)) = simpSpecial(flags, context, decArg1) val (genArg3, decArg3, _ (*specArg3*)) = simpSpecial(initial, context, decArg2) in (AllocateWordMemory{numWords=genArg1, flags=genArg2, initial=genArg3}, decArg3, EnvSpecNone) end (* Loads, stores and block operations use address values. The index value is initially an arbitrary code tree but we can recognise common cases of constant index values or where a constant has been added to the index. TODO: If these are C memory moves we can also look at the base address. The base address for C memory operations is a LargeWord.word value i.e. the address is contained in a box. The base addresses for ML memory moves is an ML address i.e. unboxed. *) and simpAddress({base, index=NONE, offset}, _, context) = let val (genBase, decBase, _ (*specBase*)) = simpSpecial(base, context, RevList[]) in ({base=genBase, index=NONE, offset=offset}, decBase) end | simpAddress({base, index=SOME index, offset}, multiplier, context) = let val (genBase, RevList decBase, _) = simpSpecial(base, context, RevList[]) val (genIndex, RevList decIndex, _ (* specIndex *)) = simpSpecial(index, context, RevList[]) val (newIndex, newOffset) = case genIndex of Constnt(indexOffset, _) => (* Convert small, positive offsets but leave large values as indexes. We could have silly index values here which will never be executed because of a range check but should still compile. *) if isShort indexOffset andalso toShort indexOffset < 0w1000 then (NONE, offset + toShort indexOffset * multiplier) else (SOME genIndex, offset) | _ => (SOME genIndex, offset) in ({base=genBase, index=newIndex, offset=newOffset}, RevList(decIndex @ decBase)) end (* (* A built-in function. We can call certain built-ins immediately if the arguments are constants. *) and simpBuiltIn(rtsCallNo, argList, context as { reprocess, ...}) = let val copiedArgs = map (fn arg => simpSpecial(arg, context)) argList open RuntimeCalls (* When checking for a constant we need to check that there are no bindings. They could have side-effects. *) fun isAConstant(Constnt _, [], _) = true | isAConstant _ = false in (* If the function is an RTS call that is safe to evaluate immediately and all the arguments are constants evaluate it now. *) if earlyRtsCall rtsCallNo andalso List.all isAConstant copiedArgs then let val () = reprocess := true exception Interrupt = Thread.Thread.Interrupt (* Turn the arguments into a vector. *) val argVector = case makeConstVal(mkTuple(List.map specialToGeneral copiedArgs)) of Constnt(w, _) => w | _ => raise InternalError "makeConstVal: Not constant" (* Call the function. If it raises an exception (e.g. divide by zero) generate code to raise the exception at run-time. We don't do that for Interrupt which we assume only arises by user interaction and not as a result of executing the code so we reraise that exception immediately. *) val ioOp : int -> machineWord = RunCall.run_call1 RuntimeCalls.POLY_SYS_io_operation (* We need callcode_tupled here because we pass the arguments as a tuple but the RTS functions we're calling expect arguments in registers or on the stack. *) val call: (address * machineWord) -> machineWord = RunCall.run_call1 RuntimeCalls.POLY_SYS_callcode_tupled val code = Constnt (call(toAddress(ioOp rtsCallNo), argVector), []) handle exn as Interrupt => raise exn (* Must not handle this *) | exn => Raise (Constnt(toMachineWord exn, [])) in (code, [], EnvSpecNone) end (* We can optimise certain built-ins in combination with others. If we have POLY_SYS_unsigned_to_longword combined with POLY_SYS_longword_to_tagged we can eliminate both. This can occur in cases such as Word.fromLargeWord o Word8.toLargeWord. If we have POLY_SYS_cmem_load_X functions where the address is formed by adding a constant to an address we can move the addend into the load instruction. *) (* TODO: Could we also have POLY_SYS_signed_to_longword here? *) else if rtsCallNo = POLY_SYS_longword_to_tagged andalso (case copiedArgs of [(_, _, EnvSpecBuiltIn(r, _))] => r = POLY_SYS_unsigned_to_longword | _ => false) then let val arg = (* Get the argument of the argument. *) case copiedArgs of [(_, _, EnvSpecBuiltIn(_, [arg]))] => arg | _ => raise Bind in (arg, [], EnvSpecNone) end else if (rtsCallNo = POLY_SYS_cmem_load_8 orelse rtsCallNo = POLY_SYS_cmem_load_16 orelse rtsCallNo = POLY_SYS_cmem_load_32 orelse rtsCallNo = POLY_SYS_cmem_load_64 orelse rtsCallNo = POLY_SYS_cmem_store_8 orelse rtsCallNo = POLY_SYS_cmem_store_16 orelse rtsCallNo = POLY_SYS_cmem_store_32 orelse rtsCallNo = POLY_SYS_cmem_store_64) andalso (* Check if the first argument is an addition. The second should be a constant. If the addend is a constant it will be a large integer i.e. the address of a byte segment. *) let (* Check that we have a valid value to add to a large word. The cmem_load/store values sign extend their arguments so we use toLargeWordX here. *) fun isAcceptableOffset c = if isShort c (* Shouldn't occur. *) then false else let val l: LargeWord.word = RunCall.unsafeCast c in Word.toLargeWordX(Word.fromLargeWord l) = l end in case copiedArgs of (_, _, EnvSpecBuiltIn(r, args)) :: (Constnt _, _, _) :: _ => r = POLY_SYS_plus_longword andalso (case args of (* If they were both constants we'd have folded them. *) [Constnt(c, _), _] => isAcceptableOffset c | [_, Constnt(c, _)] => isAcceptableOffset c | _ => false) | _ => false end then let (* We have a load or store with an added constant. *) val (base, offset) = case copiedArgs of (_, _, EnvSpecBuiltIn(_, [Constnt(offset, _), base])) :: (Constnt(existing, _), _, _) :: _ => (base, Word.fromLargeWord(RunCall.unsafeCast offset) + toShort existing) | (_, _, EnvSpecBuiltIn(_, [base, Constnt(offset, _)])) :: (Constnt(existing, _), _, _) :: _ => (base, Word.fromLargeWord(RunCall.unsafeCast offset) + toShort existing) | _ => raise Bind val newDecs = List.map(fn h => makeNewDecl(h, context)) copiedArgs val genArgs = List.map(fn ((g, _), _) => envGeneralToCodetree g) newDecs val preDecs = List.foldr (op @) [] (List.map #2 newDecs) val gen = BuiltIn(rtsCallNo, base :: Constnt(toMachineWord offset, []) :: List.drop(genArgs, 2)) in (gen, preDecs, EnvSpecNone) end else let (* Create bindings for the arguments. This ensures that any side-effects in the evaluation of the arguments are performed in the correct order even if the application of the built-in itself is applicative. The new arguments are either loads or constants which are applicative. *) val newDecs = List.map(fn h => makeNewDecl(h, context)) copiedArgs val genArgs = List.map(fn ((g, _), _) => envGeneralToCodetree g) newDecs val preDecs = List.foldr (op @) [] (List.map #2 newDecs) val gen = BuiltIn(rtsCallNo, genArgs) val spec = if reorderable gen then EnvSpecBuiltIn(rtsCallNo, genArgs) else EnvSpecNone in (gen, preDecs, spec) end end *) and simpIfThenElse(condTest, condThen, condElse, context, tailDecs) = (* If-then-else. The main simplification is if we have constants in the test or in both the arms. *) let val word0 = toMachineWord 0 val word1 = toMachineWord 1 val False = word0 val True = word1 in case simpSpecial(condTest, context, tailDecs) of (* If the test is a constant we can return the appropriate arm and ignore the other. *) (Constnt(testResult, _), bindings, _) => let val arm = if wordEq (testResult, False) (* false - return else-part *) then condElse (* if false then x else y == y *) (* if true then x else y == x *) else condThen in simpSpecial(arm, context, bindings) end | (testGen, testbindings as RevList testBList, testSpec) => let fun mkNot (Unary{oper=BuiltIns.NotBoolean, arg1}) = arg1 | mkNot arg = Unary{oper=BuiltIns.NotBoolean, arg1=arg} (* If the test involves a variable that was created with a NOT it's better to move it in here. *) val testCond = case testSpec of EnvSpecUnary(BuiltIns.NotBoolean, arg1) => mkNot arg1 | _ => testGen in case (simpSpecial(condThen, context, RevList[]), simpSpecial(condElse, context, RevList[])) of ((thenConst as Constnt(thenVal, _), RevList [], _), (elseConst as Constnt(elseVal, _), RevList [], _)) => (* Both arms return constants. This situation can arise in situations where we have andalso/orelse where the second "argument" has been reduced to a constant. *) if wordEq (thenVal, elseVal) then (* If the test has a side-effect we have to do it otherwise we can remove it. If we're in a nested andalso/orelse that may mean we can simplify the next level out. *) (thenConst (* or elseConst *), if sideEffectFree testCond then testbindings else RevList(NullBinding testCond :: testBList), EnvSpecNone) (* if x then true else false == x *) else if wordEq (thenVal, True) andalso wordEq (elseVal, False) then (testCond, testbindings, EnvSpecNone) (* if x then false else true == not x *) else if wordEq (thenVal, False) andalso wordEq (elseVal, True) then (mkNot testCond, testbindings, EnvSpecNone) else (* can't optimise *) (Cond (testCond, thenConst, elseConst), testbindings, EnvSpecNone) (* Rewrite "if x then raise y else z" into "(if x then raise y else (); z)" The advantage is that any tuples in z are lifted outside the "if". *) | (thenPart as (Raise _, _:revlist, _), (elsePart, RevList elseBindings, elseSpec)) => (* then-part raises an exception *) (elsePart, RevList(elseBindings @ NullBinding(Cond (testCond, specialToGeneral thenPart, CodeZero)) :: testBList), elseSpec) | ((thenPart, RevList thenBindings, thenSpec), elsePart as (Raise _, _, _)) => (* else part raises an exception *) (thenPart, RevList(thenBindings @ NullBinding(Cond (testCond, CodeZero, specialToGeneral elsePart)) :: testBList), thenSpec) | (thenPart, elsePart) => (Cond (testCond, specialToGeneral thenPart, specialToGeneral elsePart), testbindings, EnvSpecNone) end end (* Tuple construction. Tuples are also used for datatypes and structures (i.e. modules) *) and simpTuple(entries, isVariant, context, tailDecs) = (* The main reason for optimising record constructions is that they appear as tuples in ML. We try to ensure that loads from locally created tuples do not involve indirecting from the tuple but can get the value which was put into the tuple directly. If that is successful we may find that the tuple is never used directly so the use-count mechanism will ensure it is never created. *) let val tupleSize = List.length entries (* The record construction is treated as a block of local declarations so that any expressions which might have side-effects are done exactly once. *) (* We thread the bindings through here to avoid having to append the result. *) fun processFields([], bindings) = ([], bindings) | processFields(field::fields, bindings) = let val (thisField, newBindings) = makeNewDecl(simpSpecial(field, context, bindings), context) val (otherFields, resBindings) = processFields(fields, newBindings) in (thisField::otherFields, resBindings) end val (fieldEntries, allBindings) = processFields(entries, tailDecs) (* Make sure we include any inline code in the result. If this tuple is being "exported" we will lose the "special" part. *) fun envResToCodetree(EnvGenLoad(ext), _) = Extract ext | envResToCodetree(EnvGenConst(w, p), s) = Constnt(w, setInline s p) val generalFields = List.map envResToCodetree fieldEntries val genRec = if List.all isConstnt generalFields then makeConstVal(Tuple{ fields = generalFields, isVariant = isVariant }) else Tuple{ fields = generalFields, isVariant = isVariant } (* Get the field from the tuple if possible. If it's a variant, though, we may try to get an invalid field. See Tests/Succeed/Test167. *) fun getField addr = if addr < tupleSize then List.nth(fieldEntries, addr) else if isVariant then (EnvGenConst(toMachineWord 0, []), EnvSpecNone) else raise InternalError "getField - invalid index" val specRec = EnvSpecTuple(tupleSize, getField) in (genRec, allBindings, specRec) end and simpFieldSelect(base, offset, indKind, context, tailDecs) = let val (genSource, decSource, specSource) = simpSpecial(base, context, tailDecs) in (* Try to do the selection now if possible. *) case specSource of EnvSpecTuple(_, recEnv) => let (* The "special" entry we've found is a tuple. That means that we are taking a field from a tuple we made earlier and so we should be able to get the original code we used when we made the tuple. That might mean the tuple is never used and we can optimise away the construction of it completely. *) val (newGen, newSpec) = recEnv offset in (envGeneralToCodetree newGen, decSource, newSpec) end | _ => (* No special case possible. If the tuple is a constant mkInd/mkVarField will do the selection immediately. *) let val genSelect = case indKind of IndTuple => mkInd(offset, genSource) | IndVariant => mkVarField(offset, genSource) | IndContainer => mkIndContainer(offset, genSource) in (genSelect, decSource, EnvSpecNone) end end (* Process a SetContainer. Unlike the other simpXXX functions this is called after the arguments have been processed. We try to push the SetContainer to the leaves of the expression. This is particularly important with tail-recursive functions that return tuples. Without this the function will lose tail-recursion since each recursion will be followed by code to copy the result back to the previous container. *) and simpPostSetContainer(container, Tuple{fields, ...}, RevList tupleDecs, filter) = let (* Apply the filter now. *) fun select(n, hd::tl) = if n >= BoolVector.length filter then [] else if BoolVector.sub(filter, n) then hd :: select(n+1, tl) else select(n+1, tl) | select(_, []) = [] val selected = select(0, fields) (* Frequently we will have produced an indirection from the same base. These will all be bindings so we have to reverse the process. *) fun findOriginal a = List.find(fn Declar{addr, ...} => addr = a | _ => false) tupleDecs fun checkFields(last, Extract(LoadLocal a) :: tl) = ( case findOriginal a of SOME(Declar{value=Indirect{base=Extract ext, indKind=IndContainer, offset, ...}, ...}) => ( case last of NONE => checkFields(SOME(ext, [offset]), tl) | SOME(lastExt, offsets) => (* It has to be the same base and with increasing offsets (no reordering). *) if lastExt = ext andalso offset > hd offsets then checkFields(SOME(ext, offset :: offsets), tl) else NONE ) | _ => NONE ) | checkFields(_, _ :: _) = NONE | checkFields(last, []) = last fun fieldsToFilter fields = let val maxDest = List.foldl Int.max ~1 fields val filterArray = BoolArray.array(maxDest+1, false) val _ = List.app(fn n => BoolArray.update(filterArray, n, true)) fields in BoolArray.vector filterArray end in case checkFields(NONE, selected) of SOME (ext, fields) => (* It may be a container. *) let val filter = fieldsToFilter fields in case ext of LoadLocal localAddr => let (* Is this a container? If it is and we're copying all of it we can replace the inner container with a binding to the outer. We have to be careful because it is possible that we may create and set the inner container, then have some bindings that do some side-effects with the inner container before then copying it to the outer container. For simplicity and to maintain the condition that the container is set in the tails we only merge the containers if it's at the end (after any "filtering"). *) val allSet = BoolVector.foldl (fn (a, t) => a andalso t) true filter fun findContainer [] = NONE | findContainer (Declar{value, ...} :: tl) = if sideEffectFree value then findContainer tl else NONE | findContainer (Container{addr, size, setter, ...} :: tl) = if localAddr = addr andalso size = BoolVector.length filter andalso allSet then SOME (setter, tl) else NONE | findContainer _ = NONE in case findContainer tupleDecs of SOME (setter, decs) => (* Put in a binding for the inner container address so the setter will set the outer container. For this to work all loads from the stack must use native word length. *) mkEnv(List.rev(Declar{addr=localAddr, value=container, use=[]} :: decs), setter) | NONE => mkEnv(List.rev tupleDecs, SetContainer{container=container, tuple = mkTuple selected, filter=BoolVector.tabulate(List.length selected, fn _ => true)}) end | _ => mkEnv(List.rev tupleDecs, SetContainer{container=container, tuple = mkTuple selected, filter=BoolVector.tabulate(List.length selected, fn _ => true)}) end | NONE => mkEnv(List.rev tupleDecs, SetContainer{container=container, tuple = mkTuple selected, filter=BoolVector.tabulate(List.length selected, fn _ => true)}) end | simpPostSetContainer(container, Cond(ifpt, thenpt, elsept), RevList tupleDecs, filter) = mkEnv(List.rev tupleDecs, Cond(ifpt, simpPostSetContainer(container, thenpt, RevList [], filter), simpPostSetContainer(container, elsept, RevList [], filter))) | simpPostSetContainer(container, Newenv(envDecs, envExp), RevList tupleDecs, filter) = simpPostSetContainer(container, envExp, RevList(List.rev envDecs @ tupleDecs), filter) | simpPostSetContainer(container, BeginLoop{loop, arguments}, RevList tupleDecs, filter) = mkEnv(List.rev tupleDecs, BeginLoop{loop = simpPostSetContainer(container, loop, RevList [], filter), arguments=arguments}) | simpPostSetContainer(_, loop as Loop _, RevList tupleDecs, _) = (* If we are inside a BeginLoop we only set the container on leaves that exit the loop. Loop entries will go back to the BeginLoop so we don't add SetContainer nodes. *) mkEnv(List.rev tupleDecs, loop) | simpPostSetContainer(container, Handle{exp, handler, exPacketAddr}, RevList tupleDecs, filter) = mkEnv(List.rev tupleDecs, Handle{ exp = simpPostSetContainer(container, exp, RevList [], filter), handler = simpPostSetContainer(container, handler, RevList [], filter), exPacketAddr = exPacketAddr}) | simpPostSetContainer(container, tupleGen, RevList tupleDecs, filter) = mkEnv(List.rev tupleDecs, mkSetContainer(container, tupleGen, filter)) - fun simplifier(c, numLocals) = + fun simplifier{code, numLocals, maxInlineSize} = let val localAddressAllocator = ref 0 val addrTab = Array.array(numLocals, NONE) fun lookupAddr (LoadLocal addr) = valOf(Array.sub(addrTab, addr)) | lookupAddr (env as LoadArgument _) = (EnvGenLoad env, EnvSpecNone) | lookupAddr (env as LoadRecursive) = (EnvGenLoad env, EnvSpecNone) | lookupAddr (LoadClosure _) = raise InternalError "top level reached in simplifier" and enterAddr (addr, tab) = Array.update (addrTab, addr, SOME tab) fun mkAddr () = ! localAddressAllocator before localAddressAllocator := ! localAddressAllocator + 1 val reprocess = ref false val (gen, RevList bindings, spec) = - simpSpecial(c, - {lookupAddr = lookupAddr, enterAddr = enterAddr, nextAddress = mkAddr, reprocess = reprocess}, RevList[]) + simpSpecial(code, + {lookupAddr = lookupAddr, enterAddr = enterAddr, nextAddress = mkAddr, + reprocess = reprocess, maxInlineSize = maxInlineSize}, RevList[]) in ((gen, List.rev bindings, spec), ! localAddressAllocator, !reprocess) end fun specialToGeneral(g, b as _ :: _, s) = mkEnv(b, specialToGeneral(g, [], s)) | specialToGeneral(Constnt(w, p), [], s) = Constnt(w, setInline s p) | specialToGeneral(g, [], _) = g structure Sharing = struct type codetree = codetree and codeBinding = codeBinding and envSpecial = envSpecial 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 ec4601c9..2d399c4f 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE_STATIC_LINK_AND_CASES.sml +++ b/mlsource/MLCompiler/CodeTree/CODETREE_STATIC_LINK_AND_CASES.sml @@ -1,879 +1,881 @@ (* - Copyright (c) 2012-13, 2015-17 David C.J. Matthews + Copyright (c) 2012-13, 2015-17, 2020 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(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 *) + (* We have to rewrite this. + e.g. if isShort i andalso isShort j then toShort i < toShort j else callComp(i, j) < 0 + This isn't done at the higher level because we'd like to recognise cases of + comparisons with short constants *) 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) - ) + BICCond(insShort, fixedComp(insArg1, insArg2), insCall) 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. *) + the lower levels assume that all values are tagged. + This could be used for PointerEq which is what arbitrary precision will generate + provided that there was an extra check for long values. N.B. the same also + happens for + e.g. datatype t = A | B | C | D | E of int*int + i.e. one non-nullary constructor. *) 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/CodetreeFunctionsSig.sml b/mlsource/MLCompiler/CodeTree/CodetreeFunctionsSig.sml index 648e80bf..2774f13d 100644 --- a/mlsource/MLCompiler/CodeTree/CodetreeFunctionsSig.sml +++ b/mlsource/MLCompiler/CodeTree/CodetreeFunctionsSig.sml @@ -1,76 +1,84 @@ (* Copyright (c) 2012,13,17,20 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 CodetreeFunctionsSig = sig type codetree and codeBinding and loadForm and envSpecial type machineWord = Address.machineWord val mkLoadLocal: int -> codetree and mkLoadArgument: int -> codetree and mkLoadClosure: int -> codetree val mkEnv: codeBinding list * codetree -> codetree and mkInd: int * codetree -> codetree and mkVarField: int * codetree -> codetree and mkIndContainer: int * codetree -> codetree and mkTuple: codetree list -> codetree and mkDatatype: codetree list -> codetree val CodeFalse: codetree and CodeTrue: codetree and CodeZero: codetree val mkSetContainer: codetree * codetree * BoolVector.vector -> codetree val mkTupleFromContainer: int * int -> codetree val decSequenceWithFinalExp: codeBinding list -> codetree val sideEffectFree: codetree -> bool and reorderable: codetree -> bool and sideEffectFreeRTSCall: int -> bool val makeConstVal: codetree -> codetree val evalue: codetree -> machineWord option val findEntryInBlock: codetree * int * bool -> codetree val earlyRtsCall: int -> bool val partitionMutualBindings: codeBinding -> codeBinding list type createClosure val makeClosure: unit -> createClosure and addToClosure: createClosure -> loadForm -> loadForm and extractClosure: createClosure -> loadForm list val findInline: Universal.universal list -> envSpecial val setInline: envSpecial -> Universal.universal list -> Universal.universal list + datatype inlineTest = + TooBig + | NonRecursive + | TailRecursive of bool vector + | NonTailRecursive of bool vector + + val evaluateInlining: codetree * int * int -> inlineTest + structure Sharing: sig type codetree = codetree and codeBinding = codeBinding and loadForm = loadForm and createClosure = createClosure and envSpecial = envSpecial end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86CodetreeToICode.ML b/mlsource/MLCompiler/CodeTree/X86Code/X86CodetreeToICode.ML index ff46f1a3..53ab1f6c 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86CodetreeToICode.ML +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86CodetreeToICode.ML @@ -1,3988 +1,3995 @@ (* - Copyright David C. J. Matthews 2016-19 + Copyright David C. J. Matthews 2016-20 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=moveNativeWord}) :: 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(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 | codeToICodeUnaryRev({oper=BuiltIns.TouchAddress, arg1}, context, _, destination, tailCode) = let (* Put the value in a register. This is not entirely necessary but ensures that if the value is a constant the constant will be included in the code. *) val (argCode, aReg) = codeToPRegRev(arg1, context, tailCode) in moveIfNotAllowedRev(destination, BlockSimple(TouchArgument{source=aReg}) :: argCode, (* Unit result *) IntegerConstant(tag 0)) 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. *) + is perfectly possible that the argument could be an address. + The higher levels used to generate this for pointer equality. *) 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.PointerEq, arg1, arg2}, context, isTail, destination, tailCode) = + (* Equality of general values which can include pointers. This can be treated exactly as a word equality. + It has to be analysed differently for indexed cases. *) + codeToICodeBinaryRev({oper=BuiltIns.WordComparison{test=BuiltIns.TestEqual, isSigned=false}, arg1=arg1, arg2=arg2}, + context, isTail, destination, tailCode) + | 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 iOffset = Word.toInt offset handle Overflow => 0 (* See below: special case may not happen. *) val memResult = if wordSize = 0w8 then {base=realBase, offset=iOffset-4, index=MemIndex4 indexReg, cache=NONE} else {base=realBase, offset=iOffset-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) (* A negative value for "offset" will produce an overflow at compile time. It should never be reached at run-time because of bounds checking. See Test192. *) val iOffset = Word.toInt offset handle Overflow => 0 val memResult = {offset=iOffset, 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/ml_bind.ML b/mlsource/MLCompiler/CodeTree/ml_bind.ML index 60086034..b5e34210 100644 --- a/mlsource/MLCompiler/CodeTree/ml_bind.ML +++ b/mlsource/MLCompiler/CodeTree/ml_bind.ML @@ -1,91 +1,91 @@ (* 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. + 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 structure CodetreeFunctions = CODETREE_FUNCTIONS(structure BASECODETREE = BaseCodeTree and STRONGLY = StronglyConnected) structure CodetreeBackend = CODETREE_STATIC_LINK_AND_CASES( structure PRETTY = Pretty structure GCODE = GCode structure DEBUG = Debug structure BASECODETREE = BaseCodeTree structure BACKENDTREE = BackendIntermediateCode structure CODETREE_FUNCTIONS = CodetreeFunctions structure CODE_ARRAY = CODE_ARRAY ) structure CodetreeLamdbaLift = CODETREE_LAMBDA_LIFT ( structure BASECODETREE = BaseCodeTree and CODETREE_FUNCTIONS = CodetreeFunctions and BACKEND = CodetreeBackend and PRETTY = Pretty and DEBUG = Debug and CODE_ARRAY = CODE_ARRAY ) structure CodetreeCodegenConstantFns = CODETREE_CODEGEN_CONSTANT_FUNCTIONS ( structure BASECODETREE = BaseCodeTree and CODETREE_FUNCTIONS = CodetreeFunctions and BACKEND = CodetreeLamdbaLift and PRETTY = Pretty and DEBUG = Debug and CODE_ARRAY = CODE_ARRAY ) structure CodetreeRemoveRedundant = CODETREE_REMOVE_REDUNDANT( structure BASECODETREE = BaseCodeTree structure CODETREE_FUNCTIONS = CodetreeFunctions ) structure CodetreeSimplifier = CODETREE_SIMPLIFIER( structure BASECODETREE = BaseCodeTree - structure CODETREE_FUNCTIONS = CodetreeFunctions - structure REMOVE_REDUNDANT = CodetreeRemoveRedundant + and CODETREE_FUNCTIONS = CodetreeFunctions + and REMOVE_REDUNDANT = CodetreeRemoveRedundant + and DEBUG = Debug ) structure CodetreeOptimiser = CODETREE_OPTIMISER( structure PRETTY = Pretty structure DEBUG = Debug structure BASECODETREE = BaseCodeTree structure CODETREE_FUNCTIONS = CodetreeFunctions structure BACKEND = CodetreeCodegenConstantFns structure REMOVE_REDUNDANT = CodetreeRemoveRedundant structure SIMPLIFIER = CodetreeSimplifier ) in structure CodeTree = CODETREE ( structure PRETTY = Pretty structure DEBUG = Debug structure BASECODETREE = BaseCodeTree structure CODETREE_FUNCTIONS = CodetreeFunctions structure BACKEND = CodetreeCodegenConstantFns structure OPTIMISER = CodetreeOptimiser ) end; diff --git a/mlsource/MLCompiler/CompilerVersion.sml b/mlsource/MLCompiler/CompilerVersion.sml index 0935d07c..375d1d44 100644 --- a/mlsource/MLCompiler/CompilerVersion.sml +++ b/mlsource/MLCompiler/CompilerVersion.sml @@ -1,23 +1,23 @@ (* Copyright (c) 2007-20 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 CompilerVersion = struct - val compilerVersion = "5.8.1 Release" - val versionNumber = 581 + val compilerVersion = "5.8.2 Testing" + val versionNumber = 582 val versionSuffix = Int.toString versionNumber end; diff --git a/mlsource/MLCompiler/DATATYPE_REP.ML b/mlsource/MLCompiler/DATATYPE_REP.ML index 280d48cd..c1da502a 100644 --- a/mlsource/MLCompiler/DATATYPE_REP.ML +++ b/mlsource/MLCompiler/DATATYPE_REP.ML @@ -1,685 +1,683 @@ (* - Copyright (c) 2009, 2013, 2015-16 David C.J. Matthews + Copyright (c) 2009, 2013, 2015-16, 2020 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 *) (* Title: Operations on global and local values. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1986 *) functor DATATYPE_REP ( structure CODETREE : CODETREESIG structure STRUCTVALS : STRUCTVALSIG; structure TYPESTRUCT : TYPETREESIG structure MISC : sig exception InternalError of string; (* compiler error *) val quickSort : ('a -> 'a -> bool) -> 'a list -> 'a list end; structure ADDRESS : AddressSig structure COPIER: COPIERSIG structure TYPEIDCODE: TYPEIDCODESIG sharing STRUCTVALS.Sharing = TYPESTRUCT.Sharing = COPIER.Sharing = CODETREE.Sharing = ADDRESS = MISC = TYPEIDCODE.Sharing ) : DATATYPEREPSIG = struct open MISC; open CODETREE; open TYPESTRUCT; (* Open this first because unitType is in STRUCTVALS as well. *) open Universal; (* for tag etc. *) open STRUCTVALS; open ADDRESS; open TYPEIDCODE open COPIER val length = List.length; val orb = Word8.orb infix 7 orb; (* These are the possible representations of a value constructor. *) datatype representations = RefForm (* As for OnlyOne but must be a monotype. *) | UnitForm (* If the only value in an enumeration. *) | OnlyOne (* If only one constructor, there is no tag or box. *) (* Could be replaced by "UnboxedForm"? *) | EnumForm of { tag: word, maxTag: word } (* Enumeration - argument is the number. *) | ShortForm of word (* As EnumForm except that one datatype is BoxedForm. *) | BoxedForm (* Boxed but not tagged (only unary constructor) *) | UnboxedForm of int (* Unboxed and untagged (only unary constructor) *) | ConstForm of { value: machineWord, maxTag: word} (* Constant - argument is a tagged value. *) | TaggedBox of { tag: word, maxTag: word } (* Union - tagged and boxed. i.e. the representation is a pair whose first word is the tag and second is the value. *) | TaggedTuple of { tag: word, maxTag: word, size: int } (* Union - tagged but with in-line tuple. i.e. for a tuple of size n the representation is a tuple of size n+1 whose first word contains the tag. *) val arg1 = mkLoadArgument 0 (* saves a lot of garbage *) val mutableFlags = F_words orb F_mutable; (* allocate 1 mutable word, initialise to "v" *) fun refApplyCode v = mkAllocateWordMemory(mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), v) local fun mkTag (tag:word) : codetree = mkConst (toMachineWord tag); (* How to apply the constructor at run-time or, if, it's a constant make it now. *) fun constrApply (test: representations, arg) : codetree = let fun tagTupleApplyCode (tag, n, arg) = mkEval (mkInlproc (mkDatatype (mkTag tag :: List.tabulate(n, fn i => mkInd(i, arg1))), 1, "", [], 0), [arg]) (* Even though unboxed tuples (e.g. list cells) are the same as tuples we need to add this extra step so that the result is a variant tuple i.e. the optimiser can tell that this may not always be a tuple. *) fun tupleApplyCode (n, arg) = mkEval (mkInlproc (mkDatatype (List.tabulate(n, fn i => mkInd(i, arg1))), 1, "", [], 0), [arg]) in case test of UnboxedForm 0 => arg (* Function - never detupled. *) | UnboxedForm size => tupleApplyCode(size, arg) | BoxedForm => mkDatatype [arg] | RefForm => refApplyCode arg | TaggedBox{tag, ...} => mkDatatype [mkTag tag, arg] | TaggedTuple{tag, size, ...} => tagTupleApplyCode(tag, size, arg) | OnlyOne => arg | ConstForm{ value, ...} => mkConst value (* tagged value. *) | EnumForm{tag, ...} => mkConst (toMachineWord tag) | ShortForm tag => mkConst (toMachineWord tag) | UnitForm => CodeZero end (* The run-time test whether a value matches a constructor. *) fun constrMatch (test: representations, value:codetree) : codetree = let - fun testTag (tag, v) = mkEqualWord(mkTag tag, v) - fun testTagOf(tag, maxTag, v) = mkTagTest (v, tag, maxTag) fun testBoxedTagOf (tag, maxTag, v) = testTagOf (tag, maxTag, mkInd (0, v)) (* Tag is first field. It is always present and is always the tag so we can use mkInd here rather than mkVarField. *) val testBoxed = mkNot o mkIsShort (* not (isShort v) *) (* get the tag from a TaggedBox or ConstForm *) fun loadTag (u: machineWord) : machineWord = loadWord (toAddress u, 0w0); (* tag is first field *) in case test of UnboxedForm _ => testBoxed value | BoxedForm => testBoxed value | RefForm => CodeTrue | EnumForm{tag, maxTag} => testTagOf(tag, maxTag, value) - | ShortForm tag => testTag(tag, value) + | ShortForm tag => mkEqualPointerOrWord(mkTag tag, value) (* Could be an address. *) | TaggedBox{tag, maxTag} => testBoxedTagOf(tag, maxTag, value) | TaggedTuple{tag, maxTag, ...} => testBoxedTagOf(tag, maxTag, value) | ConstForm{value=c, maxTag} => testBoxedTagOf(toShort (loadTag c), maxTag, value) | OnlyOne => CodeTrue | UnitForm => CodeTrue end (* The run-time code to destruct a construction. *) (* shouldn't the CodeZero's raise an exception instead? No, because I think there are circumstances in which the destructor code is created even for nullary constructors. *) fun constrDestruct (test: representations, value: codetree) : codetree = let (* Copy out the fields and build a tuple. Used either if we have a tagged tuple (offset 1) or a tuple that does not need boxing (because we need to use mkVarField to extract the fields). *) fun tupleDestructCode (n, arg, offset) = mkEval ( mkInlproc (mkTuple (List.tabulate(n, fn i => mkVarField(i+offset, arg1))), 1, "", [], 0), [arg]) (* Use loadWord not indirect because the optimiser reorders indirections. *) fun refDestructCode v = mkLoadOperation(LoadStoreMLWord{isImmutable=false}, v, CodeZero) in case test of UnboxedForm 0 => value (* Function - never detupled. *) | UnboxedForm size => tupleDestructCode(size, value, 0) | BoxedForm => mkVarField (0, value) | RefForm => refDestructCode value | TaggedBox _ => mkVarField (1, value) (* contents is second field of record *) | TaggedTuple { size, ...} => tupleDestructCode(size, value, 1) | OnlyOne => value | EnumForm _ => CodeZero (* To keep optimiser happy. *) | ShortForm _ => CodeZero (* To keep optimiser happy. *) | ConstForm _ => CodeZero (* (rather than raising an exception) *) | UnitForm => CodeZero end open ValueConstructor in (* Constructors are now represented as run-time values. A nullary constructor is a pair consisting of a test function and the constructor value. A unary constructor is a triple: a test function, an injection function and a projection function. The above applies to monotypes. If this is a polytype each of these is actually a function from the base type values to the functions. *) fun createNullaryConstructor (test, tvs, name): codetree = let val numTypes = if justForEqualityTypes then 0 else List.length tvs val testFn = mkInlproc(constrMatch(test, arg1), 1, name, [], 0) (* Test function. *) and constrVal = constrApply(test, CodeZero) (* Value. *) in if numTypes = 0 then createNullaryConstr{ testMatch = testFn, constrValue = constrVal } else createNullaryConstr{ testMatch = mkInlproc(testFn, numTypes, name, [], 0), constrValue = mkInlproc(constrVal, numTypes, name, [], 0)} end fun createUnaryConstructor(test: representations, tvs, name: string): codetree = let val numTypes = if justForEqualityTypes then 0 else List.length tvs val testMatch = mkInlproc(constrMatch(test, arg1), 1, name, [], 0) (* Test function. *) and injectValue = mkInlproc(constrApply(test, arg1), 1, name, [], 0) (* Injection function. *) and projectValue = mkInlproc(constrDestruct(test, arg1), 1, name, [], 0) (* Projection function. *) in if numTypes = 0 then createValueConstr{testMatch = testMatch, injectValue = injectValue, projectValue = projectValue } else createValueConstr{ testMatch = mkInlproc(testMatch, numTypes, name, [], 0), injectValue = mkInlproc(injectValue, numTypes, name, [], 0), projectValue = mkInlproc(projectValue, numTypes, name, [], 0)} end end (* RefForm is used for "ref" (only). We use various representations of datatype / abstype constructors. Nullary constructors are represented as: UnitForm (if it's the only constructor in the datatype) EnumForm (if all the constructors are nullary) ShortForm (if there's one non-nullary constructor) ConstForm (otherwise) Unary constructors are represented as: OnlyOne (if it's the only constructor in the datatype) UnboxedForm (if it's the only unary constructor and the argument is always a tuple e.g. list) TaggedTuple (if it's not the only unary constructor, applied to a tuple) BoxedForm (if it's the only unary constructor and the argument may not be a tuple e.g. SOME) TaggedBox (otherwise) Note that we use ConstForm, not EnumForm, for nullary constructors when the unary constructors are represented as TaggedTuple/TaggedBox because that allows the TaggedBox test to be: fn w => wordEq (loadWord (w,0), tag) rather than: fn w => not (isShort w) andalso wordEq (loadWord (w,0), tag) Note that EnumForm and ShortForm differ in that the tests for EnumForm use mkTagTest which can be converted into an indexed case. This can't be used for ShortForm because the values for the datatype include addresses. *) datatype constructorKind = Nullary (* a nullary constructor *) | UnaryGeneric (* a normal unary constructor *) | UnaryFunction (* unary constructor applied to a function *) | UnaryTupled of int (* a unary constructor applied to a tuple of size n *) ; fun getTupleKind t = case t of (* We cannot have flexible records here. All the fields must be listed. *) LabelledType {recList = [{typeof=t', ...}], ...} => (* Singleton records are always represented simply by the value. *) getTupleKind t' | LabelledType {recList, ...} => UnaryTupled (length recList) | FunctionType _ => UnaryFunction | TypeConstruction {constr, args, ...} => ( (* We may have a type equivalence or this may be a datatype. *) if tcIsAbbreviation constr then getTupleKind (makeEquivalent(constr, args)) else if sameTypeId (tcIdentifier constr, tcIdentifier refConstr) then UnaryGeneric (* A tuple ref is NOT the same as the tuple. *) else (* Datatype. For the moment we only consider datatypes with a single constructor since we want to find the width of the tuple. At present we simply return UnaryGeneric for all other cases but it might be helpful to return a special result when we have a datatype which we know will always be boxed. *) (* case tcConstructors constr of [Value{typeOf, class=Constructor{nullary=false, ...}, ...}] => (* This may be a polymorphic datatype in which case we have to invert the constructor to find the base type. e.g. we may have an instance (int*int) t where t was declared as datatype 'a t = X of 'a .*) getTupleKind(constructorResult(typeOf, args)) | _ => UnaryGeneric *) UnaryGeneric ) | _ => UnaryGeneric (* This now creates the functions as well as choosing the representation. *) (* N.B. The representation for the "context" and "pretty" datatypes is defined in Pretty.sml. Any changes here that may affect the representation of a datatype may require changes there as well. *) fun chooseConstrRepr(cs, tvs: types list) = let fun checkArgKind (name, EmptyType) = (Nullary, name) | checkArgKind (name, argType) = (getTupleKind argType, name) val kinds = map checkArgKind cs; fun chooseRepr [(Nullary, name)] = [createNullaryConstructor(UnitForm, tvs, name)] | chooseRepr [(UnaryGeneric, name)] = [createUnaryConstructor(OnlyOne, tvs, name)] | chooseRepr [(UnaryFunction, name)] = [createUnaryConstructor(OnlyOne, tvs, name)] | chooseRepr [(UnaryTupled _, name)] = [createUnaryConstructor(OnlyOne, tvs, name)] | chooseRepr l = let val unaryCount = List.foldl(fn((Nullary, _), n) => n | (_,n) => n+1) 0 l in case unaryCount of 0 => (* All are nullary. *) let val maxTag = Word.fromInt(List.length l)-0w1 (* Largest no is length-1 *) fun createRepr(_, []) = [] | createRepr(n, (_, name) :: t) = createNullaryConstructor(EnumForm{tag=n, maxTag=maxTag}, tvs, name) :: createRepr (n + 0w1, t) in createRepr(0w0, l) end | 1 => let (* We use this version if all the constructors are nullary (i.e. constants) except one. The unary constructor is represented by the boxed value and the nullary constructors by untagged integers. *) (* Note that "UnaryTupled 0" (which would arise as a result of a declaration of the form datatype t = A of () | ... ) can't be represented as "UnboxedForm" because "{}" is represented as a short (unboxed) integer. *) fun chooseOptimisedRepr1(_, _, []) = [] | chooseOptimisedRepr1(n, tvs, (Nullary, name) :: t) = createNullaryConstructor(ShortForm n, tvs, name) :: chooseOptimisedRepr1 (n + 0w1, tvs, t) | chooseOptimisedRepr1(n, tvs, (UnaryGeneric, name) :: t) = createUnaryConstructor(BoxedForm, tvs, name) :: chooseOptimisedRepr1(n, tvs, t) | chooseOptimisedRepr1(n, tvs, (UnaryFunction, name) :: t) = createUnaryConstructor(UnboxedForm 0, tvs, name) :: chooseOptimisedRepr1(n, tvs, t) | chooseOptimisedRepr1(n, tvs, (UnaryTupled 0, name) :: t) = createUnaryConstructor(BoxedForm, tvs, name) :: chooseOptimisedRepr1(n, tvs, t) | chooseOptimisedRepr1(n, tvs, (UnaryTupled s, name) :: t) = createUnaryConstructor(UnboxedForm s, tvs, name) :: chooseOptimisedRepr1(n, tvs, t) in chooseOptimisedRepr1(0w0, tvs, l) (* can save the box *) end | _ => let (* We use this version there's more than 1 unary constructor. *) (* With this representation constructors of small tuples make tuples of size n+1 whose first word is the tag. Nullary constructors are represented by single word objects containing the tag. *) val maxTag = Word.fromInt(List.length l) - 0w1 (* Largest no is length - 1 *) fun chooseOptimisedRepr2(_, _, []) = [] | chooseOptimisedRepr2(n, tvs, h :: t) = let val repr = case h of (Nullary, name) => let (* Make an object with the appropriate tag. Doing it here means we only do it once for this object. *) fun genConstForm (n :word) : representations = let val vec : address = allocWordData (0w1, F_words, toMachineWord n) (* The new call does not require locking but the old code still sets the F_mutable bit. *) val _ = if isMutable vec then lock vec else () in ConstForm{value=toMachineWord vec, maxTag=maxTag} end in createNullaryConstructor(genConstForm n, tvs, name) end | (UnaryGeneric, name) => createUnaryConstructor(TaggedBox{tag=n, maxTag=maxTag}, tvs, name) | (UnaryFunction, name) => createUnaryConstructor(TaggedBox{tag=n, maxTag=maxTag}, tvs, name) | (UnaryTupled i, name) => createUnaryConstructor( if i <= 4 (*!maxPacking*) then TaggedTuple {tag=n, size=i, maxTag=maxTag} else TaggedBox{tag=n, maxTag=maxTag}, tvs, name) in repr :: chooseOptimisedRepr2(n + 0w1, tvs, t) end; in chooseOptimisedRepr2(0w0, tvs, l) (* can use tagged tuples *) end end; fun makeFun c = mkInlproc(c, List.length tvs, "boxed/size", [], 0) val (boxed, size) = case tvs of [] => (* Monotype *) (TypeValue.boxedEither, TypeValue.singleWord) | _ => (* Polytype *) (makeFun TypeValue.boxedEither, makeFun TypeValue.singleWord) in { constrs = chooseRepr kinds, boxed = boxed, size = size } end; (* RefForm, NilForm and ConsForm are only used for built-in types *) (*****************************************************************************) (* Standard values and exceptions. *) (*****************************************************************************) (* Build a datatype within the basis. *) fun buildBasisDatatype(tcName, tIdPath, tyVars, isEqType: bool, mkValConstrs: typeConstrs -> (values * codetree) list * codetree * codetree) = let (* Create a temporary datatype. The "name" we put in here is usually the same as the type constructor name except for datatypes in the PolyML structure which have the PolyML prefix. *) val arity = List.length tyVars val description = basisDescription tIdPath val id = makeBoundId(arity, Local{addr = ref ~1, level = ref baseLevel}, 0 (* IdNumber*), isEqType, true, description) val dtype = makeTypeConstructor (tcName, tyVars, id, [DeclaredAt inBasis]); (* Build the constructors. *) val (valConstrsAndDecs, boxedCode, sizeCode) = mkValConstrs dtype (* The constructors have to be ordered as in genValueConstrs in PARSE_TREE. *) fun leq (Value{name=xname, ...}, _) (Value{name=yname, ...}, _) = xname < yname; val sortedConstrs = quickSort leq valConstrsAndDecs; val initialTypeSet = TypeConstrSet(dtype, (List.map #1 valConstrsAndDecs)) val addrs = ref 0 fun mkAddrs n = ! addrs before (addrs := !addrs+n) fun declConstr(Value{access=Local{addr, level}, ...}, repr) = let val newAddr = mkAddrs 1 in addr := newAddr; level := baseLevel; (mkDec(newAddr, repr), mkLoadLocal newAddr) end | declConstr _ = raise InternalError "declConstr: not local" val (declConstrs, loadConstrs) = ListPair.unzip(List.map declConstr sortedConstrs) val defMap = TypeVarMap.defaultTypeVarMap(mkAddrs, baseLevel) (* Create the datatype. Sets the address of the local in "id". *) val dtCode = createDatatypeFunctions( [{typeConstr=initialTypeSet, eqStatus=isEqType, boxedCode=boxedCode, sizeCode=sizeCode}], mkAddrs, baseLevel, defMap, true) (* Compile and execute the code to build the functions and extract the result. *) val globalCode = genCode( mkEnv( declConstrs @ TypeVarMap.getCachedTypeValues defMap @ dtCode, mkTuple(codeId(id, baseLevel) :: loadConstrs)), [], !addrs)() val newId = makeFreeId(arity, Global(mkInd(0, globalCode)), isEqType, description) (* Get the value constructors out as globals. *) fun mkGlobal((Value{name, typeOf, class, locations, ...}, _), (decs, offset)) = (decs @ [Value{name=name, typeOf=typeOf, class=class, locations=locations, references=NONE, instanceTypes=NONE, access=Global(mkInd(offset, globalCode))}], offset+1) val (gConstrs, _) = List.foldl mkGlobal ([], 1 (* Offset 0 is the type ID *)) sortedConstrs (* Finally copy the datatype to put in the code. *) in fullCopyDatatype(TypeConstrSet(dtype, gConstrs), fn 0 => newId | _ => raise Subscript, "") end (* Nil and :: are used in parsetree for lists constructed using [ ... ] and are also used for initialisation. *) local fun makeConsAndNil listType = let val listTypeVars = tcTypeVars listType; val alpha = TypeVar(hd listTypeVars); val alphaList = mkTypeConstruction ("list", listType, [alpha], [DeclaredAt inBasis]); val consType = mkFunctionType (mkProductType [alpha, alphaList], alphaList); val nilConstructor = makeValueConstr ("nil", alphaList, true, 2, Local{addr=ref ~1, level=ref baseLevel}, [DeclaredAt inBasis]) val consConstructor = makeValueConstr ("::", consType, false, 2, Local{addr=ref ~1, level=ref baseLevel}, [DeclaredAt inBasis]) val nilRepresentation = createNullaryConstructor(ShortForm 0w0, [alpha], "nil") val consRepresentation = createUnaryConstructor(UnboxedForm 2, [alpha], "::") in ([(nilConstructor, nilRepresentation), (consConstructor, consRepresentation)], mkInlproc(TypeValue.boxedEither, 1, "boxed-list", [], 0), mkInlproc(TypeValue.singleWord, 1, "size-list", [], 0)) end in val listConstr = buildBasisDatatype("list", "list", [makeTv {value=EmptyType, level=generalisable, nonunifiable=false, equality=false, printable=false}], true, makeConsAndNil) val (nilConstructor, consConstructor) = case listConstr of TypeConstrSet(_, [consC as Value{name="::", ...}, nilC as Value{name="nil", ...}]) => (nilC, consC) | _ => raise InternalError "nil and cons in wrong order" end local fun makeNoneAndSome optionType = let val optionTypeVars = tcTypeVars optionType; val alpha = TypeVar(hd optionTypeVars); val alphaOption = mkTypeConstruction ("option", optionType, [alpha], [DeclaredAt inBasis]); val someType = mkFunctionType (alpha, alphaOption); val noneConstructor = makeValueConstr ("NONE", alphaOption, true, 2, Local{addr=ref ~1, level=ref baseLevel}, [DeclaredAt inBasis]); val someConstructor = makeValueConstr ("SOME", someType, false, 2, Local{addr=ref ~1, level=ref baseLevel}, [DeclaredAt inBasis]); val noneRepresentation = createNullaryConstructor(ShortForm 0w0, [alpha], "NONE") and someRepresentation = createUnaryConstructor(BoxedForm, [alpha], "SOME") in ([(noneConstructor, noneRepresentation), (someConstructor, someRepresentation)], mkInlproc(TypeValue.boxedEither, 1, "boxed-option", [], 0), mkInlproc(TypeValue.singleWord, 1, "size-option", [], 0)) end in val optionConstr= buildBasisDatatype("option", "option", [makeTv {value=EmptyType, level=generalisable, nonunifiable=false, equality=false, printable=false}], true, makeNoneAndSome) val (noneConstructor, someConstructor) = case optionConstr of TypeConstrSet(_, [noneC as Value{name="NONE", ...}, someC as Value{name="SOME", ...}]) => (noneC, someC) | _ => raise InternalError "NONE and SOME in wrong order" end local fun listConstruct (base : types) : types = let val TypeConstrSet(listCons, _) = listConstr in mkTypeConstruction ("list", listCons, [base], [DeclaredAt inBasis]) end; val intTypeConstr = TYPESTRUCT.fixedIntType val stringTypeConstr = TYPESTRUCT.stringType val boolTypeConstr = TYPESTRUCT.boolType in local val fields = [ mkLabelEntry("file", stringTypeConstr), mkLabelEntry("startLine", intTypeConstr), mkLabelEntry("startPosition", intTypeConstr), mkLabelEntry("endLine", intTypeConstr), mkLabelEntry("endPosition", intTypeConstr) ] in val locationCons = makeTypeConstructor("location", [], makeTypeFunction(basisDescription "PolyML.location", ([], mkLabelled(sortLabels fields, true))), [DeclaredAt inBasis]) val locationConstr = TypeConstrSet(locationCons, []) end local (* Pretty print context information. *) fun makeConstructors typeconstr = let val contextType = mkTypeConstruction ("context", typeconstr, [], [DeclaredAt inBasis]) val locationType = mkTypeConstruction ("location", locationCons, [], [DeclaredAt inBasis]) val constrs = [ ("ContextLocation", locationType), ("ContextProperty", mkProductType[stringTypeConstr, stringTypeConstr])]; (* The representation of this datatype is given in Pretty.sml and must be the same as the representation that chooseConstrRepr will use. *) val numConstrs = List.length constrs fun makeCons(s,t) = makeValueConstr(s, mkFunctionType(t, contextType), false, numConstrs, Local{addr=ref ~1, level=ref baseLevel}, [DeclaredAt inBasis]) val {constrs=constrCode, boxed, size} = chooseConstrRepr(constrs, []) in (ListPair.zipEq(List.map makeCons constrs, constrCode), boxed, size) end in val contextConstr = buildBasisDatatype("context", "PolyML.context", [], false, makeConstructors) end local fun makeConstructors typeconstr = let val TypeConstrSet(contextCons, _) = contextConstr val prettyType = mkTypeConstruction ("pretty", typeconstr, [], [DeclaredAt inBasis]) val contextType = mkTypeConstruction ("context", contextCons, [], [DeclaredAt inBasis]) val constrs = [ ("PrettyBlock", mkProductType[intTypeConstr, boolTypeConstr, listConstruct contextType, listConstruct prettyType]), ("PrettyBreak", mkProductType[intTypeConstr, intTypeConstr]), ("PrettyLineBreak", EmptyType), ("PrettyString", stringTypeConstr), ("PrettyStringWithWidth", mkProductType[stringTypeConstr, intTypeConstr])]; (* The representation of this datatype is given in Pretty.sml and must be the same as the representation that chooseConstrRepr will use. *) val numConstrs = List.length constrs fun makeCons(s,t) = let val (ctype, nullary) = case t of EmptyType => (prettyType, true) | t => (mkFunctionType(t, prettyType), false) in makeValueConstr(s, ctype, nullary, numConstrs, Local{addr=ref ~1, level=ref baseLevel}, [DeclaredAt inBasis]) end val {constrs=constrCode, ...} = chooseConstrRepr(constrs, []) in (ListPair.zipEq(List.map makeCons constrs, constrCode), TypeValue.boxedEither, TypeValue.singleWord) end in val prettyConstr = buildBasisDatatype("pretty", "PolyML.pretty", [], false, makeConstructors) end end (* The representation of ptProperties is given in ExportTree.sml and must also match. *) (* Construct an exception identifier - This is a ref (so we can uniquely identify it) containing a print function for the type. *) local (* The exception identifier contains a value of type (exn*int->pretty) option. *) val TypeConstrSet(optionCons, _) = optionConstr and TypeConstrSet(prettyCons, _) = prettyConstr val exnPrinter = mkTypeConstruction ("option", optionCons, [ mkFunctionType( mkProductType[TYPESTRUCT.exnType, TYPESTRUCT.fixedIntType], mkTypeConstruction ("pretty", prettyCons, [], [DeclaredAt inBasis]) ) ], [DeclaredAt inBasis]) in fun mkExIden(ty, level, tvMap) = let (* Get the constructor tuple, select the constructor operation, apply it to the type. *) val makeSome = applyToInstance( [{value=exnPrinter, equality=false, printity=false}], level, tvMap, fn _ => mkInd(1, case someConstructor of Value { access, ...} => vaGlobal access)) val makeNone = applyToInstance( [{value=exnPrinter, equality=false, printity=false}], level, tvMap, fn _ => mkInd(1, case noneConstructor of Value { access, ...} => vaGlobal access)) val printerCode = case ty of FunctionType { arg, ...} => mkEval(makeSome, [printerForType(arg, level, tvMap)]) | _ => makeNone in refApplyCode printerCode end end (* Types that can be shared. *) structure Sharing = struct type codetree = codetree type types = types type values = values type typeConstrSet = typeConstrSet type typeId = typeId type typeVarForm = typeVarForm type typeVarMap = typeVarMap type level = level end end; diff --git a/mlsource/MLCompiler/INITIALISE_.ML b/mlsource/MLCompiler/INITIALISE_.ML index 888c0ada..8c8baa33 100644 --- a/mlsource/MLCompiler/INITIALISE_.ML +++ b/mlsource/MLCompiler/INITIALISE_.ML @@ -1,1976 +1,1976 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited - Updated David C.J. Matthews 2008-9, 2012, 2013, 2015-19 + Updated David C.J. Matthews 2008-9, 2012, 2013, 2015-20 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 "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) + makePolymorphic([a], mkBinaryFn PointerEq), a ** a ->> Bool) (* load a word. The index is in words and is always zero or positive. *) val () = enterRunCall ("loadWord", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLWord{isImmutable=false})), a ** Word ->> b) (* Load a word from an immutable. *) val () = enterRunCall ("loadWordFromImmutable", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLWord{isImmutable=true})), a ** Word ->> b) (* load a byte. The index is in bytes and is always zero or positive. Probably the result should be a Word8.word value or a char. *) val () = enterRunCall ("loadByte", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLByte{isImmutable=false})), a ** Word ->> b) (* Load a byte from an immutable. *) val () = enterRunCall ("loadByteFromImmutable", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLByte{isImmutable=true})), a ** Word ->> b) (* Get the length of a heap cell. *) val () = enterRunCall ("memoryCellLength", makePolymorphic([a], mkUnaryFn MemoryCellLength), a ->> Word) (* Return the flags. Perhaps this could return a Word8.word value instead of a word. *) val () = enterRunCall ("memoryCellFlags", makePolymorphic([a], mkUnaryFn MemoryCellFlags), a ->> Word) (* Return the number of bytes per word. This is a constant since we have separate pre-built compilers for 32-bit and 64-bit. N.B. The byte order is not a constant since we only have a single pre-built compiler for little-endian and big-endian interpreted code. *) val () = enterRunCall ("bytesPerWord", mkConst(toMachineWord wordSize), Word) (* Store a word *) val () = enterRunCall ("storeWord", makePolymorphic([a, b], mkStoreOperationFn(LoadStoreMLWord{isImmutable=false})), mkProductType[a, Word, b] ->> Unit) (* Store a byte *) val () = enterRunCall ("storeByte", makePolymorphic([a, b], mkStoreOperationFn(LoadStoreMLByte{isImmutable=false})), mkProductType[a, Word, b] ->> Unit) (* Lock a mutable cell. *) val () = enterRunCall ("clearMutableBit", makePolymorphic([a], mkUnaryFn ClearMutableFlag), a ->> Unit) (* Allocate a byte cell. The second argument is the flags byte. It might be better if this were a Word8.word value. *) val () = enterRunCall ("allocateByteMemory", makePolymorphic([a], mkBinaryFn AllocateByteMemory), Word ** Word ->> a) (* Allocate a word cell. *) val () = enterRunCall ("allocateWordMemory", makePolymorphic([a, b], mkAllocateWordMemoryFn), mkProductType[Word, Word, a] ->> b) (* Byte vector operations. *) val () = enterRunCall ("byteVectorEqual", makePolymorphic([a], mkBlockOperationFn BlockOpEqualByte), mkProductType[a, a, Word, Word, Word] ->> Bool) val () = enterRunCall ("byteVectorCompare", makePolymorphic([a], mkBlockOperationFn BlockOpCompareByte), mkProductType[a, a, Word, Word, Word] ->> Int) (* Block moves. *) val () = enterRunCall ("moveBytes", makePolymorphic([a], mkBlockOperationFn (BlockOpMove{isByteMove=true})), mkProductType[a, a, Word, Word, Word] ->> Unit) val () = enterRunCall ("moveWords", makePolymorphic([a], mkBlockOperationFn (BlockOpMove{isByteMove=false})), mkProductType[a, a, Word, Word, Word] ->> Unit) (* Untagged loads and stores. *) val () = enterRunCall ("loadUntagged", mkLoadOperationFn LoadStoreUntaggedUnsigned, String ** Word ->> Word) val () = enterRunCall ("storeUntagged", mkStoreOperationFn LoadStoreUntaggedUnsigned, mkProductType[String, Word, Word] ->> Unit) val () = enterRunCall ("touch", makePolymorphic([a], mkUnaryFn TouchAddress), a ->> Unit) end local val debugOpts = [] (* Place to add debugging if necessary. *) (* [tagInject Pretty.compilerOutputTag (Pretty.prettyPrint(print, 70)), tagInject assemblyCodeTag true] *) fun makeCall rtsCall n entryName = rtsCall (entryName, n, debugOpts) val makeFastCall = makeCall CODETREE.Foreign.rtsCallFast (* We need to wrap this so that the arguments are passed in registers. *) fun makeRunCallTupled (argTypes, resultType, callN) : codetree = let val width = List.length argTypes val name = "rtsCall" ^ Int.toString width; local val f = mkLoadClosure 0 (* first item from enclosing scope *) val tuple = mkLoadArgument 0 (* the inner parameter *) val args = case argTypes of [singleType] => [(tuple, singleType)] | argTypes => let val argVals = List.tabulate(width, fn n => mkInd (n, tuple)) in ListPair.zipEq(argVals, argTypes) end in val innerBody = mkCall (f, args, resultType) end local (* The closure contains the address of the RTS call. *) val f = mkEval(mkConst callN, [mkLoadArgument 0]) val innerLambda = mkInlproc (innerBody, 1, name ^ "(1)", [mkLoadLocal 0], 0) in val outerBody = mkEnv([mkDec (0, f)], innerLambda) end val outerLambda = mkInlproc (outerBody, 1, name, [], 1) in outerLambda end (* "Full" calls pass the thread Id as the first parameter. *) fun makeRunCallTupledFull (argTypes, resultType) = let val width = List.length argTypes val callN = toMachineWord(makeFastCall(width + 1)) val name = "rtsCall" ^ Int.toString width; local val f = mkLoadClosure 0 (* first item from enclosing scope *) val tuple = mkLoadArgument 0 (* the inner parameter *) val args = case argTypes of [singleType] => [(tuple, singleType)] | argTypes => let val argVals = List.tabulate(width, fn n => mkInd (n, tuple)) in ListPair.zipEq(argVals, argTypes) end in val innerBody = mkEnv( [ mkDec(0, mkCall (f, (getCurrentThreadId, GeneralType) :: args, resultType)), mkNullDec checkRTSException ], mkLoadLocal 0) end local (* The closure contains the address of the RTS call. *) val f = mkEval(mkConst callN, [mkLoadArgument 0]) (* This creates the actual call. *) val innerLambda = mkInlproc (innerBody, 1, name ^ "(1)", [mkLoadLocal 0], 1) in val outerBody = mkEnv([mkDec (0, f)], innerLambda) end val outerLambda = mkInlproc (outerBody, 1, name, [], 1) in outerLambda end local val a = makeTV () and b = makeTV () fun makeInlCode(makeCall, name) = let val call1 = toMachineWord(makeCall 1) val body = mkEval(mkConst call1, [mkLoadArgument 0]) val proc = mkInlproc (body, 1, name, [], 0) in makePolymorphic([a, b], proc) end in val rtsCallFast1Entry = makeInlCode(makeFastCall, "rtsCallFast1") end local val a = makeTV () and b = makeTV () and c = makeTV () and d = makeTV () and e = makeTV () and f = makeTV () fun makeRtsCall(n, makeCall) = makeRunCallTupled(List.tabulate(n, fn _ => GeneralType), GeneralType, toMachineWord(makeCall n)) fun makeFullRtsCall n = makeRunCallTupledFull(List.tabulate(n, fn _ => GeneralType), GeneralType) in val rtsCallFull0Entry = makePolymorphic([a], makeFullRtsCall 0) and rtsCallFast0Entry = makePolymorphic([a], makeRtsCall(0, makeFastCall)) val rtsCall0Type = String ->> Unit ->> a val rtsCall1Type = String ->> a ->> b val rtsCallFull1Entry = makePolymorphic([a, b], makeFullRtsCall 1) val rtsCallFull2Entry = makePolymorphic([a, b, c], makeFullRtsCall 2) and rtsCallFast2Entry = makePolymorphic([a, b, c], makeRtsCall(2, makeFastCall)) val rtsCall2Type = String ->> TYPETREE.mkProductType [a,b] ->> c val rtsCallFull3Entry = makePolymorphic([a, b, c, d], makeFullRtsCall 3) val rtsCallFast3Entry = makePolymorphic([a, b, c, d], makeRtsCall(3, makeFastCall)) val rtsCall3Type = String ->> TYPETREE.mkProductType [a,b,c] ->> d val rtsCallFull4Entry = makePolymorphic([a, b, c, d, e], makeFullRtsCall 4) val rtsCallFast4Entry = makePolymorphic([a, b, c, d, e], makeRtsCall(4, makeFastCall)) val rtsCall4Type = String ->> TYPETREE.mkProductType [a,b,c,d] ->> e val rtsCallFull5Entry = makePolymorphic([a, b, c, d, e, f], makeFullRtsCall 5) val rtsCall5Type = String ->> TYPETREE.mkProductType [a,b,c,d,e] ->> f end in val () = enterRunCall ("rtsCallFull0", rtsCallFull0Entry, rtsCall0Type) val () = enterRunCall ("rtsCallFast0", rtsCallFast0Entry, rtsCall0Type) val () = enterRunCall ("rtsCallFull1", rtsCallFull1Entry, rtsCall1Type) val () = enterRunCall ("rtsCallFast1", rtsCallFast1Entry, rtsCall1Type) val () = enterRunCall ("rtsCallFull2", rtsCallFull2Entry, rtsCall2Type) val () = enterRunCall ("rtsCallFast2", rtsCallFast2Entry, rtsCall2Type) val () = enterRunCall ("rtsCallFull3", rtsCallFull3Entry, rtsCall3Type) val () = enterRunCall ("rtsCallFast3", rtsCallFast3Entry, rtsCall3Type) val () = enterRunCall ("rtsCallFast4", rtsCallFast4Entry, rtsCall4Type) val () = enterRunCall ("rtsCallFull4", rtsCallFull4Entry, rtsCall4Type) val () = enterRunCall ("rtsCallFull5", rtsCallFull5Entry, rtsCall5Type) val makeRunCallTupled = makeRunCallTupled (* Needed for reals. *) end local (* Create nullary exception. *) fun makeException0(name, id) = let val exc = Value{ name = name, typeOf = TYPETREE.exnType, access = Global(mkConst(toMachineWord id)), class = Exception, locations = declInBasis, references = NONE, instanceTypes=NONE } in #enterVal runCallEnv (name, exc) end (* Create exception with parameter. *) and makeException1(name, id, exType) = let val exc = Value{ name = name, typeOf = exType ->> TYPETREE.exnType, access = Global(mkConst(toMachineWord id)), class = Exception, locations = declInBasis, references = NONE, instanceTypes=NONE } in #enterVal runCallEnv (name, exc) end (* Exception numbers. Most of these are hard-coded in the RTS. *) val EXC_interrupt = 1 val EXC_syserr = 2 val EXC_size = 4 val EXC_overflow = 5 val EXC_divide = 7 val EXC_conversion = 8 val EXC_XWindows = 10 val EXC_subscript = 11 val EXC_thread = 12 val EXC_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 (* 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, + eqCode=equalPointerOrWordFn, 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), + mkEqualTaggedWord(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), + mkEqualTaggedWord(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), + mkEqualTaggedWord(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/MLCompiler/TYPEIDCODE.sml b/mlsource/MLCompiler/TYPEIDCODE.sml index 4193fdad..c8f51ed2 100644 --- a/mlsource/MLCompiler/TYPEIDCODE.sml +++ b/mlsource/MLCompiler/TYPEIDCODE.sml @@ -1,1374 +1,1375 @@ (* - Copyright (c) 2009, 2013, 2015-16 David C. J. Matthews + Copyright (c) 2009, 2013, 2015-16, 2020 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 TYPEIDCODE ( structure LEX : LEXSIG; structure CODETREE : CODETREESIG structure TYPETREE : TYPETREESIG structure STRUCTVALS : STRUCTVALSIG structure DEBUG: DEBUGSIG structure PRETTY : PRETTYSIG structure ADDRESS : AddressSig sharing LEX.Sharing = STRUCTVALS.Sharing = PRETTY.Sharing = CODETREE.Sharing = TYPETREE.Sharing = ADDRESS ) : TYPEIDCODESIG = struct open CODETREE PRETTY ADDRESS STRUCTVALS TYPETREE (* This module deals with handling the run-time values that carry type information. At the moment that's just the equality and print operations but that will be extended. There are different versions according to whether this is a monomorphic constructor, a polymorphic constructor or a type. Monomorphic and polymorphic constructor values are passed around in the module system as run-time values for types and datatypes whereas type values are passed in the core language as an extra argument to polymorphic functions. Both monomorphic and polymorphic constructors contain a reference for the "printer" entry so that a pretty printer can be installed. The functions in polymorphic datatypes have to be applied to type values for the base types to construct a type value. Monomorphic datatypes just need some transformation. The effective types in each case are PolyType : (T('a) -> <'a t, 'a t> -> bool) * (T('a) -> 'a t * int -> pretty) ref MonoType : ( -> bool) * (t * int -> pretty) ref Type: ( -> bool) * (t * int -> pretty) where < > denotes multiple (poly-style) arguments rather than tuples. *) (* If this is true we are just using additional arguments for equality type variables. If false we are using them for all type variables and every polymorphic function is wrapped in a function that passes the type information. *) val justForEqualityTypes = true val arg1 = mkLoadArgument 0 (* Used frequently. *) val arg2 = mkLoadArgument 1 val InternalError = Misc.InternalError val orb = Word8.orb infix 7 orb; val mutableFlags = F_words orb F_mutable (* codeAccess is copied from ValueOps. *) fun codeAccess (Global code, _) = code | codeAccess (Local{addr=ref locAddr, level=ref locLevel}, level) = mkLoad (locAddr, level, locLevel) | codeAccess (Selected{addr, base}, level) = mkInd (addr, codeAccess (base, level)) | codeAccess _ = raise InternalError "No access" (* Load an identifier. *) fun codeId(TypeId{access, ...}, level) = codeAccess(access, level) (* Pretty printer code. These produce code to apply the pretty printer functions. *) fun codePrettyString(s: string) = mkDatatype[mkConst(toMachineWord tagPrettyString), mkConst(toMachineWord s)] and codePrettyBreak(n, m) = mkDatatype[mkConst(toMachineWord tagPrettyBreak), mkConst(toMachineWord n), mkConst(toMachineWord m)] and codePrettyBlock(n: int, t: bool, c: context list, args: codetree) = mkDatatype[mkConst(toMachineWord tagPrettyBlock), mkConst(toMachineWord n), mkConst(toMachineWord t), mkConst(toMachineWord c), args] (* Turn a list of codetrees into a run-time list. *) and codeList(c: codetree list, tail: codetree): codetree = List.foldr (fn (hd, tl) => mkTuple[hd, tl]) tail c (* Generate code to check that the depth is not less than the allowedDepth and if it is to print "..." rather than the given code. *) and checkDepth(depthCode: codetree, allowedDepth: int, codeOk, codeFail) = mkIf(mkBinary(BuiltIns.WordComparison{test=BuiltIns.TestLess, isSigned=true}, depthCode, mkConst(toMachineWord allowedDepth)), codeFail, codeOk) (* Subtract one from the current depth to produce the depth for sub-elements. *) and decDepth depthCode = mkBinary(BuiltIns.FixedPrecisionArith BuiltIns.ArithSub, depthCode, mkConst(toMachineWord 1)) val codePrintDefault = mkProc(codePrettyString "?", 1, "print-default", [], 0) structure TypeVarMap = struct (* Entries are either type var maps or "stoppers". *) datatype typeVarMapEntry = TypeVarFormEntry of (typeVarForm * (level->codetree)) list | TypeConstrListEntry of typeConstrs list type typeVarMap = { entryType: typeVarMapEntry, (* Either the type var map or a "stopper". *) cache: (* Cache of new type values. *) {typeOf: types, address: int, decCode: codeBinding} list ref, mkAddr: int->int, (* Make new addresses at this level. *) level: level (* Function nesting level. *) } list (* Default map. *) fun defaultTypeVarMap (mkAddr, level) = [{entryType=TypeConstrListEntry[], cache=ref [], mkAddr=mkAddr, level=level}] fun markTypeConstructors(typConstrs, mkAddr, level, tvs) = {entryType = TypeConstrListEntry typConstrs, cache = ref [], mkAddr=mkAddr, level=level} :: tvs fun getCachedTypeValues(({cache=ref cached, ...}) ::_): codeBinding list = (* Extract the values from the list. The later values may refer to earlier so the list must be reversed. *) List.rev (List.map (fn{decCode, ...} => decCode) cached) | getCachedTypeValues _ = raise Misc.InternalError "getCachedTypeValues" (* Extend a type variable environment with a new map of type variables to load functions. *) fun extendTypeVarMap (tvMap: (typeVarForm * (level->codetree)) list, mkAddr, level, typeVarMap) = {entryType = TypeVarFormEntry tvMap, cache = ref [], mkAddr=mkAddr, level=level} :: typeVarMap (* If we find the type var in the map return it as a type. This is used to eliminate apparently generalisable type vars from the list. *) fun mapTypeVars [] _ = NONE | mapTypeVars ({entryType=TypeVarFormEntry typeVarMap, ...} :: rest) tyVar = ( case List.find(fn(t, _) => sameTv(t, tyVar)) typeVarMap of SOME (tv, _) => SOME(TypeVar tv) | NONE => mapTypeVars rest tyVar ) | mapTypeVars (_ :: rest) tyVar = mapTypeVars rest tyVar (* Check to see if a type constructor is in the "stopper" set and return the level if it is. *) fun checkTypeConstructor(_, []) = ~1 (* Not there. *) | checkTypeConstructor(tyCons, {entryType=TypeVarFormEntry _, ...} :: rest) = checkTypeConstructor(tyCons, rest: typeVarMap) | checkTypeConstructor(tyCons, {entryType=TypeConstrListEntry tConstrs, ...} :: rest) = if List.exists(fn t => sameTypeId(tcIdentifier t, tcIdentifier tyCons)) tConstrs then List.length rest + 1 else checkTypeConstructor(tyCons, rest) local open TypeValue (* The printer and equality functions must be valid functions even when they will never be called. We may have to construct dummy type values by applying a polymorphic type constructor to them and if they don't have the right form the optimiser will complain. If we're only using type values for equality type variables the default print function will be used in polymorphic functions so must print "?". *) val errorFunction2 = mkProc(CodeZero, 2, "errorCode2", [], 0) val codeFn = mkProc(codePrettyString "fn", 1, "print-function", [], 0) local fun typeValForMonotype typConstr = let val codedId = codeId(tcIdentifier typConstr, baseLevel) val printerRefAddress = extractPrinter codedId val printFn = (* Create a function to load the printer ref and apply to the args. *) mkProc( mkEval( mkLoadOperation(LoadStoreMLWord{isImmutable=false}, printerRefAddress, CodeZero), [arg1]), 1, "print-" ^ tcName typConstr, [], 0) in createTypeValue{ eqCode=extractEquality codedId, printCode=printFn, boxedCode=extractBoxed codedId, sizeCode=extractSize codedId} end in (* A few common types. These are effectively always cached. *) val fixedIntCode = typeValForMonotype fixedIntConstr and intInfCode = typeValForMonotype intInfConstr and boolCode = typeValForMonotype boolConstr and stringCode = typeValForMonotype stringConstr and charCode = typeValForMonotype charConstr end (* Code generate this now so we only get one entry. *) val codeTuple = mkTuple[ createTypeValue{ (* Unused type variable. *) eqCode=errorFunction2, printCode=codePrintDefault, boxedCode=boxedEither, sizeCode=singleWord}, createTypeValue{ (* Function. *) eqCode=errorFunction2, printCode=codeFn, boxedCode=boxedAlways, sizeCode=singleWord}, fixedIntCode, intInfCode, boolCode, stringCode, charCode ] val code = genCode(codeTuple, [], 0)() in (* Default code used for a type variable that is not referenced but needs to be provided to satisfy the type. *) val defaultTypeCode = mkInd(0, code) val functionCode = mkInd(1, code) val cachedCode = [(fixedIntConstr, mkInd(2, code)), (intInfConstr, mkInd(3, code)), (boolConstr, mkInd(4, code)), (stringConstr, mkInd(5, code)), (charConstr, mkInd(6, code))] end fun findCachedTypeCode(typeVarMap: typeVarMap, typ): ((level->codetree) * int) option = let (* Test if we have the same type as the cached type. *) fun sameType (t1, t2) = case (eventual t1, eventual t2) of (TypeVar tv1, TypeVar tv2) => ( case (tvValue tv1, tvValue tv2) of (EmptyType, EmptyType) => sameTv(tv1, tv2) | _ => false ) | (FunctionType{arg=arg1, result=result1}, FunctionType{arg=arg2, result=result2}) => sameType(arg1, arg2) andalso sameType(result1, result2) | (LabelledType{recList=list1, ...}, LabelledType{recList=list2, ...}) => ListPair.allEq( fn({name=n1, typeof=t1}, {name=n2, typeof=t2}) => n1 = n2 andalso sameType(t1, t2)) (list1, list2) | (TypeConstruction{constr=c1, args=a1, ...}, TypeConstruction{constr=c2, args=a2, ...}) => sameTypeConstr(c1, c2) andalso ListPair.allEq sameType (a1, a2) | _ => false and sameTypeConstr(tc1, tc2) = sameTypeId(tcIdentifier tc1, tcIdentifier tc2) fun findCodeFromCache([], _) = NONE | findCodeFromCache(({cache=ref cache, level, ...} :: rest): typeVarMap, ty) = ( case List.find(fn {typeOf, ...} => sameType(typeOf, ty)) cache of NONE => findCodeFromCache(rest, ty) | SOME{address, ...} => SOME(fn l => mkLoad(address, l, level), List.length rest +1) ) in case typ of TypeVar tyVar => ( case tvValue tyVar of EmptyType => let (* If it's a type var it is either in the type var list or we return the default. It isn't in the cache. *) fun findCodeFromTypeVar([], _) = ((fn _ => defaultTypeCode), 0) (* Return default code for a missing type variable. This can occur if we have unreferenced type variables that need to be supplied but are treated as "don't care". *) | findCodeFromTypeVar({entryType=TypeVarFormEntry typeVarMap, ...} :: rest, tyVar) = ( case List.find(fn(t, _) => sameTv(t, tyVar)) typeVarMap of SOME(_, codeFn) => (codeFn, List.length rest+1) | NONE => findCodeFromTypeVar(rest, tyVar) ) | findCodeFromTypeVar(_ :: rest, tyVar) = findCodeFromTypeVar(rest, tyVar) in SOME(findCodeFromTypeVar(typeVarMap, tyVar)) end | OverloadSet _ => let val constr = typeConstrFromOverload(typ, false) in findCachedTypeCode(typeVarMap, mkTypeConstruction(tcName constr, constr, [], [])) end | ty => findCachedTypeCode(typeVarMap, ty) ) | TypeConstruction { constr, args, ...} => let fun sameTypeConstr(tc1, tc2) = sameTypeId(tcIdentifier tc1, tcIdentifier tc2) in if tcIsAbbreviation constr (* Type abbreviation *) then findCachedTypeCode(typeVarMap, makeEquivalent (constr, args)) else if null args then (* Check the permanently cached monotypes. *) case List.find(fn (t, _) => sameTypeConstr(t, constr)) cachedCode of SOME (_, c) => SOME ((fn _ => c), ~1) | NONE => findCodeFromCache(typeVarMap, typ) else findCodeFromCache(typeVarMap, typ) end | FunctionType _ => SOME(fn _ => functionCode, ~1) (* Every function has the same code. *) | _ => findCodeFromCache(typeVarMap, typ) end end open TypeVarMap (* Find the earliest entry in the cache table where we can put this entry. *) fun getMaxDepth (typeVarMap: typeVarMap) (ty: types, maxSoFar:int) : int = case findCachedTypeCode(typeVarMap, ty) of SOME (_, cacheDepth) => Int.max(cacheDepth, maxSoFar) | NONE => let in case ty of TypeVar tyVar => ( case tvValue tyVar of OverloadSet _ => maxSoFar (* Overloads are all global. *) | EmptyType => maxSoFar | tyVal => getMaxDepth typeVarMap (tyVal, maxSoFar) ) | TypeConstruction{constr, args, ...} => if tcIsAbbreviation constr (* May be an alias *) then getMaxDepth typeVarMap (makeEquivalent (constr, args), maxSoFar) else List.foldl (getMaxDepth typeVarMap) (Int.max(maxSoFar, checkTypeConstructor(constr, typeVarMap))) args | LabelledType {recList, ...} => List.foldl (fn ({typeof, ...}, m) => getMaxDepth typeVarMap (typeof, m)) maxSoFar recList | _ => maxSoFar end (* Get the boxedness status for a type i.e. whether values of the type are always addresses, always tagged integers or could be either. *) fun boxednessForType(ty, level: level, getTypeValueForID, typeVarMap): codetree = case findCachedTypeCode(typeVarMap, ty) of SOME (code, _) => TypeValue.extractBoxed(code level) | NONE => let fun boxednessForConstruction(constr, args): codetree = (* Get the boxedness for a datatype construction. *) let (* Get the boxedness functions for the argument types. This applies only to polytypes. *) fun getArg ty : codetree = let val boxedFun = boxednessForType(ty, level, getTypeValueForID, typeVarMap) open TypeValue in (* We need a type value here although only the boxedFun will be used. *) createTypeValue{eqCode=CodeZero, printCode=CodeZero, boxedCode=boxedFun, sizeCode=singleWord} end val codeForId = TypeValue.extractBoxed(getTypeValueForID(tcIdentifier constr, args, level)) in (* Apply the function we obtained to any type arguments. *) if null args then codeForId else mkEval(codeForId, map getArg args) end in case ty of TypeVar tyVar => ( case tvValue tyVar of OverloadSet _ => boxednessForConstruction(typeConstrFromOverload(ty, false), []) | EmptyType => raise InternalError "boxedness: should already have been handled" | tyVal => boxednessForType(tyVal, level, getTypeValueForID, typeVarMap) ) | TypeConstruction{constr, args, ...} => if tcIsAbbreviation constr (* May be an alias *) then boxednessForType (makeEquivalent (constr, args), level, getTypeValueForID, typeVarMap) else boxednessForConstruction(constr, args) | LabelledType {recList=[{typeof=singleton, ...}], ...} => (* Unary tuples are optimised - no indirection. *) boxednessForType(singleton, level, getTypeValueForID, typeVarMap) | LabelledType _ => TypeValue.boxedAlways (* Tuple are currently always boxed. *) (* Functions are handled in the cache case. *) | _ => raise InternalError "boxednessForType: Unknown type" end (* Get the size for values of the type. A value N other than 1 means that every value of the type is a pointer to a tuple of exactly N words. Zero is never used. *) fun sizeForType(ty, level, getTypeValueForID, typeVarMap): codetree = case findCachedTypeCode(typeVarMap, ty) of SOME (code, _) => TypeValue.extractSize(code level) | NONE => let fun sizeForConstruction(constr, args): codetree = (* Get the size for a datatype construction. *) let (* Get the size functions for the argument types. This applies only to polytypes. *) fun getArg ty : codetree = let val sizeFun = sizeForType(ty, level, getTypeValueForID, typeVarMap) open TypeValue in (* We need a type value here although only the sizeFun will be used. *) createTypeValue{eqCode=CodeZero, printCode=CodeZero, boxedCode=CodeZero, sizeCode=sizeFun} end val codeForId = TypeValue.extractSize(getTypeValueForID(tcIdentifier constr, args, level)) in (* Apply the function we obtained to any type arguments. *) if null args then codeForId else mkEval(codeForId, map getArg args) end in case ty of TypeVar tyVar => ( case tvValue tyVar of OverloadSet _ => sizeForConstruction(typeConstrFromOverload(ty, false), []) | EmptyType => raise InternalError "size: should already have been handled" | tyVal => sizeForType(tyVal, level, getTypeValueForID, typeVarMap) ) | TypeConstruction{constr, args, ...} => if tcIsAbbreviation constr (* May be an alias *) then sizeForType (makeEquivalent (constr, args), level, getTypeValueForID, typeVarMap) else sizeForConstruction(constr, args) | LabelledType {recList=[{typeof=singleton, ...}], ...} => (* Unary tuples are optimised - no indirection. *) sizeForType(singleton, level, getTypeValueForID, typeVarMap) | LabelledType{recList, ...} => let val length = List.length recList in (* Set the length to the number of words that can be unpacked. If there are more than 4 items it's probably not worth packing them into other tuples so set this to one. *) if length <= 4 (*!maxPacking*) then mkConst(toMachineWord length) else TypeValue.singleWord end (* Functions are handled in the cache case. *) | _ => raise InternalError "sizeForType: Unknown type" end fun printerForType(ty, baseLevel, argTypes: typeVarMap) = let fun printCode(typ, level: level) = ( case typ of typ as TypeVar tyVar => ( case tvValue tyVar of EmptyType => ( case findCachedTypeCode(argTypes, typ) of SOME (code, _) => TypeValue.extractPrinter(code level) | NONE => raise InternalError "printerForType: should already have been handled" ) | OverloadSet _ => let val constr = typeConstrFromOverload(typ, false) in printCode(mkTypeConstruction(tcName constr, constr, [], []), level) end | _ => (* Just a bound type variable. *) printCode(tvValue tyVar, level) ) | TypeConstruction { constr=typConstr, args, name, ...} => if tcIsAbbreviation typConstr (* Handle type abbreviations directly *) then printCode(makeEquivalent (typConstr, args), level) else let val nLevel = newLevel level (* Get the type Id and put in code to extract the printer ref. *) val codedId = codeId(tcIdentifier typConstr, nLevel) open TypeValue val printerRefAddress = extractPrinter codedId (* We need a type value here. The printer field will be used to print the type argument and the boxedness and size fields may be needed to extract the argument from the constructed value. *) fun makePrinterId t = let fun codeForId(typeId, _, l) = codeId(typeId, l) in createTypeValue {eqCode=CodeZero, printCode=printCode(t, nLevel), boxedCode=boxednessForType(t, nLevel, codeForId, argTypes), sizeCode=sizeForType(t, nLevel, codeForId, argTypes)} end val argList = map makePrinterId args in case args of [] => (* Create a function that, when called, will extract the function from the reference and apply it the pair of the value and the depth. *) mkProc( mkEval( mkLoadOperation(LoadStoreMLWord{isImmutable=false}, printerRefAddress, CodeZero), [arg1]), 1, "print-"^name, getClosure nLevel, 0) | _ => (* Construct a function, that when called, will extract the function from the reference and apply it first to the base printer functions and then to the pair of the value and depth. *) mkProc( mkEval( mkEval( mkLoadOperation(LoadStoreMLWord{isImmutable=false}, printerRefAddress, CodeZero), argList), [arg1]), 1, "print-"^name, getClosure nLevel, 0) end | LabelledType { recList=[], ...} => (* Empty tuple: This is the unit value. *) mkProc(codePrettyString "()", 1, "print-labelled", [], 0) | LabelledType {recList=[{name, typeof}], ...} => let (* Optimised unary record *) val localLevel = newLevel level val entryCode = mkEval(printCode(typeof, localLevel), [arg1]) val printItem = codeList([codePrettyString(name^" ="), codePrettyBreak(1, 0), entryCode, codePrettyString "}"], CodeZero) in mkProc( codePrettyBlock(1, false, [], mkTuple[codePrettyString "{", printItem]), 1, "print-labelled", getClosure localLevel, 0) end | LabelledType (r as { recList, ...}) => let (* See if this has fields numbered 1=, 2= etc. N.B. If it has only one field we need to print 1= since we don't have singleton tuples. *) fun isRec([], _) = true | isRec({name, ...} :: l, n) = name = Int.toString n andalso isRec(l, n+1) val isTuple = recordIsFrozen r andalso isRec(recList, 1) andalso List.length recList >= 2 val localLevel = newLevel level val valToPrint = mkInd(0, arg1) and depthCode = mkInd(1, arg1) val fields = List.tabulate(List.length recList, fn n => n) val items = ListPair.zipEq(recList, fields) (* The ordering on fields is designed to allow mixing of tuples and records (e.g. #1). It puts shorter names before longer so that #11 comes after #2 and before #100. For named records it does not make for easy reading so we sort those alphabetically when printing. *) val printItems = if isTuple then items else Misc.quickSort(fn ({name = a, ...}, _) => fn ({name = b, ...}, _) => a <= b) items fun asRecord([], _) = raise Empty (* Shouldn't happen. *) | asRecord([({name, typeof, ...}, offset)], _) = let val entryCode = (* Last field: no separator. *) mkEval(printCode(typeof, localLevel), [mkTuple[mkInd(offset, valToPrint), decDepth depthCode]]) val (start, terminator) = if isTuple then ([], ")") else ([codePrettyString(name^" ="), codePrettyBreak(1, 0)], "}") in codeList(start @ [entryCode, codePrettyString terminator], CodeZero) end | asRecord(({name, typeof, ...}, offset) :: fields, depth) = let val (start, terminator) = if isTuple then ([], ")") else ([codePrettyString(name^" ="), codePrettyBreak(1, 0)], "}") in checkDepth(depthCode, depth, codeList( start @ [ mkEval( printCode(typeof, localLevel), [mkTuple[mkInd(offset, valToPrint), decDepth depthCode]]), codePrettyString ",", codePrettyBreak (1, 0) ], asRecord(fields, depth+1)), codeList([codePrettyString ("..." ^ terminator)], CodeZero) ) end in mkProc( codePrettyBlock(1, false, [], mkTuple[codePrettyString (if isTuple then "(" else "{"), asRecord(printItems, 0)]), 1, "print-labelled", getClosure localLevel, 0) end | FunctionType _ => mkProc(codePrettyString "fn", 1, "print-function", [], 0) | _ => mkProc(codePrettyString "", 1, "print-empty", [], 0) ) in printCode(ty, baseLevel) end and makeEq(ty, level: level, getTypeValueForID, typeVarMap): codetree = let fun equalityForConstruction(constr, args): codetree = (* Generate an equality function for a datatype construction. *) let (* Get argument types parameters for polytypes. There's a special case here for type vars, essentially the type arguments to the datatype, to avoid taking apart the type value record and then building it again. *) fun getArg ty = if (case ty of TypeVar tyVar => (case tvValue tyVar of EmptyType => true | _ => false) | _ => false) then ( case findCachedTypeCode(typeVarMap, ty) of SOME (code, _) => code level | NONE => raise InternalError "getArg" ) else let val eqFun = makeEq(ty, level, getTypeValueForID, typeVarMap) open TypeValue in (* We need a type value here. The equality function will be used to compare the argument type and the boxedness and size parameters may be needed for the constructors. *) createTypeValue{eqCode=eqFun, printCode=CodeZero, boxedCode=boxednessForType(ty, level, getTypeValueForID, typeVarMap), sizeCode=sizeForType(ty, level, getTypeValueForID, typeVarMap)} end val resFun = let val iden = tcIdentifier constr in (* Special case: If this is ref, Array.array or Array2.array we must use pointer equality and not attempt to create equality functions for the argument. It may not be an equality type. *) if isPointerEqType iden - then equalWordFn + then equalPointerOrWordFn else let open TypeValue val codeForId = extractEquality(getTypeValueForID(tcIdentifier constr, args, level)) in (* Apply the function we obtained to any type arguments. *) if null args then codeForId else mkEval(codeForId, map getArg args) end end in resFun end in case ty of TypeVar tyVar => ( case tvValue tyVar of OverloadSet _ => (* This seems to occur if there are what amount to indirect references to literals. *) equalityForConstruction(typeConstrFromOverload(ty, false), []) | EmptyType => ( case findCachedTypeCode(typeVarMap, ty) of SOME (code, _) => TypeValue.extractEquality(code level) | NONE => raise InternalError "makeEq: should already have been handled" ) | tyVal => makeEq(tyVal, level, getTypeValueForID, typeVarMap) ) | TypeConstruction{constr, args, ...} => if tcIsAbbreviation constr (* May be an alias *) then makeEq (makeEquivalent (constr, args), level, getTypeValueForID, typeVarMap) else equalityForConstruction(constr, args) | LabelledType {recList=[{typeof=singleton, ...}], ...} => (* Unary tuples are optimised - no indirection. *) makeEq(singleton, level, getTypeValueForID, typeVarMap) | LabelledType {recList, ...} => (* Combine the entries. fun eq(a,b) = #1 a = #1 b andalso #2 a = #2 b ... *) let (* Have to turn this into a new function. *) val nLevel = newLevel level fun combineEntries ([], _) = CodeTrue | combineEntries ({typeof, ...} :: t, n) = let val compareElements = makeEq(typeof, nLevel, getTypeValueForID, typeVarMap) in mkCand( mkEval(compareElements, [mkInd(n, arg1), mkInd(n, arg2)]), combineEntries (t, n+1)) end val tupleCode = combineEntries(recList, 0) in mkProc(tupleCode, 2, "eq{...}(2)", getClosure nLevel, 0) end | _ => raise InternalError "Equality for function" end (* Create equality functions for a set of possibly mutually recursive datatypes. *) fun equalityForDatatypes(typeDataList, eqAddresses, baseEqLevel, typeVarMap): (int * codetree) list = let val typesAndAddresses = ListPair.zipEq(typeDataList, eqAddresses) fun equalityForDatatype(({typeConstr=TypeConstrSet(tyConstr, vConstrs), eqStatus, (*boxedCode, sizeCode,*) ...}, addr), otherFns) = if eqStatus then let val nTypeVars = tcArity tyConstr val argTypes = List.tabulate(tcArity tyConstr, fn _ => makeTv{value=EmptyType, level=generalisable, nonunifiable=false, equality=false, printable=false}) val baseEqLevelP1 = newLevel baseEqLevel (* Argument type variables. *) val (localArgList, argTypeMap) = case argTypes of [] => ([], typeVarMap) | _ => let (* Add the polymorphic variables after the ordinary ones. *) (* Create functions to load these if they are used in the map. They may be non-local!!! *) val args = List.tabulate(nTypeVars, fn addr => fn l => mkLoadParam(addr+2, l, baseEqLevelP1)) (* Put the outer args in the map *) val varToArgMap = ListPair.zipEq(argTypes, args) (* Load the local args to return. *) val localArgList = List.tabulate (nTypeVars, fn addr => mkLoadParam(addr+2, baseEqLevelP1, baseEqLevelP1)) val addrs = ref 0 (* Make local declarations for any type values. *) fun mkAddr n = !addrs before (addrs := !addrs + n) in (localArgList, extendTypeVarMap(varToArgMap, mkAddr, baseEqLevelP1, typeVarMap)) end (* If this is a reference to a datatype we're currently generating load that address otherwise fall back to the default. *) fun getEqFnForID(typeId, _, l) = (* if sameTypeId(typeId, tcIdentifier tyConstr) andalso null argTypes then (* Directly recursive. *) TypeValue.createTypeValue{eqCode=mkLoadRecursive(l-baseLevel-1), printCode=CodeZero, boxedCode=boxedCode, sizeCode=sizeCode} else *) case List.find(fn({typeConstr=tc, ...}, _) => sameTypeId(tcIdentifier(tsConstr tc), typeId)) typesAndAddresses of SOME({boxedCode, sizeCode, ...}, addr) => (* Mutually recursive. *) TypeValue.createTypeValue{eqCode=mkLoad(addr, l, baseEqLevel), printCode=CodeZero, boxedCode=boxedCode, sizeCode=sizeCode} | NONE => codeId(typeId, l) (* Filter out the ShortForm constructors. They arise in situations such as datatype t = A of int*int | B | C i.e. where we have only one non-nullary constructor and it is a tuple. In this case we can deal with all the nullary constructors simply by testing whether the two arguments are the same. We don't have to discriminate the individual cases. *) fun processConstrs [] = (* The last of the alternatives is false *) CodeZero | processConstrs (Value{class, access, typeOf, ...} :: rest) = let fun addPolymorphism c = if nTypeVars = 0 orelse justForEqualityTypes then c else mkEval(c, localArgList) val base = codeAccess(access, baseEqLevelP1) open ValueConstructor fun matches arg = mkEval(addPolymorphism(extractTest base), [arg]) in case class of Constructor{nullary=true, ...} => let (* Nullary constructors are represented either by short constants or by constant tuples depending on the rest of the datatype. If this is a short constant the pointer equality is sufficient. This appears to increase the code size but the test should be optimised away because it is applied to a constant. (The "injection function" of a nullary constructor is the constant that represents the value). We have to test the tags if it is not short because we can't guarantee that the constant tuple hasn't been duplicated. *) val isShort = mkIsShort(addPolymorphism(extractInjection base)) in mkIf(mkIf(isShort, CodeFalse, matches arg1), matches arg2, processConstrs rest) end | _ => (* We have to unwrap the value. *) let (* Get the constructor argument given the result type. We might actually be able to take the argument type off directly but there's some uncertainty about whether we use the same type variables for the constructors as for the datatype. (This only applies for polytypes). *) val resType = constructorResult(typeOf, List.map TypeVar argTypes) (* Code to extract the value. *) fun destruct argNo = mkEval(addPolymorphism(extractProjection(codeAccess(access, baseEqLevelP1))), [mkLoadParam(argNo, baseEqLevelP1, baseEqLevelP1)]) (* Test whether the values match. *) val eqValue = mkEval( makeEq(resType, baseEqLevelP1, getEqFnForID, argTypeMap), [destruct 0, destruct 1]) in (* We have equality if both values match this constructor and the values within the constructor match. *) mkIf(matches arg1, mkCand(matches arg2, eqValue), processConstrs rest) end end (* processConstrs assumes that if there are nullary constructors we have already tested for bitwise equality. We also do that if there is more than one constructor to try to speed up equality for deep structures. *) val eqCode = case vConstrs of [Value{class=Constructor{nullary=true, ...}, ...}] => CodeTrue | [_] => processConstrs vConstrs - | _ => mkCor(mkEqualWord(arg1, arg2), processConstrs vConstrs) + | _ => mkCor(mkEqualPointerOrWord(arg1, arg2), processConstrs vConstrs) in if null argTypes then (addr, mkProc(eqCode, 2, "eq-" ^ tcName tyConstr ^ "(2)", getClosure baseEqLevelP1, 0)) :: otherFns else (* Polymorphic. Add an extra inline functions. *) let val nArgs = List.length argTypes val nLevel = newLevel baseEqLevel val nnLevel = newLevel nLevel (* Call the second function with the values to be compared and the base types. *) val polyArgs = List.tabulate(nArgs, fn i => mkLoadParam(i, nnLevel, nLevel)) in (addr, mkInlproc( mkInlproc( mkEval(mkLoad(addr+1, nnLevel, baseEqLevel), [arg1, arg2] @ polyArgs), 2, "eq-" ^ tcName tyConstr ^ "(2)", getClosure nnLevel, 0), nArgs, "eq-" ^ tcName tyConstr ^ "(2)(P)", getClosure nLevel, 0)) :: (addr+1, mkProc(mkEnv(getCachedTypeValues argTypeMap, eqCode), 2+nTypeVars, "eq-" ^ tcName tyConstr ^ "()", getClosure baseEqLevelP1, 0)) :: otherFns end end else (* Not an equality type. This will not be called but it still needs to be a function to ensure it's valid inside mkMutualDecs. *) (addr, mkProc(CodeZero, 2, "no-eq", [], 0)) :: otherFns in List.foldl equalityForDatatype [] typesAndAddresses end (* Create a printer function for a datatype when the datatype is declared. We don't have to treat mutually recursive datatypes specially because this is called after the type IDs have been created. *) fun printerForDatatype(TypeConstrSet(typeCons as TypeConstrs{name, ...}, vConstrs), level, typeVarMap) = let val argCode = mkInd(0, arg1) and depthCode = mkInd(1, arg1) val nLevel = newLevel level val constrArity = tcArity typeCons val argTypes = List.tabulate(constrArity, fn _ => makeTv{value=EmptyType, level=generalisable, nonunifiable=false, equality=false, printable=false}) val (localArgList, innerLevel, newTypeVarMap) = case constrArity of 0 => ([], nLevel, typeVarMap) | _ => let val nnLevel = newLevel nLevel fun mkTcArgMap (argTypes, level, oldLevel) = let val nArgs = List.length argTypes val argAddrs = List.tabulate(nArgs, fn n => n) val args = List.map(fn addr => fn l => mkLoadParam(addr, l, oldLevel)) argAddrs in (ListPair.zipEq(argTypes, args), List.map (fn addr => mkLoadParam(addr, level, oldLevel)) argAddrs) end val (varToArgMap, localArgList) = mkTcArgMap(argTypes, nnLevel, nLevel) val addrs = ref 1 (* Make local declarations for any type values. *) fun mkAddr n = !addrs before (addrs := !addrs + n) in (localArgList, nnLevel, extendTypeVarMap(varToArgMap, mkAddr, nLevel, typeVarMap)) end (* 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 p = let val test = case p of PrettyBlock(_, _, _, items) => ( case items of PrettyString first :: tl => not(null tl) andalso first <> "(" andalso first <> "{" andalso first <> "[" | _ => false ) | _ => false in if test then PrettyBlock(3, true, [], [ PrettyString "(", PrettyBreak(0, 0), p, PrettyBreak(0, 0), PrettyString ")" ]) else p end *) local - fun eqStr (arg, str) = mkEqualWord(arg, mkConst(toMachineWord str)) + fun eqStr (arg, str) = mkEqualPointerOrWord(arg, mkConst(toMachineWord str)) + (* eqStr assumes that all occurrences of the same single character string are shared. *) val isNotNull = mkNot o mkIsShort fun testTag(arg, tagV) = (* Test the tag in the first word of the datatype. *) mkTagTest(mkInd(0, arg), tagV, maxPrettyTag) fun listHd x = mkVarField(0, x) and listTl x = mkVarField(1, x) in val parenCode = mkProc( mkIf( testTag(mkLoadArgument 0, tagPrettyBlock), (* then *) mkEnv( [mkDec(0, mkVarField(4, mkLoadArgument 0))], (* items *) mkIf ( (* not(null items) andalso not(null(tl items)) andalso not (isPrettyString(hd items) andalso bracket) *) mkCand( isNotNull(mkLoadLocal 0), mkCand( isNotNull (listTl(mkLoadLocal 0)), mkNot ( mkCand(testTag(listHd(mkLoadLocal 0), tagPrettyString), mkEnv( [mkDec(1, mkVarField(1, listHd(mkLoadLocal 0)))], mkCor(eqStr(mkLoadLocal 1, "("), mkCor(eqStr(mkLoadLocal 1, "{"), eqStr(mkLoadLocal 1, "["))) ) ) ) ) ), (* then: Parenthesise the argument. *) codePrettyBlock( 3, true, [], mkDatatype [ codePrettyString "(", mkDatatype [ codePrettyBreak(0, 0), mkDatatype [ mkLoadArgument 0, mkDatatype [ codePrettyBreak(0, 0), mkDatatype [codePrettyString ")", CodeZero ] ] ] ] ] ), (* else *) mkLoadArgument 0 ) ), (* else *) mkLoadArgument 0 ), 1, "parenthesise", [], 2) end fun printerForConstructors (Value{name, typeOf, access, class = Constructor{nullary, ...}, locations, ...} :: rest) = let (* The "value" for a value constructor is a tuple containing the test code, the injection and the projection functions. *) val constructorCode = codeAccess(access, innerLevel) (* If this is a polytype the fields in the constructor tuple are functions that first have to be applied to the type arguments to yield the actual injection/test/projection functions. For monotypes the fields contain the injection/test/projection functions directly. *) fun addPolymorphism c = if constrArity = 0 orelse justForEqualityTypes then c else mkEval(c, localArgList) open ValueConstructor val locProps = (* Get the declaration location. *) List.foldl(fn (DeclaredAt loc, _) => [ContextLocation loc] | (_, l) => l) [] locations val nameCode = codePrettyBlock(0, false, locProps, codeList([codePrettyString name], CodeZero)) val printCode = if nullary then (* Just the name *) nameCode else let val typeOfArg = constructorResult(typeOf, List.map TypeVar argTypes) val getValue = mkEval(addPolymorphism(extractProjection constructorCode), [argCode]) in codePrettyBlock(1, false, [], codeList( [ (* Put it in a block with the declaration location. *) nameCode, codePrettyBreak (1, 0), (* Print the argument and parenthesise it if necessary. *) mkEval(parenCode, [ mkEval( printerForType(typeOfArg, innerLevel, newTypeVarMap), [mkTuple[getValue, decDepth depthCode]] )] ) ], CodeZero)) end in (* If this was the last or only constructor we don't need to test. *) checkDepth(depthCode, 1, if null rest then printCode else let val testValue = mkEval(addPolymorphism(extractTest constructorCode), [argCode]) in mkIf(testValue, printCode, printerForConstructors rest) end, codePrettyString "...") end | printerForConstructors _ = raise InternalError ("No constructors:"^name) val printerCode = printerForConstructors vConstrs in (* Wrap this in the functions for the base types. *) if constrArity = 0 then mkProc(printerCode, 1, "print-"^name, getClosure innerLevel, 0) else mkProc(mkEnv(getCachedTypeValues newTypeVarMap, mkProc(printerCode, 1, "print-"^name, getClosure innerLevel, 0)), constrArity, "print"^name^"()", getClosure nLevel, 0) end (* Opaque matching and functor application create new type IDs using an existing type as implementation. The equality function is inherited whether the type was specified as an eqtype or not. The print function is no longer inherited. Instead a new reference is installed with a default print function. This hides the implementation. *) (* If this is a type function we're going to generate a new ref anyway so we don't need to copy it. *) fun codeGenerativeId{source=TypeId{idKind=TypeFn([], resType), ...}, isEq, mkAddr, level, ...} = let (* Monotype abbreviation. *) (* Create a new type value cache. *) val typeVarMap = defaultTypeVarMap(mkAddr, level) open TypeValue val eqCode = if not isEq then CodeZero else (* We need a function that takes two arguments rather than a single pair. *) makeEq(resType, level, fn (typeId, _, l) => codeId(typeId, l), typeVarMap) val boxedCode = boxednessForType(resType, level, fn (typeId, _, l) => codeId(typeId, l), typeVarMap) val sizeCode = sizeForType(resType, level, fn (typeId, _, l) => codeId(typeId, l), typeVarMap) in mkEnv( TypeVarMap.getCachedTypeValues typeVarMap, createTypeValue { eqCode = eqCode, boxedCode = boxedCode, sizeCode = sizeCode, printCode = mkAllocateWordMemory( mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), codePrintDefault) }) end | codeGenerativeId{source=TypeId{idKind=TypeFn(argTypes, resType), ...}, isEq, mkAddr, level, ...} = let (* Polytype abbreviation: All the entries in the tuple are functions that must be applied to the base type values when the type constructor is used. *) (* Create a new type value cache. *) val typeVarMap = defaultTypeVarMap(mkAddr, level) val nArgs = List.length argTypes fun createCode(makeCode, name) = let val nLevel = newLevel level val addrs = ref 0 fun mkAddr n = !addrs before (addrs := !addrs + n) local val args = List.tabulate(nArgs, fn addr => fn l => mkLoadParam(addr, l, nLevel)) in val typeEnv = ListPair.zipEq(argTypes, args) end val argTypeMap = extendTypeVarMap(typeEnv, mkAddr, nLevel, typeVarMap) val innerFnCode = makeCode(nLevel, argTypeMap) in mkProc(mkEnv(getCachedTypeValues argTypeMap, innerFnCode), nArgs, name, getClosure nLevel, !addrs) end open TypeValue (* Create a print function.*) val printCode = createCode(fn _ => codePrintDefault, "print-helper()") and eqCode = if not isEq then CodeZero else createCode(fn(nLevel, argTypeMap) => makeEq(resType, nLevel, fn (typeId, _, l) => codeId(typeId, l), argTypeMap), "equality()") and boxedCode = createCode(fn(nLevel, argTypeMap) => boxednessForType(resType, nLevel, fn (typeId, _, l) => codeId(typeId, l), argTypeMap), "boxedness()") and sizeCode = createCode(fn(nLevel, argTypeMap) => sizeForType(resType, nLevel, fn (typeId, _, l) => codeId(typeId, l), argTypeMap), "size()") in mkEnv( TypeVarMap.getCachedTypeValues typeVarMap, createTypeValue { eqCode = eqCode, boxedCode = boxedCode, printCode = mkAllocateWordMemory( mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), printCode), sizeCode = sizeCode }) end | codeGenerativeId{source=sourceId, isDatatype, mkAddr, level, ...} = let (* Datatype. This is the same for monotype and polytypes except for the print fn. *) (* We hide the print function if the target is just a type name but if the target is a datatype it's probably better to have a print function. We inherit it from the source although that may expose the representation of other types. e.g. structure S:> sig type t datatype s = A of t end = ... *) open TypeValue val { dec, load } = multipleUses (codeId(sourceId, level), fn () => mkAddr 1, level) val loadLocal = load level val arity = case sourceId of TypeId{idKind=Bound{arity, ...},...} => arity | TypeId{idKind=Free{arity, ...},...} => arity | TypeId{idKind=TypeFn _,...} => raise InternalError "Already checked" val printFn = if isDatatype then mkLoadOperation(LoadStoreMLWord{isImmutable=false}, extractPrinter loadLocal, CodeZero) else if arity = 0 then codePrintDefault else mkProc(codePrintDefault, arity, "print-helper()", [], 0) val printCode = mkAllocateWordMemory( mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), printFn) in mkEnv( dec, createTypeValue { eqCode = extractEquality loadLocal, printCode = printCode, boxedCode = extractBoxed loadLocal, sizeCode = extractSize loadLocal } ) end (* Create the equality and type functions for a set of mutually recursive datatypes. *) fun createDatatypeFunctions( typeDatalist: {typeConstr: typeConstrSet, eqStatus: bool, boxedCode: codetree, sizeCode: codetree } list, mkAddr, level, typeVarMap, makePrintFunction) = let (* Each entry has an equality function and a ref to a print function. The print functions for each type needs to indirect through the refs when printing other types so that if a pretty printer is later installed for one of the types the others will use the new pretty printer. That means that the code has to be produced in stages. *) (* Create the equality functions. Because mutual decs can only be functions we can't create the typeIDs themselves as mutual declarations. *) local (* If this is polymorphic make two addresses, one for the returned equality function and one for the inner function. *) fun makeEqAddr{typeConstr=TypeConstrSet(tyConstr, _), ...} = mkAddr(if tcArity tyConstr = 0 then 1 else 2) in val eqAddresses = List.map makeEqAddr typeDatalist (* Make addresses for the equalities. *) end val equalityFunctions = mkMutualDecs(equalityForDatatypes(typeDatalist, eqAddresses, level, typeVarMap)) (* Create the typeId values and set their addresses. The print function is initially set as zero. *) local fun makeTypeId({typeConstr, boxedCode, sizeCode, ...}, eqAddr) = let val var = vaLocal(idAccess(tcIdentifier(tsConstr typeConstr))) val newAddr = mkAddr 1 open TypeValue val idCode = createTypeValue { eqCode=mkLoadLocal eqAddr, printCode= mkAllocateWordMemory( mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), CodeZero (* Temporary - replaced by setPrinter. *)), boxedCode = boxedCode, sizeCode = sizeCode } in #addr var := newAddr; #level var:= level; mkDec(newAddr, idCode) end in val typeIdCode = ListPair.map makeTypeId (typeDatalist, eqAddresses) end (* Create the print functions and set the printer code for each typeId. *) local fun setPrinter{typeConstr as TypeConstrSet(tCons as TypeConstrs{identifier, ...}, _), ...} = let val arity = tcArity tCons val printCode = if makePrintFunction then printerForDatatype(typeConstr, level, typeVarMap) else if arity = 0 then codePrintDefault else mkProc(codePrintDefault, arity, "print-printdefault", [], 0) in mkNullDec( mkStoreOperation(LoadStoreMLWord{isImmutable=false}, TypeValue.extractPrinter(codeId(identifier, level)), CodeZero, printCode)) end in val printerCode = List.map setPrinter typeDatalist end in equalityFunctions :: typeIdCode @ printerCode end (* Exported function. Returns a function from an ML pair of values to bool. N.B. This differs from the functions in the typeID which take a Poly pair. *) fun equalityForType(ty: types, level: level, typeVarMap: typeVarMap): codetree = let val nLevel = newLevel level (* The final result function must take a single argument. *) val resultCode = makeEq(ty, nLevel, fn (typeId, _, l) => codeId(typeId, l), typeVarMap) in (* We need to wrap this up in a new inline function. *) mkInlproc(mkEval(resultCode, [mkInd(0, arg1), mkInd(1, arg1)]), 1, "equality", getClosure nLevel, 0) end (* This code is used when the type checker has to construct a unique monotype because a type variable has escaped to the top level. The equality code always returns true and the printer prints "?". *) fun codeForUniqueId() = let open TypeValue val alwaysTrue = mkProc(CodeTrue, 2, "codeForUniqueId-equal", [], 0) val printCode = mkAllocateWordMemory( mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), codePrintDefault) in createTypeValue{ eqCode = alwaysTrue, printCode = printCode, boxedCode = boxedEither, sizeCode = singleWord } end val noEquality = mkProc(CodeFalse, 2, "noEquality", [], 0) (* Since we don't have a way of writing a "printity" type variable there are cases when the printer will have to fall back to this. e.g. if we have a polymorphic printing function as a functor argument. *) val noPrinter = codePrintDefault (* If this is a polymorphic value apply it to the type instance. *) fun applyToInstance'([], level, _, code) = code level (* Monomorphic. *) | applyToInstance'(sourceTypes, level, polyVarMap, code) = let (* If we need either the equality or print function we generate a new entry and ignore anything in the cache. *) fun makePolyParameter {value=t, equality, printity} = if equality orelse printity then let open TypeValue fun getTypeValueForID(typeId, _, l) = codeId(typeId, l) val eqCode = if equality then makeEq(t, level, fn (typeId, _, l) => codeId(typeId, l), polyVarMap) else noEquality val boxedCode = boxednessForType(t, level, getTypeValueForID, polyVarMap) val printCode = if printity then printerForType(t, level, polyVarMap) else noPrinter val sizeCode = sizeForType(t, level, getTypeValueForID, polyVarMap) in createTypeValue{ eqCode=eqCode, printCode=printCode, boxedCode=boxedCode, sizeCode=sizeCode} end else (* If we don't require the equality or print function we can use the cache. *) case findCachedTypeCode(polyVarMap, t) of SOME (code, _) => code level | NONE => let val maxCache = getMaxDepth polyVarMap (t, 1) val cacheEntry = List.nth(polyVarMap, List.length polyVarMap - maxCache) val { cache, mkAddr, level=decLevel, ...} = cacheEntry local open TypeValue val boxedCode = boxednessForType(t, decLevel, fn (typeId, _, l) => codeId(typeId, l), polyVarMap) val sizeCode = sizeForType(t, decLevel, fn (typeId, _, l) => codeId(typeId, l), polyVarMap) in val typeValue = createTypeValue{ eqCode=noEquality, printCode=noPrinter, boxedCode=boxedCode, sizeCode=sizeCode} end (* Make a new entry and put it in the cache. *) val decAddr = mkAddr 1 val () = cache := {decCode = mkDec(decAddr, typeValue), typeOf = t, address = decAddr } :: !cache in mkLoad(decAddr, level, decLevel) end in mkEval(code level, List.map makePolyParameter sourceTypes) end (* For now limit this to equality types. *) fun applyToInstance(sourceTypes, level, polyVarMap, code) = applyToInstance'( List.filter(fn {equality, ...} => not justForEqualityTypes orelse equality) sourceTypes, level, polyVarMap, code) structure Sharing = struct type typeId = typeId type codetree = codetree type types = types type typeConstrs= typeConstrs type typeConstrSet=typeConstrSet type typeVarForm=typeVarForm type typeVarMap = typeVarMap type codeBinding = codeBinding type level = level end end; diff --git a/mlsource/MLCompiler/TYPE_TREE.ML b/mlsource/MLCompiler/TYPE_TREE.ML index d5b4460f..e2314b42 100644 --- a/mlsource/MLCompiler/TYPE_TREE.ML +++ b/mlsource/MLCompiler/TYPE_TREE.ML @@ -1,3266 +1,3264 @@ (* Original Poly version: Title: Operations on type structures. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 ML translation and other changes: Copyright (c) 2000 Cambridge University Technical Services Limited Further development: - Copyright (c) 2000-9, 2012-2018 David C.J. Matthews + Copyright (c) 2000-9, 2012-2018, 2020 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 TYPE_TREE ( structure LEX : LEXSIG structure STRUCTVALS : STRUCTVALSIG; structure PRETTY : PRETTYSIG structure CODETREE : CODETREESIG where type machineWord = Address.machineWord structure EXPORTTREE: EXPORTTREESIG; structure DEBUG: DEBUGSIG structure UTILITIES : sig val mapTable: ('a * 'a -> bool) -> {enter: 'a * 'b -> unit, lookup: 'a -> 'b option} val splitString: string -> { first:string, second:string } end; structure MISC : sig exception InternalError of string; val lookupDefault : ('a -> 'b option) -> ('a -> 'b option) -> 'a -> 'b option end; sharing LEX.Sharing = PRETTY.Sharing = EXPORTTREE.Sharing = STRUCTVALS.Sharing = CODETREE.Sharing ) : TYPETREESIG = (*****************************************************************************) (* TYPETREE functor body *) (*****************************************************************************) struct open MISC; open PRETTY; open STRUCTVALS; open LEX; open UTILITIES; open CODETREE; open EXPORTTREE (* added 16/4/96 SPF *) fun sameTypeVar (TypeVar x, TypeVar y) = sameTv (x, y) | sameTypeVar _ = false; fun isTypeVar (TypeVar _) = true | isTypeVar _ = false; fun isFunctionType (FunctionType _) = true | isFunctionType _ = false; fun isEmpty EmptyType = true | isEmpty _ = false; fun isBadType BadType = true | isBadType _ = false; val emptyType = EmptyType; fun typesTypeVar (TypeVar x) = x | typesTypeVar _ = raise Match; fun typesFunctionType (FunctionType x) = x | typesFunctionType _ = raise Match; (* This is really left over from an old definition. *) fun tcEquivalent(TypeConstrs{identifier = TypeId {idKind = TypeFn(_, result), ...}, ...}) = result | tcEquivalent _ = raise InternalError "tcEquivalent: Not a type function" (* A type construction is the application of a type constructor to a sequence of types to yield a type. A construction may have a nil list if it is a single type identifier such as ``int''. *) (* When a type constructor is encountered in the first pass this entry is put in. Subsequently a type constructor entry will be assigned to it so that the types can be checked. *) (*************) fun mkTypeVar (level, equality, nonunifiable, printable) = TypeVar (makeTv {value=emptyType, level=level, equality=equality, nonunifiable=nonunifiable, printable=printable}); fun mkTypeConstruction (name, typc, args, locations) = TypeConstruction {name = name, constr = typc, args = args, locations = locations} local (* Turn a tuple into a record of the form {1=.., 2=... }*) fun maptoRecord ([], _) = [] | maptoRecord (H::T, i) = {name=Int.toString i, typeof=H} :: maptoRecord (T,i+1) in fun mkProductType (typel: types list) = let val fields = maptoRecord (typel, 1) in LabelledType {recList = fields, fullList = FieldList(List.map #name fields, true)} end end fun mkFunctionType (arg, result) = FunctionType {arg = arg, result = result}; fun mkOverloadSet [constr] = (* If there is just a single constructor in the set we make a type construction from it. *) mkTypeConstruction(tcName constr, constr, nil, []) | mkOverloadSet constrs = let (* Make a type variable and point this at the overload set so we can narrow down the overloading. *) val var = mkTypeVar (generalisable, false, false, false) val set = OverloadSet {typeset=constrs}; in tvSetValue (typesTypeVar var, set); var end fun mkLabelled (l, frozen) = let val final = FieldList(map #name l, frozen) val lab = LabelledType {recList = l, fullList = if frozen then final else FlexibleList(ref final) } in if frozen then lab else let (* Use a type variable so that the record can be expanded. This also provides a model (equality etc). for any fields that are added later. *) val var = mkTypeVar (generalisable, false, false, false) val () = if isTypeVar var then tvSetValue (typesTypeVar var, lab) else (); in var end end (* Must remove leading zeros because the labels are compared by string comparison. *) fun mkLabelEntry (name, t) = let fun stripZeros s = if size s <= 1 orelse String.str(String.sub(s, 0)) <> "0" then s else stripZeros (String.substring(s, 1, size s-1)); in {name = stripZeros name, typeof = t} end; (* Functions to construct the run-time representations of type constructor values, type values and value constructors. These are all tuples and centralising the code here avoids having the offsets as integers at various places. Monotype constructor and type values are almost the same except that type values have the printer entry as the function whereas monotype constructors have the print entry as a ref pointing to the function, allowing addPrettyPrint to set a printer for the type. The entries for polytypes are functions that take the type values as arguments and return the corresponding values. *) structure TypeValue = struct val equalityOffset = 0 and printerOffset = 1 and boxnessOffset = 2 and sizeOffset = 3 local (* Values used to represent boxness. *) val boxedRepNever = 0w1 (* Never boxed, always tagged e.g. bool *) and boxedRepAlways = 0w2 (* Always boxed, never tagged e.g. function types *) and boxedRepEither = 0w3 (* Either boxed or tagged e.g. (arbitrary precision) int *) fun make n = mkConst(Address.toMachineWord n) fun isCode n = - mkInlproc(mkEqualWord(mkLoadArgument 0, make n), 1, "test-box", [], 0) + mkInlproc(mkEqualTaggedWord(mkLoadArgument 0, make n), 1, "test-box", [], 0) in val boxedNever = make boxedRepNever and boxedAlways = make boxedRepAlways and boxedEither = make boxedRepEither (* Test for boxedness. This must be applied to the value extracted from the "boxedness" field after applying to any base type arguments in the case of a polytype constructor. *) val isBoxedNever = isCode boxedRepNever and isBoxedAlways = isCode boxedRepAlways and isBoxedEither = isCode boxedRepEither end (* Sizes are always a single word. *) val singleWord = mkConst(Address.toMachineWord 0w1) fun extractEquality idCode = mkInd(equalityOffset, idCode) and extractPrinter idCode = mkInd(printerOffset, idCode) and extractBoxed idCode = mkInd(boxnessOffset, idCode) and extractSize idCode = mkInd(sizeOffset, idCode) fun createTypeValue{eqCode, printCode, boxedCode, sizeCode} = mkTuple[eqCode, printCode, boxedCode, sizeCode] end (* Value constructors are represented by tuples, either pairs for nullary constructors or triples for constructors with arguments. For nullary functions the "injection" function is actually the value itself. If this is a polytype all the entries are functions that take the type values for the base types as arguments. *) structure ValueConstructor = struct val testerOffset = 0 val injectorOffset = 1 val projectorOffset = 2 fun extractTest constrCode = mkInd(testerOffset, constrCode) and extractInjection constrCode = mkInd(injectorOffset, constrCode) and extractProjection constrCode = mkInd(projectorOffset, constrCode) fun createValueConstr{testMatch, injectValue, projectValue} = mkTuple[testMatch, injectValue, projectValue] fun createNullaryConstr{ testMatch, constrValue } = mkTuple[testMatch, constrValue] end (* Eqtypes with built-in equality functions. The printer functions are all replaced in the basis. *) local open Address PRETTY TypeValue fun defaultMonoTypePrinter _ = PrettyString "?" fun defaultPolyTypePrinter _ _ = PrettyString "?" fun eqAndPrintCode (eqCode, nArgs, boxed) = let val code = if nArgs = 0 then createTypeValue{ eqCode=eqCode, printCode=mkConst (toMachineWord (ref defaultMonoTypePrinter)), boxedCode = boxed, sizeCode = singleWord } else createTypeValue{ eqCode=mkInlproc(eqCode, nArgs, "eq-helper()", [], 0), printCode=mkConst (toMachineWord (ref defaultPolyTypePrinter)), boxedCode = mkInlproc(boxed, nArgs, "boxed-helper()", [], 0), sizeCode = mkInlproc(singleWord, nArgs, "size-helper()", [], 0) } in Global (genCode(code, [], 0) ()) end fun makeConstr(name, fullName, eqFun, boxed) = makeTypeConstructor (name, [], makeFreeId(0, eqAndPrintCode(eqFun, 0, boxed), true, basisDescription fullName), [DeclaredAt inBasis]) (* since code generator relies on these representations, we may as well export them *) - (* wordEq is used both for tagged words and for pointer equality *) - val wordEq = equalWordFn + (* Strings are now always vectors whose first word is the length. The old special case for single-character strings has been removed. *) local val stringEquality = mkInlproc( (* This previously checked for pointer equality first. That has been removed. Test the lengths first and only do the byte comparison if they are the same. This seems to save more time than including the length word in the byte comparison. *) mkCand( - mkEqualWord( + mkEqualPointerOrWord( (* Because we're not actually tagging these we use pointerEq here. *) mkLoadOperation(LoadStoreUntaggedUnsigned, mkLoadArgument 0, CodeZero), mkLoadOperation(LoadStoreUntaggedUnsigned, mkLoadArgument 1, CodeZero)), mkBlockOperation{kind=BlockOpEqualByte, leftBase=mkLoadArgument 0, rightBase=mkLoadArgument 1, leftIndex=mkConst(toMachineWord wordSize), rightIndex=mkConst(toMachineWord wordSize), (* Use argument 1 here rather than 0. We could use either but this works better when we're using equality for pattern matching since it gets the length of the constant string. It also works better for the, to me, more natural ordering of variable=constant. *) length=mkLoadOperation(LoadStoreUntaggedUnsigned, mkLoadArgument 1, CodeZero) } ), 2, "stringEquality", [], 0) in val stringEquality = stringEquality end local (* Arbitrary precision values are normalised so if a value can be represented as a tagged fixed precision value it will be. Unlike strings it is much more likely that the value will be short so we generate equality as a test that handles the short case as inline code and the long case as a function call. If either argument is a short constant this will be optimised away so the test will reduce to a test on whether the value equals the constant. *) val intEquality = mkEnv( [mkDec(0, (* Long-form equality - should not be inlined. *) mkProc( (* Equal if signs are the same ... *) mkCand( - mkEqualWord( + mkEqualTaggedWord( mkUnary(BuiltIns.MemoryCellFlags, mkLoadArgument 0), mkUnary(BuiltIns.MemoryCellFlags, mkLoadArgument 1) ), mkEnv( [mkDec(0, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 1))], mkCand( (* ... and the lengths are equal ... *) - mkEqualWord( + mkEqualTaggedWord( mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 0), mkLoadLocal 0 ), (* ... and they're byte-wise equal .*) mkBlockOperation{kind=BlockOpEqualByte, leftBase=mkLoadArgument 0, rightBase=mkLoadArgument 1, leftIndex=CodeZero, rightIndex=CodeZero, length=mkBinary(BuiltIns.WordArith BuiltIns.ArithMult, mkConst(toMachineWord RunCall.bytesPerWord), mkLoadLocal 0)} ) ) ), 2, "arbitraryPrecisionEquality", [], 1) ) ], mkInlproc( mkCor( (* Either they're equal... *) - (* We can't use mkEqualWord here - because if we have a short constant here the code will reduce to the - simple equality. If we used mkEqualWord it could further reduce to - an indexed case but the code for that does not handle arbitrary - precision values in the lo *) - mkEqualArbShort(mkLoadArgument 0, mkLoadArgument 1), + (* N.B. The values could be short or long. That's particularly important + if we have a series of tests against short constants. If we convert it to + an indexed case we MUST check that the value is short before computing + the index. *) + mkEqualPointerOrWord(mkLoadArgument 0, mkLoadArgument 1), (* .. or if either is short the result is false ... *) mkCand( mkCand( mkNot(mkIsShort(mkLoadArgument 0)), mkNot(mkIsShort(mkLoadArgument 1)) ), (* ... otherwise we have to test the vectors. *) mkEval(mkLoadClosure 0, [mkLoadArgument 0, mkLoadArgument 1]) ) ), 2, "intInfEquality", [mkLoadLocal 0], 0) ) in (* Code-generate the function and return the inline part. We need to set the maximum inline size here to ensure the long form code is not inlined. It would be better to have a way of turning off inlining for specific functions. *) val intEquality = genCode(intEquality, [Universal.tagInject DEBUG.maxInlineSizeTag 5], 1) () end in - val fixedIntConstr = makeConstr("int", "FixedInt.int", wordEq, boxedNever) (* Fixed precision is always short *) + val fixedIntConstr = makeConstr("int", "FixedInt.int", equalTaggedWordFn, boxedNever) (* Fixed precision is always short *) val intInfConstr = makeConstr("int", "IntInf.int", intEquality, boxedEither) - val charConstr = makeConstr("char", "char", wordEq, boxedNever) (* Always short *) + val charConstr = makeConstr("char", "char", equalTaggedWordFn, boxedNever) (* Always short *) val stringConstr = makeConstr("string", "string", stringEquality, boxedEither (* Single chars are unboxed. *)) - val wordConstr = makeConstr("word", "word", wordEq, boxedNever) + val wordConstr = makeConstr("word", "word", equalTaggedWordFn, boxedNever) (* Ref is a datatype with a single constructor. The constructor is added in INITIALISE. Equality is special for "'a ref", "'a array" and "'a Array2.array". They permit equality even if the 'a is not an eqType. *) val refConstr = makeTypeConstructor ("ref", [makeTv {value=EmptyType, level=generalisable, equality=false, nonunifiable=false, printable=false}], - makeFreeId(1, eqAndPrintCode(wordEq, 1, boxedAlways), true, basisDescription "ref"), + makeFreeId(1, eqAndPrintCode(equalPointerOrWordFn, 1, boxedAlways), true, basisDescription "ref"), [DeclaredAt inBasis]); val arrayConstr = makeTypeConstructor ("array", [makeTv {value=EmptyType, level=generalisable, equality=false, nonunifiable=false, printable=false}], - makeFreeId(1, eqAndPrintCode(wordEq, 1, boxedAlways), true, basisDescription "Array.array"), + makeFreeId(1, eqAndPrintCode(equalPointerOrWordFn, 1, boxedAlways), true, basisDescription "Array.array"), [DeclaredAt inBasis]); val array2Constr = makeTypeConstructor ("array", [makeTv {value=EmptyType, level=generalisable, equality=false, nonunifiable=false, printable=false}], - makeFreeId(1, eqAndPrintCode(wordEq, 1, boxedAlways), true, basisDescription "Array2.array"), + makeFreeId(1, eqAndPrintCode(equalPointerOrWordFn, 1, boxedAlways), true, basisDescription "Array2.array"), [DeclaredAt inBasis]); val byteArrayConstr = makeTypeConstructor ("byteArray", [], - makeFreeId(0, eqAndPrintCode(wordEq, 0, boxedAlways), true, basisDescription "byteArray"), + makeFreeId(0, eqAndPrintCode(equalPointerOrWordFn, 0, boxedAlways), true, basisDescription "byteArray"), [DeclaredAt inBasis]); (* Bool is a datatype. The constructors are added in INITIALISE. *) val boolConstr = makeTypeConstructor - ("bool", [], makeFreeId(0, eqAndPrintCode(wordEq, 0, boxedNever), true, basisDescription "bool"), + ("bool", [], makeFreeId(0, eqAndPrintCode(equalTaggedWordFn, 0, boxedNever), true, basisDescription "bool"), [DeclaredAt inBasis]); end (* These polytypes allow equality even if the type argument is not an equality type. *) fun isPointerEqType id = sameTypeId (id, tcIdentifier refConstr) orelse sameTypeId (id, tcIdentifier arrayConstr) orelse sameTypeId (id, tcIdentifier array2Constr) orelse sameTypeId (id, tcIdentifier byteArrayConstr) (* Non-eqtypes *) local open Address PRETTY TypeValue fun makeType(name, descr, boxed) = let fun defaultPrinter _ = PrettyString "?" val code = createTypeValue{ eqCode=CodeZero (* No equality. *), printCode=mkConst (toMachineWord (ref defaultPrinter)), boxedCode=boxed, sizeCode=singleWord } in makeTypeConstructor ( name, [], makeFreeId(0, Global (genCode(code, [], 0) ()), false, descr), [DeclaredAt inBasis]) end in val realConstr = makeType("real", basisDescription "real", boxedAlways(* Currently*)) (* Not an eqtype in ML97. *) (* Short real: Real32.real *) val floatConstr = makeType("real", basisDescription "real", if RunCall.bytesPerWord <= 0w4 then boxedAlways else boxedNever) val exnConstr = makeType("exn", basisDescription "exn", boxedAlways); (* "undefConstr" is used as a place-holder during parsing for the actual type constructor. If the type constructor is not found this may appear in an error message. *) val undefConstr = makeType("undefined", { location = inBasis, description = "Undefined", name = "undefined" }, boxedEither); end (* The unit type is equivalent to the empty record. *) val unitConstr = makeTypeConstructor ("unit", [], makeTypeFunction({ location = inBasis, description = "unit", name = "unit" }, ([], LabelledType {recList = [], fullList = FieldList([], true)})), [DeclaredAt inBasis]); (* Type identifiers bound to standard type constructors. *) val unitType = mkTypeConstruction ("unit", unitConstr, [], []) val fixedIntType = mkTypeConstruction ("int", fixedIntConstr, [], []) val stringType = mkTypeConstruction ("string", stringConstr, [], []) val boolType = mkTypeConstruction ("bool", boolConstr, [], []) val exnType = mkTypeConstruction ("exn", exnConstr, [], []) fun isUndefined cons = sameTypeId (tcIdentifier cons, tcIdentifier undefConstr); val isUndefinedTypeConstr = isUndefined (* Test if a type is the undefined constructor. *) fun isUndefinedType(TypeConstruction{constr, ...}) = isUndefined constr | isUndefinedType _ = false (* Similar to alphabetic ordering except that shorter labels come before longer ones. This has the advantage that numerical labels are compared by their numerical order i.e. 1 < 2 < 10 whereas alphabetic ordering puts "1" < "10" < "2". *) fun compareLabels (a : string, b : string) : int = if size a = size b then if a = b then 0 else if a < b then ~1 else 1 else if size a < size b then ~1 else 1; (* Sort using the label ordering. A simple sort routine - particularly if the list is already sorted. *) fun sortLabels [] = [] | sortLabels (s::rest) = let fun enter s _ [] = [s] | enter s name (l as ( (h as {name=hname, ...}) :: t)) = let val comp = compareLabels (name, hname); in if comp <= 0 then s :: l else h :: enter s name t end; in enter s (#name s) (sortLabels rest) end (* Chains down a list of type variables returning the type they are bound to. As a side-effect it also points all the type variables at this type to reduce the need for future chaining and to free unused type variables. Normally a type variable points to at most one other, which then points to "empty". However if we have unified two type variables by pointing one at the other, there may be type variables which pointed to the first and which cannot be found and redirected at the second until they themselves are examined. *) fun eventual (t as (TypeVar tv)) : types = let (* Note - don't change the level/copy information - the only type variable with this correct is the one at the end of the list. *) val oldVal = tvValue tv val newVal = eventual oldVal; (* Search that *) in (* Update the type variable to point to the last in the chain. We don't do this if the value hasn't changed. The reason for that was that assignment to refs in the database in the old persistent store system was very expensive and we wanted to avoid unnecessary assignments. This special case could probably be removed. *) if PolyML.pointerEq(oldVal, newVal) then () else tvSetValue (tv, newVal); (* Put it on *) case newVal of EmptyType => t (* Not bound to anything - return the type variable *) | LabelledType (r as { recList, fullList }) => if List.length recList = List.length(recordFields r) then (* All the generic fields are present so we don't need to do anything. *) if recordIsFrozen r then newVal else t else (* We need to add fields from the generic. *) let (* Add any fields from the generic that aren't present in this instance. *) fun createNewField name = { name = name, (* The new type variable has to be created with the same properties as if we had first generalised it from the generic and then unified with this instance. The level is inherited from the instance since the generic will always have level = generalisable. Nonunifiable must be false. *) typeof = mkTypeVar (tvLevel tv, tvEquality tv, false, tvPrintity tv)} fun addToInstance([], []) = [] | addToInstance(generic :: geRest, []) = createNewField generic :: addToInstance(geRest, []) | addToInstance([], instance) = instance (* This case can occur if we are producing an error message because of a type-incorrect program so we just ignore it. *) | addToInstance(generic :: geRest, inst as instance :: iRest) = let val order = compareLabels (generic, #name instance); in if order = 0 (* Equal *) then instance :: addToInstance(geRest, iRest) else if order < 0 (* generic name < instance name *) then createNewField generic :: addToInstance(geRest, inst) else (* This is another case that can occur with type-incorrect code. *) instance :: addToInstance(generic :: geRest, iRest) end val newList = addToInstance(recordFields r, recList) val newRecord = LabelledType {recList = newList, fullList = fullList} in tvSetValue(tv, newRecord); if recordIsFrozen r then newRecord else t end | OverloadSet _ => t (* Return the set of types. *) | _ => newVal (* Return the type it is bound to *) end | eventual t (* not a type variable *) = t; (* Apply a function to every element of a type. *) fun foldType f = let fun foldT typ v = let val t = eventual typ; val res = f t v; (* Process this entry. *) in case t of TypeVar tv => foldT (tvValue tv) res | TypeConstruction {args, ...} => (* Then process the arguments. *) List.foldr (fn (t, v) => foldT t v) res args | FunctionType {arg, result} => foldT arg (foldT result res) | LabelledType {recList,...} => List.foldr (fn ({ typeof, ... }, v) => foldT typeof v) res recList | BadType => res | EmptyType => res | OverloadSet _ => res end in foldT end; (* Checks to see whether a labelled record is in the form of a product i.e. 1=, 2= We only need this for prettyprinting. Zero-length records (i.e. unit) and singleton records are not considered as tuples. *) fun isProductType(LabelledType(r as {recList=recList as _::_::_, ...})) = let fun isRec [] _ = true | isRec ({name, ...} :: l) n = name = Int.toString n andalso isRec l (n+1) in recordIsFrozen r andalso isRec recList 1 end | isProductType _ = false; (* Test to see is a type constructor is in an overload set. *) fun isInSet(tcons: typeConstrs, (H::T): typeConstrs list) = sameTypeId (tcIdentifier tcons, tcIdentifier H) orelse isInSet(tcons, T) | isInSet(_, []: typeConstrs list) = false val prefInt = ref fixedIntConstr (* Returns the preferred overload if there is one. *) fun preferredOverload typeset = if isInSet(!prefInt, typeset) then SOME(!prefInt) else if isInSet(realConstr, typeset) then SOME realConstr else if isInSet(wordConstr, typeset) then SOME wordConstr else if isInSet(charConstr, typeset) then SOME charConstr else if isInSet(stringConstr, typeset) then SOME stringConstr else NONE fun setPreferredInt c = prefInt := c fun equalTypeIds(x, y) = let (* True if two types are equal. *) fun equalTypes (TypeConstruction{constr=xVal, args=xArgs, ...}, TypeConstruction{constr=yVal, args=yArgs, ...}) = equalTypeIds(tcIdentifier xVal, tcIdentifier yVal) andalso equalTypeLists (xArgs, yArgs) | equalTypes (FunctionType x, FunctionType y) = equalTypes (#arg x, #arg y) andalso equalTypes (#result x, #result y) | equalTypes (LabelledType x, LabelledType y) = recordIsFrozen x andalso recordIsFrozen y andalso equalRecordLists (#recList x, #recList y) | equalTypes (TypeVar x, TypeVar y) = sameTv (x, y) | equalTypes (EmptyType, EmptyType) = true | equalTypes _ = false and equalTypeLists ([], []) = true | equalTypeLists (x::xs, y::ys) = equalTypes(x, y) andalso equalTypeLists (xs, ys) | equalTypeLists _ = false and equalRecordLists ([], []) = true | equalRecordLists (x::xs, y::ys) = #name x = #name y andalso equalTypes(#typeof x, #typeof y) andalso equalRecordLists (xs, ys) | equalRecordLists _ = false in case (x, y) of (TypeId{idKind=TypeFn(_, xEquiv), ...}, TypeId{idKind=TypeFn(_, yEquiv), ...}) => equalTypes(xEquiv, yEquiv) | _ => sameTypeId(x, y) end (* See if the types are the same. This is a bit of a fudge, but saves carrying around a flag saying whether the structures were copied. This is only an optimisation. If the values are different it will not go wrong. *) val identical : types * types -> bool = PolyML.pointerEq and identicalConstr : typeConstrs * typeConstrs -> bool = PolyML.pointerEq and identicalList : 'a list * 'a list -> bool = PolyML.pointerEq (* Copy a type, avoiding copying type structures unnecessarily. Used to make new type variables for all distinct type variables when generalising polymorphic functions, and to make new type stamps for type constructors when generalising signatures. *) fun copyType (at, copyTypeVar, copyTypeConstr) = let fun copyList [] = [] | copyList (l as (h :: t)) = let val h' = copyType (h, copyTypeVar, copyTypeConstr); val t' = copyList t; in if identical (h', h) andalso identicalList (t', t) then l else h' :: t' end (* copyList *); fun copyRecordList [] = [] | copyRecordList (l as ({name, typeof} :: t)) = let val typeof' = copyType (typeof, copyTypeVar, copyTypeConstr); val t' = copyRecordList t; in if identical (typeof', typeof) andalso identicalList (t', t) then l else {name=name, typeof=typeof'} :: t' end (* copyList *); val atyp = eventual at; in case atyp of TypeVar _ => (* Unbound type variable, flexible record or overloading. *) copyTypeVar atyp | TypeConstruction {constr, args, locations, ...} => let val copiedArgs = copyList args; val copiedConstr = copyTypeConstr constr; (* Use the name from the copied constructor. This will normally be the same as the original EXCEPT in the case where we are using copyType to generate copies of the value constructors of replicated datatypes. *) val copiedName = tcName copiedConstr in if identicalList (copiedArgs, args) andalso identicalConstr (copiedConstr, constr) then atyp else (* Must copy it. *) mkTypeConstruction (copiedName, copiedConstr, copiedArgs, locations) end | FunctionType {arg, result} => let val copiedArg = copyType (arg, copyTypeVar, copyTypeConstr); val copiedRes = copyType (result, copyTypeVar, copyTypeConstr); in if identical (copiedArg, arg) andalso identical (copiedRes, result) then atyp else FunctionType {arg = copiedArg, result = copiedRes} end | LabelledType {recList, fullList} => (* Rigid labelled records only. Flexible ones are treated as type vars. *) let val copiedList = copyRecordList recList in if identicalList (copiedList, recList) then atyp else LabelledType {recList = copiedList, fullList = fullList} end | EmptyType => EmptyType | BadType => BadType | OverloadSet _ => raise InternalError "copyType: OverloadSet found" end (* copyType *); (* Copy a type constructor if it is Bound and in the required range. If this refers to a type function copies that as well. Does not copy value constructors. *) fun copyTypeConstrWithCache (tcon, typeMap, _, mungeName, cache) = case tcIdentifier tcon of TypeId{idKind = TypeFn(args, equiv), description, access, ...} => let val copiedEquiv = copyType(equiv, fn x => x, fn tcon => copyTypeConstrWithCache (tcon, typeMap, fn x => x, mungeName, cache)) in if identical (equiv, copiedEquiv) then tcon (* Type is identical and we don't want to change the name. *) else (* How do we find a type function? *) makeTypeConstructor (mungeName(tcName tcon), args, TypeId { access = access, description = description, idKind = TypeFn(args, copiedEquiv)}, tcLocations tcon) end | id => ( case typeMap id of NONE => ( (*print(concat[tcName tcon, " not copied\n"]);*) tcon (* No change *) ) | SOME newId => let val name = #second(splitString (tcName tcon)) (* We must only match here if they're really the same. *) fun cacheMatch tc = equalTypeIds(tcIdentifier tc, newId) andalso #second(splitString(tcName tc)) = name in case List.find cacheMatch cache of SOME tc => ( (*print(concat[tcName tcon, " copied as ", tcName tc, "\n"]);*) tc (* Use the entry from the cache. *) ) | NONE => (* Either a hidden identifier or alternatively this can happen as part of the matching process. When matching a structure to a signature we first match up the type constructors then copy the type of each value replacing bound type IDs with the actual IDs as part of the checking process. We will return SOME newId but we don't have a cache so return NONE for List.find. *) let val newName = mungeName(tcName tcon) in (*print(concat[tcName tcon, " not cached\n"]);*) makeTypeConstructor(newName, tcTypeVars tcon, newId, tcLocations tcon) end end ) (* Exported version. *) fun copyTypeConstr (tcon, typeMap, copyTypeVar, mungeName) = copyTypeConstrWithCache(tcon, typeMap, copyTypeVar, mungeName, []) (* Compose typeID maps. If the first map returns a Bound id we apply the second otherwise just return the result of the first. *) fun composeMaps(m1, m2) n = let fun map2 (TypeId{idKind=Bound{ offset, ...}, ...}) = m2 offset | map2 (id as TypeId{idKind=Free _, ...}) = id | map2 (TypeId{idKind=TypeFn(args, equiv), access, description, ...}) = let fun copyId(TypeId{idKind=Free _, ...}) = NONE | copyId id = SOME(map2 id) (* If it's a type function e.g. this was a "where type" we have to apply the map to any type identifiers in the type. *) val copiedEquiv = copyType(equiv, fn x => x, fn tcon => copyTypeConstr (tcon, copyId, fn x => x, fn y => y)) in TypeId{idKind = TypeFn(args, copiedEquiv), access=access, description=description} end in map2(m1 n) end (* Basic procedure to print a type structure. *) type printTypeEnv = { lookupType: string -> (typeConstrSet * (int->typeId) option) option, lookupStruct: string -> (structVals * (int->typeId) option) option} val emptyTypeEnv = { lookupType = fn _ => NONE, lookupStruct = fn _ => NONE } (* Test whether two type constructors are the same after mapping. This is used to try to find the correct "path" to a type constructor when printing. *) fun eqTypeConstrs(xTypeCons, xMap, yTypeCons, yMap) = let fun id x = x fun copyId (SOME mapTypeId) (TypeId{idKind=Bound{ offset, ...}, ...}) = SOME(mapTypeId offset) | copyId _ _ = NONE val mappedX = copyTypeConstr(xTypeCons, copyId xMap, id, id) and mappedY = copyTypeConstr(yTypeCons, copyId yMap, id, id) in equalTypeIds(tcIdentifier mappedX, tcIdentifier mappedY) end (* prints a block of items *) fun tDisp (t : types, depth : FixedInt.int, typeVarName : typeVarForm -> string, env: printTypeEnv, sigMap: (int->typeId)option) : pretty = let (* prints a block of items *) fun dispP (t : types, depth : FixedInt.int) : pretty = let (* prints a block of items *) fun parenthesise depth t = if depth <= 1 then PrettyString "..." else PrettyBlock (0, false, [], [ PrettyString "(", dispP (t, depth - 1), PrettyString ")" ]); (* prints a sequence of items *) fun prettyList [] _ _: pretty list = [] | prettyList [H] depth separator = let val v = eventual H; in if separator = "*" andalso (isFunctionType v orelse isProductType v) then (* Must bracket the expression *) [parenthesise depth v] else [dispP (v, depth)] end | prettyList (H :: T) depth separator = if depth <= 0 then [PrettyString "..."] else let val v = eventual H; in PrettyBlock (0, false, [], [(if separator = "*" andalso (isFunctionType v orelse isProductType v) then (* Must bracket the expression *) parenthesise depth v else dispP (v, depth)), PrettyBreak (if separator = "," then 0 else 1, 0), PrettyString separator ]) :: PrettyBreak (1, 0) :: prettyList T (depth - 1) separator end; val typ = eventual t; (* Find the real type structure *) in case typ of TypeVar tyVar => let val tyVal : types = tvValue tyVar; in case tyVal of EmptyType => PrettyString (typeVarName tyVar) | _ => dispP (tyVal, depth) end (* Type construction. *) | TypeConstruction {args, name, constr=typeConstructor, ...} => let val constrName = (* Use the type constructor name unless we're had an error. *) if isUndefined typeConstructor then name else tcName typeConstructor (* There are three possible cases: we may not find any type with the name, we may look up the name and find the type or we may look up the name and find a different type. *) datatype isFound = NotFound | FoundMatch | FoundNotMatch (* If we're printing a value that refers to a type constructor we want to print the correct amount of any structure prefix for the current context. *) fun findType (_, []) = NotFound | findType ({ lookupType, ... }, [typeName]) = ( (* This must be the name of a type. *) case lookupType typeName of SOME (t, map) => if eqTypeConstrs(typeConstructor, sigMap, tsConstr t, map) then FoundMatch else FoundNotMatch | NONE => NotFound ) | findType ({ lookupStruct, ... }, structName :: tail) = ( (* This must be the name of a structure. Does it contain our type? *) case lookupStruct structName of SOME(Struct { signat, ...}, map) => let val Signatures { tab, typeIdMap, ...} = signat val Env { lookupType, lookupStruct, ...} = makeEnv tab val newMap = case map of SOME map => composeMaps(typeIdMap, map) | NONE => typeIdMap fun subLookupType s = case lookupType s of NONE => NONE | SOME t => SOME(t, SOME newMap) fun subLookupStruct s = case lookupStruct s of NONE => NONE | SOME t => SOME(t, SOME newMap) in findType({lookupType=subLookupType, lookupStruct=subLookupStruct}, tail) end | NONE => NotFound ) (* See if we have this type in the current environment or in some structure in the current environment. The name we have may be a full structure path. *) fun nameToList ("", l) = (l, NotFound) (* Not there. *) | nameToList (s, l) = let val { first, second } = splitString s val currentList = second :: l in case findType(env, currentList) of FoundMatch => (currentList, FoundMatch) | FoundNotMatch => ( case nameToList(first, currentList) of result as (_, FoundMatch) => result | (l, _) => (l, FoundNotMatch) ) | NotFound => nameToList(first, currentList) end (* Try the type constructor name first. This is usually accurate. If not fall back to the type identifier. This may be needed in rarer cases. *) val names = case nameToList(constrName, []) of (names, FoundMatch) => names (* Found the type constructor name. *) | (names, f) => let (* Try the type identifier name. *) val TypeId { description = { name=idName, ...}, ...} = case (sigMap, tcIdentifier typeConstructor) of (SOME map, TypeId{idKind=Bound{offset, ...}, ...}) => map offset | (_, id) => id (* Only add "?" if we actually found a type with the required name but it wasn't the right one. This allows us to print a sensible result where the type has been shadowed but doesn't affect situations such as where we create a unique type name for a free type variable. *) fun addQuery n = case f of FoundNotMatch => "?" :: n | _ => n in if idName = "" then addQuery names else case nameToList(idName, []) of (idNames, FoundMatch) => idNames | (_, _) => addQuery names (* Print it as "?.t". This isn't ideal but will help in situations where we have redefined "t". *) end val newName = String.concatWith "." names (* Get the declaration position for the type constructor. *) val constrContext = if isUndefined typeConstructor then [] else ( case List.find(fn DeclaredAt _ => true | _ => false) (tcLocations typeConstructor) of SOME(DeclaredAt loc) => [ContextLocation loc] | _ => [] ) val constructorEntry = PrettyBlock(0, false, constrContext, [PrettyString newName(*constrName*)]) in case args of [] => constructorEntry | args as hd :: tl => let val argVal = eventual hd; in PrettyBlock (0, false, [], [ (* If we have just a single argument and it's just a type constructor or a construction we don't need to parenthesise it. *) if null tl andalso not (isProductType argVal orelse isFunctionType argVal) then dispP (argVal, depth - 1) else if depth <= 1 then PrettyString "..." else PrettyBlock(0, false, [], [PrettyString "(", PrettyBreak (0, 0)] @ prettyList args (depth - 1) "," @ [PrettyBreak (0, 0), PrettyString ")"] ), PrettyBreak(1, 0), constructorEntry (* The constructor. *) ]) end end | FunctionType {arg, result} => if depth <= 0 then PrettyString "..." else (* print out in infix notation *) let val evArg = eventual arg; in PrettyBlock (0, false, [], [ (* If the argument is a function it must be printed as (a-> b)->.. *) if isFunctionType evArg then parenthesise depth evArg else dispP (evArg, depth - 1), PrettyBreak(1, 2), PrettyString "->", PrettyBreak (1, 2), dispP (result, depth - 1) ]) end | LabelledType (r as {recList, ...}) => if depth <= 0 then PrettyString "..." else if isProductType typ then (* Print as a product *) PrettyBlock (0, false, [], (* Print them as t1 * t2 * t3 .... *) prettyList (map (fn {typeof, ...} => typeof) recList) depth "*") else (* Print as a record *) let (* The ordering on fields is designed to allow mixing of tuples and records (e.g. #1). It puts shorter names before longer so that #11 comes after #2 and before #100. For named records it does not make for easy reading so we sort those alphabetically when printing. *) val sortedRecList = Misc.quickSort(fn {name = a, ...} => fn {name = b, ...} => a <= b) recList in PrettyBlock (2, false, [], PrettyString "{" :: (let fun pRec [] _ = [] | pRec ({name, typeof} :: T) depth = if depth <= 0 then [PrettyString "..."] else [ PrettyBlock(0, false, [], [ PrettyBlock(0, false, [], [ PrettyString (name ^ ":"), PrettyBreak(1, 0), dispP(typeof, depth - 1) ] @ (if null T then [] else [PrettyBreak (0, 0), PrettyString ","]) ) ]@ (if null T then [] else PrettyBreak (1, 0) :: pRec T (depth-1)) ) ] in pRec sortedRecList (depth - 1) end) @ [ PrettyString (if recordIsFrozen r then "}" else case recList of [] => "...}" | _ => ", ...}")] ) end | OverloadSet {typeset = []} => PrettyString "no type" | OverloadSet {typeset = tconslist} => (* This typically arises when printing error messages in the second pass because the third pass will select a single type e.g. int where possible. To simplify the messages select a single type if possible. *) ( case preferredOverload tconslist of SOME tcons => dispP(mkTypeConstruction (tcName tcons, tcons,[], []), depth) | NONE => (* Just print the type constructors separated by / *) let fun constrLocation tcons = case List.find(fn DeclaredAt _ => true | _ => false) (tcLocations tcons) of SOME(DeclaredAt loc) => [ContextLocation loc] | _ => [] (* Type constructor with context. *) fun tconsItem tcons = PrettyBlock(0, false, constrLocation tcons, [PrettyString(tcName tcons)]) fun printTCcons [] = [] | printTCcons [tcons] = [tconsItem tcons] | printTCcons (tcons::rest) = tconsItem tcons :: PrettyBreak (0, 0) :: PrettyString "/" :: printTCcons rest in PrettyBlock (0, false, [], printTCcons tconslist) end ) | EmptyType => PrettyString "no type" | BadType => PrettyString "bad" end (* dispP *) in dispP (t, depth) end (* tDisp *); (* Generate unique type-variable names. *) fun varNameSequence () : typeVarForm -> string = (* We need to ensure that every distinct type variable has a distinct name. Each new type variable is given a name starting at "'a" and going on through the alphabet. *) let datatype names = Names of {name: string, entry: typeVarForm} val nameNum = ref ~1 val gNameList = ref [] (* List of names *) in (* If the type is already there return the name we have given it otherwise make a new name and put it in the list. *) fn var => case List.find (fn (Names {entry,...}) => sameTv (entry, var)) (!gNameList) of NONE => (* Not on the list - make a new name *) let fun name num = (if num >= 26 then name (num div 26 - 1) else "") ^ String.str (Char.chr (num mod 26 + Char.ord #"a")) val () = nameNum := !nameNum + 1 val n = (if tvEquality var then "''" else "'") ^ name(!nameNum) (* Should explicit type variables be distinguished? *) in gNameList := Names{name=n, entry=var} :: !gNameList; n end | SOME (Names {name,...}) => name end (* varNameSequence *) (* Print a type (as a block of items) *) fun displayWithMap (t : types, depth : FixedInt.int, env, sigMap) = tDisp (t, depth, varNameSequence (), env, sigMap) and display (t : types, depth : FixedInt.int, env) = tDisp (t, depth, varNameSequence (), env, NONE) (* Print out zero, one or more type variables (unblocked) *) fun printTypeVars([], _, _) = [] (* No type vars i.e. monotype *) | printTypeVars([oneVar], depth, typeV) = (* Single type var. *) [ tDisp (TypeVar oneVar, depth, typeV, emptyTypeEnv, NONE), PrettyBreak (1, 0) ] | printTypeVars(vars, depth, typeV) = (* Must parenthesise them. *) if depth <= 1 then [PrettyString "..."] else [ PrettyBlock(0, false, [], PrettyString "(" :: PrettyBreak(0, 0) :: (let fun pVars vars depth: pretty list = if depth <= 0 then [PrettyString "..."] else if null vars then [] else [ tDisp (TypeVar(hd vars), depth, typeV, emptyTypeEnv, NONE), PrettyBreak (0, 0) ] @ (if null (tl vars) then [] else PrettyString "," :: PrettyBreak (1, 0) :: pVars (tl vars) (depth - 1) ) in pVars vars depth end) @ [PrettyString ")"] ), PrettyBreak (1, 0) ] (* Version used in parsetree. *) fun displayTypeVariables (vars : typeVarForm list, depth : FixedInt.int) = printTypeVars (vars, depth, varNameSequence ()) (* Parse tree for types. This is used to represent types in the source. *) datatype typeParsetree = ParseTypeConstruction of { name: string, args: typeParsetree list, location: location, nameLoc: location, argLoc: location, (* foundConstructor is set to the constructor when it has been looked up. This allows us to get the location where it was declared if we export the parse-tree. *) foundConstructor: typeConstrs ref } | ParseTypeProduct of { fields: typeParsetree list, location: location } | ParseTypeFunction of { argType: typeParsetree, resultType: typeParsetree, location: location } | ParseTypeLabelled of { fields: ((string * location) * typeParsetree * location) list, frozen: bool, location: location } | ParseTypeId of { types: typeVarForm, location: location } | ParseTypeBad (* Place holder for errors. *) fun typeFromTypeParse( ParseTypeConstruction{ args, name, location, foundConstructor = ref constr, ...}) = let val argTypes = List.map typeFromTypeParse args in TypeConstruction {name = name, constr = constr, args = argTypes, locations = [DeclaredAt location]} end | typeFromTypeParse(ParseTypeProduct{ fields, ...}) = mkProductType(List.map typeFromTypeParse fields) | typeFromTypeParse(ParseTypeFunction{ argType, resultType, ...}) = mkFunctionType(typeFromTypeParse argType, typeFromTypeParse resultType) | typeFromTypeParse(ParseTypeLabelled{ fields, frozen, ...}) = let fun makeField((name, _), t, _) = mkLabelEntry(name, typeFromTypeParse t) in mkLabelled(sortLabels(List.map makeField fields), frozen) end | typeFromTypeParse(ParseTypeId{ types, ...}) = TypeVar types | typeFromTypeParse(ParseTypeBad) = BadType fun makeParseTypeConstruction((constrName, nameLoc), (args, argLoc), location) = ParseTypeConstruction{ name = constrName, nameLoc = nameLoc, args = args, argLoc = argLoc, location = location, foundConstructor = ref undefConstr } fun makeParseTypeProduct(recList, location) = ParseTypeProduct{ fields = recList, location = location } fun makeParseTypeFunction(arg, result, location) = ParseTypeFunction{ argType = arg, resultType = result, location = location } fun makeParseTypeLabelled(recList, frozen, location) = ParseTypeLabelled{ fields = recList, frozen = frozen, location = location } fun makeParseTypeId(types, location) = ParseTypeId{ types = types, location = location } fun unitTree location = ParseTypeLabelled{ fields = [], frozen = true, location = location } (* Build an export tree from the parse tree. *) fun typeExportTree(navigation, p: typeParsetree) = let val typeof = typeFromTypeParse p (* Common properties for navigation and printing. *) val commonProps = PTprint(fn d => display(typeof, d, emptyTypeEnv)) :: PTtype typeof :: exportNavigationProps navigation fun asParent () = typeExportTree(navigation, p) in case p of ParseTypeConstruction{ location, nameLoc, args, argLoc, ...} => let (* If the constructor has been bound return the declaration location. We have to attach the declaration location in the right place if this is a polytype e.g. if we have "int list" here we will have the location for "list" which is the second item not the first. *) val (name, decLoc) = case typeof of TypeConstruction { constr, name, ...} => if isUndefined constr then (name, []) else (name, mapLocationProps(tcLocations constr)) | _ => ("", []) (* Error? *) val navNameAndArgs = (* Separate cases for nullary, unary and higher type constructions. *) case args of [] => decLoc (* Singleton e.g. int *) | [oneArg] => let (* Single arg e.g. int list. *) (* Navigate between the type constructor and the argument. Since the arguments come before the constructor we go there first. *) fun getArg () = typeExportTree({parent=SOME asParent, previous=NONE, next=SOME getName}, oneArg) and getName () = getStringAsTree({parent=SOME asParent, previous=SOME getArg, next=NONE}, name, nameLoc, decLoc) in [PTfirstChild getArg] end | args => let (* Multiple arguments e.g. (int, string) pair *) fun getArgs () = (argLoc, exportList(typeExportTree, SOME getArgs) args @ exportNavigationProps{parent=SOME asParent, previous=NONE, next=SOME getName}) and getName () = getStringAsTree({parent=SOME asParent, previous=SOME getArgs, next=NONE}, name, nameLoc, decLoc) in [PTfirstChild getArgs] end in (location, navNameAndArgs @ commonProps) end | ParseTypeProduct{ location, fields, ...} => (location, exportList(typeExportTree, SOME asParent) fields @ commonProps) | ParseTypeFunction{ location, argType, resultType, ...} => (location, exportList(typeExportTree, SOME asParent) [argType, resultType] @ commonProps) | ParseTypeLabelled{ location, fields, ...} => let fun exportField(navigation, label as ((name, nameLoc), t, fullLoc)) = let (* The first position is the label, the second the type *) fun asParent () = exportField (navigation, label) fun getLab () = getStringAsTree({parent=SOME asParent, next=SOME getType, previous=NONE}, name, nameLoc, [PTtype(typeFromTypeParse t)]) and getType () = typeExportTree({parent=SOME asParent, previous=SOME getLab, next=NONE}, t) in (fullLoc, PTfirstChild getLab :: exportNavigationProps navigation) end in (location, exportList(exportField, SOME asParent) fields @ commonProps) end | ParseTypeId{ location, ...} => (location, commonProps) | ParseTypeBad => (nullLocation, commonProps) end fun displayTypeParse(types, depth, env) = display(typeFromTypeParse types, depth, env) (* Associates type constructors from the environment with type identifiers (NOT type variables) *) fun assignTypes (tp : typeParsetree, lookupType : string * location -> typeConstrSet, lex : lexan) = let fun typeFromTypeParse(ParseTypeConstruction{ args, name, location, foundConstructor, ...}) = let (* Assign constructor, then the parameters. *) val TypeConstrSet(constructor, _) = lookupType (name, location) val () = (* Check that it has the correct arity. *) if not (isUndefined constructor) then let val arity : int = tcArity constructor; val num : int = length args; in if arity <> num then (* Give an error message *) errorMessage (lex, location, String.concat["Type constructor (", tcName constructor, ") requires ", Int.toString arity, " type(s) not ", Int.toString num]) else foundConstructor := constructor end else () val argTypes = List.map typeFromTypeParse args in TypeConstruction {name = name, constr = constructor, args = argTypes, locations = [DeclaredAt location]} end | typeFromTypeParse(ParseTypeProduct{ fields, ...}) = mkProductType(List.map typeFromTypeParse fields) | typeFromTypeParse(ParseTypeFunction{ argType, resultType, ...}) = mkFunctionType(typeFromTypeParse argType, typeFromTypeParse resultType) | typeFromTypeParse(ParseTypeLabelled{ fields, frozen, ...}) = let fun makeField((name, _), t, _) = mkLabelEntry(name, typeFromTypeParse t) in mkLabelled(sortLabels(List.map makeField fields), frozen) end | typeFromTypeParse(ParseTypeId{ types, ...}) = TypeVar types | typeFromTypeParse(ParseTypeBad) = BadType in typeFromTypeParse tp end; (* When we have finished processing a list of patterns we need to check that the record is now frozen. *) fun recordNotFrozen (TypeVar t) : bool = (* Follow the chain *) recordNotFrozen (tvValue t) | recordNotFrozen (LabelledType r) = not(recordIsFrozen r) | recordNotFrozen _ = false (* record or type alias *); datatype generalMatch = Matched of {old: typeVarForm, new: types}; fun generaliseTypes (atyp : types, checkTv: typeVarForm->types option) = let val madeList = ref [] (* List of tyVars. *); fun tvs atyp = let val tyVar = typesTypeVar atyp; in case List.find(fn Matched{old, ...} => sameTv (old, tyVar)) (!madeList) of SOME(Matched{new, ...}) => new | NONE => ( case checkTv tyVar of SOME found => found | NONE => let (* Not on the list - make a new name *) (* Make a unifiable type variable even if the original is nonunifiable. *) val n : types = mkTypeVar (generalisable, tvEquality tyVar, false, tvPrintity tyVar) in (* Set the new variable to have the same value as the existing. That is only really needed if we have an overload set. *) tvSetValue (typesTypeVar n, tvValue tyVar); madeList := Matched {old = tyVar, new = n} :: !madeList; n end ) end fun copyTypeVar (atyp as TypeVar tyVar) = if tvLevel tyVar <> generalisable then atyp (* Not generalisable. *) else (* Unbound, overload set or flexible record *) let val newTv = tvs atyp in (* If we have a type variable pointing to a flexible record we have to copy the type pointed at by the variable. *) case tvValue tyVar of valu as LabelledType _ => tvSetValue (typesTypeVar newTv, copyType (valu, copyTypeVar, fn t => t)) | _ => (); newTv end | copyTypeVar atyp = atyp val copied = (* Only process type variables. Return type constructors unchanged. *) copyType (atyp, copyTypeVar, fn t => t (*copyTCons*)) in (copied, ! madeList) end (* generaliseTypes *); (* Exported wrapper for generaliseTypes. *) fun generalise atyp = let val (t, newMatch) = generaliseTypes (atyp, fn _ => NONE) fun makeResult(Matched{new, old}) = {value=new, equality=tvEquality old, printity=tvPrintity old} in (t, List.map makeResult newMatch) end; (* Return the original polymorphic type variables. *) fun getPolyTypeVars(atyp, map) = let val (_, newMatch) = generaliseTypes (atyp, map) in List.map (fn(Matched{old, ...}) => old) newMatch end; fun generaliseWithMap(atyp, map) = let val (t, newMatch) = generaliseTypes (atyp, map) fun makeResult(Matched{new, old}) = {value=new, equality=tvEquality old, printity=tvPrintity old} in (t, List.map makeResult newMatch) end (* Find the argument type which gives this result when the constructor is applied. If we have, for example, a value of type int list and we have discovered that this is a "::" node we have to work back by comparing the type of "::" ('a * 'a list -> 'a list) to find the argument of the constructor (int * int list) and hence how to print it. (Actually "list" is treated specially). *) fun constructorResult (FunctionType{arg, result=TypeConstruction{args, ...}}, typeArgs) = let val matches = ListPair.zip(List.map typesTypeVar args, typeArgs) fun getArg tv = case List.find(fn (atv, _) => sameTv(tv, atv)) matches of SOME (_, ty) => SOME ty | NONE => NONE in #1 (generaliseTypes(arg, getArg)) end | constructorResult _ = raise InternalError "Not a function type" (* If we have a type construction which is an alias for another type we construct the alias by first instantiating all the type variables and then copying the type. *) fun makeEquivalent (atyp, args) = case tcIdentifier atyp of TypeId{idKind=TypeFn(typeArgs, typeResult), ...} => let val matches = ListPair.zip(typeArgs, args) fun getArg tv = case List.find(fn (atv, _) => sameTv(tv, atv)) matches of SOME (_, ty) => SOME ty | NONE => NONE in #1 (generaliseTypes(typeResult, getArg)) end | TypeId _ => raise InternalError "makeEquivalent: Not a type function" (* Look for the occurrence of locally declared datatypes in the type of a value. *) fun checkForEscapingDatatypes(ty: types, errorFn: string->unit) : unit = let fun checkTypes (typ: types) (ok: bool) : bool = case typ of TypeConstruction {constr, args, ...} => if tcIsAbbreviation constr then (* May be an alias for a type that contains a local datatype. *) foldType checkTypes (makeEquivalent (constr, args)) ok else if ok then ( case tcIdentifier constr of TypeId{access=Local{addr, ...}, ...} => if !addr < 0 then ( errorFn("Type of expression contains local datatype (" ^ tcName constr ^") outside its definition."); false ) else true | _ => true (* Could we have a "selected" entry with a local datatype? *) ) else false | _ => ok in foldType checkTypes ty true; () end (* This 3-valued logic is used because in a few cases we may not be sure if equality testing is allowed. If we have 2 mutually recursive datatypes t = x of s | ... and s = z of t we would first examine "t", find that it uses "s", look at "s", find that refers back to "t". To avoid infinite recursion we return the result that equality "maybe" allowed for "t" and hence for "s". However we may find that the other constructors for "t" do not allow equality and so equality will not be allowed for "s" either. *) datatype tri = Yes (* 3-valued logic *) | No | Maybe; (* Returns a flag saying if equality testing is allowed for values of the given type. "equality" is used both to generate the code for a specific call of equality e.g. (a, b, c) = f(x), and to generate the equality operation for a type when it is declared. In the latter case type variables may be parameters which will be filled in later e.g. type 'a list = nil | op :: of ('a * 'a list). "search" is a function which looks up constructors in mutually recursive type declarations. "lookupTypeVar" deals with type variables. If they represent parameters to a type declaration equality checking will be allowed. If we are unifying this type to an equality type variable they will be unified to new equality type variables. Otherwise equality is not allowed. *) fun equality (ty, search, lookupTypeVar) : tri = let (* Can't use foldT because it is not monotonic (equality on ref 'a is allowed). *) (* Returns Yes only if equality testing is allowed for all types in the list. *) fun eqForList ([], soFar) = soFar | eqForList (x::xs, soFar) = case equality (x, search, lookupTypeVar) of No => No | Maybe => eqForList (xs, Maybe) | Yes => eqForList (xs, soFar); in case eventual ty of TypeVar tyVar => (* The type variable may point to a flexible record or an overload set or it may be the end of the chain. If this is a labelled record we have to make sure that any fields we add also admit equality. lookupTypeVar makes the type variable an equality type so that any new fields are checked for equality but we also have to call "equality" to check the existing fields. *) if tvEquality tyVar then Yes else ( case tvValue tyVar of lab as LabelledType _ => ( case lookupTypeVar tyVar of No => No | _ => equality (lab, search, lookupTypeVar) ) | _ => lookupTypeVar tyVar ) | FunctionType {...} => No (* No equality on function types! *) | TypeConstruction {constr, args, ...} => if isUndefined constr then No else if tcIsAbbreviation constr then (* May be an alias for a type that allows equality. *) equality (makeEquivalent (constr, args), search, lookupTypeVar) (* ref - Equality is permitted on refs of all types *) (* The Definition of Standard ML says that ref is the ONLY type constructor which is treated in this way. The standard basis library says that other mutable types such as array should also work this way. *) else if isPointerEqType(tcIdentifier constr) then Yes (* Others apart from ref and real *) else if tcEquality constr (* Equality allowed. *) then eqForList (args, Yes) (* Must be allowed for all the args *) else let (* Not an alias. - Look it up. *) val s = search (tcIdentifier constr); in if s = No then No else eqForList (args, s) end (* TypeConstruction *) | LabelledType {recList, ...} => (* Record equality if all subtypes are (ignore frozen!) *) (* TODO: Avoid copying the list? *) eqForList (map (fn{typeof, ...}=>typeof) recList, Yes) | OverloadSet _ => (* This should not happen because all overload sets should be pointed to by type variables and so should be handled in the TypeVar case. *) raise InternalError "equality - Overloadset found" | BadType => No | EmptyType => No (* shouldn't occur *) end (* When a datatype is declared we test to see if equality is allowed. The types are mutually recursive so value constructors of one type may take arguments involving values of any of the others. *) fun computeDatatypeEqualities(types: typeConstrSet list, boundIdEq) = let datatype state = Processed of tri (* Already processed or processing. *) | NotSeen of typeConstrSet list (* Value is list of constrs. *); (* This table tells us, for each type constructor, whether it definitely admits equality, definitely does not or whether we have yet to look at it. *) fun isProcessed (Processed _) = true | isProcessed _ = false; fun stateProcessed (Processed x) = x | stateProcessed _ = raise Match; fun stateNotSeen (NotSeen x) = x | stateNotSeen _ = raise Match; val {enter:typeId * state -> unit,lookup} = mapTable sameTypeId; (* Look at each of the constructors in the list. Equality testing is only allowed if it is allowed for each of the alternatives. *) fun constrEq _ [] soFar = soFar (* end of list - all o.k. *) | constrEq constructor (h :: t) soFar = (* The constructor may be a constant e.g. datatype 'a list = nil | ... or a function e.g. datatype 'a list = ... cons of 'a * 'a list. *) if not (isFunctionType (valTypeOf h)) (* Constant *) then constrEq constructor t soFar (* Go on to the next. *) else let (* Function - look at the argument type. *) (* Equality is allowed for any type-variable. The only type variables allowed are parameters to the datatype so if we have a type variable then equality is allowed for this datatype. *) val eq = equality (#arg (typesFunctionType (valTypeOf h)), genEquality, fn _ => Yes); in if eq = No then (* Not allowed. *) No else (* O.k. - go on to the next. *) constrEq constructor t (if eq = Maybe then Maybe else soFar) end (* constrEq *) (* This procedure checks to see if equality is allowed for this datatype. *) and genEquality constructorId = let (* Look it up to see if we have already done it. It may fail because we may have constructors that do not admit equality. *) val thisState = case (lookup constructorId, constructorId) of (SOME inList, _) => inList | (NONE, TypeId{idKind = Bound{offset, ...}, ...}) => Processed(if boundIdEq offset then Yes else No) | _ => Processed No in if isProcessed thisState then stateProcessed thisState (* Have either done it already or are currently doing it. *) else (* notSeen - look at it now. *) let (* Equality is allowed for this datatype only if all of them admit it. There are various other alternatives but this is what the standard says. If the "name" is rigid (free) we must not grant equality if it is not already there although that is not an error. *) (* Set the state to "Maybe". This prevents infinite recursion. *) val () = enter (constructorId, Processed Maybe); val eq = List.foldl (fn (cons, t) => if t = No then No else constrEq cons (tsConstructors cons) t) Yes (stateNotSeen thisState); in (* Set the state we have found if it is "yes" or "no". If it is maybe we have a recursive reference which appears to admit equality, but may not. E.g. if we have datatype t = A of s | B of int->int and s = C of t if we start processing "t" we will go on to "s" and do that before returning to "t". It is only later we find that "t" does not admit equality. If we get "Maybe" as the final result when all the recursion has been unwound we can set the result to "yes", but any intermediate "Maybe"s have to be done again. *) enter (constructorId, if eq = Maybe then thisState else Processed eq); eq end end (* genEquality *); in (* If we have an eqtype we set it to true, otherwise we set all of them to "notSeen" with the constructor as value. *) List.app (fn dec as TypeConstrSet(decCons, _) => let (* If we have two datatypes which share we may already have one in the table. We have to link them together. *) val tclist = case lookup (tcIdentifier decCons) of NONE => [dec] | SOME l => let val others = stateNotSeen l val newList = dec :: others; in (* If any of these are already equality types (i.e. share with an eqtype) then they all must be. *) if tcEquality decCons orelse tcEquality (tsConstr(hd others)) then List.app (fn d => tcSetEquality (tsConstr d, true)) newList else (); newList end in enter (tcIdentifier decCons, NotSeen tclist) end) types; (* Apply genEquality to each element of the list. *) List.app (fn TypeConstrSet(constructor, _) => let val constructorId = tcIdentifier constructor; val eqForCons = genEquality constructorId; in (* If the result is "Maybe" it involves a recursive reference, but the rest of the type allows equality. The type admits equality. *) if eqForCons = No then () (* Equality not allowed *) else ( (* Turn on equality. *) enter (constructorId, Processed Yes); tcSetEquality (constructor, true) ) end) types end (* computeDatatypeEqualities *); datatype matchResult = SimpleError of types * types * string | TypeConstructorError of types * types * typeConstrs * typeConstrs (* Type matching algorithm for both unification and signature matching. *) (* The mapping has now been moved out of here. Instead when signature matching the target signature is copied before this is called which means that this process is now symmetric. There may be some redundant tests left in here. *) fun unifyTypes(Atype : types, Btype : types) : matchResult option = let (* Get the result in here. This isn't very ML-like but it greatly simplifies converting the code. *) val matchResult: matchResult option ref = ref NONE fun matchError error = (* Only report one error. *) case matchResult of ref (SOME _) => () | r => r := SOME error fun cantMatch(alpha, beta, text) = matchError(SimpleError(alpha, beta, text)) fun match (Atype : types, Btype : types) : unit = let (* Check two records/tuples and return the combined type. *) fun unifyRecords (rA as {recList=typAlist, fullList = gA}, rB as {recList=typBlist, fullList = gB}, typA : types, typB : types) : types = let val typAFrozen = recordIsFrozen rA and typBFrozen = recordIsFrozen rB fun matchLabelled ([], []) = [] (* Something left in bList - this is fine if typeA is not frozen. e.g. (a: s, b: t) will match (a: s, ...) but not just (a:s). *) | matchLabelled ([], bList as {name=bName, ...} :: _) = ( if typAFrozen then cantMatch (typA, typB, "(Field " ^ bName ^ " missing)") else (); bList (* return the remainder of the list *) ) | matchLabelled (aList as {name=aName, ...} :: _, []) = (* Something left in bList *) ( if typBFrozen then cantMatch (typA, typB, "(Field " ^ aName ^ " missing)") else (); aList (* the rest of aList *) ) | matchLabelled (aList as ((aVal as {name=aName,typeof=aType})::aRest), bList as ((bVal as {name=bName,typeof=bType})::bRest)) = (* both not nil - look at the names. *) let val order = compareLabels (aName, bName); in if order = 0 (* equal *) then (* same name - must be unifiable types *) ( (* The result is (either) one of these with the rest of the list. *) match (aType, bType); aVal :: matchLabelled (aRest, bRest) ) else if order < 0 (* aName < bName *) then (* The entries in each list are in order so this means that this entry is not in bList. If the typeB is frozen this is an error. *) if typBFrozen (* Continue with the entry removed. *) then (cantMatch (typA, typB, "(Field " ^ aName ^ " missing)"); aList) else aVal :: matchLabelled (aRest, bList) else (* aName > bName *) if typAFrozen then (cantMatch (typA, typB, "(Field " ^ bName ^ " missing)"); bList) else bVal :: matchLabelled (aList, bRest) end (* not nil *); (* Return the combined list. Only actually used if both are flexible. *) val result = if typAFrozen andalso typBFrozen andalso List.length typAlist <> List.length typBlist then (* Don't attempt to unify the fields if we have the wrong number of items. If we've added or removed an item from a tuple e.g. a function with multiple arguments, it's more useful to know this than to get unification errors on fields that don't match. *) (cantMatch (typA, typB, "(Different number of fields)"); []) else matchLabelled (typAlist, typBlist) fun lastFlex(FlexibleList(ref(r as FlexibleList _))) = lastFlex r | lastFlex(FlexibleList r) = SOME r | lastFlex(FieldList _) = NONE in if typAFrozen then (if typBFrozen then () else valOf(lastFlex gB) := gA; typA) else if typBFrozen then (valOf(lastFlex gA) := gB; typB) else let (* We may have these linked already in which case we shouldn't do anything. *) val lastA = valOf(lastFlex gA) and lastB = valOf(lastFlex gB) in if lastA = lastB then () else let val genericFields = FieldList(map #name result, false) in (* If these are both flexible we have link all the generics together so that if we freeze any one of them they all get frozen. *) lastA := genericFields; lastB := FlexibleList lastA end; LabelledType {recList = result, fullList = gA} end end (* unifyRecords *); (* Sets a type variable to a value. - Checks that the type variable we are assigning does not occur in the expression we are about to assign to it. Such cases can occur if we have infinitely-typed expressions such as fun a. a::a where a has type 'a list list ... Also propagates the level information of the type variable. Now also deals with flexible records. *) fun assign (var, t) = let (* Mapped over the type to be assigned. *) (* Returns "false" if it is safe to make the assignment. Sorts out imperative type variables and propagates level information. N.B. It does not propagate equality status. The reason is that if we are unifying ''a with 'b ref, the 'b does NOT become an equality type var. In all other cases it would. *) fun occursCheckFails _ true = true | occursCheckFails ty false = let val t = eventual ty in case t of TypeVar tvar => let (* The level is the minimum of the two, and if we are unifying with an equality type variable we must make this into one. *) val minLev = Int.min (tvLevel var, tvLevel tvar) val oldValue = tvValue tvar in if tvLevel tvar <> minLev then (* If it is nonunifiable we cannot make its level larger. *) if tvNonUnifiable tvar then cantMatch (Atype, Btype, "(Type variable is free in surrounding scope)") else let (* Must make a new type var with the right properties *) (* This type variable may be a flexible record, in which case we have to save the record and put it on the new type variable. We have to do this for the record itself so that new fields inherit the correct status and also for any existing fields. *) val newTv = mkTypeVar (minLev, tvEquality tvar, false, tvPrintity tvar) in tvSetValue (typesTypeVar newTv, oldValue); tvSetValue (tvar, newTv) end else (); (* Safe if vars are different but we also have to check any flexible records. *) occursCheckFails oldValue (sameTv (tvar, var)) end | TypeConstruction {args, constr, ...} => (* If this is a type abbreviation we have to expand this before processing any arguments. We mustn't process arguments that are not actually used. *) if tcIsAbbreviation constr then occursCheckFails(makeEquivalent (constr, args)) false else List.foldr (fn (t, v) => occursCheckFails t v) false args | FunctionType {arg, result} => occursCheckFails arg false orelse occursCheckFails result false | LabelledType {recList,...} => List.foldr (fn ({ typeof, ... }, v) => occursCheckFails typeof v) false recList | _ => false end val varVal = tvValue var (* Current value of the variable to be set. *) local (* We need to process any type abbreviations before applying the occurs check. The type we're assigning could boil down to the same type variable we're trying to assign. This doesn't breach the occurs check. *) fun followVarsAndTypeFunctions t = case eventual t of ev as TypeConstruction{constr, args, ...} => if tcIsAbbreviation constr then followVarsAndTypeFunctions(makeEquivalent (constr, args)) else ev | ev => ev in val finalType = followVarsAndTypeFunctions t end (* We may actually have the same type variable after any type abbreviations have been followed. *) val reallyTheSame = case finalType of TypeVar tv => sameTv (tv, var) | _ => false in (* start of "assign" *) case varVal of LabelledType _ => (* Flexible record. Check that the records are compatible. *) match (varVal, t) | OverloadSet _ => (* OverloadSet. Check that the sets match. This is only in the case where t is something other than an overload set since we remove the overload set from a variable when unifying two sets. *) match (varVal, t) | _ => (); if reallyTheSame then () (* Don't apply the occurs check or check for non-unifiable. *) (* If this type variable was put in explicitly then it can't be assigned to something else. (We have already checked for the type variables being the same). *) else if tvNonUnifiable var then cantMatch (Atype, Btype, "(Cannot unify with explicit type variable)") else if occursCheckFails finalType false then cantMatch (Atype, Btype, "(Type variable to be unified occurs in type)") else let (* Occurs check succeeded. *) fun canMkEqTv (tvar : typeVarForm) : tri = (* Turn it into an equality type var. *) if tvEquality tvar then Yes (* If it is nonunifiable we cannot make it into an equality type var. *) else if tvNonUnifiable tvar then No else (* Must make a new type var with the right properties *) let (* This type variable may be a flexible record or an overload set, in which case we have to save the record and put it on the new type variable. We have to do both because we have to ensure that the existing fields in the flexible record admit equality and ALSO that any additional fields we may add by unification with other records also admit equality. *) val newTv = mkTypeVar (tvLevel tvar, true, false, tvPrintity tvar) val oldValue = tvValue tvar in tvSetValue (tvar, newTv); (* If this is an overloaded type we must remove any types that don't admit equality. *) case oldValue of OverloadSet{typeset} => let (* Remove any types which do not admit equality. *) fun filter [] = [] | filter (h::t) = if tcEquality h then h :: filter t else filter t in case filter typeset of [] => No | [constr] => ( (* Turn a singleton into a type construction. *) tvSetValue (typesTypeVar newTv, mkTypeConstruction(tcName constr, constr, nil, [])); Yes ) | newset => ( tvSetValue (typesTypeVar newTv, OverloadSet{typeset=newset}); Yes ) end | _ => (* Labelled record or unbound variable. *) ( tvSetValue (typesTypeVar newTv, oldValue); Yes ) end in (* If we are unifying a type with an equality type variable we must ensure that equality is allowed for that type. This will turn most type variables into equality type vars. *) if tvEquality var andalso equality (t, fn _ => No, canMkEqTv) = No then cantMatch (Atype, Btype, "(Requires equality type)") (* TODO: This can result in an unhelpful message if var is bound to a flexible record since there is no indication in the printed type that the flexible record is an equality type. It would be improved if we set the value to be EmptyType. At least then the type variable would be printed which would be an equality type. --- Adding the "Requires equality type" should improve things. *) else (); (* Propagate the "printity" status. This is probably not complete but doesn't matter too much since this is a Poly extension. *) if tvPrintity var then let fun makePrintity(TypeVar tv) _ = ( if tvPrintity tv then () else case tvValue tv of (* If it's an overload set we don't need to do anything. This will eventually be a monotype. *) OverloadSet _ => () | oldValue => let (* Labelled record or unbound variable. *) val newTv = mkTypeVar (tvLevel tv, tvEquality tv, tvNonUnifiable tv, true) in tvSetValue(tv, newTv); (* Put this on the chain if it's a labelled record. *) tvSetValue (typesTypeVar newTv, oldValue) end ) | makePrintity _ _ = () in foldType makePrintity t () end else (); (* Actually make the assignment. It doesn't matter if var is a labelled record, because t will be either a fixed record or a combination of the fields of var and t. Likewise if var was previously an overload set this may replace the set by a single type construction. *) (* If we have had an error don't make the assignment. At the very least it could prevent us producing useful error information and it could also result in unnecessary consequential errors. *) case !matchResult of NONE => tvSetValue (var, t) | SOME _ => () end end (* assign *); (* First find see if typeA and typeB are unified to anything already, and get the end of a list of "flexibles". *) val tA = eventual Atype and tB = eventual Btype in (* start of "match" *) if isUndefinedType tA orelse isUndefinedType tB then () (* If either of these was an undefined type constructor don't try to match. TODO: There are further tests below for this which are now redundant. *) else case (tA, tB) of (BadType, _) => () (* If either is an error don't try to match *) | (_, BadType) => () | (TypeVar typeAVar, TypeVar typeBVar) => (* Unbound type variable, flexible record or overload set. *) let (* Even if this is a one-way match we can allow type variables in the typeA to be instantiated to anything in the typeB. *) val typeAVal = tvValue typeAVar; (* We have two unbound type variables or flex. records. *) in if sameTv (typeAVar, typeBVar) (* same type variable? *) then () else (* no - assign one to the other *) if tvNonUnifiable typeAVar (* If we have a nonunifiable type variable we want to assign the typeB to it. If the typeB is nonunifiable as well we will get an error message. *) then assign (typeBVar, tA) else let (* If they are both flexible records we first set the typeB to the union of the records, and then set the typeA to that. In that way we propagate properties such as equality and level between the two variables. *) val typBVal = tvValue typeBVar in case (typeAVal, typBVal) of (LabelledType recA, LabelledType recB) => ( (* Turn these back into simple type variables to save checking the combined record against the originals when we make the assignment. (Would be safe but redundant). *) tvSetValue (typeBVar, emptyType); tvSetValue (typeAVar, emptyType); assign (typeBVar, unifyRecords (recA, recB, typeAVal, typBVal)); assign (typeAVar, tB) ) | (OverloadSet{typeset=setA}, OverloadSet{typeset=setB}) => let (* The lists aren't ordered so we just have to go through by hand. *) fun intersect(_, []) = [] | intersect(a, H::T) = if isInSet(H, a) then H::intersect(a, T) else intersect(a, T) val newSet = intersect(setA, setB) in case newSet of [] => cantMatch (Atype, Btype, "(Incompatible overloadings)") | _ => ( tvSetValue (typeBVar, emptyType); tvSetValue (typeAVar, emptyType); (* I've changed this from OverloadSet{typeset=newset} to use mkOverloadSet. The main reason was that it fixed a bug which resulted from a violation of the assumption that "equality" would not be passed an overload set except when pointed to by a type variable. It also removed the need for a separate test for singleton sets since mkOverloadSet deals with them. DCJM 1/9/00. *) assign (typeBVar, mkOverloadSet newSet); assign (typeAVar, tB) ) end | (EmptyType, _) => (* A is not a record or an overload set. *) assign (typeAVar, tB) | (_, EmptyType) => (* A is a record but B isn't *) assign (typeBVar, tA) (* typeB is ordinary type var. *) | _ => (* Bad combination of labelled record and overload set *) cantMatch (Atype, Btype, "(Incompatible types)") end end | (TypeVar typeAVar, _) => (* typeB is not a type variable so set typeA to typeB.*) (* Be careful if this is a non-unifiable type variable being matched to the special case of the identity type-construction. *) ( if tvNonUnifiable typeAVar orelse (case tvValue typeAVar of OverloadSet _ => true | _ => false) then ( case tB of TypeConstruction {constr, args, ...} => if isUndefined constr orelse not (tcIsAbbreviation constr) then ( case tB of TypeConstruction {constr, args, ...} => if isUndefined constr orelse not (tcIsAbbreviation constr) then assign (typeAVar, tB) else match(tA, eventual (makeEquivalent (constr, args))) | _ => assign (typeAVar, tB) ) else match(tA, eventual (makeEquivalent (constr, args))) | _ => assign (typeAVar, tB) ) else assign (typeAVar, tB) ) | (_, TypeVar typeBVar) => (* and typeA is not *) ( (* We have to check for the special case of the identity type-construction. *) if tvNonUnifiable typeBVar orelse (case tvValue typeBVar of OverloadSet _ => true | _ => false) then ( case tA of TypeConstruction {constr, args, ...} => if isUndefined constr orelse not (tcIsAbbreviation constr) then ( case tB of TypeVar tv => (* This will fail if we are matching a signature because the typeB will be non-unifiable. *) assign (tv, tA) (* set typeB to typeA *) | typB => match (tA, typB) ) else match(eventual (makeEquivalent (constr, args)), tB) | _ => ( case tB of TypeVar tv => (* This will fail if we are matching a signature because the typeB will be non-unifiable. *) assign (tv, tA) (* set typeB to typeA *) | typB => match (tA, typB) ) ) else ( case tB of TypeVar tv => (* This will fail if we are matching a signature because the typeB will be non-unifiable. *) assign (tv, tA) (* set typeB to typeA *) | typB => match (tA, typB) ) ) | (TypeConstruction({constr = tACons, args=tAargs, ...}), TypeConstruction ({constr = tBCons, args=tBargs, ...})) => ( (* We may have a number of possibilities here. a) If tA is an alias we simply expand it out and recurse (even if tB is the same alias). e.g. if we have string t where type 'a t = int*'a we expand string t into int*string and try to unify that. b) map it and see if the result is an alias. -- NOW REMOVED c) If tB is a type construction and it is an alias we expand that e.g. unifying "int list" and "int t" where type 'a t = 'a list (particularly common in signature/structure matching.) d) Finally we try to unify the stamps and the arguments. *) if isUndefined tACons orelse isUndefined tBCons then () (* If we've had an undefined type constructor don't try to check further. *) else if tcIsAbbreviation tACons (* Candidate is an alias - expand it. *) then match (makeEquivalent (tACons, tAargs), tB) else if tcIsAbbreviation tBCons then match (tA, makeEquivalent (tBCons, tBargs)) else if tcIsAbbreviation tBCons (* If the typeB is an alias it must be expanded. *) then match (tA, makeEquivalent (tBCons, tBargs)) else if sameTypeId (tcIdentifier tACons, tcIdentifier tBCons) then let (* Same type constructor - do the arguments match? *) fun matchLists [] [] = () | matchLists (a::al) (b::bl) = ( match (a, b); matchLists al bl ) | matchLists _ _ = (* This should only happen as a result of a different error. *) cantMatch (Atype, Btype, "(Different numbers of arguments)") in matchLists tAargs tBargs end (* When we have different type constructors, especially two with the same name, we try to produce more information. *) else matchError(TypeConstructorError(tA, tB, tACons, tBCons)) ) | (OverloadSet {typeset}, TypeConstruction {constr=tBCons, args=tBargs, ...}) => (* The candidate is an overloaded type and the target is a type construction. *) ( if not (isUndefined tBCons orelse not (tcIsAbbreviation tBCons)) then match (tA, makeEquivalent (tBCons, tBargs)) else if isUndefined tBCons then () else if tcIsAbbreviation tBCons then match (tA, makeEquivalent (tBCons, tBargs)) else (* See if the target type is among those in the overload set. *) if null tBargs (* Must be a nullary type constructor. *) andalso isInSet(tBCons, typeset) then () (* ok. *) (* Overload sets arise primarily with literals such as "1" and it's most likely that the error is a mismatch between int and another type rather than that the user assumed that the literal was overloaded on a type it actually wasn't. *) else case preferredOverload typeset of NONE => cantMatch (tA, tB, "(Different type constructors)") | SOME prefType => matchError( TypeConstructorError( mkTypeConstruction (tcName prefType, prefType,[], []), tB, prefType, tBCons)) ) | (TypeConstruction {constr=tACons, args=tAargs, ...}, OverloadSet {typeset}) => ( if not (isUndefined tACons orelse not (tcIsAbbreviation tACons)) then match (makeEquivalent (tACons, tAargs), tB) (* We should never find an overload set as the target for a signature match but it is perfectly possible for tB to be an overload set when unifying two types. *) else if null tAargs andalso isInSet(tACons, typeset) then () (* ok. *) else case preferredOverload typeset of NONE => cantMatch (tA, tB, "(Different type constructors)") | SOME prefType => matchError( TypeConstructorError( tA, mkTypeConstruction (tcName prefType, prefType,[], []), tACons, prefType)) ) | (OverloadSet _ , OverloadSet _) => raise InternalError "Unification: OverloadSet/OverloadSet" (* (OverloadSet , OverloadSet) should not occur because that should be handled in the (TypeVar, TypeVar) case. *) | (TypeConstruction({constr = tACons, args=tAargs, ...}), _) => if not (isUndefined tACons orelse not (tcIsAbbreviation tACons)) (* Candidate is an alias - expand it. *) then match (makeEquivalent (tACons, tAargs), tB) else (* typB not a construction (but typeA is) *) cantMatch (tA, tB, "(Incompatible types)") | (_, TypeConstruction {constr=tBCons, args=tBargs, ...}) => (* and typeA is not. *) (* May have a type equivalence e.g. "string t" matches int*string if type 'a t = int * 'a . Alternatively we may be matching a structure to a signature where the signature says "type t" and the structure contains "type t = int->int" (say). We need to set the type in the signature to int->int. *) if not (isUndefined tBCons orelse not (tcIsAbbreviation tBCons)) then match (tA, makeEquivalent (tBCons, tBargs)) else if isUndefined tBCons then () else if tcIsAbbreviation tBCons then match (tA, makeEquivalent (tBCons, tBargs)) else cantMatch (tB, tA, "(Incompatible types)") | (FunctionType {arg=typAarg, result=typAres, ...}, FunctionType {arg=typBarg, result=typBres, ...}) => ( (* must be unifiable functions *) (* In principle it doesn't matter whether we unify arguments or results first but it could affect the error messages. Is this the best way to do it? *) match (typAarg, typBarg); match (typAres, typBres) ) | (EmptyType, EmptyType) => () (* This occurs only with exceptions - empty means no argument *) | (LabelledType recA, LabelledType recB) => (* Unify the records, but discard the result because at least one of the records is frozen. *) (unifyRecords (recA, recB, tA, tB); ()) | _ => cantMatch (tA, tB, "(Incompatible types)") end (* match *) in match (Atype, Btype); ! matchResult end (* unifyTypes *) (* Turn a result from matchTypes into a pretty structure so that it can be included in a message. *) fun unifyTypesErrorReport (_, alphaTypeEnv, betaTypeEnv, what) = let fun reportError(SimpleError(alpha: types, beta: types, reason)) = (* This previously used a single type variable sequence for both types. It may be that this is needed to make sensible error messages. *) PrettyBlock(3, false, [], [ PrettyString ("Can't " ^ what (* "match" if a signature, "unify" if core lang. *)), PrettyBreak (1, 0), display (alpha, 1000 (* As deep as necessary *), alphaTypeEnv), PrettyBreak (1, 0), PrettyString "to", PrettyBreak (1, 0), display (beta, 1000 (* As deep as necessary *), betaTypeEnv), PrettyBreak (1, 0), PrettyString reason ]) | reportError(TypeConstructorError(alpha: types, beta: types, alphaCons, betaCons)) = let fun expandedTypeConstr(ty, tyEnv, tyCons) = let fun lastPart name = #second(splitString name) (* Print the type which includes the type constructor name with as much additional information as we can. *) fun printWithDesc{ location, name, description } = PrettyBlock(3, false, [], [ display (ty, 1000, tyEnv) ] @ (if lastPart name = lastPart(tcName tyCons) then [] else [ PrettyBreak(1, 0), PrettyString "=", PrettyBreak(1, 0), PrettyBlock(0, false, [ContextLocation location], [PrettyString name]) ] ) @ (if description = "" then [] else [ PrettyBreak(1, 0), PrettyBlock(0, false, [ContextLocation location], [PrettyString ("(*" ^ description ^ "*)")]) ] ) ) in case tcIdentifier tyCons of TypeId { description, ...} => printWithDesc description end in PrettyBlock(3, false, [], [ PrettyString ("Can't " ^ what (* "match" if a signature, "unify" if core lang. *)), PrettyBreak (1, 0), expandedTypeConstr(alpha, alphaTypeEnv, alphaCons), PrettyBreak (1, 0), PrettyString (if what = "unify" then "with" else "to"), PrettyBreak (1, 0), expandedTypeConstr(beta, betaTypeEnv, betaCons), PrettyBreak (1, 0), PrettyString "(Different type constructors)" ]) end in reportError end (* Given a function type returns the first argument if the function takes a tuple otherwise returns the only argument. Extended to include the case where the argument is not a function in order to work properly for overloaded literals. *) fun firstArg(FunctionType{arg= LabelledType { recList = {typeof, ...} ::_, ...}, ...}) = eventual typeof | firstArg(FunctionType{arg, ...}) = eventual arg | firstArg t = t (* Returns an instance of an overloaded function using the supplied list of type constructors for the overloading. *) fun generaliseOverload(t, constrs, isConverter) = let (* Returns the result type of a function. *) fun getResult(FunctionType{result, ...}) = eventual result | getResult _ = raise InternalError "getResult - not a function"; val arg = if isConverter then getResult t else firstArg t in case arg of TypeVar tv => let (* The argument should be a type variable, possibly set to an empty overload set. This should be replaced by the current overload set in the copied function type. *) val newSet = mkOverloadSet constrs val (t, _) = generaliseTypes(t, fn old => if sameTv(old, tv) then SOME newSet else NONE) in (t, [newSet]) end | _ => raise InternalError "generaliseOverload - arg is not a type var" end (* Prints out a type constructor e.g. type 'a fred = 'a * 'a or datatype 'a joe = bill of 'a list | mary of 'a * int or simply type 'a abs if the type is abstract. *) fun displayTypeConstrsWithMap ( TypeConstrSet( TypeConstrs{identifier=TypeId{idKind=TypeFn(args, result), ...}, name, ...}, []), depth, typeEnv, sigMap) = (* Type function *) if depth <= 0 then PrettyString "..." else let val typeV = varNameSequence () (* Local sequence for this binding. *) in PrettyBlock (3, false, [], PrettyString "type" :: PrettyBreak (1, 0) :: printTypeVars (args, depth, typeV) @ [ PrettyString (#second(splitString name)), PrettyBreak(1, 0), PrettyString "=", PrettyBreak(1, 0), tDisp(result, depth-1, typeV, typeEnv, sigMap) ] ) end | displayTypeConstrsWithMap (TypeConstrSet(tCons, [] (* No constructors *)), depth, _, _) = (* Abstract type or type in a signature. *) if depth <= 0 then PrettyString "..." else PrettyBlock (3, false, [], PrettyString ( if tcEquality tCons then "eqtype" else "type") :: PrettyBreak (1, 0) :: printTypeVars (tcTypeVars tCons, depth, varNameSequence ()) @ [PrettyString (#second(splitString(tcName tCons)))] ) | displayTypeConstrsWithMap (TypeConstrSet(tCons as TypeConstrs{name, locations, ...}, tcConstructors), depth, typeEnv, sigMap) = (* It has constructors - datatype declaration *) if depth <= 0 then PrettyString "..." else let val typeV = varNameSequence () (* Construct a ('a, 'b, 'c) tyCons construction for the result types of each of the constructors. N.B. We use the original type constructors because they have the appropriate equality type properties. datatype 'a t = A of 'a is not the same as ''a t = A of ''a. *) val typeVars = tcTypeVars tCons val typeResult = mkTypeConstruction(name, tCons, map TypeVar typeVars, locations) (* Print a single constructor (blocked) *) fun pValConstr (first, name, typeOf, depth) = let val (t, _) = generalise typeOf val firstBreak = PrettyBreak (1, if first then 2 else 0) in case t of FunctionType { arg, result} => let (* Constructor with an argument. The constructor "type" is the argument. We have to unify the result type of the function with the ('a, 'b, 'c) tyCons type so that we get the correct type variables in the argument. We just print the argument of the function. *) val _ = unifyTypes(result, typeResult) in [ firstBreak, PrettyBlock (0, false, [], PrettyBlock (0, false, [], (if first then PrettyBreak (0, 2) else PrettyBlock (0, false, [], [PrettyString "|", PrettyBreak(1, 2)]) ) :: (if depth <= 0 then [PrettyString "..."] else [ PrettyString name, PrettyBreak (1, 4), PrettyString "of"]) ) :: (if depth > 0 then [ PrettyBreak (1, 4), (* print the type as a single block of output *) tDisp (arg, depth - 1, typeV, typeEnv, sigMap) ] else []) ) ] end | _ => [ firstBreak, PrettyBlock (0, false, [], [if first then PrettyBreak (0, 2) else PrettyBlock (0, false, [], [PrettyString "|", PrettyBreak(1, 2)]), PrettyString (if depth <= 0 then "..." else name)] ) ] end (* Print a sequence of constructors (unblocked) *) fun pValConstrRest ([], _ ): pretty list = [] | pValConstrRest (H :: T, depth): pretty list = if depth < 0 then [] else pValConstr (false, valName H, valTypeOf H, depth) @ pValConstrRest (T, depth - 1) fun pValConstrList ([], _ ) = PrettyString "" (* shouldn't occur *) | pValConstrList (H :: T, depth) = PrettyBlock (2, true, [], pValConstr (true, valName H, valTypeOf H, depth) @ pValConstrRest (T, depth - 1) ) in PrettyBlock(0, false, [], [ PrettyBlock(0, false, [], PrettyString "datatype" :: PrettyBreak (1, 2) :: printTypeVars (typeVars, depth, typeV) @ [ PrettyString(#second(splitString(tcName tCons))), PrettyBreak(1, 0), PrettyString "=" ] ), pValConstrList (tcConstructors, depth - 1) ] ) end (* displayTypeConstrsWithMap *) fun displayTypeConstrs (tCons : typeConstrSet, depth : FixedInt.int, typeEnv) : pretty = displayTypeConstrsWithMap(tCons, depth, typeEnv, NONE) (* Return a type constructor from an overload. If there are several (i.e. the overloading has not resolved to a single type) it returns the "best". This is called in the third pass so it should never be called if there is not at least one type that is possible. *) fun typeConstrFromOverload(f, _) = let fun prefType(TypeVar tvar) = ( (* If we still have an overload set that's because it has not reduced to a single type. In ML 97 we default to int, real, word, char or string in that order. This works correctly for overloading literals so long as the literal conversion functions are correctly installed. *) case tvValue tvar of OverloadSet{typeset} => let (* If we accept this type we have to freeze the overloading to this type. I'm not happy about doing this here but it seems the easiest solution. *) fun freezeType tcons = ( tvSetValue(tvar, mkTypeConstruction(tcName tcons, tcons, [], [])); tcons ) in case preferredOverload typeset of SOME tycons => freezeType tycons | NONE => raise InternalError "typeConstrFromOverload: No matching type" end | _ => raise InternalError "typeConstrFromOverload: No matching type" (* Unbound or flexible record. *) ) | prefType(TypeConstruction{constr, args, ...}) = if not (tcIsAbbreviation constr) then constr (* Generally args will be nil in this case but in the special case of looking for an equality function for 'a ref or 'a array it may not be. *) else prefType (makeEquivalent (constr, args)) | prefType _ = raise InternalError "typeConstrFromOverload: No matching type" in prefType(firstArg(eventual f)) end; (* Return the result type of a function. Also used to test if the value is a function type. *) fun getFnArgType t = case eventual t of FunctionType {arg, ... } => SOME arg | _ => NONE (* Assigns type variables to variables with generalisation permitted if their level is at least that of the current level. In ML90 mode this produced an error message for any top-level free imperative type variables. We don't do that in ML97 because it is possible that another declaration may "freeze" the type variable before the composite expression reaches the top level. *) fun allowGeneralisation (t, level, nonExpansive, lex, location, moreInfo, typeEnv) = let fun giveError(s1: string, s2: string) = let (* Use a single sequence. *) val vars : typeVarForm -> string = varNameSequence (); open DEBUG val parameters = debugParams lex val errorDepth = getParameter errorDepthTag parameters in reportError lex { hard = true, location = location, message = PrettyBlock (3, false, [], [ PrettyString s1, PrettyBreak (1, 0), tDisp (t, errorDepth, vars, typeEnv, NONE), PrettyBreak (1, 0), PrettyString s2 ] ), context = SOME(moreInfo ()) } end local open DEBUG val parameters = debugParams lex in val checkOverloadFlex = getParameter narrowOverloadFlexRecordTag parameters end fun general t (genArgs as (showError, nonExpansive)) = case eventual t of TypeVar tvar => let val argSet = if tvLevel tvar >= level andalso tvLevel tvar <> generalisable andalso (case tvValue tvar of OverloadSet _ => false | _ => true) then let (* Make a new generisable type variable, except that type variables in an expansive context cannot be generalised. We also don't generalise if this is an overload set. The reason for that is that it allows us to get overloading information from the surrounding context. e.g. let fun f x y = x+y in f 2.0 end. An alternative would be take the default type (in this case int). DCJM 1/9/00. *) val nonCopiable = not nonExpansive val newLevel = if nonCopiable then level-1 else generalisable (* copiable *); val isOk = (* If the type variable has top-level scope then we have a free type variable. We only want to generate this message once even if we have multiple type variables.*) (* If the type variable is non-unifiable and the expression is expansive then we have an error since this will have to be a monotype. *) if tvNonUnifiable tvar andalso nonCopiable andalso showError then ( giveError("Type", "includes a free type variable"); false ) else showError; (* It may be a flexible record so we have to transfer the record to the new variable. *) val newTypeVar = makeTv {value=tvValue tvar, level=newLevel, equality=tvEquality tvar, nonunifiable=if nonCopiable then (tvNonUnifiable tvar) else false, printable=tvPrintity tvar} in tvSetValue (tvar, TypeVar newTypeVar); (* If we are using the "narrow" context for overloading and flexible records we should apply this here. Otherwise it is dealt with in the next pass when we have the full program context. *) case (checkOverloadFlex, tvValue tvar) of (true, LabelledType _) => giveError("Type", "is an unresolved flexible record") | (true, OverloadSet {typeset, ...}) => ( (* Set this to the "preferred" type. Typically this is "int" but for overloaded literals (e.g. 0w0) it could be something else. *) case preferredOverload typeset of SOME tycons => tvSetValue(tvar, mkTypeConstruction(tcName tycons, tycons, [], [])) | NONE => raise InternalError "general: No matching type" ) | _ => (); (isOk, nonExpansive) end else genArgs in general (tvValue tvar) argSet (* Process any flexible record. *) end | TypeConstruction {args, constr, ...} => (* There is a pathological case here. If we have a type equivalence which contains type variables that do not occur on the RHS (e.g. type 'a t = int) then we generalise over them even with an expansive expression. This is because the semantics treats type abbreviations as type functions and so any type variables that are eliminated by the function application do not appear in the "type" that the semantics applies to the expression. *) if tcIsAbbreviation constr then let val (r1, _) = general(makeEquivalent (constr, args)) genArgs (* Process any arguments that have not been processed in the equivalent. *) val (r2, _) = List.foldr (fn (t, v) => general t v) (r1, true) args in (r2, nonExpansive) end else List.foldr (fn (t, v) => general t v) genArgs args | FunctionType {arg, result} => general arg (general result genArgs) | LabelledType {recList,...} => List.foldr (fn ({ typeof, ... }, v) => general typeof v) genArgs recList | _ => genArgs in general t (true, nonExpansive); () end (* end allowGeneralisation *); (* Check for free type variables at the top level. Added for ML97. This replaces the test in allowGeneralisation above and is applied to all top-level values including those in structures and functors. *) (* I've changed this from giving an error message, which prevented the code from evaluating, to giving a warning and setting the type variables to unique type variables. That allows, for example, fun f x = raise x; f Subscript; to work. DCJM 8/3/01. *) fun checkForFreeTypeVariables(valName: string, ty: types, lex: lexan, printAndEqCode) : unit = let (* Generate new names for the type constructors. *) val count = ref 0 fun genName num = (if num >= 26 then genName (num div 26 - 1) else "") ^ String.str (Char.chr (num mod 26 + Char.ord #"a")); fun checkTypes (TypeVar tvar) () = if isEmpty(tvValue tvar) andalso tvLevel tvar = 1 then (* The type variable is unbound (specifically, not an overload set) and it is not generic i.e. it must have come from an expansive expression. *) let val name = "_" ^ genName(!count) val _ = count := !count + 1; val declLoc = location lex (* Not correct but OK for the moment. *) val declDescription = { location = declLoc, name = name, description = "Constructed from a free type variable." } val tCons = makeTypeConstructor (name, [], makeFreeId(0, Global(printAndEqCode()), tvEquality tvar, declDescription), [DeclaredAt declLoc]); val newVal = mkTypeConstruction(name, tCons, [], []) in warningMessage(lex, location lex, concat["The type of (", valName, ") contains a free type variable. Setting it to a unique monotype."]); tvSetValue (tvar, newVal) end else () | checkTypes _ () = () in foldType checkTypes ty (); () end (* Returns true if a type constructor permits equality. *) fun permitsEquality constr = if tcIsAbbreviation constr then typePermitsEquality( mkTypeConstruction (tcName constr, constr, List.map TypeVar (tcTypeVars constr), [])) else tcEquality constr and typePermitsEquality ty = equality (ty, fn _ => No, fn _ => Yes) <> No (* See if a type abbreviation or "where type" has the form type t = s or type 'a t = 'a s etc and so is simply giving a new name to the type constructor. If it is it then checks that the type constructor used (s in this example) is just a simple type name. *) fun typeNameRebinding(typeArgs, typeResult): typeId option = let fun eqTypeVar(TypeVar ta, tb) = sameTv (ta, tb) | eqTypeVar _ = false in case typeResult of TypeConstruction {constr, args, ... } => if not (ListPair.allEq eqTypeVar(args, typeArgs)) then NONE else ( case tcIdentifier constr of TypeId{idKind=TypeFn _, ...} => NONE | tId => SOME tId ) | _ => NONE end (* Returns the number of the entry in the list. Used to find out the location of fields in a labelled record for expressions and pattern matching. Assumes that the label appears in the list somewhere. *) fun entryNumber (label, LabelledType{recList, ...}) = let (* Count up the list. *) fun entry ({name, ...}::l) n = if name = label then n else entry l (n + 1) | entry [] _ = raise Match in entry recList 0 end | entryNumber (label, TypeVar tvar) = entryNumber (label, tvValue tvar) | entryNumber (label, TypeConstruction{constr, ...}) = (* Type alias *) entryNumber (label, tcEquivalent constr) | entryNumber _ = raise InternalError "entryNumber - not a record" (* Size of a labelled record. *) fun recordWidth (LabelledType{recList, ...}) = length recList | recordWidth (TypeVar tvar) = recordWidth (tvValue tvar) | recordWidth (TypeConstruction{constr, ...}) = (* Type alias *) recordWidth (tcEquivalent constr) | recordWidth _ = raise InternalError "entryNumber - not a record" fun recordFieldMap f (LabelledType{recList, ...}) = List.map (f o (fn {typeof, ...} => typeof)) recList | recordFieldMap f (TypeVar tvar) = recordFieldMap f (tvValue tvar) | recordFieldMap f (TypeConstruction{constr, ...}) = recordFieldMap f (tcEquivalent constr) | recordFieldMap _ _ = raise InternalError "entryNumber - not a record" (* Unify two type variables which would otherwise be non-unifiable. Used when we have found a local type variable with the same name as a global one. *) fun linkTypeVars (a, b) = let val ta = typesTypeVar (eventual(TypeVar a)); (* Must both be type vars. *) val tb = typesTypeVar (eventual(TypeVar b)); in (* Set the one with the higher level to point to the one with the lower, so that the effective level is the lower. *) if (tvLevel ta) > (tvLevel tb) then tvSetValue (ta, TypeVar b) else tvSetValue (tb, TypeVar a) end; (* Set its level by setting it to a new type variable. *) fun setTvarLevel (typ, level) = let val tv = typesTypeVar (eventual(TypeVar typ)); (* Must be type var. *) in tvSetValue (tv, mkTypeVar (level, tvEquality tv, true, tvPrintity tv)) end; (* Construct the least general type from a list of types. This is used after type checking to try to remove polymorphism from local values. It takes the list of actual uses of the value, usually a function, and removes any unnecessary polymorphism. This is particularly the case if the function involves a flexible record, where the unspecified fields are treated as polymorphic, but where the function is actually applied to a records which are monomorphic. *) fun leastGeneral [] = EmptyType (* Never used? *) (* Don't use this at the moment - see the comment on TypeVar below. Also the comment on TypeConstruction for local datatypes. *) (* | leastGeneral [oneType] = oneType *)(* Just one - this is it. *) | leastGeneral(firstType::otherTypes): types = let fun canonical (typ as TypeVar tyVar) = ( case tvValue tyVar of EmptyType => typ | OverloadSet _ => let val constr = typeConstrFromOverload(typ, false) in mkTypeConstruction(tcName constr, constr, [], []) end | t => canonical t ) | canonical (typ as TypeConstruction { constr, args, ...}) = if tcIsAbbreviation constr (* Handle type abbreviations directly *) then canonical(makeEquivalent (constr, args)) else typ | canonical typ = typ (* Take the head of the each argument list and extract the least general. Then process the tail. It's an error if each element of the list does not contain the same number of items. *) fun leastArgs ([]::_) = [] | leastArgs (args as _::_) = leastGeneral(List.map hd args) :: leastArgs (List.map tl args) | leastArgs _ = raise Empty in case canonical firstType of (*typ as *)TypeVar _(*tv*) => let (*fun sameTypeVar(TypeVar tv1) = sameTv(tv, tv1) | sameTypeVar _ = false*) in (* If they are all the same type variable return that otherwise return a new generalisable type variable. They may all be equal if we always apply this function to a value whose type is a polymorphic type in the function that contains all these uses. *) (* Temporarily, at least, create a new type var in this case. If we have a polymorphic function that is only used inside another polymorphic function but isn't declared inside it, if we use the caller's type variable here the call won't be recognised as polymorphic. *) (*if List.all sameTypeVar otherTypes then typ else*) mkTypeVar(generalisable, false, false, false) end | TypeConstruction{ constr, args, name, locations, ...} => ( (* There is a potential problem if the datatype is local including if it was constructed in a functor. Almost always it will have been declared after the polymorphic function but if it happens not to have been we could set a polymorphic function to a type that doesn't exist yet. To avoid this we don't allow a local datatype here and instead fall back to the polymorphic case. *) case tcIdentifier constr of thisConstrId as TypeId{access=Global _, ...} => let val argLength = List.length args (* This matches if it is an application of the same type constructor. *) fun getTypeConstrs(TypeConstruction{constr, args, ...}) = if sameTypeId(thisConstrId, tcIdentifier constr) andalso List.length args = argLength then SOME args else NONE | getTypeConstrs _ = NONE val allArgs = List.mapPartial (getTypeConstrs o canonical) otherTypes in if List.length allArgs = List.length otherTypes then TypeConstruction{constr=constr, name=name, locations=locations, args = leastArgs(args :: allArgs)} else (* At least one of these wasn't the same type constructor. *) mkTypeVar(generalisable, false, false, false) end | _ => mkTypeVar(generalisable, false, false, false) ) | FunctionType{ arg, result } => let fun getFuns(FunctionType{arg, result}) = SOME(arg, result) | getFuns _ = NONE val argResults = List.mapPartial (getFuns o canonical) otherTypes in if List.length argResults = List.length otherTypes then let val (args, results) = ListPair.unzip argResults in FunctionType{arg=leastGeneral(arg::args), result = leastGeneral(result::results)} end else (* At least one of these wasn't a function. *) mkTypeVar(generalisable, false, false, false) end | LabelledType (r as {recList=firstRec, fullList}) => if recordIsFrozen r then let (* This matches if all the field names are the same. Extract the types. *) fun nameMatch({name=name1: string, ...}, {name=name2, ...}) = name1 = name2 fun getRecords(LabelledType{recList, ...}) = if ListPair.allEq nameMatch (firstRec, recList) then SOME(List.map #typeof recList) else NONE | getRecords _ = NONE val argResults = List.mapPartial (getRecords o canonical) otherTypes in if List.length argResults = List.length otherTypes then let (* Use the names from the first record (they all are the same) to build a new record. *) val argTypes = leastArgs(List.map #typeof firstRec :: argResults) fun recreateRecord({name, ...}, types) = {name=name, typeof=types} val newList = ListPair.map recreateRecord(firstRec, argTypes) in LabelledType{recList=newList, fullList=fullList } end else (* At least one of these wasn't a record. *) mkTypeVar(generalisable, false, false, false) end else (* At this stage the record should be frozen if the program is correct but if it isn't we could have a flexible record which we report elsewhere. *) mkTypeVar(generalisable, false, false, false) | _ => (* May arise if there's been an error. *) mkTypeVar(generalisable, false, false, false) end (* Test if this is floating point i.e. the "real" type. We could include abbreviations of real as well but it's probably not worth it. *) datatype floatKind = FloatDouble | FloatSingle local val realId = tcIdentifier realConstr and floatId = tcIdentifier floatConstr fun isFloatId constr = let val id = tcIdentifier constr in if sameTypeId(id, realId) then SOME FloatDouble else if sameTypeId(id, floatId) then SOME FloatSingle else NONE end in fun isFloatingPt(TypeConstruction{args=[], constr, ...}) = isFloatId constr | isFloatingPt(OverloadSet {typeset, ...}) = ( case preferredOverload typeset of SOME t => isFloatId t (* real only. float is never preferred. *) | NONE => NONE ) | isFloatingPt(TypeVar tv) = isFloatingPt (tvValue tv) | isFloatingPt _ = NONE end fun checkDiscard(t: types, lex: lexan): string option = let open DEBUG val checkLevel = getParameter reportDiscardedValuesTag (debugParams lex) fun isUnit(LabelledType{recList=[], ...}) = true (* Unit is actually an empty record *) | isUnit(TypeConstruction{ constr as TypeConstrs{identifier=TypeId{idKind=TypeFn _, ...}, ...}, args, ...}) = isUnit(makeEquivalent(constr, args)) | isUnit(TypeVar _) = true (* Allow unbound type vars *) | isUnit _ = false fun isAFunction(FunctionType _) = true | isAFunction(TypeConstruction{ constr as TypeConstrs{identifier=TypeId{idKind=TypeFn _, ...}, ...}, args, ...}) = isAFunction(makeEquivalent(constr, args)) | isAFunction _ = false in case checkLevel of 1 => if isAFunction (eventual t) then SOME "A function value is being discarded." else NONE | 2 => if isUnit (eventual t) then NONE else SOME "A non unit value is being discarded." | _ => NONE end structure Sharing = struct type types = types and values = values and typeId = typeId and structVals = structVals and typeConstrs= typeConstrs and typeConstrSet=typeConstrSet and typeParsetree = typeParsetree and locationProp = locationProp and pretty = pretty and lexan = lexan and ptProperties = ptProperties and typeVarForm = typeVarForm and codetree = codetree and matchResult = matchResult and generalMatch = generalMatch end end (* TYPETREE *); diff --git a/mlsource/MLCompiler/VALUE_OPS.ML b/mlsource/MLCompiler/VALUE_OPS.ML index 6eb1ecc2..de28adb1 100644 --- a/mlsource/MLCompiler/VALUE_OPS.ML +++ b/mlsource/MLCompiler/VALUE_OPS.ML @@ -1,1321 +1,1321 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited - Modified David C.J. Matthews 2008-9, 2013, 2015-16. + Modified David C.J. Matthews 2008-9, 2013, 2015-16, 2020. 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: Operations on global and local values. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1986 *) functor VALUE_OPS ( structure LEX : LEXSIG; structure CODETREE : CODETREESIG structure STRUCTVALS : STRUCTVALSIG; structure TYPESTRUCT : TYPETREESIG structure PRINTTABLE : PRINTTABLESIG structure UNIVERSALTABLE: sig type universal = Universal.universal type univTable val app: (string * universal -> unit) -> univTable -> unit end; structure DEBUG : DEBUGSIG structure MISC : sig exception InternalError of string; (* compiler error *) exception Conversion of string (* string to int conversion failure *) val quickSort : ('a -> 'a -> bool) -> 'a list -> 'a list end; structure PRETTY : PRETTYSIG structure ADDRESS : AddressSig structure UTILITIES : sig val splitString: string -> { first:string,second:string } end; structure COPIER: COPIERSIG structure TYPEIDCODE: TYPEIDCODESIG structure DATATYPEREP: DATATYPEREPSIG sharing STRUCTVALS.Sharing = TYPESTRUCT.Sharing = LEX.Sharing = PRETTY.Sharing = COPIER.Sharing = CODETREE.Sharing = PRINTTABLE = ADDRESS = UNIVERSALTABLE = MISC = TYPEIDCODE.Sharing = DATATYPEREP.Sharing ) : VALUEOPSSIG = (*****************************************************************************) (* VALUEOPS functor body *) (*****************************************************************************) struct open MISC; open PRETTY; open LEX; open CODETREE; open TYPESTRUCT; (* Open this first because unitType is in STRUCTVALS as well. *) open Universal; (* for tag etc. *) open STRUCTVALS; open PRINTTABLE; open DEBUG; open ADDRESS; open UTILITIES; open TYPEIDCODE open COPIER open DATATYPEREP (* Functions to construct the values. *) fun mkGconstr (name, typeof, code, nullary, constrs, location) = makeValueConstr (name, typeof, nullary, constrs, Global code, location); (* Global variable *) fun mkGvar (name, typeOf, code, locations) : values = Value{ name = name, typeOf = typeOf, access = Global code, class = ValBound, locations = locations, references = NONE, instanceTypes=NONE }; (* Local variable - Generated by the second pass. *) local fun makeLocalV class (name, typeOf, locations) = Value{ name = name, typeOf = typeOf, access = Local {addr = ref ~1 (* Must be set later *), level = ref baseLevel}, class = class, locations = locations, references = makeRef(), instanceTypes=SOME(ref []) }; in val mkValVar = makeLocalV ValBound and mkPattVar = makeLocalV PattBound end (* Value in a local structure or a functor argument. May be simple value, exception or constructor. *) fun mkSelectedVar (Value { access = Formal addr, name, typeOf, class, locations, ...}, Struct{access=sAccess, ...}, openLocs) = (* If the argument is "formal" set the base to the base structure. *) let (* If the base structure is a constant do the selection now. This is redundant unless we're being called from PolyML.NameSpace.Structures.contents. *) val access = case sAccess of Global code => Global(mkInd (addr, code)) | _ => Selected{addr=addr, base=sAccess} in Value{name=name, typeOf=typeOf, class=class, access=access, locations=openLocs @ locations, references = NONE, instanceTypes=NONE} end | mkSelectedVar (Value { access = Global code, name, typeOf, class, locations, ...}, _, openLocs) = (* Global: We need to add the location information. *) Value{name=name, typeOf=typeOf, class=class, access=Global code, locations=openLocs @ locations, references = NONE, instanceTypes=NONE} | mkSelectedVar(selected, _, _) = selected (* Overloaded? *); (* Construct a global exception. *) fun mkGex (name, typeof, code, locations) = Value{ name = name, typeOf = typeof, access = Global code, class = Exception, locations = locations, references = NONE, instanceTypes=NONE } (* Construct a local exception. *) fun mkEx (name, typeof, locations) = Value{ name = name, typeOf = typeof, access = Local{addr = ref 0, level = ref baseLevel}, class = Exception, locations=locations, references = NONE, instanceTypes=NONE } (* Locations in exception packets. In order to have a defined ordering of the fields, when we put the location in an exception packet we use this datatype rather than the "location" type. *) (* *) datatype RuntimeLocation = NoLocation | SomeLocation of (* file: *) string * (*startLine:*) int * (*startPosition:*) int * (*endLine:*) int * (*endPosition:*) int fun codeLocation({file="", startLine=0, startPosition=0, ...}) = mkConst(toMachineWord NoLocation) (* No useful information *) | codeLocation({file, startLine, startPosition, endLine, endPosition}) = mkConst(toMachineWord(file, startLine, startPosition, endLine, endPosition)) (*****************************************************************************) (* Look-up functions. *) (* These are used locally and also exported to INITIALISE to be used in PolyML.NameSpace.Structures.contents. *) fun makeSelectedValue( Value{ name, typeOf, access, class, locations, ... }, baseStruct as Struct{signat=Signatures { typeIdMap, ...}, name=baseName, ...}) = let fun copyId(TypeId{idKind=Bound{ offset, ...}, ...}) = SOME(typeIdMap offset) | copyId _ = NONE val copiedType = copyType (typeOf, fn x => x, fn tcon => copyTypeConstr (tcon, copyId, fn x => x, fn s => baseName^"."^s)) val baseLoc = case List.find (fn DeclaredAt _ => true | _ => false) locations of SOME (DeclaredAt loc) => [StructureAt loc] | _ => [] in mkSelectedVar ( Value{ name=name, typeOf=copiedType, access=access, class=class, locations=locations, references = NONE, instanceTypes=NONE }, baseStruct, baseLoc) end fun makeSelectedStructure( Struct {signat, access, name=structName, locations, ...}, Struct {signat=Signatures { typeIdMap, firstBoundIndex, ...}, access=baseAccess, ...}) = let val Signatures { name=sigName, tab, typeIdMap = childMap, locations=sigLocs, ... } = signat (* We need to apply the map from the parent structure to the child. *) val copiedSig = makeSignature(sigName, tab, firstBoundIndex, sigLocs, composeMaps(childMap, typeIdMap), []) (* Convert Formal access to Selected and leave the others (Global?). If this is Formal but the base structure is global do the selection now. This is only needed if we're called from PolyML.NameSpace.Structures.contents. *) val newAccess = case (access, baseAccess) of (Formal sel, Global code) => Global(mkInd(sel, code)) | (Formal sel, baseAccess) => Selected { addr = sel, base = baseAccess } | (access, _) => access (* If we have a DeclaredAt location for the structure use this as the StructureAt.*) val baseLoc = case List.find (fn DeclaredAt _ => true | _ => false) locations of SOME (DeclaredAt loc) => [StructureAt loc] | _ => [] in Struct { name = structName, signat = copiedSig, access = newAccess, locations = baseLoc @ locations} end fun makeSelectedType(typeConstr, Struct { signat=Signatures { typeIdMap, ...}, name, ...}) = fullCopyDatatype(typeConstr, typeIdMap, name^".") (* Look up a structure. *) fun lookupStructure (kind, {lookupStruct:string -> structVals option}, name, errorMessage) = let val {first = prefix, second = suffix} = splitString name; val strLookedUp = if prefix = "" then lookupStruct suffix else case lookupStructure ("Structure", {lookupStruct=lookupStruct}, prefix, errorMessage) of NONE => NONE (* Already reported *) | SOME(baseStruct as Struct { signat=Signatures { tab, ... }, ...}) => let (* Look up the first part in the structure environment. *) val Env{lookupStruct, ...} = makeEnv tab in case lookupStruct suffix of SOME foundStruct => SOME(makeSelectedStructure(foundStruct, baseStruct)) | NONE => NONE end in case strLookedUp of SOME s => SOME s | NONE => (* Not declared? *) (errorMessage (kind ^ " (" ^ suffix ^ ") has not been declared" ^ (if prefix = "" then "" else " in structure " ^ prefix)); NONE) end fun mkEnv x = let val Env e = makeEnv x in e end (* Look up a structure but ignore the access. This is used in sharing constraints where we're only interested in the signature. *) (* It's simpler to use the common code for this. *) fun lookupStructureAsSignature (lookupStruct, name, errorMessage) = lookupStructure("Structure", { lookupStruct = lookupStruct}, name, errorMessage) (* Look up a value, possibly in a structure. If it is in a structure we may have to apply a selection. *) fun lookupValue (kind, {lookupVal,lookupStruct}, name, errorMessage) = let val {first = prefix, second = suffix} = splitString name; val found = if prefix = "" then lookupVal suffix (* Look up the first part in the structure environment. *) else case lookupStructure ("Structure", {lookupStruct=lookupStruct}, prefix, errorMessage) of NONE => SOME undefinedValue | SOME (baseStruct as Struct { signat=Signatures { tab, ...}, ...}) => ( case #lookupVal (mkEnv tab) suffix of SOME foundValue => SOME(makeSelectedValue(foundValue, baseStruct)) | NONE => NONE ) in case found of SOME v => v | NONE => (* Not declared? *) ( errorMessage (kind ^ " (" ^ suffix ^ ") has not been declared" ^ (if prefix = "" then "" else " in structure " ^ prefix)); undefinedValue ) end fun lookupTyp ({lookupType,lookupStruct}, name, errorMessage) = let val {first = prefix, second = suffix} = splitString name; val found = if prefix = "" then lookupType suffix else (* Look up the first part in the structure environment. *) case lookupStructure ("Structure", {lookupStruct=lookupStruct}, prefix, errorMessage) of NONE => SOME(TypeConstrSet(undefConstr, [])) | SOME (baseStruct as Struct { signat=Signatures { tab, ...}, ...}) => ( case #lookupType (mkEnv tab) suffix of SOME typeConstr => SOME(makeSelectedType(typeConstr, baseStruct)) | NONE => NONE ) in case found of SOME v => v | NONE => (* Not declared? *) ( errorMessage ("Type constructor" ^ " (" ^ suffix ^ ") has not been declared" ^ (if prefix = "" then "" else " in structure " ^ prefix)); TypeConstrSet(undefConstr, []) ) end (* Printing. *) (* Print a value given its type. *) fun printValueForType (value:machineWord, types, depth): pretty = let (* Constuct printer code applied to the argument and the depth. Code-generate and evaluate it. *) (* If this is polymorphic apply it to a dummy set of instance types. This may happen if we have val it = NONE at the top level. The equality attributes of the type variables must match so that this works correctly with justForEqualityTypes set. *) val addrs = ref 0 (* Make local declarations for any type values. *) local fun mkAddr n = !addrs before (addrs := !addrs + n) in val typeVarMap = TypeVarMap.defaultTypeVarMap(mkAddr, baseLevel) end val dummyTypes = List.map(fn tv => {value=TYPESTRUCT.unitType, equality=tvEquality tv, printity=false}) (getPolyTypeVars(types, fn _ => NONE)) val polyCode = applyToInstance(dummyTypes, baseLevel, typeVarMap, fn _ => mkConst value) val printerCode = mkEval( printerForType(types, baseLevel, typeVarMap), [mkTuple[polyCode, mkConst(toMachineWord depth)]]) val pretty = RunCall.unsafeCast( valOf(evalue(genCode(CODETREE.mkEnv(TypeVarMap.getCachedTypeValues typeVarMap, printerCode), [], !addrs)()))) in pretty end (* These are used to display the declarations made. *) fun displayFixStatus(FixStatus(name, f)): pretty = let open PRETTY val status = case f of Nonfix => PrettyString "nonfix" | Infix prec => PrettyBlock(0, false, [], [ PrettyString "infix", PrettyBreak (1, 0), PrettyString (Int.toString prec) ]) | InfixR prec => PrettyBlock(0, false, [], [ PrettyString "infixr", PrettyBreak (1, 0), PrettyString (Int.toString prec) ]) in PrettyBlock (0, false, [], [status, PrettyBreak (1, 0), PrettyString name]) end (* Returns the declaration location as the location for the context. *) fun getLocation locations = case List.find(fn DeclaredAt _ => true | _ => false) locations of SOME(DeclaredAt loc) => [ContextLocation loc] | _ => [] (* Displays value as a block, with no external formatting. This is used at the top level but it can be applied to values extracted with #lookup globalNameSpace. That can include constructors and overloaded functions. *) fun displayValues (Value{name, typeOf, class, access, locations, ...}, depth: FixedInt.int, nameSpace, sigMap): pretty = let (* Create the "val X =" part. *) fun valPart (valOrCons, isColon) = let (* If we're putting in a colon we don't need a space after an alphanumeric id but we do if it's symbolic. *) val isAlphaNumeric = let val first = String.sub(name, 0) in Char.isAlpha first orelse first = #"'" end val space = if isColon andalso isAlphaNumeric then 0 else 1 val equOrColon = if isColon then ":" else "=" in PrettyBlock (0, false, [], [ PrettyString valOrCons, PrettyBreak (1, 0), PrettyBlock(0, false, getLocation locations, [PrettyString name]), PrettyBreak (space, 0), PrettyString equOrColon ] ) end val typeEnv = (* Environment to check for type constructors. *) { lookupType = #lookupType nameSpace, lookupStruct = #lookupStruct nameSpace} in if depth <= 0 then PrettyString "..." else case class of ValBound => let (* In nearly all cases if we have Global code we will have a constant. There was one case where "!" was actually a Lambda that hadn't been code-generated. *) val value = case access of Global code => evalue code | _ => NONE val start = case value of SOME v => [ valPart("val", false), PrettyBreak (1, 0), printValueForType (v, typeOf, depth), PrettyString ":" ] | _ => [ valPart("val", true) ] in PrettyBlock (3, false, [], start @ [ PrettyBreak (1, 0), displayWithMap (typeOf, depth, typeEnv, sigMap) ]) end | Exception => (* exceptions *) PrettyBlock (0, false, [], PrettyBlock (0, false, [], [ PrettyString "exception", PrettyBreak (1, 0), PrettyBlock(0, false, getLocation locations, [PrettyString name]) ] ) :: ( case getFnArgType typeOf of NONE => [] | SOME excType => [ PrettyBreak (1, 1), PrettyString "of", PrettyBreak (1, 3), displayWithMap (excType, depth, typeEnv, sigMap) ] ) ) | Constructor _ => (* This can only occur with #lookupVal *) PrettyBlock (3, false, [], [ valPart("constructor", true), PrettyBreak (1, 0), displayWithMap (typeOf, depth, typeEnv, sigMap) ]) | PattBound => (* Can this ever occur? *) PrettyBlock (3, false, [], [ valPart("val", true), PrettyBreak (1, 0), displayWithMap (typeOf, depth, typeEnv, sigMap) ]) end (* Print global values. This is passed through the bootstrap and used in the debugger. *) fun printValues (Value{typeOf, class, access, ...}, depth) = case (class, access) of (ValBound, Global code) => printValueForType (valOf(evalue code), typeOf, depth) | _ => PrettyString "" (* Probably shouldn't occur. *) (* Prints "sig ... end" as a block, with no external formatting *) fun displaySig (Signatures{tab, typeIdMap, ...}, depth : FixedInt.int, _ : int, { lookupType, lookupStruct, ...}, sigMap: (int-> typeId) option) : pretty = let (* Construct an environment for the types. *) val Env { lookupType = strType, lookupStruct = strStr, ...} = makeEnv tab (* Construct a map for types. *) val innerMap = case sigMap of NONE => SOME typeIdMap | SOME outerMap => SOME(composeMaps(typeIdMap, outerMap)) val compositeEnv = { lookupType = fn s => case strType s of NONE => lookupType s | SOME t => SOME (t, innerMap), lookupStruct = fn s => case strStr s of NONE => lookupStruct s | SOME s => SOME (s, innerMap) } val typeEnv: printTypeEnv = { lookupType = #lookupType compositeEnv, lookupStruct = #lookupStruct compositeEnv } fun displaySpec (_, value) : pretty list = if (tagIs signatureVar value) then (* Not legal ML97 *) [ PrettyBreak(1,2), displaySignatures (tagProject signatureVar value, depth - 1, compositeEnv)] else if (tagIs structVar value) then [ PrettyBreak(1,2), displayStructures (tagProject structVar value, depth - 1, compositeEnv, innerMap)] else if (tagIs typeConstrVar value) then [ PrettyBreak(1,2), displayTypeConstrsWithMap (tagProject typeConstrVar value, depth, typeEnv, innerMap) ] else if (tagIs valueVar value) then let (* Only print variables. Constructors are printed with their type. *) val value = tagProject valueVar value; in case value of Value{class = Constructor _, ...} => [] | _ => [ PrettyBreak(1,2), (* We lookup the infix status and any exception in the global environment only. Infix status isn't a property of a structure and it's too much trouble to look up exceptions in the structure. *) displayValues (value, depth, compositeEnv, innerMap) ] end else if (tagIs fixVar value) then (* Not legal ML97 *) [ PrettyBreak(1,2), displayFixStatus (tagProject fixVar value) ] else [] (* end displaySpec *) in PrettyBlock (0, true, [], PrettyString "sig" :: ( ( if depth <= 1 (* If the depth is 1 each of the calls to displaySpec will print "..." so we replace them all by a single "..." here. *) then [PrettyBreak (1, 0), PrettyString "..."] else let val declist = ref nil : (string * universal) list ref fun addToList nv = declist := nv :: !declist (* For the moment order them by name. We may change this to order primarily by kind and secondarily by name. *) fun order (s1: string, _) (s2: string, _) = s1 > s2 in (* Put all the entries into a list. *) UNIVERSALTABLE.app addToList tab; (* Sort the list and print it. *) List.foldl (fn (a, l) => displaySpec a @ l) [] (quickSort order (!declist)) end ) @ [PrettyBreak (1, 0), PrettyString "end"] ) ) end (* displaySig *) (* Print: signature S = sig .... end *) and displaySignatures (str as Signatures{locations, name, ...}, depth : FixedInt.int, nameSpace) : pretty = if depth <= 0 then PrettyString "..." else PrettyBlock(0, false, [], [ PrettyBlock(0, false, [], [ PrettyString "signature", PrettyBreak(1, 0), PrettyBlock(0, false, getLocation locations, [PrettyString name]), PrettyBreak(1, 0), PrettyString "=" ] ), PrettyBreak (1, 2), displaySig (str, depth, 1, nameSpace, NONE) ]) (* print structure in a block (no external spacing) *) and displayStructures (Struct{name, locations, signat, ...}, depth, nameSpace, sigMap): pretty = if depth <= 0 then PrettyString "..." else PrettyBlock (0, false, [], [ PrettyBlock(0, false, [], [ PrettyString "structure", PrettyBreak(1, 0), PrettyBlock(0, false, getLocation locations, [PrettyString name]), PrettyBreak(0, 0), PrettyString ":" ] ), PrettyBreak(1, 2), displayNamedSig(signat, depth - 1, 1, nameSpace, sigMap) ]) (* Internal function for printing structures and functors. If a signature has a name print the name rather than the contents. *) and displayNamedSig(sign as Signatures{name = "", ...}, depth, space, nameSpace, sigMap) = displaySig (sign, depth, space, nameSpace, sigMap) | displayNamedSig(Signatures{name, ...}, _, _, _, _) = PrettyString name fun displayFunctors (Functor{ name, locations, arg, result, ...}, depth, nameSpace) = if depth <= 0 then PrettyString "..." else let val arg as Struct { name = argName, signat as Signatures { tab = argTab, ... }, ...} = arg val argEntries = (if argName <> "" then [ PrettyBlock(0, false, [], [PrettyString argName, PrettyBreak(0, 0), PrettyString ":"]), PrettyBreak(1, 2) ] else []) @ [ displayNamedSig (signat, depth - 1, 0, nameSpace, NONE), PrettyBreak(0, 0), PrettyString "):", PrettyBreak(1, 0) ] (* Include the argument structure name in the type environment. *) val argEnv = if argName = "" then let val Env { lookupType=lt, lookupStruct=ls, ...} = makeEnv argTab in { lookupType = fn s => case lt s of NONE => #lookupType nameSpace s | SOME t => SOME(t, NONE), lookupStruct = fn s => case ls s of NONE => #lookupStruct nameSpace s | SOME s => SOME(s, NONE) } end else { lookupType = #lookupType nameSpace, lookupStruct = fn s => if s = argName then SOME(arg, NONE) else #lookupStruct nameSpace s } in PrettyBlock (0, false, [], [ PrettyBlock(0, false, [], [ PrettyBlock(0, false, [], [ PrettyString "functor", PrettyBreak(1, 0), PrettyBlock(0, false, getLocation locations, [PrettyString name]), PrettyBreak(1, 0), PrettyString "(" ]), PrettyBreak(0, 2), PrettyBlock(0, false, [], argEntries) ]), PrettyBreak(0, 2), displayNamedSig (result, depth - 1, 1, argEnv, NONE) ] ) end (* Exported version. *) val displayValues = fn (value, depth, nameSpace) => displayValues (value, depth, nameSpace, NONE) and displayStructures = fn (str, depth, nameSpace) => displayStructures (str, depth, nameSpace, NONE) (* Code-generation. *) (* Code-generate the values. *) fun codeStruct (Struct{access, ...}, level) = (* Global structures have no code value. Instead the values are held in the values of the signature. *) codeAccess (access, level) and codeAccess (Global code, _) = code | codeAccess (Local{addr=ref locAddr, level=ref locLevel}, level) = mkLoad (locAddr, level, locLevel) (* Argument or local *) | codeAccess (Selected{addr, base}, level) = (* Select from a structure. *) mkInd (addr, codeAccess (base, level)) | codeAccess _ = raise InternalError "No access" (*****************************************************************************) (* datatype access functions *) (*****************************************************************************) (* Get the appropriate instance of an overloaded function. If the overloading has not resolved to a single type it finds the preferred type if possible (i.e. int for most overloadings, but possibly real, word, string or char for conversion functions.) *) fun getOverloadInstance(name, instance, isConv): codetree*string = let val constr = typeConstrFromOverload(instance, isConv) in (getOverload(name, constr, fn _ => raise InternalError "getOverloadInstance: Missing"), tcName constr) end (* This is only used in addPrettyPrint. There's no point in producing a lot of detailed information. *) fun checkPPType (instanceType, matchType, fnName, lex, location, moreInfo) = case unifyTypes (instanceType, matchType) of NONE => () | SOME error => let open DEBUG val parameters = LEX.debugParams lex val errorDepth = getParameter errorDepthTag parameters in reportError lex { location = location, hard = true, message = PrettyBlock(0, true, [], [ PrettyString ("Argument for " ^ fnName), PrettyBreak (1, 3), PrettyBlock(0, false, [], [ PrettyString "Required type:", PrettyBreak (1, 0), display (matchType, errorDepth, emptyTypeEnv) ]), PrettyBreak (1, 3), PrettyBlock(0, false, [], [ PrettyString "Argument type:", PrettyBreak (1, 0), display (instanceType, errorDepth, emptyTypeEnv) ]), PrettyBreak (1, 3), unifyTypesErrorReport(lex, emptyTypeEnv, emptyTypeEnv, "unify") error ]), context = SOME (moreInfo ()) } end; (* This is applied to the instance variables if it is polymorphic and bound by a val or fun binding or is a datatype constructor. *) fun applyToInstanceType(polyVars, ValBound, level, typeVarMap, code) = applyToInstance(polyVars, level, typeVarMap, code) | applyToInstanceType(polyVars, Constructor _, level, typeVarMap, code) = applyToInstance(if justForEqualityTypes then [] else polyVars, level, typeVarMap, code) | applyToInstanceType(_, PattBound, level, _, code) = code level | applyToInstanceType(_, Exception, level, _, code) = code level val arg1 = mkLoadArgument 0 (* saves a lot of garbage *) fun addStatus typ = {value=typ, equality=false, printity=false} (* Code-generate an identifier matched to a value. N.B. If the value is a constructor it returns the pair or triple representing the functions on the constructor. *) fun codeVal (Value{access = Global code, class, ...}, level: level, typeVarMap, instance, _, _) = applyToInstanceType(instance, class, level, typeVarMap, fn _ => code) | codeVal (Value{access = Local{addr=ref locAddr, level=ref locLevel}, class, ...}, level, typeVarMap, instance, _, _) = let fun loadVar level = mkLoad (locAddr, level, locLevel) (* Argument or local *) in applyToInstanceType(instance, class, level, typeVarMap, loadVar) end | codeVal (Value{access = Selected{addr, base}, class, ...}, level: level, typeVarMap, instance, _, _) = (* Select from a structure. *) applyToInstanceType(instance, class, level, typeVarMap, fn level => mkInd (addr, codeAccess (base, level))) | codeVal (Value{access = Formal _, ...}, _, _, _, _, _) = raise InternalError "codeVal - Formal" | codeVal (Value{access = Overloaded Print, ...}, _, _, [], lex, _) = (* If this appears in a structure return a null printer function. It has to have the polymorphic form with an extra lambda outside. *) let (* We should have a single entry for the type. *) open DEBUG (* The parameter is the reference used to control the print depth when the value is actually printed. *) val prettyOut = getPrintOutput (LEX.debugParams lex) in mkProc( mkProc( CODETREE.mkEnv ( [ mkNullDec (mkEval( mkConst(toMachineWord prettyOut), [ mkConst(toMachineWord(PrettyString "?")) ]) ) ], arg1 (* Returns its argument. *) ), 1, "print()", [], 0), 1, "print(P)", [], 0) end | codeVal (Value{access = Overloaded Print, ...}, level: level, typeVarMap, [{value=argType, ...}], lex, _) = let (* We should have a single entry for the type. *) open DEBUG (* The parameter is the reference used to control the print depth when the value is actually printed. *) val printDepthFun = getParameter printDepthFunTag (LEX.debugParams lex) and prettyOut = getPrintOutput (LEX.debugParams lex) val nLevel = newLevel level in (* Construct a function that gets the print code, prints it out and returns its argument. *) mkProc( CODETREE.mkEnv ( [ mkNullDec ( mkEval( mkConst(toMachineWord prettyOut), [ mkEval( printerForType(argType, nLevel, typeVarMap), [ mkTuple[arg1, mkEval(mkConst(toMachineWord printDepthFun), [CodeZero])] ]) ]) ) ], arg1 (* Returns its argument. *) ), 1, "print()", getClosure nLevel, 0) end | codeVal (Value{access = Overloaded Print, ...}, _, _, _, _, _) = raise InternalError "Overloaded Print - wrong instance type" | codeVal (Value{access = Overloaded MakeString, ...}, _, _, [], _, _) = (* If this appears in a structure produce a default version. *) mkInlproc( mkProc(mkConst(toMachineWord "?"), 1, "makestring()", [], 0), 1, "makestring(P)", [], 0) | codeVal (Value{access = Overloaded MakeString, ...}, level: level, typeVarMap, [{value=argType, ...}], _, _) = let val nLevel = newLevel level in (* Construct a function that gets the print code and prints it out using "uglyPrint". *) mkProc( mkEval( mkConst(toMachineWord uglyPrint), [ mkEval( printerForType(argType, nLevel, typeVarMap), [ mkTuple[arg1, mkConst(toMachineWord 10000)] ]) ]), 1, "makestring()", getClosure nLevel, 0) end | codeVal (Value{access = Overloaded MakeString, ...}, _, _, _, _, _) = raise InternalError "Overloaded MakeString - wrong instance type" | codeVal (Value{access = Overloaded GetPretty, ...}, level, typeVarMap, [], _, _) = let val nLevel = newLevel level in (* If this appears in a structure return a default function. *) mkProc(printerForType(badType, nLevel, typeVarMap), 1, "getPretty", getClosure nLevel, 0) end | codeVal (Value{access = Overloaded GetPretty, ...}, level: level, typeVarMap, [{value=argType, ...}], _, _) = (* Get the pretty code for the specified argument. *) printerForType(argType, level, typeVarMap) | codeVal (Value{access = Overloaded GetPretty, ...}, _, _, _, _, _) = raise InternalError "Overloaded GetPretty - wrong instance type" | codeVal (Value{access = Overloaded AddPretty, ...}, _, _, [], _, _) = (* If this appears in a structure create a function that raises an exception if run. *) mkProc( mkConst (toMachineWord (fn _ => raise Fail "addPrettyPrint: The argument type was not a simple type construction")), 1, "AddPretty(P)", [], 0) | codeVal (Value{access = Overloaded AddPretty, ...}, level: level, _, [{value=installType, ...}, {value=argPrints, ...}], lex, loc) = let (* "instance" should be (int-> 'a -> 'b -> pretty) -> unit. We need to get the 'a and 'b. This function installs a pretty printer against the type which matches 'b. The type 'a is related to type of 'b as follows: If 'b is a monotype t then 'a is ignored. If 'b is a unary type constructor 'c t then 'a must have type 'c * int -> pretty. If 'b is a binary or higher type constructor e.g. ('c, 'd, 'e) t then 'a must be a tuple of functions of the form ('c * int -> pretty, 'd * int -> pretty, 'e * int -> pretty). When the installed function is called it will be passed the appropriate argument functions which it can call to print the argument types. *) val pretty = mkTypeVar (generalisable, false, false, false); (* Temporary hack. *) (* Find the last type constructor in the chain. We have to install this against the last in the chain because type constructors in different modules may be at different points in the chain. *) (* This does mean that it's not possible to install a pretty printer for a type constructor rather than a datatype. *) fun followTypes (TypeConstruction{constr, args, ...}) = if not (tcIsAbbreviation constr) then SOME(tcIdentifier constr, constr, List.length args) else followTypes (makeEquivalent (constr, args)) | followTypes (TypeVar tv) = ( case tvValue tv of EmptyType => NONE (* Unbound type variable *) | t => followTypes t ) | followTypes _ = NONE; val constrId = followTypes installType val () = case constrId of NONE => () | SOME (_, constr, arity) => let (* Check that the function tuple matches the arguments of the type we're installing for. *) (* Each entry should be a function of type 'a * int -> pretty *) fun mkFn arg = mkFunctionType(mkProductType[arg, TYPESTRUCT.fixedIntType], pretty) (* Create non-unifiable type vars to ensure this is properly polymorphic. *) val typeVars = List.tabulate(arity, fn _ => mkTypeVar (0, false, true, false)) val tupleType = case typeVars of [] => (* No arg so must have unit. *) unitType | [arg] => mkFn arg (* Just a single function. *) | args => mkProductType(List.map mkFn args) val addPPType = mkFunctionType(argPrints, mkFunctionType(installType, pretty)) val testType = mkFunctionType(tupleType, mkFunctionType( mkTypeConstruction(tcName constr, constr, typeVars, [DeclaredAt loc]), pretty)) in checkPPType(addPPType, testType, "addPrettyPrint", lex, loc, fn () => PrettyString "addPrettyPrint element functions must have type 'a * int -> pretty, 'b * int -> pretty, ... with one function for each type parameter") end; (* Only report the error when the function is run. Because addPrettyPrint is contained in the PolyML structure we may compile a reference to a polymorphic version of this for the structure record. It's replaced in the final structure by this version. *) in case constrId of SOME (typeId, _, arity) => let (* We need to transform the user-supplied function into the form required for the reference. The user function has type int -> 'b -> 'a -> pretty where 'b is either "don't care" if this is a monotype, the print function for the base type if it takes a single type argument or a tuple of base type functions if it takes more than one. The reference expects to contain a function of type 'a * int -> pretty for a monotype or a function of the form <'b1, 'b2...> -> 'a * int -> pretty if this is polytype where <...> represents poly-style multiple arguments. *) val printFunction = case arity of 0 => mkProc( mkEval( mkEval( mkEval( mkLoadClosure 0 (* The user-supplied fn *), [mkInd(1, arg1)] (* The depth *)), [CodeZero] (* Ignored args. *)), [mkInd(0, arg1)] (* Value to print *)), 1, "addPP-1", [arg1](* The user-supplied fn *), 0) | arity => let open TypeValue val args = if arity = 1 then [extractPrinter(mkLoadClosure 1)] else [mkTuple(List.tabulate(arity, fn n => extractPrinter(mkLoadClosure(n+1))))] in mkProc( mkProc( mkEval( mkEval( mkEval( mkLoadClosure 0 (* The user-supplied fn *), [mkInd(1, arg1)] (* The depth *)), args (* Base fns. *)), [mkInd(0, arg1)] (* Value to print *)), 1, "addPP-2", mkLoadClosure 0 :: List.tabulate(arity, mkLoadArgument), 0), arity, "addPP-1", [arg1], 0) end val nLevel = newLevel level in (* Generate a function that will set the "print" ref for the type to the argument function. *) mkProc( mkStoreOperation(LoadStoreMLWord{isImmutable=false}, TypeValue.extractPrinter( codeAccess(idAccess typeId, nLevel)), CodeZero, printFunction ), 1, "addPP", getClosure nLevel, 0) end | NONE => mkConst (toMachineWord (fn _ => raise Fail "addPrettyPrint: The argument type was not a simple type construction")) end | codeVal (Value{access = Overloaded AddPretty, ...}, _, _, _, _, _) = raise InternalError "Overloaded AddPretty - wrong instance type" | codeVal (Value{access = Overloaded GetLocation, ...}, _, _, _, _, _) = (* This can't be used a value: It must be called immediately. *) let fun getLoc() = raise Fail "The special function PolyML.sourceLocation cannot be used as a value" in mkConst (toMachineWord getLoc) end | codeVal (value as Value{access = Overloaded _, ...}, level: level, typeVarMap, instance, lex, lineno) = let val nLevel = newLevel level in (* AddOverload, Equal, NotEqual, TypeDep *) mkProc(applyFunction (value, arg1, nLevel, typeVarMap, instance, lex, lineno), 1, "", getClosure nLevel, 0) end (* Some of these have a more efficient way of calling them as functions. *) and applyFunction (value as Value{class=Exception, ...}, argument, level, typeVarMap, instance, lex, lineno) = let (* If we are applying it as a function we cannot be after the exception id, we must be constructing an exception packet. *) (* Get the exception id, put it in the packet with the exception name the argument and, currently, an empty location as the exception location. *) val exIden = codeVal (value, level, typeVarMap, instance, lex, lineno); in mkTuple (exIden :: mkStr (valName value) :: argument :: [mkConst(toMachineWord NoLocation)]) end | applyFunction(value as Value{class=Constructor _, ...}, argument, level, typeVarMap, argVars, lex, lineno) = let (* If this is a value constructor we need to get the construction function and use that. *) fun getConstr level = ValueConstructor.extractInjection(codeVal (value, level, typeVarMap, [], lex, lineno)) val polyConstr = applyToInstance(if justForEqualityTypes then [] else argVars, level, typeVarMap, getConstr) in (* Don't apply this "early". It might be the ref constructor and that must not be applied until run-time. The optimiser should take care of any other cases. *) mkEval (polyConstr, [argument]) end | applyFunction (value as Value{access = Overloaded oper, name = valName, ...}, argument, level, typeVarMap, instance, lex, lineno) = ( case oper of Equal => (* Get the equality function for the type. *) let (* We should have a single entry for the type. *) val argType = case instance of [{value, ...}] => value | _ => raise InternalError "Overload Equal" (* The instance type is a function so we have to get the first argument. *) val code = equalityForType(argType, level, typeVarMap) in mkEval (code, [argument]) end | NotEqual => let (* We should have a single entry for the type. *) val argType = case instance of [{value, ...}] => value | _ => raise InternalError "Overload NotEqual" (* Use the "=" function to provide inequality as well as equality. *) val code = equalityForType(argType, level, typeVarMap) val isEqual = mkEval (code, [argument]) in mkNot isEqual end | TypeDep => let val argType = case instance of [{value, ...}] => value | _ => raise InternalError "Overload TypeDep" val (code, _) = getOverloadInstance(valName, argType, false) in mkEval (code, [argument]) end | AddOverload => (* AddOverload is only intended for use by writers of library modules. It only does limited checking and should be regarded as "unsafe". *) let fun rmvars (TypeVar tv) = rmvars(tvValue tv) | rmvars t = t (* instance should be ('a->'b) -> string -> unit. For overloadings on most functions (e.g. abs and +) we are looking for the 'a, which may be a pair, but in the case of conversion functions we want the 'b. *) val (resultType, argType) = case instance of [{value=alpha, ...}, {value=beta, ...}] => (rmvars alpha, rmvars beta) | _ => (badType, badType) fun followTypes(TypeConstruction{constr as TypeConstrs {identifier = TypeId{idKind = Free _, ...},...}, ...}) = constr | followTypes(TypeConstruction{constr as TypeConstrs {identifier = TypeId{idKind = TypeFn _, ...},...}, args, ...}) = followTypes (makeEquivalent (constr, args)) | followTypes(TypeConstruction{constr = TypeConstrs {identifier = TypeId{idKind = Bound _, ...},...}, ...}) = raise Fail "Cannot install an overload within a structure or functor" | followTypes _ = raise Fail "Invalid type (not a type construction) (addOverload)" fun addOverloading (argCode: codetree) (name: string) = let val typeToUse = if size name > 4 andalso String.substring(name, 0, 4) = "conv" (* For conversion functions it's the result type we're interested in. For everything else it's the argument type. This will be a pair for functions such as "+" and a single argument for "abs". *) then resultType else case argType of LabelledType{recList=[{typeof, ...}, _], ...} => rmvars typeof | argType => argType val tcons = followTypes typeToUse in addOverload(name, tcons, argCode) end (* This function is used if we can't get the codetree at compile time. *) fun addOverloadGeneral (arg: machineWord) = addOverloading(mkConst arg) in (* This is messy but necessary for efficiency. If we simply treat addOverload as a function we would be able to pick up the additional overloading as a pointer to a function. Most overloads are small functions or wrapped calls to RTS functions and so we need to get the inline code for them. *) (* evalue raises an exception if "argument" is not a constant, or more usefully, a global value containing a constant and possibly a piece of codetree to inline. *) case evalue(argument) of SOME _ => mkConst (toMachineWord (addOverloading argument)) | NONE => mkEval (mkConst (toMachineWord addOverloadGeneral), [argument]) end | GetLocation => (* Return the current location. *) mkConst(toMachineWord lineno) | _ => (* Print, MakeString, InstallPP *) (* Just call as functions. *) (* not early *) mkEval (codeVal (value, level, typeVarMap, instance, lex, lineno), [argument]) ) (* overloaded *) | applyFunction (value, argument, level, typeVarMap, instance, lex, lineno) = mkEval (codeVal (value, level, typeVarMap, instance, lex, lineno), [argument]) (* end applyFunction *) (* If the exception is being used as a value we want an exception packet or a function to make a packet. If it is a nullary constructor make an exception packet now, otherwise generate a function to construct an exception packet. *) fun codeExFunction (value, level, typeVarMap, instance, lex, lineno) = case getFnArgType(valTypeOf value) of (* N.B. Not "instance" *) NONE => applyFunction (value, CodeZero, level, typeVarMap, List.map addStatus instance, lex, lineno) | SOME _ => let val nLevel = newLevel level in mkProc (applyFunction (value, arg1, nLevel, typeVarMap, List.map addStatus instance, lex, lineno), 1, "", getClosure nLevel, 0) end (* Operations to compile code from the representation of a constructor. *) (* Code to test whether a value matches a constructor. This must be applied to any polymorphic variables in the instance but the result is always bool so we don't create a new function if the result is also polymorphic. It is just possible to have a resulting polytype here (N.B. that's different from having a parametric type) if we have a val binding. e.g. val SOME x = SOME nil. In that case we can choose an arbitrary type for the test and have to parameterise the result. *) fun makeGuard (value as Value{class=Constructor _, ...}, argVars, testing, level, typeVarMap) = let fun tester level = ValueConstructor.extractTest(codeVal (value, level, typeVarMap, [], nullLex, location nullLex)) val testCode = applyToInstance(if justForEqualityTypes then [] else List.map addStatus argVars, level, typeVarMap, tester) in mkEval(testCode, [testing]) end | makeGuard (value as Value{class=Exception, ...}, _, testing, level, typeVarMap) = (* Should only be an exception. Get the value of the exception identifier and compare with the identifier in the exception packet. *) - mkEqualWord (mkInd (0, testing), + mkEqualPointerOrWord (mkInd (0, testing), codeVal (value, level, typeVarMap, [], nullLex, location nullLex)) | makeGuard _ = raise InternalError "makeGuard" (* Code to invert a constructor. i.e. return the value originally used as the argument. Apply to any polymorphic variables and construct a result. *) fun makeInverse(value as Value{class=Constructor{nullary=false, ...}, ...}, argVars, arg, level, typeVarMap): codetree = let fun getInverse level = ValueConstructor.extractProjection(codeVal (value, level, typeVarMap, [], nullLex, location nullLex)) val loadCode = applyToInstance(if justForEqualityTypes then [] else List.map addStatus argVars, level, typeVarMap, getInverse) in mkEval(loadCode, [arg]) end | makeInverse(Value{class=Constructor{nullary=true, ...}, ...}, _, _, _, _): codetree = (* makeInverse is called even on nullary constructors. Return zero to keep the optimiser happy. *) CodeZero | makeInverse (Value{class=Exception, ...}, _, arg, _, _) = (* Exceptions. - Get the parameter from third word *) (* We have to use a VarField here even though this field is present in every exception. The format of the value that is returned depends on the exception id. *) mkVarField (2,arg) | makeInverse _ = raise InternalError "makeInverse" (* Work out the polymorphism and the mapping between the formal type variables and the actual types. Because flexible records may introduce extra polymorphism we can only do this once we've frozen them. e.g. fun f x = #1 x + #2 x may be monomorphic or polymorphic depending on what it's subsequently applied to. *) (* Using unification here isn't ideal. We have to put the equality attribute back on to abstypes in case the unification requires it. There may be other situations where things don't work properly. *) fun getPolymorphism (Value{ typeOf, access, name, ...}, expType, typeVarMap) = let val (t, polyVars) = case access of Overloaded TypeDep => let val (t, polyVars) = generaliseOverload(typeOf, List.map #1 (getOverloads name), false) in (t, List.map (fn t => {value=t, equality=false, printity=false}) polyVars) end | _ => generaliseWithMap(typeOf, TypeVarMap.mapTypeVars typeVarMap) (* Ignore the result. There are circumstances in which we can get a unification error as the result of failing to find a fixed record type where the possible records we could find have non-unifiable types. See Tests/Fail/Test072.ML *) val _ = unifyTypes(t, expType) in polyVars end (* Convert a literal constant. We can only do this once any overloading has been resolved. *) fun getLiteralValue(converter, literal, instance, error): machineWord option = let val (conv, name) = getOverloadInstance(valName converter, instance, true) in SOME(RunCall.unsafeCast(valOf(evalue conv)) literal) handle Match => NONE (* Overload error *) | Conversion s => ( error("Conversion exception ("^s^") raised while converting " ^ literal ^ " to " ^ name); NONE ) | Overflow => ( error ("Overflow exception raised while converting " ^ literal ^ " to " ^ name); NONE ) | Thread.Thread.Interrupt => raise Thread.Thread.Interrupt | _ => ( error ("Exception raised while converting " ^ literal ^ " to " ^ name); NONE ) end (* Types that can be shared. *) structure Sharing = struct type lexan = lexan type codetree = codetree type types = types type values = values type structVals = structVals type functors = functors type valAccess = valAccess type typeConstrs = typeConstrs type typeConstrSet = typeConstrSet type signatures = signatures type fixStatus = fixStatus type univTable = univTable type pretty = pretty type locationProp = locationProp type typeId = typeId type typeVarForm = typeVarForm type typeVarMap = typeVarMap type level = level type machineWord = machineWord end end (* body of VALUEOPS *); diff --git a/polystatistics.h b/polystatistics.h index cfde01fb..f6db5341 100644 --- a/polystatistics.h +++ b/polystatistics.h @@ -1,84 +1,86 @@ /* Title: polystatics.h - Layout of statistics data in shared memory - Copyright (c) 2011, 2019 David C.J. Matthews + Copyright (c) 2011, 2019-20 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 POLY_STATISTICS_INCLUDED #define POLY_STATISTICS_INCLUDED #ifdef HAVE_SYS_TIME_H #include #endif // Name of shared memory file. This has the process ID appended. -// In Unix this is in /tmp +// In Unix this may be in the the $POLYSTATSDIR or $HOME/.polyml directories. #define POLY_STATS_NAME "poly-stats-" // ASN1 tags for the statistics #define POLY_STATS_C_STATISTICS 0x60 // Application 0 - Implicit set #define POLY_STATS_C_COUNTERSTAT 0x61 // Application 1 - Implicit sequence #define POLY_STATS_C_SIZESTAT 0x62 // Application 2 - Implicit sequence #define POLY_STATS_C_TIMESTAT 0x63 // Application 3 - Implicit sequence #define POLY_STATS_C_IDENTIFIER 0x44 // Application 4 - Implicit integer #define POLY_STATS_C_NAME 0x45 // Application 5 - Implicit visible string #define POLY_STATS_C_COUNTER_VALUE 0x46 // Application 6 - Implicit integer #define POLY_STATS_C_BYTE_COUNT 0x47 // Application 7 - Implicit integer #define POLY_STATS_C_TIME 0x68 // Application 8 - Implicit sequence #define POLY_STATS_C_SECONDS 0x49 // Application 9 - Implicit integer #define POLY_STATS_C_MICROSECS 0x4A // Application 10 - Implicit integer #define POLY_STATS_C_USERSTAT 0x6B // Application 11 - Implicit sequence // Identifiers for the particular statistics #define POLY_STATS_ID_THREADS 1 // Total number of threads #define POLY_STATS_ID_THREADS_IN_ML 2 // Threads running ML code #define POLY_STATS_ID_THREADS_WAIT_IO 3 // Threads waiting for IO #define POLY_STATS_ID_THREADS_WAIT_MUTEX 4 // Threads waiting for a mutex #define POLY_STATS_ID_THREADS_WAIT_CONDVAR 5 // Threads waiting for a condition var #define POLY_STATS_ID_THREADS_WAIT_SIGNAL 6 // Special case - signal handling thread #define POLY_STATS_ID_GC_FULLGC 7 // Number of full garbage collections #define POLY_STATS_ID_GC_PARTIALGC 8 // Number of partial GCs #define POLY_STATS_ID_TOTAL_HEAP 9 // Total size of the local heap #define POLY_STATS_ID_AFTER_LAST_GC 10 // Space free after last GC #define POLY_STATS_ID_AFTER_LAST_FULLGC 11 // Space free after the last full GC #define POLY_STATS_ID_ALLOCATION 12 // Size of allocation space #define POLY_STATS_ID_ALLOCATION_FREE 13 // Space available in allocation area #define POLY_STATS_ID_NONGC_UTIME 14 #define POLY_STATS_ID_NONGC_STIME 15 #define POLY_STATS_ID_GC_UTIME 16 #define POLY_STATS_ID_GC_STIME 17 #define POLY_STATS_ID_USER0 18 #define POLY_STATS_ID_USER1 19 #define POLY_STATS_ID_USER2 20 #define POLY_STATS_ID_USER3 21 #define POLY_STATS_ID_USER4 22 #define POLY_STATS_ID_USER5 23 #define POLY_STATS_ID_USER6 24 #define POLY_STATS_ID_USER7 25 #define POLY_STATS_ID_NONGC_RTIME 26 // Real time apart from GC #define POLY_STATS_ID_GC_RTIME 27 // Real time in GC #define POLY_STATS_ID_GC_SHARING 28 // Number of sharing passes #define POLY_STATS_ID_CODE_SPACE 29 // Space occupied by code #define POLY_STATS_ID_STACK_SPACE 30 // Space occupied by stacks +#define POLY_STATS_ID_GC_STATE 31 +#define POLY_STATS_ID_GC_PERCENT 32 #endif // POLY_STATISTICS_INCLUDED