diff --git a/RootInterpreted.ML b/RootInterpreted.ML index 3de7d222..653e6d89 100644 --- a/RootInterpreted.ML +++ b/RootInterpreted.ML @@ -1,131 +1,131 @@ (* Copyright (c) 2009, 2010, 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 *) (* Compiler root file. This gives the "use" instructions necessary to build the compiler and suitable for use with an IDE project file. It was constructed from the Poly/ML make files. *) PolyML.print_depth 1; PolyML.Compiler.reportUnreferencedIds := true; use "mlsource/MLCompiler/Address.ML"; use "mlsource/MLCompiler/Misc.ML"; use "mlsource/MLCompiler/HashTable.ML"; use "mlsource/MLCompiler/UniversalTable.ML"; use "mlsource/MLCompiler/StronglyConnected.sml"; use "mlsource/MLCompiler/StretchArray.ML"; use "mlsource/MLCompiler/STRUCTVALSIG.sml"; use "mlsource/MLCompiler/PRETTYSIG.sml"; use "mlsource/MLCompiler/LEXSIG.sml"; use "mlsource/MLCompiler/SymbolsSig.sml"; use "mlsource/MLCompiler/COMPILERBODYSIG.sml"; use "mlsource/MLCompiler/DEBUGSIG.ML"; use "mlsource/MLCompiler/MAKESIG.sml"; use "mlsource/MLCompiler/MAKE_.ML"; use "mlsource/MLCompiler/FOREIGNCALLSIG.sml"; use "mlsource/MLCompiler/BUILTINS.sml"; use "mlsource/MLCompiler/CODETREESIG.ML"; use "mlsource/MLCompiler/STRUCT_VALS.ML"; use "mlsource/MLCompiler/CodeTree/BackendIntermediateCodeSig.sml"; use "mlsource/MLCompiler/CodeTree/BaseCodeTreeSig.sml"; use "mlsource/MLCompiler/CodeTree/CodetreeFunctionsSig.sml"; use "mlsource/MLCompiler/CodeTree/CODEARRAYSIG.ML"; use "mlsource/MLCompiler/CodeTree/CodegenTreeSig.sml"; use "mlsource/MLCompiler/CodeTree/GENCODESIG.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_FUNCTIONS.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_STATIC_LINK_AND_CASES.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_CODEGEN_CONSTANT_FUNCTIONS.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_LAMBDA_LIFT.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_REMOVE_REDUNDANT.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_OPTIMISER.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE.ML"; use "mlsource/MLCompiler/Pretty.sml"; use "mlsource/MLCompiler/CodeTree/CODE_ARRAY.ML"; use "mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONSSIG.sml"; use "mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONS.ML"; use "mlsource/MLCompiler/CodeTree/ByteCode/INTGCODE.ML"; use "mlsource/MLCompiler/Debug.ML"; use "mlsource/MLCompiler/CodeTree/BackendIntermediateCode.sml"; use "mlsource/MLCompiler/CodeTree/BaseCodeTree.sml"; use "mlsource/MLCompiler/CodeTree/ByteCode/ml_bind.ML"; use "mlsource/MLCompiler/CodeTree/GCode.interpreted.ML"; use "mlsource/MLCompiler/CodeTree/ml_bind.ML"; use "mlsource/MLCompiler/StructVals.ML"; use "mlsource/MLCompiler/LEX_.ML"; use "mlsource/MLCompiler/Symbols.ML"; use "mlsource/MLCompiler/Lex.ML"; use "mlsource/MLCompiler/SymsetSig.sml"; use "mlsource/MLCompiler/DATATYPEREPSIG.sml"; use "mlsource/MLCompiler/VALUEOPSSIG.sml"; use "mlsource/MLCompiler/EXPORTTREESIG.sml"; use "mlsource/MLCompiler/STRUCTURESSIG.sml"; use "mlsource/MLCompiler/COMPILER_BODY.ML"; use "mlsource/MLCompiler/SymSet.ML"; use "mlsource/MLCompiler/TYPETREESIG.sml"; use "mlsource/MLCompiler/COPIERSIG.sml"; use "mlsource/MLCompiler/TYPEIDCODESIG.sml"; use "mlsource/MLCompiler/DATATYPE_REP.ML"; use "mlsource/MLCompiler/PRINTTABLESIG.sml"; use "mlsource/MLCompiler/VALUE_OPS.ML"; use "mlsource/MLCompiler/TYPE_TREE.ML"; use "mlsource/MLCompiler/UTILITIES_.ML"; use "mlsource/MLCompiler/Utilities.ML"; use "mlsource/MLCompiler/PRINT_TABLE.ML"; use "mlsource/MLCompiler/PrintTable.ML"; use "mlsource/MLCompiler/ExportTree.sml"; use "mlsource/MLCompiler/ExportTreeStruct.sml"; use "mlsource/MLCompiler/TypeTree.ML"; use "mlsource/MLCompiler/COPIER.sml"; use "mlsource/MLCompiler/CopierStruct.sml"; use "mlsource/MLCompiler/TYPEIDCODE.sml"; use "mlsource/MLCompiler/TypeIDCodeStruct.sml"; use "mlsource/MLCompiler/DatatypeRep.ML"; use "mlsource/MLCompiler/ValueOps.ML"; use "mlsource/MLCompiler/PARSETREESIG.sml"; use "mlsource/MLCompiler/SIGNATURESSIG.sml"; -use "mlsource/MLCompiler/DEBUGGERSIG.sml"; +use "mlsource/MLCompiler/DEBUGGER.sig"; use "mlsource/MLCompiler/STRUCTURES_.ML"; use "mlsource/MLCompiler/DEBUGGER_.sml"; use "mlsource/MLCompiler/Debugger.sml"; use "mlsource/MLCompiler/ParseTree/BaseParseTreeSig.sml"; use "mlsource/MLCompiler/ParseTree/BASE_PARSE_TREE.sml"; use "mlsource/MLCompiler/ParseTree/PrintParsetreeSig.sml"; use "mlsource/MLCompiler/ParseTree/PRINT_PARSETREE.sml"; use "mlsource/MLCompiler/ParseTree/ExportParsetreeSig.sml"; use "mlsource/MLCompiler/ParseTree/EXPORT_PARSETREE.sml"; use "mlsource/MLCompiler/ParseTree/TypeCheckParsetreeSig.sml"; use "mlsource/MLCompiler/ParseTree/TYPECHECK_PARSETREE.sml"; use "mlsource/MLCompiler/ParseTree/MatchCompilerSig.sml"; use "mlsource/MLCompiler/ParseTree/MATCH_COMPILER.sml"; use "mlsource/MLCompiler/ParseTree/CodegenParsetreeSig.sml"; use "mlsource/MLCompiler/ParseTree/CODEGEN_PARSETREE.sml"; use "mlsource/MLCompiler/ParseTree/PARSE_TREE.ML"; use "mlsource/MLCompiler/ParseTree/ml_bind.ML"; use "mlsource/MLCompiler/SIGNATURES.sml"; use "mlsource/MLCompiler/SignaturesStruct.sml"; use "mlsource/MLCompiler/Structures.ML"; use "mlsource/MLCompiler/PARSE_DEC.ML"; use "mlsource/MLCompiler/SKIPS_.ML"; use "mlsource/MLCompiler/Skips.ML"; use "mlsource/MLCompiler/PARSE_TYPE.ML"; use "mlsource/MLCompiler/ParseType.ML"; use "mlsource/MLCompiler/ParseDec.ML"; use "mlsource/MLCompiler/CompilerBody.ML"; use "mlsource/MLCompiler/CompilerVersion.sml"; use "mlsource/MLCompiler/Make.ML"; use "mlsource/MLCompiler/INITIALISE_.ML"; use "mlsource/MLCompiler/Initialise.ML"; use "mlsource/MLCompiler/ml_bind.ML"; diff --git a/RootX86.ML b/RootX86.ML index c3cb205c..ec80cd18 100644 --- a/RootX86.ML +++ b/RootX86.ML @@ -1,151 +1,151 @@ (* Copyright (c) 2009, 2010, 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 *) (* Compiler root file. This gives the "use" instructions necessary to build the compiler and suitable for use with an IDE project file. It was constructed from the Poly/ML make files. *) PolyML.print_depth 1; PolyML.Compiler.reportUnreferencedIds := true; use "mlsource/MLCompiler/Address.ML"; use "mlsource/MLCompiler/Misc.ML"; use "mlsource/MLCompiler/HashTable.ML"; use "mlsource/MLCompiler/UniversalTable.ML"; use "mlsource/MLCompiler/StronglyConnected.sml"; use "mlsource/MLCompiler/StretchArray.ML"; use "mlsource/MLCompiler/STRUCTVALSIG.sml"; use "mlsource/MLCompiler/PRETTYSIG.sml"; use "mlsource/MLCompiler/LEXSIG.sml"; use "mlsource/MLCompiler/SymbolsSig.sml"; use "mlsource/MLCompiler/COMPILERBODYSIG.sml"; use "mlsource/MLCompiler/DEBUGSIG.ML"; use "mlsource/MLCompiler/MAKESIG.sml"; use "mlsource/MLCompiler/MAKE_.ML"; use "mlsource/MLCompiler/FOREIGNCALLSIG.sml"; use "mlsource/MLCompiler/BUILTINS.sml"; use "mlsource/MLCompiler/CODETREESIG.ML"; use "mlsource/MLCompiler/STRUCT_VALS.ML"; use "mlsource/MLCompiler/CodeTree/BackendIntermediateCodeSig.sml"; use "mlsource/MLCompiler/CodeTree/BaseCodeTreeSig.sml"; use "mlsource/MLCompiler/CodeTree/CodetreeFunctionsSig.sml"; use "mlsource/MLCompiler/CodeTree/CODEARRAYSIG.ML"; use "mlsource/MLCompiler/CodeTree/CodegenTreeSig.sml"; use "mlsource/MLCompiler/CodeTree/GENCODESIG.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_FUNCTIONS.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_STATIC_LINK_AND_CASES.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_CODEGEN_CONSTANT_FUNCTIONS.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_LAMBDA_LIFT.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_REMOVE_REDUNDANT.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE_OPTIMISER.sml"; use "mlsource/MLCompiler/CodeTree/CODETREE.ML"; use "mlsource/MLCompiler/Pretty.sml"; use "mlsource/MLCompiler/CodeTree/CODE_ARRAY.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86CODESIG.sml"; use "mlsource/MLCompiler/CodeTree/X86Code/ICodeSig.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICODEGENERATESIG.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ALLOCATEREGISTERSSIG.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICODETRANSFORMSIG.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86IDENTIFYREFSSIG.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86GETCONFLICTSETSIG.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86PUSHREGISTERSIG.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/INTSETSIG.sml"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICODEOPTSIG.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/IntSet.sml"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICode.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICodeToX86Code.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86AllocateRegisters.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICodeOptimise.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICodeTransform.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICodeIdentifyReferences.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86ICodeGetConflictSets.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86PushRegisters.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86CodetreeToICode.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86OUTPUTCODE.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86OPTIMISE.ML"; use "mlsource/MLCompiler/Debug.ML"; use "mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml"; use "mlsource/MLCompiler/CodeTree/BackendIntermediateCode.sml"; use "mlsource/MLCompiler/CodeTree/BaseCodeTree.sml"; use "mlsource/MLCompiler/CodeTree/X86Code/ml_bind.ML"; use "mlsource/MLCompiler/CodeTree/GCode.i386.ML"; use "mlsource/MLCompiler/CodeTree/ml_bind.ML"; use "mlsource/MLCompiler/StructVals.ML"; use "mlsource/MLCompiler/LEX_.ML"; use "mlsource/MLCompiler/Symbols.ML"; use "mlsource/MLCompiler/Lex.ML"; use "mlsource/MLCompiler/SymsetSig.sml"; use "mlsource/MLCompiler/DATATYPEREPSIG.sml"; use "mlsource/MLCompiler/VALUEOPSSIG.sml"; use "mlsource/MLCompiler/EXPORTTREESIG.sml"; use "mlsource/MLCompiler/STRUCTURESSIG.sml"; use "mlsource/MLCompiler/COMPILER_BODY.ML"; use "mlsource/MLCompiler/SymSet.ML"; use "mlsource/MLCompiler/TYPETREESIG.sml"; use "mlsource/MLCompiler/COPIERSIG.sml"; use "mlsource/MLCompiler/TYPEIDCODESIG.sml"; use "mlsource/MLCompiler/DATATYPE_REP.ML"; use "mlsource/MLCompiler/PRINTTABLESIG.sml"; use "mlsource/MLCompiler/VALUE_OPS.ML"; use "mlsource/MLCompiler/TYPE_TREE.ML"; use "mlsource/MLCompiler/UTILITIES_.ML"; use "mlsource/MLCompiler/Utilities.ML"; use "mlsource/MLCompiler/PRINT_TABLE.ML"; use "mlsource/MLCompiler/PrintTable.ML"; use "mlsource/MLCompiler/ExportTree.sml"; use "mlsource/MLCompiler/ExportTreeStruct.sml"; use "mlsource/MLCompiler/TypeTree.ML"; use "mlsource/MLCompiler/COPIER.sml"; use "mlsource/MLCompiler/CopierStruct.sml"; use "mlsource/MLCompiler/TYPEIDCODE.sml"; use "mlsource/MLCompiler/TypeIDCodeStruct.sml"; use "mlsource/MLCompiler/DatatypeRep.ML"; use "mlsource/MLCompiler/ValueOps.ML"; use "mlsource/MLCompiler/PARSETREESIG.sml"; use "mlsource/MLCompiler/SIGNATURESSIG.sml"; -use "mlsource/MLCompiler/DEBUGGERSIG.sml"; +use "mlsource/MLCompiler/DEBUGGER.sig"; use "mlsource/MLCompiler/STRUCTURES_.ML"; use "mlsource/MLCompiler/DEBUGGER_.sml"; use "mlsource/MLCompiler/Debugger.sml"; use "mlsource/MLCompiler/ParseTree/BaseParseTreeSig.sml"; use "mlsource/MLCompiler/ParseTree/BASE_PARSE_TREE.sml"; use "mlsource/MLCompiler/ParseTree/PrintParsetreeSig.sml"; use "mlsource/MLCompiler/ParseTree/PRINT_PARSETREE.sml"; use "mlsource/MLCompiler/ParseTree/ExportParsetreeSig.sml"; use "mlsource/MLCompiler/ParseTree/EXPORT_PARSETREE.sml"; use "mlsource/MLCompiler/ParseTree/TypeCheckParsetreeSig.sml"; use "mlsource/MLCompiler/ParseTree/TYPECHECK_PARSETREE.sml"; use "mlsource/MLCompiler/ParseTree/MatchCompilerSig.sml"; use "mlsource/MLCompiler/ParseTree/MATCH_COMPILER.sml"; use "mlsource/MLCompiler/ParseTree/CodegenParsetreeSig.sml"; use "mlsource/MLCompiler/ParseTree/CODEGEN_PARSETREE.sml"; use "mlsource/MLCompiler/ParseTree/PARSE_TREE.ML"; use "mlsource/MLCompiler/ParseTree/ml_bind.ML"; use "mlsource/MLCompiler/SIGNATURES.sml"; use "mlsource/MLCompiler/SignaturesStruct.sml"; use "mlsource/MLCompiler/Structures.ML"; use "mlsource/MLCompiler/PARSE_DEC.ML"; use "mlsource/MLCompiler/SKIPS_.ML"; use "mlsource/MLCompiler/Skips.ML"; use "mlsource/MLCompiler/PARSE_TYPE.ML"; use "mlsource/MLCompiler/ParseType.ML"; use "mlsource/MLCompiler/ParseDec.ML"; use "mlsource/MLCompiler/CompilerBody.ML"; use "mlsource/MLCompiler/CompilerVersion.sml"; use "mlsource/MLCompiler/Make.ML"; use "mlsource/MLCompiler/INITIALISE_.ML"; use "mlsource/MLCompiler/Initialise.ML"; use "mlsource/MLCompiler/ml_bind.ML"; diff --git a/Tests/Succeed/Test163.ML b/Tests/Succeed/Test163.ML index 17066634..1db79f8b 100644 --- a/Tests/Succeed/Test163.ML +++ b/Tests/Succeed/Test163.ML @@ -1,60 +1,77 @@ (* Some tests on C memory operations. *) fun check f a b = if f a = b then () else raise Fail "Mismatch"; (* 64-bit operations are not implemented in 32-bit mode. *) fun checkEx f a b = (if f a = b then () else raise Fail "Mismatch") handle Foreign.Foreign _ => (); open Foreign.Memory; val m = malloc 0w32; +val e = ++(m, 0w32); val r = ref 0w0; set32(m, 0w0, 0wx12343421); set32(m, 0w1, 0w0); set32(m, 0w2, 0w0); set32(m, 0w3, 0w0); set32(m, 0w4, 0w0); set32(m, 0w5, 0w0); set32(m, 0w6, 0wxabccccab); set32(m, 0w7, 0wx12211221); (* These are often handled differently depending on whether the offset is a compile-time constant. *) check get32 (m, 0w0) 0wx12343421; check get32 (m, !r) 0wx12343421; +check get32 (e, ~ 0w8) 0wx12343421; +check get32 (e, !r - 0w8) 0wx12343421; + check get32 (m, 0w6) 0wxabccccab; +check get32 (e, ~ 0w2) 0wxabccccab; r := 0w6; check get32 (m, !r) 0wxabccccab; +check get32 (e, !r - 0w8) 0wxabccccab; check get16 (m, 0w14) 0wx1221; +check get16 (e, ~ 0w2) 0wx1221; r := 0w14; check get16 (m, !r) 0wx1221; +check get16 (e, !r - 0w16) 0wx1221; checkEx get64 (m, 0w1) 0w0; +checkEx get64 (e, ~ 0w7) 0w0; r := 0w1; checkEx get64 (m, !r) 0w0; +checkEx get64 (e, !r - 0w8) 0w0; check get8 (m, 0w24) 0wxab; +check get8 (e, ~ 0w8) 0wxab; r := 0w24; check get8 (m, !r) 0wxab; +check get8 (e, !r - 0w32) 0wxab; set8(m, !r, 0wx88); check get8 (m, 0w24) 0wx88; +set8(e, !r - 0w32, 0wx77); +check get8 (e, ~ 0w8) 0wx77; set64(m, 0w1, 0wx123456) handle Foreign.Foreign _ => (); checkEx get64 (m, 0w1) 0wx123456; set16(m, 0w4, 0wxffee); check get16 (m, 0w4) 0wxffee; setFloat(m, 0w2, 1.0); if Real.==(getFloat(m, 0w2), 1.0) then () else raise Fail "Mismatch"; +if Real.==(getFloat(e, ~ 0w6), 1.0) then () else raise Fail "Mismatch"; r := 0w2; if Real.==(getFloat(m, !r), 1.0) then () else raise Fail "Mismatch"; setDouble(m, 0w2, 2.0); if Real.==(getDouble(m, 0w2), 2.0) then () else raise Fail "Mismatch"; +if Real.==(getDouble(e, ~ 0w2), 2.0) then () else raise Fail "Mismatch"; if Real.==(getDouble(m, !r), 2.0) then () else raise Fail "Mismatch"; + free m; diff --git a/basis/ASN1.sml b/basis/ASN1.sml index b89ad0ef..c38ef69b 100644 --- a/basis/ASN1.sml +++ b/basis/ASN1.sml @@ -1,256 +1,256 @@ (* Title: ASN1 support. Author: David Matthews - Copyright David Matthews 2015-16, 2019 + Copyright David Matthews 2015-16, 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 *) -(* +(** These functions provide assistance in the encoding and decoding of ASN1 binary encoding. -*) +**) signature ASN1 = sig datatype form = Primitive | Constructed datatype tagType = Universal of int * form | Application of int * form | Context of int * form | Private of int * form val asn1Boolean: tagType and asn1Integer: tagType and asn1BitString: tagType and asn1OctetString: tagType (* Parse the tag and length information to extract the first tag/value pair from the input. Returns with the reader pointing at the start of the data. *) val readHeader: (Word8.word, 'a) StringCvt.reader -> ((tagType * int), 'a) StringCvt.reader (* Parse the tag and length information to extract the first tag/value pair from the input. Returns the remainder of the input. *) val decodeItem: Word8VectorSlice.slice -> {tag: tagType, data: Word8VectorSlice.slice, remainder: Word8VectorSlice.slice} option val decodeInt: Word8VectorSlice.slice -> int and decodeLargeInt: Word8VectorSlice.slice -> LargeInt.int and decodeString: Word8VectorSlice.slice -> string and decodeBool: Word8VectorSlice.slice -> bool (* Encode a tag/value pair. *) val encodeItem: tagType * Word8Vector.vector list -> Word8Vector.vector list val encodeInt: int -> Word8Vector.vector and encodeString: string -> Word8Vector.vector and encodeBool: bool -> Word8Vector.vector end; structure Asn1: ASN1 = struct datatype form = Primitive | Constructed datatype tagType = Universal of int * form | Application of int * form | Context of int * form | Private of int * form (* A few standard tags *) val asn1Boolean = Universal(1, Primitive) and asn1Integer = Universal(2, Primitive) and asn1BitString = Universal(3, Primitive) (* Could also be constructed *) and asn1OctetString = Universal(4, Primitive) (* Could also be constructed *) open Word8VectorSlice (* Convert the length data. The first byte is either the length itself, if it is less than 128 otherwise it is the number of bytes containing the length. *) fun getLength getNext p = case getNext p of SOME (n, t) => if n < 0wx80 then SOME(Word8.toInt n, t) else let fun getL(0w0, m, l) = SOME(m, l) | getL(n, m, t) = case getNext t of SOME (hd, tl) => getL(n-0w1, m * 256 + Word8.toInt hd, tl) | NONE => NONE val lengthOfLength = Word8.andb(n, 0wx7f) in if lengthOfLength = 0w0 then raise Fail "Indefinite length is not implemented" else getL(lengthOfLength, 0, t) end | NONE => NONE fun readHeader getNext input = case getNext input of SOME (code, t) => let (* The type is encoded in the top two bits of the first byte. *) val tagType: int * form -> tagType = case Word8.andb(code, 0wxc0) of 0wx00 => Universal | 0wx40 => Application | 0wx80 => Context | _ => Private val sc = if Word8.andb(code, 0wx20) = 0w0 then Primitive else Constructed (* The tag is the bottom five bits except that if it is 0x1f the tag is encoded in subsequent bytes. *) val tagRest = case Word8.andb(code, 0w31) of 0w31 => (* This is a long-format tag *) let fun decode (acc, seq) = case getNext seq of SOME(code, seq') => let (* Keep accumulating the tags until we find a byte with the top bit clear. *) val tag' = acc * 128 + Word8.toInt(Word8.andb(code, 0wx7f)) in if Word8.andb(code, 0wx80) = 0w0 then SOME(tag', seq') else decode(tag', seq') end | NONE => NONE in decode(0, t) end | firstTag => SOME(Word8.toInt firstTag, t) in case tagRest of SOME(tag, rest) => ( case getLength getNext rest of SOME(len, tail) => SOME((tagType(tag, sc), len), tail) | NONE => NONE ) | NONE => NONE end | NONE => NONE (* Decode Word8VectorSlice.slice input. *) local fun getNext n = if length n = 0 then NONE else SOME(sub(n, 0), subslice(n, 1, NONE)) in fun decodeItem input = case readHeader getNext input of SOME((tag, len), tail) => SOME{tag = tag, data = Word8VectorSlice.subslice(tail, 0, SOME len), remainder = Word8VectorSlice.subslice(tail, len, NONE) } | NONE => NONE fun decodeLargeInt p = case getNext p of NONE => 0 | SOME(h, tl) => let fun parseRest(n, p) = case getNext p of NONE => n | SOME (hd, tl) => parseRest(n * 256 + Word8.toLargeInt hd, tl) in parseRest(Word8.toLargeIntX h, tl) end val decodeInt = LargeInt.toInt o decodeLargeInt end fun decodeString t = Byte.bytesToString(vector t) and decodeBool p = decodeInt p <> 0 fun encodeItem (tag, value) = let open Word8Vector fun encodeTag(tagType, tagValue) = if tagValue < 31 then [Word8.orb(tagType, Word8.fromInt tagValue)] else let (* Set the top bit on all bytes except the last. *) fun addToList(n, []) = [Word8.fromInt n] | addToList(n, t) = Word8.fromInt(128 + n) :: t fun encode(n, t) = if n < 128 then addToList(n, t) else encode(n div 128, addToList(n mod 128, t)) in Word8.orb(tagType, 0w31) :: encode(tagValue, []) end val tagCode = case tag of Universal (t, Primitive) => encodeTag(0wx00, t) | Universal (t, Constructed) => encodeTag(0wx20, t) | Application (t, Primitive) => encodeTag(0wx40, t) | Application (t, Constructed) => encodeTag(0wx60, t) | Context (t, Primitive) => encodeTag(0wx80, t) | Context (t, Constructed) => encodeTag(0wxa0, t) | Private (t, Primitive) => encodeTag(0wxc0, t) | Private (t, Constructed) => encodeTag(0wxe0, t) (* Encode the length the argument. *) val length = List.foldl(fn (a, b) => length a + b) 0 value val lengthCode = if length < 128 then [Word8.fromInt length] else let fun encodeLength (0, t) = t | encodeLength (v, t) = encodeLength(v div 256, Word8.fromInt(v mod 256) :: t) val encodedLength = encodeLength(length, []) in Word8.orb(0wx80, Word8.fromInt(List.length encodedLength)) :: encodedLength end in fromList(tagCode @ lengthCode) :: value end fun encodeInt n = let fun encode (n, t) = let val lo = Word8.fromInt n (* Bottom byte *) val hi = n div 256 in (* If the high byte is 0 or -1 and the sign bit is already correct we've finished. *) if hi = 0 andalso lo < 0w128 orelse hi = ~1 andalso lo >= 0w128 then lo :: t else encode(hi, lo :: t) end in Word8Vector.fromList(encode(n, [])) end val encodeString = Byte.stringToBytes fun encodeBool b = encodeInt(if b then 1 else 0) end; diff --git a/basis/CommandLine.sml b/basis/CommandLine.sml index dca3a72f..5d701e03 100644 --- a/basis/CommandLine.sml +++ b/basis/CommandLine.sml @@ -1,31 +1,31 @@ (* Title: Standard Basis Library: CommandLine Structure and Signature Author: David Matthews - Copyright David Matthews 1999, 2016, 2019 + Copyright David Matthews 1999, 2016, 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 COMMAND_LINE = sig val name : unit -> string val arguments : unit -> string list end structure CommandLine : COMMAND_LINE = struct - val name: unit -> string = RunCall.rtsCallFull1 "PolyCommandLineName" - and arguments: unit -> string list = RunCall.rtsCallFull1 "PolyCommandLineArgs" + val name = RunCall.rtsCallFull0 "PolyGetProcessName" + and arguments = RunCall.rtsCallFull0 "PolyGetCommandlineArguments" end; diff --git a/basis/DateSignature.sml b/basis/DATE.sig similarity index 100% rename from basis/DateSignature.sml rename to basis/DATE.sig diff --git a/basis/FinalPolyML.sml b/basis/FinalPolyML.sml index 4adf3b28..7437db85 100644 --- a/basis/FinalPolyML.sml +++ b/basis/FinalPolyML.sml @@ -1,2224 +1,2228 @@ (* Title: Nearly final version of the PolyML structure Author: David Matthews - Copyright David Matthews 2008-9, 2014, 2015-17, 2019 + Copyright David Matthews 2008-9, 2014, 2015-17, 2019-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 *) (* Based on: Title: Poly Make Program. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) (* This is the version of the PolyML structure that can be compiled after we have the rest of the basis library. In particular it binds in TextIO.stdIn and TextIO.stdOut. This contains the top-level read-eval-print loop as well as "use" and Poly/ML's "make". The rootFunction has now been pulled out into a separate file and is added on after this. *) local (* A hash table with a mutex that protects against multiple threads rehashing the table by entering values at the same time. *) structure ProtectedTable :> sig type 'a ptable val create: unit -> 'a ptable val lookup: 'a ptable -> string -> 'a option val enter: 'a ptable -> string * 'a -> unit val all: 'a ptable -> unit -> (string * 'a) list val delete: 'a ptable -> string -> unit end = struct open HashArray Thread.Mutex LibraryIOSupport type 'a ptable = 'a hash * mutex fun create () = (hash 10, mutex()) and lookup(tab, mutx) = protect mutx (fn s => sub(tab, s)) and enter(tab, mutx) = protect mutx (fn (s, v) => update(tab, s, v)) and all(tab, mutx) = protect mutx (fn () => fold (fn (s, v, l) => ((s, v) :: l)) [] tab) and delete(tab, mutx) = protect mutx (fn s => HashArray.delete (tab, s)) end fun quickSort _ ([]:'a list) = [] | quickSort _ ([h]:'a list) = [h] | quickSort (leq:'a -> 'a -> bool) ((h::t) :'a list) = let val (after, befor) = List.partition (leq h) t in quickSort leq befor @ (h :: quickSort leq after) end open PolyML.NameSpace local open ProtectedTable val fixTable = create() and sigTable = create() and valTable = create() and typTable = create() and fncTable = create() and strTable = create() in val globalNameSpace: PolyML.NameSpace.nameSpace = { lookupFix = lookup fixTable, lookupSig = lookup sigTable, lookupVal = lookup valTable, lookupType = lookup typTable, lookupFunct = lookup fncTable, lookupStruct = lookup strTable, enterFix = enter fixTable, enterSig = enter sigTable, enterVal = enter valTable, enterType = enter typTable, enterFunct = enter fncTable, enterStruct = enter strTable, allFix = all fixTable, allSig = all sigTable, allVal = all valTable, allType = all typTable, allFunct = all fncTable, allStruct = all strTable } val forgetFix = delete fixTable and forgetSig = delete sigTable and forgetVal = delete valTable and forgetType = delete typTable and forgetFunct = delete fncTable and forgetStruct = delete strTable end local open PolyML (* For prettyprint datatype *) (* Install a pretty printer for parsetree properties. This isn't done in the compiler. *) fun prettyProps depth _ l = if depth <= 0 then PrettyString "..." else prettyProp(l, depth-1) (* Use prettyRepresentation to print most of the arguments *) and prettyProp(PTbreakPoint b, d) = blockArg("PTbreakPoint", prettyRepresentation(b, d)) | prettyProp(PTcompletions s, d) = blockArg("PTcompletions", prettyRepresentation(s, d)) | prettyProp(PTdeclaredAt l, d) = blockArg("PTdeclaredAt", prettyRepresentation(l, d)) | prettyProp(PTdefId i, d) = blockArg("PTdefId", prettyRepresentation(i, d)) | prettyProp(PTfirstChild _, _) = blockArg("PTfirstChild", PrettyString "fn") | prettyProp(PTnextSibling _, _) = blockArg("PTnextSibling", PrettyString "fn") | prettyProp(PTopenedAt f, d) = blockArg("PTopenedAt", prettyRepresentation(f, d)) | prettyProp(PTparent _, _) = blockArg("PTparent", PrettyString "fn") | prettyProp(PTpreviousSibling _, _)= blockArg("PTpreviousSibling", PrettyString "fn") | prettyProp(PTprint _, _) = blockArg("PTprint", PrettyString "fn") | prettyProp(PTreferences f, d) = blockArg("PTreferences", prettyRepresentation(f, d)) | prettyProp(PTrefId f, d) = blockArg("PTrefId", prettyRepresentation(f, d)) | prettyProp(PTstructureAt f, d) = blockArg("PTstructureAt", prettyRepresentation(f, d)) | prettyProp(PTtype f, d) = blockArg("PTtype", prettyRepresentation(f, d)) and blockArg (s, arg) = PrettyBlock(3, true, [], [PrettyString s, PrettyBreak(1, 1), parenthesise arg]) and parenthesise(p as PrettyBlock(_, _, _, PrettyString "(" :: _)) = p | parenthesise(p as PrettyBlock(_, _, _, PrettyString "{" :: _)) = p | parenthesise(p as PrettyBlock(_, _, _, PrettyString "[" :: _)) = p | parenthesise(p as PrettyBlock(_, _, _, _ :: _)) = PrettyBlock(3, true, [], [ PrettyString "(", PrettyBreak(0, 0), p, PrettyBreak(0, 0), PrettyString ")" ]) | parenthesise p = p in val () = addPrettyPrinter prettyProps end (* PolyML.compiler takes a list of these parameter values. They all default so it's possible to pass only those that are actually needed. *) datatype compilerParameters = CPOutStream of string->unit (* Output stream for debugging and other output from the compiler. Provides a default stream for other output. Default: TextIO.print *) | CPNameSpace of PolyML.NameSpace.nameSpace (* Name space to look up and enter results. Default: globalNameSpace *) | CPErrorMessageProc of { message: PolyML.pretty, hard: bool, location: PolyML.location, context: PolyML.pretty option } -> unit (* Called by the compiler to generate error messages. Arguments (message, isHard, lineNo, context). message is the message. isHard is true if this is an error, false if a warning. location is the file-name, line number and position. context is an optional extra piece of information showing the part of the parse tree where the error was detected. Default: print this to CPOutStream value using CPLineNo and CPFileName. *) | CPLineNo of unit -> int (* Called by the compiler to get the current "line number". This is passed to CPErrorMessageProc and the debugger. It may actually be a more general location than a source line. Default: fn () => 0 i.e. no line numbering. *) | CPLineOffset of unit -> int (* Called by the compiler to get the current "offset". This is passed to CPErrorMessageProc and the debugger. This may either be an offset on the current file, a byte offset or simply zero. Default: fn () => 0 i.e. no line offset. *) | CPFileName of string (* The current file being compiled. This is used by the default CPErrorMessageProc and the debugger. Default: "" i.e. interactive stream. *) | CPPrintInAlphabeticalOrder of bool (* Whether to sort the results by alphabetical order before printing them. Applies only to the default CPResultFun. Default value of printInAlphabeticalOrder. *) | CPResultFun of { fixes: (string * Infixes.fixity) list, values: (string * Values.value) list, structures: (string * Structures.structureVal) list, signatures: (string * Signatures.signatureVal) list, functors: (string * Functors.functorVal) list, types: (string * TypeConstrs.typeConstr) list} -> unit (* Function to apply to the result of compiling and running the code. Default: print and enter the values into CPNameSpace. *) | CPCompilerResultFun of PolyML.parseTree option * ( unit -> { fixes: (string * Infixes.fixity) list, values: (string * Values.value) list, structures: (string * Structures.structureVal) list, signatures: (string * Signatures.signatureVal) list, functors: (string * Functors.functorVal) list, types: (string * TypeConstrs.typeConstr) list}) option -> unit -> unit (* Function to process the result of compilation. This can be used to capture the parse tree even if type-checking fails. Default: Execute the code and call the result function if the compilation succeeds. Raise an exception if the compilation failed. *) | CPProfiling of int (* Deprecated: No longer used. *) | CPTiming of bool (* Deprecated: No longer used. *) | CPDebug of bool (* Control whether calls to the debugger should be inserted into the compiled code. This allows breakpoints to be set, values to be examined and printed and functions to be traced at the cost of extra run-time overhead. Default: value of PolyML.Compiler.debug *) | CPPrintDepth of unit->int (* This controls the depth of printing if the default CPResultFun is used. It is also bound into any use of PolyML.print in the compiled code and will be called to get the print depth whenever that code is executed. Default: Get the current value of PolyML.print_depth. *) | CPPrintStream of string->unit (* This is bound into any occurrence of PolyML.print and is used to produce the outut. Default: CPOutStream. *) | CPErrorDepth of int (* Controls the depth of context to produce in error messages. Default : value of PolyML.error_depth. *) | CPLineLength of int (* Bound into any occurrences of PolyML.print. This is the length of a line used in the pretty printer. Default: value of PolyML.line_length. *) | CPRootTree of { parent: (unit -> PolyML.parseTree) option, next: (unit -> PolyML.parseTree) option, previous: (unit -> PolyML.parseTree) option } (* This can be used to provide a parent for parse trees created by the compiler. This appears as a PTparent property in the tree. The default is NONE which does not to provide a parent. *) | CPAllocationProfiling of int (* Controls whether to add profiling information to each allocation. Currently zero means no profiling and one means add the allocating function. *) | CPDebuggerFunction of int * Values.value * int * string * string * nameSpace -> unit (* Deprecated: No longer used. *) | CPBindingSeq of unit -> int (* Used to create a sequence no for PTdefId properties. This can be used in an IDE to allocate a unique Id for an identifier. Default fn _ => 0. *) (* References for control and debugging. *) val timing = ref false and printDepth: int ref = ref 0 and errorDepth: int ref = ref 6 and lineLength: int ref = ref 77 and allocationProfiling = ref false val assemblyCode = ref false and codetree = ref false and codetreeAfterOpt = ref false and icode = ref false and parsetree = ref false and reportUnreferencedIds = ref false and reportExhaustiveHandlers = ref false and narrowOverloadFlexRecord = ref false and createPrintFunctions = ref true and reportDiscardFunction = ref true and reportDiscardNonUnit = ref false val lowlevelOptimise = ref true val debug = ref false val inlineFunctors = ref true val maxInlineSize: int ref = ref 80 val printInAlphabeticalOrder = ref true val traceCompiler = ref false (* No longer used. *) fun prettyPrintWithIDEMarkup(stream : string -> unit, lineWidth : int): PolyML.pretty -> unit = let open PolyML val openDeclaration = "\u001bD" val closeDeclaration = "\u001bd" val separator = "\u001b," val finalSeparator = "\u001b;" fun beginMarkup context = case List.find (fn ContextLocation _ => true | _ => false) context of SOME (ContextLocation{file,startLine,startPosition,endPosition, ...}) => let (* In the unlikely event there's an escape character in the file name convert it to ESC-ESC. *) fun escapeEscapes #"\u001b" = "\u001b\u001b" | escapeEscapes c = str c in stream openDeclaration; stream(String.translate escapeEscapes file); stream separator; stream(FixedInt.toString startLine); stream separator; stream(FixedInt.toString startPosition); stream separator; stream(FixedInt.toString endPosition); stream finalSeparator end | _ => () fun endMarkup context = List.app (fn ContextLocation _ => stream closeDeclaration | _ => ()) context in prettyMarkup (beginMarkup, endMarkup) (stream, lineWidth) end; (* useMarkupInOutput is set according to the setting of *) val useMarkupInOutput = ref false fun prettyPrintWithOptionalMarkup(stream, lineWidth) = if ! useMarkupInOutput then prettyPrintWithIDEMarkup(stream, lineWidth) else PolyML.prettyPrint(stream, lineWidth) (* Top-level prompts. *) val prompt1 = ref "> " and prompt2 = ref "# "; fun printOut s = TextIO.print s (* If we get an exception while writing to stdOut we've got a big problem and can't continue. It could happen if we have closed stdOut. Try reporting the error through stdErr and exit. *) handle Thread.Thread.Interrupt => raise Thread.Thread.Interrupt | exn => ( ( TextIO.output(TextIO.stdErr, concat["Exception ", exnName exn, " raised while writing to stdOut.\n"]); TextIO.flushOut TextIO.stdErr (* probably unnecessary. *) ) handle _ => (); (* Get out without trying to do anything else. *) OS.Process.terminate OS.Process.failure ) (* Default function to print and enter a value. *) fun printAndEnter (inOrder: bool, space: PolyML.NameSpace.nameSpace, stream: string->unit, depth: int) { fixes: (string * Infixes.fixity) list, values: (string * Values.value) list, structures: (string * Structures.structureVal) list, signatures: (string * Signatures.signatureVal) list, functors: (string * Functors.functorVal) list, types: (string * TypeConstrs.typeConstr) list}: unit = let (* We need to merge the lists to sort them alphabetically. *) datatype decKind = FixStatusKind of Infixes.fixity | TypeConstrKind of TypeConstrs.typeConstr | SignatureKind of Signatures.signatureVal | StructureKind of Structures.structureVal | FunctorKind of Functors.functorVal | ValueKind of Values.value val decList = map (fn (s, f) => (s, FixStatusKind f)) fixes @ map (fn (s, f) => (s, TypeConstrKind f)) types @ map (fn (s, f) => (s, SignatureKind f)) signatures @ map (fn (s, f) => (s, StructureKind f)) structures @ map (fn (s, f) => (s, FunctorKind f)) functors @ map (fn (s, f) => (s, ValueKind f)) values fun kindToInt(FixStatusKind _) = 0 | kindToInt(TypeConstrKind _) = 1 | kindToInt(SignatureKind _) = 2 | kindToInt(StructureKind _) = 3 | kindToInt(FunctorKind _) = 4 | kindToInt(ValueKind _) = 5 fun order (s1: string, k1) (s2, k2) = if s1 = s2 then kindToInt k1 <= kindToInt k2 else s1 <= s2 (* Don't sort the declarations if we want them in declaration order. *) val sortedDecs = if inOrder then quickSort order decList else decList fun enterDec(n, FixStatusKind f) = #enterFix space (n,f) | enterDec(n, TypeConstrKind t) = #enterType space (n,t) | enterDec(n, SignatureKind s) = #enterSig space (n,s) | enterDec(n, StructureKind s) = #enterStruct space (n,s) | enterDec(n, FunctorKind f) = #enterFunct space (n,f) | enterDec(n, ValueKind v) = #enterVal space (n,v) fun printDec(_, FixStatusKind f) = prettyPrintWithOptionalMarkup (stream, !lineLength) (Infixes.print f) | printDec(_, TypeConstrKind t) = prettyPrintWithOptionalMarkup (stream, !lineLength) (TypeConstrs.print(t, FixedInt.fromInt depth, SOME space)) | printDec(_, SignatureKind s) = prettyPrintWithOptionalMarkup (stream, !lineLength) (Signatures.print(s, FixedInt.fromInt depth, SOME space)) | printDec(_, StructureKind s) = prettyPrintWithOptionalMarkup (stream, !lineLength) (Structures.print(s, FixedInt.fromInt depth, SOME space)) | printDec(_, FunctorKind f) = prettyPrintWithOptionalMarkup (stream, !lineLength) (Functors.print(f, FixedInt.fromInt depth, SOME space)) | printDec(_, ValueKind v) = if Values.isConstructor v andalso not (Values.isException v) then () (* Value constructors are printed with the datatype. *) else prettyPrintWithOptionalMarkup (stream, !lineLength) (Values.printWithType(v, FixedInt.fromInt depth, SOME space)) in (* First add the declarations to the name space and then print them. Doing it this way improves the printing of types since these require look-ups in the name space. For instance the constructors of a datatype from an opened structure should not include the structure name but that will only work once the datatype itself is in the global name-space. *) List.app enterDec sortedDecs; if depth > 0 then List.app printDec sortedDecs else () end local open Bootstrap Bootstrap.Universal (* To allow for the possibility of changing the representation we don't make Universal be the same as Bootstrap.Universal. *) (* Default error message function. *) fun defaultErrorProc printString {message: PolyML.pretty, hard: bool, location={startLine, startPosition, endPosition, file, ...}: PolyML.location, context: PolyML.pretty option} = let open PolyML val fullMessage = case context of NONE => message | SOME ctxt => PrettyBlock(0, true, [], [ message, PrettyBreak(1, 0), PrettyBlock(2, false, [], [PrettyString "Found near", PrettyBreak(1, 0), ctxt]) ]) in if ! useMarkupInOutput then (* IDE mark-up of error messages. This is actually the same as within the IDE. *) let val openError = "\u001bE" val closeError = "\u001be" val separator = "\u001b," val finalSeparator = "\u001b;" in printString( concat [ openError, if hard then "E" else "W", separator, file, (* TODO double any escapes. *) separator, FixedInt.toString startLine, separator, FixedInt.toString startPosition, separator, FixedInt.toString endPosition, finalSeparator ] ); prettyPrintWithIDEMarkup(printString, !lineLength) fullMessage; printString closeError end else (* Plain text form. *) ( printString(concat ( (if file = "" then ["poly: "] else [file, ":"]) @ (if startLine = 0 then [] else [FixedInt.toString startLine]) @ (if startPosition = 0 then [": "] else [".", FixedInt.toString startPosition, "-", FixedInt.toString endPosition, ": "]) @ (if hard then ["error: "] else ["warning: "]) )); (* ( (if hard then ["Error-"] else ["Warning-"]) @ (if file = "" then [] else [" in '", file, "',"]) @ (if startLine = 0 then [] else [" line ", Int.toString startLine]) @ (if startLine = 0 andalso file = "" then [] else [".\n"]))); *) PolyML.prettyPrint(printString, !lineLength) fullMessage ) end in (* This function ends up as PolyML.compiler. *) fun polyCompiler (getChar: unit->char option, parameters: compilerParameters list) = let (* Find the first item that matches or return the default. *) fun find _ def [] = def | find f def (hd::tl) = case f hd of SOME s => s | NONE => find f def tl val outstream = find (fn CPOutStream s => SOME s | _ => NONE) TextIO.print parameters val nameSpace = find (fn CPNameSpace n => SOME n | _ => NONE) globalNameSpace parameters val lineNo = find (fn CPLineNo l => SOME l | _ => NONE) (fn () => 0) parameters val lineOffset = find (fn CPLineOffset l => SOME l | _ => NONE) (fn () => 0) parameters val fileName = find (fn CPFileName s => SOME s | _ => NONE) "" parameters val printInOrder = find (fn CPPrintInAlphabeticalOrder t => SOME t | _ => NONE) (! printInAlphabeticalOrder) parameters val printDepth = find (fn CPPrintDepth f => SOME f | _ => NONE) (fn () => !printDepth) parameters val resultFun = find (fn CPResultFun f => SOME f | _ => NONE) (printAndEnter(printInOrder, nameSpace, outstream, printDepth())) parameters val printString = find (fn CPPrintStream s => SOME s | _ => NONE) outstream parameters val errorProc = find (fn CPErrorMessageProc f => SOME f | _ => NONE) (defaultErrorProc printString) parameters val debugging = find (fn CPDebug t => SOME t | _ => NONE) (! debug) parameters val allocProfiling = find(fn CPAllocationProfiling l => SOME l | _ => NONE) (if !allocationProfiling then 1 else 0) parameters val bindingSeq = find(fn CPBindingSeq l => SOME l | _ => NONE) (fn () => 0) parameters local (* Default is to filter the parse tree argument. *) fun defaultCompilerResultFun (_, NONE) = raise Fail "Static Errors" | defaultCompilerResultFun (_, SOME code) = fn () => resultFun(code()) in val compilerResultFun = find (fn CPCompilerResultFun f => SOME f | _ => NONE) defaultCompilerResultFun parameters end (* TODO: Make this available as a parameter. *) val prettyOut = prettyPrintWithOptionalMarkup(printString, !lineLength) val compilerOut = prettyPrintWithOptionalMarkup(outstream, !lineLength) (* Parent tree defaults to empty. *) val parentTree = find (fn CPRootTree f => SOME f | _ => NONE) { parent = NONE, next = NONE, previous = NONE } parameters (* Pass all the settings. Some of these aren't included in the parameters datatype (yet?). *) val treeAndCode = PolyML.compiler(nameSpace, getChar, [ tagInject errorMessageProcTag errorProc, tagInject compilerOutputTag compilerOut, tagInject lineNumberTag (FixedInt.fromInt o lineNo), tagInject offsetTag (FixedInt.fromInt o lineOffset), tagInject fileNameTag fileName, tagInject bindingCounterTag (FixedInt.fromInt o bindingSeq), tagInject inlineFunctorsTag (! inlineFunctors), tagInject maxInlineSizeTag (FixedInt.fromInt(! maxInlineSize)), tagInject parsetreeTag (! parsetree), tagInject codetreeTag (! codetree), tagInject icodeTag (! icode), tagInject lowlevelOptimiseTag (! lowlevelOptimise), tagInject assemblyCodeTag (! assemblyCode), tagInject codetreeAfterOptTag (! codetreeAfterOpt), tagInject profileAllocationTag (FixedInt.fromInt allocProfiling), tagInject errorDepthTag (FixedInt.fromInt(! errorDepth)), tagInject printDepthFunTag (FixedInt.fromInt o printDepth), tagInject lineLengthTag (FixedInt.fromInt(! lineLength)), tagInject debugTag debugging, tagInject printOutputTag prettyOut, tagInject rootTreeTag parentTree, tagInject reportUnreferencedIdsTag (! reportUnreferencedIds), tagInject reportExhaustiveHandlersTag (! reportExhaustiveHandlers), tagInject narrowOverloadFlexRecordTag (! narrowOverloadFlexRecord), tagInject createPrintFunctionsTag (! createPrintFunctions), tagInject reportDiscardedValuesTag (if ! reportDiscardNonUnit then 2 else if ! reportDiscardFunction then 1 else 0) ]) in compilerResultFun treeAndCode end (* Top-level read-eval-print loop. This is the normal top-level loop and is also used for the debugger. *) fun topLevel {isDebug, nameSpace, exitLoop, exitOnError, isInteractive, startExec, endExec } = let (* This is used as the main read-eval-print loop. It is also invoked by running code that has been compiled with the debug option on when it stops at a breakpoint. In that case debugEnv contains an environment formed from the local variables. This is placed in front of the normal top-level environment. *) (* Don't use the end_of_stream because it may have been set by typing EOT to the command we were running. *) val endOfFile = ref false; val realDataRead = ref false; val lastWasEol = ref true; (* Each character typed is fed into the compiler but leading blank lines result in the prompt remaining as firstPrompt until significant characters are typed. *) fun readin () : char option = let val () = if isInteractive andalso !lastWasEol (* Start of line *) then if !realDataRead then printOut (if isDebug then "debug " ^ !prompt2 else !prompt2) else printOut (if isDebug then "debug " ^ !prompt1 else !prompt1) else (); in case TextIO.input1 TextIO.stdIn of NONE => (endOfFile := true; NONE) | SOME #"\n" => ( lastWasEol := true; SOME #"\n" ) | SOME ch => ( lastWasEol := false; if ch <> #" " then realDataRead := true else (); SOME ch ) end; (* readin *) (* Remove all buffered but unread input. *) fun flushInput () = case TextIO.canInput(TextIO.stdIn, 1) of SOME 1 => (TextIO.inputN(TextIO.stdIn, 1); flushInput()) | _ => (* No input waiting or we're at EOF. *) () fun readEvalPrint () : unit = let in realDataRead := false; (* Compile and then run the code. *) let val startCompile = Timer.startCPUTimer() (* Compile a top-level declaration/expression. *) val code = polyCompiler (readin, [CPNameSpace nameSpace, CPOutStream printOut]) (* Don't print any times if this raises an exception. *) handle exn as Fail s => ( printOut(s ^ "\n"); flushInput(); lastWasEol := true; PolyML.Exception.reraise exn ) val endCompile = Timer.checkCPUTimer startCompile (* Run the code *) val startRun = Timer.startCPUTimer() val () = startExec() (* Enable any debugging *) (* Run the code and capture any exception (temporarily). *) val finalResult = (code(); NONE) handle exn => SOME exn val () = endExec() (* Turn off debugging *) (* Print the times if required. *) val endRun = Timer.checkCPUTimer startRun val () = if !timing then printOut( concat["Timing - compile: ", Time.fmt 1 (#usr endCompile + #sys endCompile), " run: ", Time.fmt 1 (#usr endRun + #sys endRun), "\n"]) else () in case finalResult of NONE => () (* No exceptions raised. *) | SOME exn => (* Report exceptions in running code. *) let open PolyML PolyML.Exception val exLoc = case exceptionLocation exn of NONE => [] | SOME loc => [ContextLocation loc] in prettyPrintWithOptionalMarkup(TextIO.print, ! lineLength) (PrettyBlock(0, false, [], [ PrettyBlock(0, false, exLoc, [PrettyString "Exception-"]), PrettyBreak(1, 3), prettyRepresentation(exn, FixedInt.fromInt(! printDepth)), PrettyBreak(1, 3), PrettyString "raised" ])); PolyML.Exception.reraise exn end end end; (* readEvalPrint *) fun handledLoop () : unit = ( (* Process a single top-level command. *) readEvalPrint() handle Thread.Thread.Interrupt => (* Allow ^C to terminate the debugger and raise Interrupt in the called program. *) if exitOnError then OS.Process.exit OS.Process.failure else if isDebug then (flushInput(); raise Thread.Thread.Interrupt) else () | _ => if exitOnError then OS.Process.exit OS.Process.failure else (); (* Exit if we've seen end-of-file or we're in the debugger and we've run "continue". *) if !endOfFile orelse exitLoop() then () else handledLoop () ) in handledLoop () end end - val suffixes = ref ["", ".ML", ".sml"] + val suffixes = ref ["", ".ML", ".sml", ".sig"] (*****************************************************************************) (* "use": compile from a file. *) (*****************************************************************************) val useFileTag: string option Universal.tag = Universal.tag() fun getUseFileName(): string option = Option.join (Thread.Thread.getLocal useFileTag) fun use (originalName: string): unit = let (* use "f" first tries to open "f" but if that fails it tries "f.ML", "f.sml" etc. *) (* We use the functional layer and a reference here rather than TextIO.input1 because that requires locking round every read to make it thread-safe. We know there's only one thread accessing the stream so we don't need it here. *) fun trySuffixes [] = (* Not found - attempt to open the original and pass back the exception. *) (TextIO.getInstream(TextIO.openIn originalName), originalName) | trySuffixes (s::l) = (TextIO.getInstream(TextIO.openIn (originalName ^ s)), originalName ^ s) handle IO.Io _ => trySuffixes l (* First in list is the name with no suffix. *) val (inStream, fileName) = trySuffixes("" :: ! suffixes) val stream = ref inStream (* Record the file name. This allows nested calls to "use" to set the correct path. *) val oldName = getUseFileName() val () = Thread.Thread.setLocal(useFileTag, SOME fileName) val lineNo = ref 1; fun getChar () : char option = case TextIO.StreamIO.input1 (! stream) of NONE => NONE | SOME (eoln as #"\n", strm) => ( lineNo := !lineNo + 1; stream := strm; SOME eoln ) | SOME(c, strm) => (stream := strm; SOME c) in while not (TextIO.StreamIO.endOfStream(!stream)) do let val code = polyCompiler(getChar, [CPFileName fileName, CPLineNo(fn () => !lineNo)]) handle exn => ( TextIO.StreamIO.closeIn(!stream); PolyML.Exception.reraise exn ) in code() handle exn => ( (* Report exceptions in running code. *) TextIO.print ("Exception- " ^ exnMessage exn ^ " raised\n"); TextIO.StreamIO.closeIn (! stream); Thread.Thread.setLocal(useFileTag, oldName); PolyML.Exception.reraise exn ) end; (* Normal termination: close the stream. *) TextIO.StreamIO.closeIn (! stream); Thread.Thread.setLocal(useFileTag, oldName) end (* use *) local open Time in fun maxTime (x : time, y : time): time = if x < y then y else x end exception ObjNotFile; type 'a tag = 'a Universal.tag; fun splitFilename (name: string) : string * string = let val {dir, file } = OS.Path.splitDirFile name in (dir, file) end (* Make *) (* There are three possible states - The object may have been checked, it may be currently being compiled, or it may not have been processed yet. *) datatype compileState = NotProcessed | Searching | Checked; fun longName (directory, file) = OS.Path.joinDirFile{dir=directory, file = file} local fun fileReadable (fileTuple as (directory, object)) = (* Use OS.FileSys.isDir just to test if the file/directory exists. *) if (OS.FileSys.isDir (longName fileTuple); false) handle OS.SysErr _ => true then false else let (* Check that the object is present in the directory with the name given and not a case-insensitive version of it. This avoids problems with "make" attempting to recursively make Array etc because they contain signatures ARRAY. *) open OS.FileSys val d = openDir (if directory = "" then "." else directory) fun searchDir () = case readDir d of NONE => false | SOME f => f = object orelse searchDir () val present = searchDir() in closeDir d; present end fun findFileTuple _ [] = NONE | findFileTuple (directory, object) (suffix :: suffixes) = let val fileName = object ^ suffix val fileTuple = (directory, fileName) in if fileReadable fileTuple then SOME fileTuple else findFileTuple (directory, object) suffixes end in fun filePresent (directory : string, kind: string option, object : string) = let (* Construct suffixes with the architecture and version number in so we can compile architecture- and version-specific code. *) val archSuffix = "." ^ String.map Char.toLower (PolyML.architecture()) val versionSuffix = "." ^ Int.toString Bootstrap.compilerVersionNumber val extraSuffixes = case kind of NONE => [archSuffix, versionSuffix, ""] | SOME k => ["." ^ k ^ archSuffix, "." ^ k ^ versionSuffix, "." ^ k, archSuffix, versionSuffix, ""] + val standardSuffixes = + case kind of + SOME "signature" => ".sig" :: ! suffixes + | _ => !suffixes val addedSuffixes = - List.foldr(fn (i, l) => (List.map (fn s => s ^ i) extraSuffixes) @ l) [] (!suffixes) + List.foldr(fn (i, l) => (List.map (fn s => s ^ i) extraSuffixes) @ l) [] standardSuffixes in (* For each of the suffixes in the list try it. *) findFileTuple (directory, object) addedSuffixes end end (* See if the corresponding file is there and if it is a directory. *) fun testForDirectory (name: string) : bool = OS.FileSys.isDir name handle OS.SysErr _ => false (* No such file. *) (* Time stamps. *) type timeStamp = Time.time; val firstTimeStamp : timeStamp = Time.zeroTime; local open ProtectedTable (* Global tables to hold information about entities that have been made using "make". *) val timeStampTable: timeStamp ptable = create() and dependencyTable: string list ptable = create() in (* When was the entity last built? Returns zeroTime if it hasn't. *) fun lastMade (objectName : string) : timeStamp = getOpt(lookup timeStampTable objectName, firstTimeStamp) (* Get the dependencies as an option type. *) val getMakeDependencies = lookup dependencyTable (* Set the time stamp and dependencies. *) fun updateMakeData(objectName, times, depends) = ( enter timeStampTable (objectName, times); enter dependencyTable (objectName, depends) ) end (* Main make function *) fun make (targetName: string) : unit = let local val sourceDateEpochEnv : string option = OS.Process.getEnv "SOURCE_DATE_EPOCH"; in val sourceDateEpoch : timeStamp option = case sourceDateEpochEnv of NONE => NONE | SOME s => (case LargeInt.fromString s of NONE => NONE | SOME t => SOME(Time.fromSeconds t) handle Time.Time => NONE) end; (* Get the current time. *) val newTimeStamp : unit -> timeStamp = case sourceDateEpoch of NONE => Time.now | SOME t => fn _ => t; (* Get the date of a file. *) val fileTimeStamp : string -> timeStamp = case sourceDateEpoch of NONE => OS.FileSys.modTime | SOME t => fn _ => t; (* This serves two purposes. It provides a list of objects which have been re-made to prevent them being made more than once, and it also prevents circular dependencies from causing infinite loops (e.g. let x = f(x)) *) local open HashArray; val htab : compileState hash = hash 10; in fun lookupStatus (name: string) : compileState = getOpt(sub (htab, name), NotProcessed); fun setStatus (name: string, cs: compileState) : unit = update (htab, name, cs) end; (* Remove leading directory names to get the name of the object itself. e.g. "../compiler/parsetree/gencode" yields simply "gencode". *) val (dirName,objectName) = splitFilename targetName; (* Looks to see if the file is in the current directory. If it is and the file is newer than the corresponding object then it must be remade. If it is a directory then we attempt to remake the directory by compiling the "bind" file. This will only actually be executed if it involves some identifier which is newer than the result object. *) fun remakeObj (objName: string, kind: string option, findDirectory: string option -> string -> string) = let (* Find a directory that contains this object. An exception will be raised if it is not there. *) val directory = findDirectory kind objName val fullName = if directory = "" (* Work around for bug. *) then objName else OS.Path.joinDirFile{dir=directory, file=objName} val objIsDir = testForDirectory fullName val here = fullName (* Look to see if the file exists, possibly with an extension, and get the extended version. *) val fileTuple = let (* If the object is a directory the source is in the bind file. *) val (dir : string, file : string) = if objIsDir then (here,"ml_bind") else (directory, objName); in case filePresent (dir, kind, file) of SOME res' => res' | NONE => raise Fail ("No such file or directory ("^file^","^dir^")") end ; val fileName = longName fileTuple; val newFindDirectory : string option -> string -> string = if objIsDir then let (* Look in this directory then in the ones above. *) fun findDirectoryHere kind (name: string) : string = case filePresent (here, kind, name) of NONE => findDirectory kind name (* not in this directory *) | _ => here; in findDirectoryHere end else findDirectory (* Compiles a file. *) fun remakeCurrentObj () = let val () = print ("Making " ^ objName ^ "\n"); local (* Keep a list of the dependencies. *) val deps : bool HashArray.hash = HashArray.hash 10; fun addDep name = if getOpt(HashArray.sub (deps, name), true) then HashArray.update(deps, name, true) else (); (* Called by the compiler to look-up a global identifier. *) fun lookupMakeEnv (globalLook, kind: string option) (name: string) : 'a option = let (* Have we re-declared it ? *) val res = lookupStatus name; in case res of NotProcessed => ( (* Compile the dependency. *) remakeObj (name, kind, newFindDirectory); (* Add this to the dependencies. *) addDep name ) | Searching => (* In the process of making it *) print("Circular dependency: " ^ name ^ " depends on itself\n") | Checked => addDep name; (* Add this to the dependencies. *) (* There was previously a comment about returning NONE here if we had a problem remaking a dependency. *) globalLook name end (* lookupMakeEnv *) (* Enter the declared value in the table. Usually this will be the target we are making. Also set the state to "Checked". The state is set to checked when we finish making the object but setting it now suppresses messages about circular dependencies if we use the identifier within the file. *) fun enterMakeEnv (kind : string, enterGlobal) (name: string, v: 'a) : unit = ( (* Put in the value. *) enterGlobal (name, v); print ("Created " ^ kind ^ " " ^ name ^ "\n"); (* The name we're declaring may appear to be a dependency but isn't, so don't include it in the list. *) HashArray.update (deps, name, false); if name = objName then let (* Put in the dependencies i.e. those names set to true in the table. *) val depends = HashArray.fold (fn (s, v, l) => if v then s :: l else l) [] deps; (* Put in a time stamp for the new object. We need to make sure that it is no older than the newest object it depends on. In theory that should not be a problem but clocks on different machines can get out of step leading to objects made later having earlier time stamps. *) val newest = List.foldl (fn (s: string, t: timeStamp) => maxTime (lastMade s, t)) (fileTimeStamp fileName) depends; val timeStamp = maxTime(newest, newTimeStamp()); in setStatus (name, Checked); updateMakeData(name, timeStamp, depends) end else () ) (* enterMakeEnv *); in val makeEnv = { lookupFix = #lookupFix globalNameSpace, lookupVal = #lookupVal globalNameSpace, lookupType = #lookupType globalNameSpace, lookupSig = lookupMakeEnv (#lookupSig globalNameSpace, SOME "signature"), lookupStruct = lookupMakeEnv (#lookupStruct globalNameSpace, SOME "structure"), lookupFunct = lookupMakeEnv (#lookupFunct globalNameSpace, SOME "functor"), enterFix = #enterFix globalNameSpace, enterVal = #enterVal globalNameSpace, enterType = #enterType globalNameSpace, enterStruct = enterMakeEnv ("structure", #enterStruct globalNameSpace), enterSig = enterMakeEnv ("signature", #enterSig globalNameSpace), enterFunct = enterMakeEnv ("functor", #enterFunct globalNameSpace), allFix = #allFix globalNameSpace, allVal = #allVal globalNameSpace, allType = #allType globalNameSpace, allSig = #allSig globalNameSpace, allStruct = #allStruct globalNameSpace, allFunct = #allFunct globalNameSpace }; end; (* local for makeEnv *) val inputFile = OS.Path.joinDirFile{dir= #1 fileTuple, file= #2 fileTuple} val inStream = TextIO.openIn inputFile; val () = let (* scope of exception handler to close inStream *) val endOfStream = ref false; val lineNo = ref 1; fun getChar () : char option = case TextIO.input1 inStream of NONE => (endOfStream := true; NONE) (* End of file *) | eoln as SOME #"\n" => (lineNo := !lineNo + 1; eoln) | c => c in while not (!endOfStream) do let val code = polyCompiler(getChar, [CPNameSpace makeEnv, CPFileName fileName, CPLineNo(fn () => !lineNo)]) in code () handle exn as Fail _ => PolyML.Exception.reraise exn | exn => ( print ("Exception- " ^ exnMessage exn ^ " raised\n"); PolyML.Exception.reraise exn ) end end (* body of scope of inStream *) handle exn => (* close inStream if an error occurs *) ( TextIO.closeIn inStream; PolyML.Exception.reraise exn ) in (* remake normal termination *) TextIO.closeIn inStream end (* remakeCurrentObj *) in (* body of remakeObj *) setStatus (objName, Searching); (* If the file is newer than the object then we definitely must remake it. Otherwise we look at the dependency list and check those. If the result of that check is that one of the dependencies is newer than the object (probably because it has just been recompiled) we have to recompile the file. Compiling a file also checks the dependencies and recompiles them, generating a new dependency list. That is why we don't check the dependency list if the object is out of date with the file. Also if the file has been changed it may no longer depend on the things it used to depend on. *) let val objDate = lastMade objName fun maybeRemake (s:string) : unit = case lookupStatus s of NotProcessed => (* see if it's a file. *) (* Compile the dependency. *) remakeObj(s, kind, newFindDirectory) | Searching => (* In the process of making it *) print ("Circular dependency: " ^ s ^ " depends on itself\n") | Checked => () (* do nothing *) open Time (* Process each entry and return true if any is newer than the target. *) val processChildren = List.foldl (fn (child:string, parentNeedsMake:bool) => ( maybeRemake child; (* Find its date and see if it is newer. *) parentNeedsMake orelse lastMade child > objDate ) ) false; in if objDate < fileTimeStamp fileName orelse ( (* Get the dependency list. There may not be one if this object has not been compiled with "make". *) case getMakeDependencies objName of SOME d => processChildren d | NONE => true (* No dependency list - must use "make" on it. *) ) then remakeCurrentObj () else () end; (* Mark it as having been checked. *) setStatus (objName, Checked) end (* body of remakeObj *) (* If the object is not a file mark it is checked. It may be a pervasive or it may be missing. In either case mark it as checked to save searching for it again. *) handle ObjNotFile => setStatus (objName, Checked) | exn => (* Compilation (or execution) error. *) ( (* Mark as checked to prevent spurious messages. *) setStatus (objName, Checked); raise exn ) in (* body of make *) (* Check that the target exists. *) case filePresent (dirName, NONE, objectName) of NONE => let val dir = if dirName = "" then "" else " (directory "^dirName^")"; val s = "File "^objectName^" not found" ^ dir in print (s ^ "\n"); raise Fail s end | _ => let val targetIsDir = testForDirectory targetName; (* If the target we are making is a directory all the objects must be in the directory. If it is a file we allow references to other objects in the same directory. Objects not found must be pervasive. *) fun findDirectory kind (s: string) : string = if (not targetIsDir orelse s = objectName) andalso isSome(filePresent(dirName, kind, s)) then dirName else raise ObjNotFile; in remakeObj (objectName, NONE, findDirectory) handle exn => ( print (targetName ^ " was not declared\n"); PolyML.Exception.reraise exn ) end end (* make *) in structure PolyML = struct open PolyML (* We must not have a signature on the result otherwise print and makestring will be given polymorphic types and will only produce "?" *) val globalNameSpace = globalNameSpace val use = use and make = make val suffixes = suffixes and getUseFileName = getUseFileName val compiler = polyCompiler val prettyPrintWithIDEMarkup = prettyPrintWithIDEMarkup structure Compiler = struct datatype compilerParameters = datatype compilerParameters val compilerVersion = Bootstrap.compilerVersion val compilerVersionNumber = Bootstrap.compilerVersionNumber val forgetSignature: string -> unit = forgetSig and forgetStructure: string -> unit = forgetStruct and forgetFunctor: string -> unit = forgetFunct and forgetValue: string -> unit = forgetVal and forgetType: string -> unit = forgetType and forgetFixity: string -> unit = forgetFix fun signatureNames (): string list = #1(ListPair.unzip (#allSig globalNameSpace ())) and structureNames (): string list = #1(ListPair.unzip (#allStruct globalNameSpace ())) and functorNames (): string list = #1(ListPair.unzip (#allFunct globalNameSpace ())) and valueNames (): string list = #1(ListPair.unzip (#allVal globalNameSpace ())) and typeNames (): string list = #1(ListPair.unzip (#allType globalNameSpace ())) and fixityNames (): string list = #1(ListPair.unzip (#allFix globalNameSpace ())) val prompt1 = prompt1 and prompt2 = prompt2 and timing = timing and printDepth = printDepth and errorDepth = errorDepth and lineLength = lineLength and allocationProfiling = allocationProfiling val assemblyCode = assemblyCode and codetree = codetree and codetreeAfterOpt = codetreeAfterOpt and icode = icode and parsetree = parsetree and reportUnreferencedIds = reportUnreferencedIds and lowlevelOptimise = lowlevelOptimise and reportExhaustiveHandlers = reportExhaustiveHandlers and narrowOverloadFlexRecord = narrowOverloadFlexRecord and createPrintFunctions = createPrintFunctions and reportDiscardFunction = reportDiscardFunction and reportDiscardNonUnit = reportDiscardNonUnit val debug = debug val inlineFunctors = inlineFunctors val maxInlineSize = maxInlineSize val printInAlphabeticalOrder = printInAlphabeticalOrder val traceCompiler = traceCompiler end (* Debugger control. Extend DebuggerInterface set up by INITIALISE. Replaces the original DebuggerInterface. *) structure DebuggerInterface: sig type debugState val debugFunction: debugState -> string val debugFunctionArg: debugState -> PolyML.NameSpace.Values.value val debugFunctionResult: debugState -> PolyML.NameSpace.Values.value val debugLocation: debugState -> PolyML.location val debugNameSpace: debugState -> PolyML.NameSpace.nameSpace val debugLocalNameSpace: debugState -> PolyML.NameSpace.nameSpace val debugState: Thread.Thread.thread -> debugState list val setOnBreakPoint: (PolyML.location * bool ref -> unit) option -> unit val setOnEntry: (string * PolyML.location -> unit) option -> unit val setOnExit: (string * PolyML.location -> unit) option -> unit val setOnExitException: (string * PolyML.location -> exn -> unit) option -> unit end = struct open PolyML.DebuggerInterface fun debugState(t: Thread.Thread.thread): debugState list = let val stack = RunCall.loadWord(t, 0w5) and static = RunCall.loadWord(t, 0w6) and dynamic = RunCall.loadWord(t, 0w7) and locationInfo = RunCall.loadWord(t, 0w8) (* Turn the chain of saved entries along with the current top entry into a list. The bottom entry will generally be the state from non-debugging code and needs to be filtered out. *) fun toList r = if RunCall.isShort r then [] else let val s = RunCall.loadWordFromImmutable(r, 0w0) and d = RunCall.loadWordFromImmutable(r, 0w1) and l = RunCall.loadWordFromImmutable(r, 0w2) and n = RunCall.loadWordFromImmutable(r, 0w3) in if RunCall.isShort s orelse RunCall.isShort l then toList n else (s, d, l) :: toList n end in if RunCall.isShort static orelse RunCall.isShort locationInfo then toList stack else (static, dynamic, locationInfo) :: toList stack end fun searchEnvs match (staticEntry :: statics, dlist as dynamicEntry :: dynamics) = ( case (match (staticEntry, dynamicEntry), staticEntry) of (SOME result, _) => SOME result | (NONE, EnvTypeid _) => searchEnvs match (statics, dynamics) | (NONE, EnvVConstr _) => searchEnvs match (statics, dynamics) | (NONE, EnvValue _) => searchEnvs match (statics, dynamics) | (NONE, EnvException _) => searchEnvs match (statics, dynamics) | (NONE, EnvStructure _) => searchEnvs match (statics, dynamics) | (NONE, EnvStartFunction _) => searchEnvs match (statics, dynamics) | (NONE, EnvEndFunction _) => searchEnvs match (statics, dynamics) (* EnvTConstr doesn't have an entry in the dynamic list *) | (NONE, EnvTConstr _) => searchEnvs match (statics, dlist) ) | searchEnvs _ _ = NONE (* N.B. It is possible to have ([EnvTConstr ...], []) in the arguments so we can't assume that if either the static or dynamic list is nil and the other non-nil it's an error. *) (* Function argument. This should always be present but if it isn't just return unit. That's probably better than an exception here. *) fun debugFunctionArg (state: debugState as (cList, rList, _)) = let val d = (cList, rList) fun match (EnvStartFunction(_, _, ty), valu) = SOME(makeAnonymousValue state (ty, valu)) | match _ = NONE in getOpt(searchEnvs match d, unitValue) end (* Function result - only valid in exit function. *) and debugFunctionResult (state: debugState as (cList, rList, _)) = let val d = (cList, rList) fun match (EnvEndFunction(_, _, ty), valu) = SOME(makeAnonymousValue state(ty, valu)) | match _ = NONE in getOpt(searchEnvs match d, unitValue) end (* debugFunction just looks at the static data. There should always be an EnvStartFunction entry. *) fun debugFunction ((cList, _, _): debugState): string = ( case List.find(fn (EnvStartFunction _) => true | _ => false) cList of SOME(EnvStartFunction(s, _, _)) => s | _ => "?" ) fun debugLocation ((_, _, locn): debugState) = locn fun nameSpace localOnly (state: debugState as (clist, rlist, _)) : nameSpace = let val debugEnviron = (clist, rlist) (* Lookup and "all" functions for the environment. We can't easily use a general function for the lookup because we have dynamic entries for values and structures but not for type constructors. *) fun lookupValues (EnvValue(name, ty, location) :: ntl, valu :: vl) s = if name = s then SOME(makeValue state (name, ty, location, valu)) else lookupValues(ntl, vl) s | lookupValues (EnvException(name, ty, location) :: ntl, valu :: vl) s = if name = s then SOME(makeException state (name, ty, location, valu)) else lookupValues(ntl, vl) s | lookupValues (EnvVConstr(name, ty, nullary, count, location) :: ntl, valu :: vl) s = if name = s then SOME(makeConstructor state (name, ty, nullary, count, location, valu)) else lookupValues(ntl, vl) s | lookupValues (EnvTConstr _ :: ntl, vl) s = lookupValues(ntl, vl) s | lookupValues (EnvStartFunction _ :: ntl, _ :: vl) s = if localOnly then NONE else lookupValues(ntl, vl) s | lookupValues (_ :: ntl, _ :: vl) s = lookupValues(ntl, vl) s | lookupValues _ _ = (* The name we are looking for isn't in the environment. The lists should be the same length. *) NONE fun allValues (EnvValue(name, ty, location) :: ntl, valu :: vl) = (name, makeValue state (name, ty, location, valu)) :: allValues(ntl, vl) | allValues (EnvException(name, ty, location) :: ntl, valu :: vl) = (name, makeException state (name, ty, location, valu)) :: allValues(ntl, vl) | allValues (EnvVConstr(name, ty, nullary, count, location) :: ntl, valu :: vl) = (name, makeConstructor state (name, ty, nullary, count, location, valu)) :: allValues(ntl, vl) | allValues (EnvTConstr _ :: ntl, vl) = allValues(ntl, vl) | allValues (EnvStartFunction _ :: ntl, _ :: vl) = if localOnly then [] else allValues(ntl, vl) | allValues (_ :: ntl, _ :: vl) = allValues(ntl, vl) | allValues _ = [] fun lookupTypes (EnvTConstr (name, tCons) :: ntl, vl) s = if name = s then SOME (makeTypeConstr state tCons) else lookupTypes(ntl, vl) s | lookupTypes (EnvStartFunction _ :: ntl, _ :: vl) s = if localOnly then NONE else lookupTypes(ntl, vl) s | lookupTypes (_ :: ntl, _ :: vl) s = lookupTypes(ntl, vl) s | lookupTypes _ _ = NONE fun allTypes (EnvTConstr(name, tCons) :: ntl, vl) = (name, makeTypeConstr state tCons) :: allTypes(ntl, vl) | allTypes (EnvStartFunction _ :: ntl, _ :: vl) = if localOnly then [] else allTypes(ntl, vl) | allTypes (_ :: ntl, _ :: vl) = allTypes(ntl, vl) | allTypes _ = [] fun lookupStructs (EnvStructure (name, rSig, locations) :: ntl, valu :: vl) s = if name = s then SOME(makeStructure state (name, rSig, locations, valu)) else lookupStructs(ntl, vl) s | lookupStructs (EnvTConstr _ :: ntl, vl) s = lookupStructs(ntl, vl) s | lookupStructs (EnvStartFunction _ :: ntl, _ :: vl) s = if localOnly then NONE else lookupStructs(ntl, vl) s | lookupStructs (_ :: ntl, _ :: vl) s = lookupStructs(ntl, vl) s | lookupStructs _ _ = NONE fun allStructs (EnvStructure (name, rSig, locations) :: ntl, valu :: vl) = (name, makeStructure state (name, rSig, locations, valu)) :: allStructs(ntl, vl) | allStructs (EnvTypeid _ :: ntl, _ :: vl) = allStructs(ntl, vl) | allStructs (EnvStartFunction _ :: ntl, _ :: vl) = if localOnly then [] else allStructs(ntl, vl) | allStructs (_ :: ntl, vl) = allStructs(ntl, vl) | allStructs _ = [] (* We have a full environment here for future expansion but at the moment only some of the entries are used. *) fun noLook _ = NONE and noEnter _ = raise Fail "Cannot update this name space" and allEmpty _ = [] in { lookupVal = lookupValues debugEnviron, lookupType = lookupTypes debugEnviron, lookupFix = noLook, lookupStruct = lookupStructs debugEnviron, lookupSig = noLook, lookupFunct = noLook, enterVal = noEnter, enterType = noEnter, enterFix = noEnter, enterStruct = noEnter, enterSig = noEnter, enterFunct = noEnter, allVal = fn () => allValues debugEnviron, allType = fn () => allTypes debugEnviron, allFix = allEmpty, allStruct = fn () => allStructs debugEnviron, allSig = allEmpty, allFunct = allEmpty } end val debugNameSpace = nameSpace false and debugLocalNameSpace = nameSpace true end local open DebuggerInterface fun debugLocation(d: debugState): string * PolyML.location = (debugFunction d, DebuggerInterface.debugLocation d) fun getStack() = debugState(Thread.Thread.self()) (* These are only relevant when we are stopped at the debugger but we need to use globals here so that the debug functions such as "variables" and "continue" will work. *) val inDebugger = ref false (* Current stack and debug level. *) val currentStack = ref [] fun getCurrentStack() = if !inDebugger then !currentStack else raise Fail "Not stopped in debugger" val debugLevel = ref 0 (* Set to true to exit the debug loop. Set by commands such as "continue". *) val exitLoop = ref false (* Exception packet sent if this was continueWithEx. *) val debugExPacket: exn option ref = ref NONE (* Call tracing. *) val tracing = ref false val breakNext = ref false (* Single stepping. *) val stepDebug = ref false val stepDepth = ref ~1 (* Only break at a stack size less than this. *) (* Break points. We have three breakpoint lists: a list of file-line pairs, a list of function names and a list of exceptions. *) val lineBreakPoints = ref [] and fnBreakPoints = ref [] and exBreakPoints = ref [] fun checkLineBreak (file, line) = let fun findBreak [] = false | findBreak ((f, l) :: rest) = (l = line andalso f = file) orelse findBreak rest in findBreak (! lineBreakPoints) end fun checkFnBreak exact name = let (* When matching a function name we allow match if the name we're looking for matches the last component of the name we have. e.g. if we set a break for "f" we match F().S.f . *) fun matchName n = if name = n then true else if exact then false else let val nameLen = size name and nLen = size n fun isSeparator #"-" = true | isSeparator #")" = true | isSeparator #"." = true | isSeparator _ = false in nameLen > nLen andalso String.substring(name, nameLen - nLen, nLen) = n andalso isSeparator(String.sub(name, nameLen - nLen - 1)) end in List.exists matchName (! fnBreakPoints) end (* Get the exception id from an exception packet. The id is the first word in the packet. It's a mutable so treat it as an int ref here. The packet, though, is immutable. *) fun getExnId(ex: exn): int ref = RunCall.loadWordFromImmutable (ex, 0w0) fun checkExnBreak(ex: exn) = let val exnId = getExnId ex in List.exists (fn n => n = exnId) (! exBreakPoints) end fun getArgResult stack get = case stack of hd :: _ => Values.print(get hd, FixedInt.fromInt(!printDepth)) | _ => PrettyString "?" fun printTrace (funName, location, stack, argsAndResult) = let (* This prints a block with the argument and, if we're exiting the result. The function name is decorated with the location. TODO: This works fine so long as the recursion depth is not too deep but once it gets too wide the pretty-printer starts breaking the lines. *) val block = PrettyBlock(0, false, [], [ PrettyBreak(FixedInt.fromInt(length stack), 0), PrettyBlock(0, false, [], [ PrettyBlock(0, false, [ContextLocation location], [PrettyString funName]), PrettyBreak(1, 3) ] @ argsAndResult) ]) in prettyPrintWithOptionalMarkup (TextIO.print, !lineLength) block end (* Try to print the appropriate line from the file.*) fun printSourceLine(prefix, fileName: string, line: FixedInt.int, funName: string, justLocation) = let open TextIO open PolyML (* Use the pretty printer here because that allows us to provide a link to the function in the markup so the IDE can go straight to it. *) val prettyOut = prettyPrintWithOptionalMarkup (printOut, !lineLength) val lineInfo = concat( [prefix] @ (if fileName = "" then [] else [fileName, " "]) @ (if line = 0 then [] else [" line:", FixedInt.toString line, " "]) @ ["function:", funName]) in (* First just print where we are. *) prettyOut( PrettyBlock(0, true, [ContextLocation{file=fileName,startLine=line, endLine=line,startPosition=0,endPosition=0}], [PrettyString lineInfo])); (* Try to print it. This may fail if the file name was not a full path name and we're not in the correct directory. *) if justLocation orelse fileName = "" then () else let val fd = openIn fileName fun pLine n = case inputLine fd of NONE => () | SOME s => if n = 1 then printOut s else pLine(n-1) in pLine line; closeIn fd end handle IO.Io _ => () (* If it failed simply ignore the error. *) end (* These functions are installed as global callbacks if necessary. *) fun onEntry (funName, location as {file, startLine, ...}: PolyML.location) = ( if ! tracing then let val stack = getStack() val arg = getArgResult stack debugFunctionArg in printTrace(funName, location, stack, [arg]) end else (); (* We don't actually break here because at this stage we don't have any variables declared. *) (* TODO: If for whatever reason we fail to find the breakpoint we need to cancel the pending break in the exit code. Otherwise we could try and break in some other code. *) if checkLineBreak (file, startLine) orelse checkFnBreak false funName then (breakNext := true; setOnBreakPoint(SOME onBreakPoint)) else () ) and onExit (funName, location) = ( if ! tracing then let val stack = getStack() val arg = getArgResult stack debugFunctionArg val res = getArgResult stack debugFunctionResult in printTrace(funName, location, stack, [arg, PrettyBreak(1, 3), PrettyString "=", PrettyBreak(1, 3), res]) end else () ) and onExitException(funName, location) exn = ( if ! tracing then let val stack = getStack() val arg = getArgResult stack debugFunctionArg in printTrace(funName, location, stack, [arg, PrettyBreak(1, 3), PrettyString "=", PrettyBreak(1, 3), PrettyString "raised", PrettyBreak(1, 3), PrettyString(exnName exn)]) end else (); if checkExnBreak exn then enterDebugger () else () ) and onBreakPoint({file, startLine, ...}: PolyML.location, _) = ( if (!stepDebug andalso (!stepDepth < 0 orelse List.length(getStack()) <= !stepDepth)) orelse checkLineBreak (file, startLine) orelse ! breakNext then enterDebugger () else () ) (* Set the callbacks when beginning to run some code. *) and setCallBacks () = ( setOnEntry(if !tracing orelse not(null(! fnBreakPoints)) then SOME onEntry else NONE); setOnExit(if !tracing then SOME onExit else NONE); setOnExitException(if !tracing orelse not(null(! exBreakPoints)) then SOME onExitException else NONE); setOnBreakPoint(if !tracing orelse ! stepDebug orelse not(null(! lineBreakPoints)) then SOME onBreakPoint else NONE) ) (* Clear all callbacks when exiting debuggable code. *) and clearCallBacks () = ( setOnEntry NONE; setOnExit NONE; setOnExitException NONE; setOnBreakPoint NONE; (* Clear all stepping. *) breakNext := false; stepDebug := false; stepDepth := ~1; (* Clear the debugger state *) debugLevel := 0; currentStack := [] ) and enterDebugger () = let (* Clear the onXXX functions to prevent any recursion. *) val () = clearCallBacks () val () = inDebugger := true (* Remove any type-ahead. *) fun flushInput () = case TextIO.canInput(TextIO.stdIn, 1) of SOME 1 => (TextIO.inputN(TextIO.stdIn, 1); flushInput()) | _ => () val () = flushInput () val () = exitLoop := false (* Save the stack on entry. If we execute any code with debugging enabled while we're in the debugger we could change this. *) val () = currentStack := getStack() val () = case !currentStack of hd :: _ => let val (funName, {file, startLine, ...}) = debugLocation hd in printSourceLine("", file, startLine, funName, false) end | [] => () (* Shouldn't happen. *) val compositeNameSpace = (* Compose any debugEnv with the global environment. Create a new temporary environment to contain any bindings made within the shell. They are discarded when we continue from the break-point. Previously, bindings were made in the global environment but that is problematic. It is possible to capture local types in the bindings which could actually be different at the next breakpoint. *) let val fixTab = ProtectedTable.create() and sigTab = ProtectedTable.create() and valTab = ProtectedTable.create() and typTab = ProtectedTable.create() and fncTab = ProtectedTable.create() and strTab = ProtectedTable.create() (* The debugging environment depends on the currently selected stack frame. *) fun debugEnv() = debugNameSpace (List.nth(!currentStack, !debugLevel)) fun dolookup f t s = case ProtectedTable.lookup t s of NONE => (case f (debugEnv()) s of NONE => f globalNameSpace s | v => v) | v => v fun getAll f t () = ProtectedTable.all t () @ f (debugEnv()) () @ f globalNameSpace () in { lookupFix = dolookup #lookupFix fixTab, lookupSig = dolookup #lookupSig sigTab, lookupVal = dolookup #lookupVal valTab, lookupType = dolookup #lookupType typTab, lookupFunct = dolookup #lookupFunct fncTab, lookupStruct = dolookup #lookupStruct strTab, enterFix = ProtectedTable.enter fixTab, enterSig = ProtectedTable.enter sigTab, enterVal = ProtectedTable.enter valTab, enterType = ProtectedTable.enter typTab, enterFunct = ProtectedTable.enter fncTab, enterStruct = ProtectedTable.enter strTab, allFix = getAll #allFix fixTab, allSig = getAll #allSig sigTab, allVal = getAll #allVal valTab, allType = getAll #allType typTab, allFunct = getAll #allFunct fncTab, allStruct = getAll #allStruct strTab } end in topLevel { isDebug = true, nameSpace = compositeNameSpace, exitLoop = fn _ => ! exitLoop, exitOnError = false, isInteractive = true, (* Don't enable debugging for anything run within the debug level. *) startExec = fn () => (), endExec = fn () => () } (* If we type control-C to the debugger we exit it and raise Interrupt within the debuggee without re-enabling any breakpoints. *) handle exn => (inDebugger := false; raise exn); inDebugger := false; setCallBacks(); (* Re-enable debugging. *) (* If this was continueWithEx raise the exception. *) case ! debugExPacket of NONE => () | SOME exn => (debugExPacket := NONE; raise exn) end in (* Normal, non-debugging top-level loop. *) fun shell () = let val argList = CommandLine.arguments() fun switchOption option = List.exists(fn s => s = option) argList (* Generate mark-up in IDE code when printing if the option has been given on the command line. *) val () = useMarkupInOutput := switchOption "--with-markup" val exitOnError = switchOption"--error-exit" val interactive = switchOption "-i" orelse let open TextIO OS open StreamIO TextPrimIO IO val s = getInstream stdIn val (r, v) = getReader s val RD { ioDesc, ...} = r in setInstream(stdIn, mkInstream(r,v)); case ioDesc of SOME io => (kind io = Kind.tty handle SysErr _ => false) | _ => false end in topLevel { isDebug = false, nameSpace = globalNameSpace, exitLoop = fn _ => false, isInteractive = interactive, exitOnError = exitOnError, startExec = setCallBacks, endExec = clearCallBacks } end structure Debug = struct (* Functions that are only relevant when called from the debugger. These check the debugging state using getCurrentStack which raises an exception if we're not in the debugger. *) (* "step" causes the debugger to be entered on the next call. "stepOver" enters the debugger on the next call when the stack is no larger than it is at present. "stepOut" enters the debugger on the next call when the stack is smaller than it is at present. *) fun step () = let val _ = getCurrentStack() in stepDebug := true; stepDepth := ~1; exitLoop := true end and stepOver() = let val stack = getCurrentStack() in stepDebug := true; stepDepth := List.length stack; exitLoop := true end and stepOut() = let val stack = getCurrentStack() in stepDebug := true; stepDepth := List.length stack - 1; exitLoop := true end and continue () = let val _ = getCurrentStack() in stepDebug := false; stepDepth := ~1; exitLoop := true end and continueWithEx exn = let val _ = getCurrentStack() in stepDebug := false; stepDepth := ~1; exitLoop := true; debugExPacket := SOME exn end (* Stack traversal. *) fun up () = let val stack = getCurrentStack() in if !debugLevel < List.length stack -1 then let val _ = debugLevel := !debugLevel + 1; val (funName, {startLine, file, ...}) = debugLocation(List.nth(stack, !debugLevel)) in printSourceLine("", file, startLine, funName, false) end else TextIO.print "Top of stack.\n" end and down () = let val stack = getCurrentStack() in if !debugLevel = 0 then TextIO.print "Bottom of stack.\n" else let val () = debugLevel := !debugLevel - 1; val (funName, {startLine, file, ...}) = debugLocation(List.nth(stack, !debugLevel)) in printSourceLine("", file, startLine, funName, false) end end (* Just print the functions without any other context. *) fun stack () : unit = let fun printTrace(d, n) = let val (funName, {file, startLine, ...}) = debugLocation d (* If this is the current level prefix it with > *) val prefix = if n = !debugLevel then "> " else " " in printSourceLine(prefix, file, startLine, funName, true); n+1 end in ignore (List.foldl printTrace 0 (getCurrentStack())) end local fun printVal v = prettyPrintWithOptionalMarkup(TextIO.print, !lineLength) (NameSpace.Values.printWithType(v, FixedInt.fromInt(!printDepth), SOME globalNameSpace)) fun printStack (stack: debugState) = List.app (fn (_,v) => printVal v) (#allVal (debugNameSpace stack) ()) in (* Print all variables at the current level. *) fun variables() = printStack (List.nth(getCurrentStack(), !debugLevel)) (* Print all the levels. *) and dump() = let fun printLevel stack = let val (funName, _) = debugLocation stack in TextIO.print(concat["Function ", funName, ":"]); printStack stack; TextIO.print "\n" end in List.app printLevel (getCurrentStack()) end (* Print local variables at the current level. *) and locals() = let val stack = List.nth(getCurrentStack(), !debugLevel) in List.app (fn (_,v) => printVal v) (#allVal (debugLocalNameSpace stack) ()) end end (* Functions to adjust tracing and breakpointing. May be called either within or outside the debugger. *) fun trace b = tracing := b fun breakAt (file, line) = if checkLineBreak(file, line) then () (* Already there. *) else lineBreakPoints := (file, line) :: ! lineBreakPoints fun clearAt (file, line) = let fun findBreak [] = (TextIO.print "No such breakpoint.\n"; []) | findBreak ((f, l) :: rest) = if l = line andalso f = file then rest else (f, l) :: findBreak rest in lineBreakPoints := findBreak (! lineBreakPoints) end fun breakIn name = if checkFnBreak true name then () (* Already there. *) else fnBreakPoints := name :: ! fnBreakPoints fun clearIn name = let fun findBreak [] = (TextIO.print "No such breakpoint.\n"; []) | findBreak (n :: rest) = if name = n then rest else n :: findBreak rest in fnBreakPoints := findBreak (! fnBreakPoints) end fun breakEx exn = if checkExnBreak exn then () (* Already there. *) else exBreakPoints := getExnId exn :: ! exBreakPoints fun clearEx exn = let val exnId = getExnId exn fun findBreak [] = (TextIO.print "No such breakpoint.\n"; []) | findBreak (n :: rest) = if exnId = n then rest else n :: findBreak rest in exBreakPoints := findBreak (! exBreakPoints) end end end structure CodeTree = struct open PolyML.CodeTree (* Add options to the code-generation phase. *) val genCode = fn (code, numLocals) => let open Bootstrap Bootstrap.Universal val compilerOut = prettyPrintWithOptionalMarkup(TextIO.print, !lineLength) in genCode(code, [ tagInject compilerOutputTag compilerOut, tagInject maxInlineSizeTag (FixedInt.fromInt(! maxInlineSize)), tagInject codetreeTag (! codetree), tagInject icodeTag (! icode), tagInject lowlevelOptimiseTag (! lowlevelOptimise), tagInject assemblyCodeTag (! assemblyCode), tagInject codetreeAfterOptTag (! codetreeAfterOpt) ], numLocals) end end (* Original print_depth etc functions. *) fun timing b = Compiler.timing := b and print_depth i = Compiler.printDepth := i and error_depth i = Compiler.errorDepth := i and line_length i = Compiler.lineLength := i (* Legacy exception_trace. *) structure Exception = struct open Exception fun exception_trace f = f() (* Backwards compatibility *) end (* Include it in the PolyML structure for backwards compatibility. *) val exception_trace = Exception.exception_trace local val systemProfile : int -> (int * string) list = RunCall.rtsCallFull1 "PolyProfiling" fun printProfile profRes = let (* Sort in ascending order. *) val sorted = quickSort (fn (a, _) => fn (b, _) => a <= b) profRes fun doPrint (count, name) = let val cPrint = Int.toString count val prefix = CharVector.tabulate(Int.max(0, 10-size cPrint), fn _ => #" ") in TextIO.output(TextIO.stdOut, concat[prefix, cPrint, " ", name, "\n"]) end val total = List.foldl (fn ((c,_),s) => c+s) 0 profRes in List.app doPrint sorted; if total = 0 then () else TextIO.print(concat["Total ", Int.toString total, "\n"]) end in structure Profiling = struct datatype profileMode = ProfileTime (* old mode 1 *) | ProfileAllocations (* old mode 2 *) | ProfileLongIntEmulation (* old mode 3 - No longer used*) | ProfileTimeThisThread (* old mode 6 *) | ProfileMutexContention fun profileStream (stream: (int * string) list -> unit) mode f arg = let (* Control profiling. This may raise Fail if profiling is turned on when it is already on or if there is insufficient memory. *) val code = case mode of ProfileTime => 1 | ProfileAllocations => 2 | ProfileLongIntEmulation => 3 | ProfileTimeThisThread => 6 | ProfileMutexContention => 7 val _ = systemProfile code (* Discard the result *) val result = f arg handle exn => (stream(systemProfile 0); PolyML.Exception.reraise exn) in stream(systemProfile 0); result end fun profile mode f arg = profileStream printProfile mode f arg (* Live data profiles show the current state. We need to run the GC to produce the counts. *) datatype profileDataMode = ProfileLiveData | ProfileLiveMutableData fun profileDataStream(stream: (int * string) list -> unit) mode = let val code = case mode of ProfileLiveData => 4 | ProfileLiveMutableData => 5 val _ = systemProfile code (* Discard the result *) val () = PolyML.fullGC() in stream(systemProfile 0) end val profileData = profileDataStream printProfile end end (* Saving and loading state. *) structure SaveState = struct local val getOS: int = LibrarySupport.getOSType() val loadMod: string -> Universal.universal list = RunCall.rtsCallFull1 "PolyLoadModule" and systemDir: unit -> string = RunCall.rtsCallFull0 "PolyGetModuleDirectory" in fun loadModuleBasic (fileName: string): Universal.universal list = (* If there is a path separator use the name and don't search further. *) if OS.Path.dir fileName <> "" then loadMod fileName else let (* Path elements are separated by semicolons in Windows but colons in Unix. *) val sepInPathList = if getOS = 1 then #";" else #":" val pathList = case OS.Process.getEnv "POLYMODPATH" of NONE => [] | SOME s => String.fields (fn ch => ch = sepInPathList) s fun findFile [] = NONE | findFile (hd::tl) = (* Try actually loading the file. That way we really check we have a module. *) SOME(loadMod (OS.Path.joinDirFile{dir=hd, file=fileName})) handle Fail _ => findFile tl | OS.SysErr _ => findFile tl in case findFile pathList of SOME l => l (* Found *) | NONE => let val sysDir = systemDir() val inSysDir = if sysDir = "" then NONE else findFile[sysDir] in case inSysDir of SOME l => l | NONE => raise Fail("Unable to find module ``" ^ fileName ^ "''") end end end val saveChild: string * int -> unit = RunCall.rtsCallFull2 "PolySaveState" fun saveState f = saveChild (f, 0); val showHierarchy: unit -> string list = RunCall.rtsCallFull0 "PolyShowHierarchy" local val doRename: string * string -> unit = RunCall.rtsCallFull2 "PolyRenameParent" in fun renameParent{ child: string, newParent: string }: unit = doRename(child, newParent) end val showParent: string -> string option = RunCall.rtsCallFull1 "PolyShowParent" and loadState: string -> unit = RunCall.rtsCallFull1 "PolyLoadState" local val loadHier: string list -> unit = RunCall.rtsCallFull1 "PolyLoadHierarchy" in (* Load hierarchy takes a list of file names in order with the parents before the children. It's easier for the RTS if this is reversed. *) fun loadHierarchy (s: string list): unit = loadHier (List.rev s) end (* Module loading and storing. *) structure Tags = struct val structureTag: (string * PolyML.NameSpace.Structures.structureVal) Universal.tag = Universal.tag() val functorTag: (string * PolyML.NameSpace.Functors.functorVal) Universal.tag = Universal.tag() val signatureTag: (string * PolyML.NameSpace.Signatures.signatureVal) Universal.tag = Universal.tag() val valueTag: (string * PolyML.NameSpace.Values.value) Universal.tag = Universal.tag() val typeTag: (string * PolyML.NameSpace.TypeConstrs.typeConstr) Universal.tag = Universal.tag() val fixityTag: (string * PolyML.NameSpace.Infixes.fixity) Universal.tag = Universal.tag() val startupTag: (unit -> unit) Universal.tag = Universal.tag() end local val saveMod: string * Universal.universal list -> unit = RunCall.rtsCallFull2 "PolyStoreModule" in fun saveModuleBasic(_, []) = raise Fail "Cannot create an empty module" | saveModuleBasic(name, contents) = saveMod(name, contents) end fun saveModule(s, {structs, functors, sigs, onStartup}) = let fun dolookup (look, tag, kind) s = case look globalNameSpace s of SOME v => Universal.tagInject tag (s, v) | NONE => raise Fail (concat[kind, " ", s, " has not been declared"]) val structVals = map (dolookup(#lookupStruct, Tags.structureTag, "Structure")) structs val functorVals = map (dolookup(#lookupFunct, Tags.functorTag, "Functor")) functors val sigVals = map (dolookup(#lookupSig, Tags.signatureTag, "Signature")) sigs val startVal = case onStartup of SOME f => [Universal.tagInject Tags.startupTag f] | NONE => [] in saveModuleBasic(s, structVals @ functorVals @ sigVals @ startVal) end fun loadModule s = let val ulist = loadModuleBasic s (* Find and run the start-up function. If it raises an exception we don't go further. *) val startFn = List.find (Universal.tagIs Tags.startupTag) ulist val () = case startFn of SOME f => (Universal.tagProject Tags.startupTag f) () | NONE => () fun extract (tag:'a Universal.tag): Universal.universal list -> 'a list = List.mapPartial( fn s => if Universal.tagIs tag s then SOME(Universal.tagProject tag s) else NONE) in (* Add the entries and print them in the same way as top-level bindings. *) printAndEnter(! printInAlphabeticalOrder, globalNameSpace, TextIO.print, !printDepth) { fixes = extract Tags.fixityTag ulist, values = extract Tags.valueTag ulist, structures = extract Tags.structureTag ulist, signatures = extract Tags.signatureTag ulist, functors = extract Tags.functorTag ulist, types = extract Tags.typeTag ulist } end end val loadModule = SaveState.loadModule end end (* PolyML. *); diff --git a/basis/ForeignMemory.sml b/basis/ForeignMemory.sml index 907375ae..5975c2dd 100644 --- a/basis/ForeignMemory.sml +++ b/basis/ForeignMemory.sml @@ -1,230 +1,237 @@ (* Title: Foreign Function Interface: memory operations Author: David Matthews - Copyright David Matthews 2015, 2017, 2019 + Copyright David Matthews 2015, 2017, 2019-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 *) structure ForeignMemory :> sig eqtype volatileRef val volatileRef: SysWord.word -> volatileRef val setVolatileRef: volatileRef * SysWord.word -> unit val getVolatileRef: volatileRef -> SysWord.word eqtype voidStar val voidStar2Sysword: voidStar -> SysWord.word val sysWord2VoidStar: SysWord.word -> voidStar val null: voidStar + (* Helper functions to add a word value to an address. + From 5.8.2 the word value is treated as signed. *) val ++ : voidStar * word -> voidStar val -- : voidStar * word -> voidStar (* Remember an address except across loads. *) val memoise: ('a -> voidStar) ->'a -> unit -> voidStar exception Memory (* malloc - allocate memory. N.B. argument is the number of bytes. Raises Memory exception if it cannot allocate. *) val malloc: word -> voidStar (* free - free allocated memory. *) val free: voidStar -> unit + (* Load and store a value. From 5.8.2 the offset is + treated as signed. *) val get8: voidStar * Word.word -> Word8.word val get16: voidStar * Word.word -> Word.word val get32: voidStar * Word.word -> Word32.word val get64: voidStar * Word.word -> SysWord.word val set8: voidStar * Word.word * Word8.word -> unit val set16: voidStar * Word.word * Word.word -> unit val set32: voidStar * Word.word * Word32.word -> unit val set64: voidStar * Word.word * SysWord.word -> unit val getFloat: voidStar * Word.word -> real val getDouble: voidStar * Word.word -> real val setFloat: voidStar * Word.word * real -> unit val setDouble: voidStar * Word.word * real -> unit val getAddress: voidStar * Word.word -> voidStar val setAddress: voidStar * Word.word * voidStar -> unit end = struct open ForeignConstants open ForeignMemory exception Foreign = RunCall.Foreign fun id x = x (* Internal utility function. *) fun alignUp(s, align) = Word.andb(s + align-0w1, ~ align) (* Both volatileRef and SysWord.word are the ADDRESSes of the actual value. *) type volatileRef = word ref val memMove: SysWord.word * SysWord.word * word * word* word -> unit = RunCall.moveBytes fun volatileRef init = let (* Allocate a single word marked as mutable, weak, no-overwrite, byte. *) (* A weak byte cell is cleared to zero when it is read in either from the executable or from a saved state. Using the no-overwrite bit ensures that if it is contained in the executable it won't be changed by loading a saved state but there's a problem if it is contained in a parent state. Then loading a child state will clear it because we reload all the parents when we load a child. *) val v = RunCall.allocateWordMemory(sysWordSize div wordSize, 0wx69, 0w0) (* Copy the SysWord into it. *) val () = memMove(init, RunCall.unsafeCast v, 0w0, 0w0, sysWordSize) in v end fun setVolatileRef(v, i) = memMove(i, RunCall.unsafeCast v, 0w0, 0w0, sysWordSize) fun getVolatileRef var = let (* Allocate a single word marked as mutable, byte. *) val v = RunCall.allocateByteMemory(sysWordSize div wordSize, 0wx41) val () = memMove(RunCall.unsafeCast var, v, 0w0, 0w0, sysWordSize) val () = RunCall.clearMutableBit v in v end type voidStar = SysWord.word val voidStar2Sysword = id and sysWord2VoidStar = id (* Exported conversions *) val null: voidStar = 0w0 infix 6 ++ -- - fun s ++ w = s + SysWord.fromLarge(Word.toLarge w) - and s -- w = s - SysWord.fromLarge(Word.toLarge w) + (* Helper operations to add a constant to an address. + These now treat the offset as signed so that adding ~1 is + the same as subtracting 1. *) + fun s ++ w = s + SysWord.fromLarge(Word.toLargeX w) + and s -- w = s - SysWord.fromLarge(Word.toLargeX w) fun 'a memoise(f: 'a -> voidStar) (a: 'a) : unit -> voidStar = let (* Initialise to zero. That means the function won't be executed until we actually want the result. *) val v = volatileRef 0w0 in (* If we've reloaded the volatile ref it will have been reset to zero. We need to execute the function and set it. *) fn () => (case getVolatileRef v of 0w0 => let val r = f a in setVolatileRef(v, r); r end | r => r) end exception Memory (* Get and set addresses. This is a bit messy because it has to compile on 64-bits as well as 32-bits. *) val getAddress: voidStar * Word.word -> voidStar = if sysWordSize = 0w4 then Word32.toLargeWord o get32 else get64 val setAddress: voidStar * Word.word * voidStar -> unit = if sysWordSize = 0w4 then fn (s, i, v) => set32(s, i, Word32.fromLargeWord v) else set64 local local val ffiGeneralCall = RunCall.rtsCallFull2 "PolyFFIGeneral" in fun ffiGeneral(code: int, arg: 'a): 'b = RunCall.unsafeCast(ffiGeneralCall(RunCall.unsafeCast(code, arg))) end fun systemMalloc (s: word): voidStar = ffiGeneral (0, s) (*fun systemFree (s: voidStar): unit = ffiGeneral (1, s)*) (* Simple malloc/free implementation to reduce the number of RTS calls needed. *) val lock = Thread.Mutex.mutex() (* It would be possible to chain the free list in the C memory itself. For the moment we don't do that. The free list is the list of chunks ordered by increasing address. That allows us to merge adjacent free blocks. *) val freeList: {address: SysWord.word, size: word} list ref = LibrarySupport.noOverwriteRef nil (* Clear it once on entry. *) val () = LibrarySupport.addOnEntry (fn _ => freeList := nil) (* Assume that if we align to the maximum of these we're all right. *) val maxAlign = Word.max(#align saDouble, Word.max(#align saPointer, #align saSint64)) (* We need a length word in each object we allocate but we need enough padding to align the result. *) val overhead = alignUp(sysWordSize, maxAlign) val chunkSize = 0w4096 (* Configure this. *) fun addFree(entry, []) = [entry] | addFree(entry, this :: rest) = if #address entry < #address this then ( if #address entry ++ #size entry = #address this then (* New entry is immediately before old one - merge. *) {address= #address entry, size = #size entry + #size this } :: rest else entry :: this :: rest ) else if #address this ++ #size this = #address entry then (* New entry is immediately after this - merge. Continue because it could also merge with an entry after this as well. *) addFree({address= #address this, size= #size entry + #size this}, rest) else this :: addFree(entry, rest) (* Search on. *) (* Find free space. *) fun findFree (_, []) = (NONE, []) | findFree (space, (this as {size, address}) :: tl) = if space = size then (SOME address, tl) else if space < size then (SOME address, {size=size-space, address=address ++ space} :: tl) else let val (res, rest) = findFree(space, tl) in (res, this :: rest) end fun freeMem s = let val addr = s -- overhead val size = Word.fromLarge(SysWord.toLarge(getAddress(addr, 0w0))) in freeList := addFree({address=addr, size=size}, !freeList) end fun allocMem s = let val space = alignUp(s + overhead, maxAlign) val (found, newList) = findFree(space, !freeList) in case found of NONE => let (* Need more memory *) val requestSpace = Word.max(chunkSize, space) val newSpace = systemMalloc requestSpace val _ = newSpace <> null orelse raise Memory in (* Add the space to the free list in the appropriate place. *) freeList := addFree({address=newSpace, size=requestSpace}, !freeList); allocMem s (* Repeat - should succeed now. *) end | SOME address => let val () = freeList := newList (* Update the free list *) (* Store the length in the first word. *) val () = setAddress(address, 0w0, SysWord.fromLarge(Word.toLarge space)) in address ++ overhead end end in val malloc: word -> voidStar = ThreadLib.protect lock allocMem fun free v = if v = null then () else ThreadLib.protect lock freeMem v end end; diff --git a/basis/Signal.sml b/basis/Signal.sml index 4dafc3e8..5b67cbe1 100644 --- a/basis/Signal.sml +++ b/basis/Signal.sml @@ -1,91 +1,121 @@ (* Title: Signal structure and signature. Author: David Matthews - Copyright David Matthews 2000, 2008, 2019 - + Copyright David Matthews 2000, 2008, 2019-20 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 *) + +(** +Although the `Posix` structure in the Standard Basis Library provides functions +which send signals to a process there is no standard method of handling signals. The +`Signal` structure has been added to Poly/ML to allow signals to be blocked or +handled. +**) signature SIGNAL = sig datatype sig_handle = SIG_DFL | SIG_IGN | SIG_HANDLE of int->unit val signal: int * sig_handle -> sig_handle end; structure Signal: SIGNAL = struct datatype sig_handle = SIG_DFL | SIG_IGN | SIG_HANDLE of int->unit local val setHandler = RunCall.rtsCallFull2 "PolySetSignalHandler" in fun signal(s, cmd) = let val c = case cmd of SIG_DFL => 0 | SIG_IGN => 1 | SIG_HANDLE f => RunCall.unsafeCast f in case setHandler(s, c) of 0 => SIG_DFL | 1 => SIG_IGN | f => SIG_HANDLE(RunCall.unsafeCast f) end end local datatype sigHandle = SigHandle of (int->unit) * int | WeakMarker val waitForSig = RunCall.rtsCallFull0 "PolyWaitForSignal" open Thread fun sigThread(): unit = let (* This call to the RTS returns either a pair of a signal and a handler or a flag indicating that some wek reference has been set to NONE. These aren't logically related but it's convenient to use a single thread for both. *) val nextSig: sigHandle = waitForSig() (* When we get a WeakMarker message we need to broadcast on this condition variable. *) fun broadCastWeak haveLock () = ( if haveLock then () else Mutex.lock Weak.weakLock; ConditionVar.broadcast Weak.weakSignal; Mutex.unlock Weak.weakLock ) in case nextSig of SigHandle (handler, signal) => (handler signal handle _ => ()) | WeakMarker => (* If the lock is free we can do the broadcast now but to avoid waiting and being unable to handle any signals we fork off a thread if we can't. *) if Mutex.trylock Weak.weakLock then broadCastWeak true () else (Thread.fork(broadCastWeak false, []); ()); sigThread() (* Forever. *) end fun forkThread() = (Thread.fork(sigThread, []); ()) handle Thread _ => print "Unable to create signal thread\n" in (* Run this thread now and also start one each time we start up. *) val _ = forkThread() val _ = LibrarySupport.addOnEntry forkThread end end; +(** +The `Signal.signal` function takes as its arguments a signal number and an +action and returns the previous action. The action may be `SIG_DFL`, +indicating the default action, `SIG_IGN`, indicating that the signal should be +ignored (blocked) or `SIG_HANDLE`, which allows a handler function to be installed. + +Signals are represented as integers using the normal Unix signal numbering. In +the Unix implementations of Poly/ML the type `Posix.Signal.signal` is the same as `int` +so the constants from `Posix.Signal` can be used as arguments to `Signal.signal`. + +The default action depends on the signal. For some signals it is to ignore the +signal, for others the process is killed. See the signal man page in Unix for a list +of the default actions. + +A handler function installed using `SIG_HANDLE` is run as a separate thread +some time after a signal arrives. + +Some signals are used internally by Poly/ML. In particular `SIGVTALRM` is used +by the profiling mechanism. + +The Signal structure is provided in the Windows implementation but only the +console interrupt signal (2) has effect. + +**) diff --git a/basis/SingleAssignment.sml b/basis/SingleAssignment.sml index 3f06ac4f..780bf17a 100644 --- a/basis/SingleAssignment.sml +++ b/basis/SingleAssignment.sml @@ -1,44 +1,90 @@ (* Title: References that allow a single assignment Author: David Matthews Copyright David Matthews 2010, 2016 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(*!The `SingleAssignment` structure provides a reference + that can be assigned a value only once.*) + structure SingleAssignment:> sig + (*!The type of a single-assignment reference. It is similar to the standard + `ref` type constructor.*) type 'a saref (* Equality not allowed *) + (*!This exception is raised if an attempt is made to assign a value twice + to the same reference.*) exception Locked + (*!Construct a single-assignment reference.*) val saref: unit -> 'a saref - val savalue: 'a saref -> 'a option + (*!Assign a value to the reference. If it has already been assigned a value + this will raise `Locked`. Note that this function is not thread-safe. A `mutex` + must be associated with reference if there is the possibility that two different + threads may attempt to assign to the same reference.*) val saset: 'a saref * 'a -> unit + (*!Extract the current value of the reference. If it has not yet been assigned + a value it will return `NONE`. If it has, + it will return `SOME v` where `v` + is the value that was assigned.*) + val savalue: 'a saref -> 'a option end = struct exception Locked type 'a saref = 'a option ref fun saref () = ref NONE val savalue = ! fun saset(saVar as ref NONE, newValue) = ( saVar := SOME newValue; RunCall.clearMutableBit saVar ) | saset _ = raise Locked end; +(*!The reason behind the `SingleAssignment` structure + has to do with the way the Poly/ML storage management system deals with *mutable* + and *immutable* data. Immutable memory cells are given a value when they + are created and once created never change. They are used for lists, tuples, + vectors and other datatypes. In contrast, refs and arrays are mutable data. + They are given a value when they are created in the same way as immutable data + but their contents can change by assignment. In addition Standard ML also distinguishes + between mutable and immutable data in the treatment of equality. Immutable data + structures are considered equal if their contents are the same, mutable cells + are considered equal only if they are the pointers to the same cell. + + Because of these differences mutable data has to be handled separately from + immutable data by the garbage collector. Using mutable cells imposes an extra + cost on each collection when compared with immutable data. In addition it is + possible to reduce the heap size by merging immutable cells that have the same + contents. In some circumstances the garbage collector may do this automatically; + more often it is done explicitly using `PolyML.shareCommonData`. + + The `SingleAssignment` structure allows for a + combination of mutable and immutable data. A value of type `saref` + is initially mutable but once it has been assigned a value it is marked as immutable. + This allows the garbage-collector and sharing code to treat it as purely immutable + once it has been locked. + + A typical use for a single-assignment reference is when a data structure is + being built by multiple threads. A `saref` can + be used within the data structure to represent a portion of the structure to + be built and a thread created to build it. When the thread completes it assigns + the `saref` with the results of its work. The + full structure is now immutable with all the advantages of immutable data.*) diff --git a/basis/Thread.sml b/basis/Thread.sml index f937155a..194c233b 100644 --- a/basis/Thread.sml +++ b/basis/Thread.sml @@ -1,724 +1,771 @@ (* Title: Thread package for ML. Author: David C. J. Matthews Copyright (c) 2007-2014, 2018 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* This signature and structure are not part of the standard basis library but are included here because they depend on the Time structure and are in turn dependencies of the BasicIO structure. *) +(*!Earlier versions of Poly/ML have provided a form of concurrent execution through + the Process structure. Version 5.1 introduces + new thread primitives in the Thread structure. This structure is modelled on + the Posix thread (pthread) package but simplified and modified for ML. The aim + is to provide an efficient implementation of parallelism particularly to enable + ML programs to make use of multi-core processors while minimising the changes + needed to existing code. The Process structure will continue to be available + as a library written on top of these primitives but new programs should use + the Thread structure directly. + +The thread package differs from pthreads in a number of ways. +There is no join function to wait for the completion of a thread. +This can be written using mutexes and condition variables. +Cancellation and signal handling are combined into the interrupt +functions. (The Poly/ML Signal structure handles signals for all the +threads together). The effect of explicit cancellation is achieved +using the interrupt function. This causes an interrupt to be +generated in a specific thread. Alternatively an interrupt can be +broadcast to all threads. This is most likely to be used +interactively to kill threads that appear to have gone out of +control. The normal top-level handler for a console interrupt will +generate this. Threads can choose how or whether they respond to +these interrupts. A thread that is doing processor-intensive work +probably needs to be able to be interrupted asynchronously whereas if +it is communicating with other threads the presence of asynchronous +interrupts makes correct programming difficult. +*) + signature THREAD = sig + (*!The Thread exception can be raised by various of the functions in the + structure if they detect an error.*) exception Thread of string (* Raised if an operation fails. *) structure Thread: sig + (*!The type of a thread identifier.*) eqtype thread (* Thread attributes - This may be extended. *) + (*!The type of a thread attribute. Thread attributes are + properties of the thread that are set initially when the thread is + created but can subsequently be modified by the thread itself. The + thread attribute type may be extended in the future to include things + like scheduling priority. The current thread attributes control the + way interrupt exceptions are delivered to the thread. + + `EnableBroadcastInterrupt` controls whether the thread will receive an interrupt sent using + `broadcastInterrupt` or as a result of pressing the console interrupt + key. If this is false the thread will not receive them. The default + for a new thread if this is not specified is false. + + `InterruptState` controls when and whether interrupts are delivered to the + thread. This includes broadcast interrupts and also interrupts directed at + a specific thread with the interrupt call. + `InterruptDefer` means the thread + will not receive any interrupts. However, if the thread has previously been + interrupted the interrupt may be delivered when the thread calls setAttributes + to change its interrupt state. `InterruptSynch` + means interrupts are delivered + synchronously. An interrupt will be delayed until an interruption point. An + interruption point is one of: `testInterrupt`, + `ConditionVar.wait`, `ConditionVar.waitUntil` + and various library calls that may block, such as IO calls, pause etc. N.B. + `Mutex.lock` is not an interruption point even though it can result in a thread + blocking for an indefinite period. `InterruptAsynch` means interrupts are delivered + asynchronously i.e. at a suitable point soon after they are triggered. + `InterruptAsynchOnce` + means that only a single interrupt is delivered asynchronously after which + the interrupt state is changed to `InterruptSynch`. It allows a thread to tidy + up and if necessary indicate that it has been interrupted without the risk + of a second asynchronous interrupt occurring in the handler for the first + interrupt. If this attribute is not specified when a thread is created the + default is `InterruptSynch`. + + `MaximumMLStack` was added in version 5.5.3. It controls the maximum size the + ML stack may grow to. It is an option type where NONE allows the stack to + grow to the limit of the available memory whereas SOME n limits the stack + to n words. This is approximate since there is some rounding involved. When + the limit is reached the thread is sent an Interrupt exception.*) datatype threadAttribute = (* Does this thread accept a broadcast interrupt? The default is not to accept broadcast interrupts. *) EnableBroadcastInterrupt of bool (* How to handle interrupts. The default is to handle interrupts synchronously. *) | InterruptState of interruptState (* Maximum size of the ML stack in words. NONE means unlimited *) | MaximumMLStack of int option and interruptState = InterruptDefer (* Defer any interrupts. *) | InterruptSynch (* Interrupts are delivered synchronously. An interrupt will be delayed until an interruption point. An interruption point is one of: testInterrupt, ConditionVar.wait, ConditionVar.waitUntil and various library calls that may block, such as IO calls, pause etc. N.B. Mutex.lock is not an interruption point even though it can result in a thread blocking for an indefinite period. *) | InterruptAsynch (* Interrupts are delivered asynchronously i.e. at a suitable point soon after they are triggered. *) | InterruptAsynchOnce (* As InterruptAsynch except that only a single interrupt is delivered asynchronously after which the interrupt state is changed to InterruptSynch. It allows a thread to tidy up and if necessary indicate that it has been interrupted without the risk of a second asynchronous interrupt occurring in the handler for the first interrupt. *) - (* fork: Fork a thread. Starts a new thread running the function argument. The - attribute list gives initial values for thread attributes which can be - modified by the thread itself. Any unspecified attributes take default values. - The thread is terminated when the thread function returns, if it - raises an uncaught exception or if it calls "exit". *) + (*!Fork a thread. Starts a new thread running + the function argument. The attribute list gives initial values for thread attributes + which can be modified by the thread itself. Any unspecified attributes take + default values. The thread is terminated when the thread function returns, if + it raises an uncaught exception or if it calls `exit`;*) val fork: (unit->unit) * threadAttribute list -> thread - (* exit: Terminate this thread. *) + + (*!Terminate this thread. *) val exit: unit -> unit - (* isActive: Test if a thread is still running or has terminated. *) + (*!Test if a thread is still running or has terminated. This function should be + used with care. The thread may be on the point of terminating and still appear + to be active.*) val isActive: thread -> bool - (* Test whether thread ids are the same. No longer needed if this is an eqtype. *) + (*!Test whether thread ids are the same. This is provided for backwards compatibility + since `thread` is an eqtype. *) val equal: thread * thread -> bool - (* Get my own ID. *) + (*!Return the thread identifier for the current thread. *) val self: unit -> thread exception Interrupt (* = SML90.Interrupt *) - (* Send an Interrupt exception to a specific thread. When and indeed whether + (*!Send an Interrupt exception to a specific thread. When and indeed whether the exception is actually delivered will depend on the interrupt state of the target thread. Raises Thread if the thread is no longer running, so an exception handler should be used unless the thread is known to be blocked. *) val interrupt: thread -> unit - (* Send an interrupt exception to every thread which is set to accept it. *) + (*!Send an interrupt exception to every thread which is set to accept it. *) val broadcastInterrupt: unit -> unit - (* If this thread is handling interrupts synchronously, test to see - if it has been interrupted. If so it raises the Interrupt - exception. *) + (*!If this thread is handling interrupts synchronously, test to see + if it has been interrupted. If so it raises the + `Interrupt` exception. *) val testInterrupt: unit -> unit - (* Terminate a thread. This should be used as a last resort. Normally + (*!Terminate a thread. This should be used as a last resort. Normally a thread should be allowed to clean up and terminate by using the interrupt call. Raises Thread if the thread is no longer running, so an exception handler should be used unless the thread is known to be blocked. *) val kill: thread -> unit - (* Get and set thread-local store for the calling thread. The store is a + (*!Get and set thread-local store for the calling thread. The store is a tagged associative memory which is initially empty for a new thread. A thread can call setLocal to add or replace items in its store and call getLocal to return values if they exist. The Universal structure contains functions to make new tags as well as injection, projection and test functions. *) val getLocal: 'a Universal.tag -> 'a option - val setLocal: 'a Universal.tag * 'a -> unit + and setLocal: 'a Universal.tag * 'a -> unit - (* Change the specified attribute(s) for the calling thread. Unspecified + (*!Change the specified attribute(s) for the calling thread. Unspecified attributes remain unchanged. *) val setAttributes: threadAttribute list -> unit - (* Get the values of attributes. *) + (*!Get the values of attributes. *) val getAttributes: unit -> threadAttribute list - (* Return the number of processors that will be used to run threads. *) + (*!Return the number of processors that will be used to run threads + and the number of physical processors if that is available. *) val numProcessors: unit -> int - (* and the number of physical processors if that is available. *) and numPhysicalProcessors: unit -> int option end structure Mutex: sig - (* Mutexes. A mutex provides simple mutual exclusion. A thread can lock + (*!A mutex provides simple mutual exclusion. A thread can lock a mutex and until it unlocks it no other thread will be able to lock it. Locking and unlocking are intended to be fast in the situation when - there is no other process attempting to lock the mutex. *) + there is no other process attempting to lock the mutex. + These functions may not work correctly if an asynchronous interrupt + is delivered during the calls. A thread should use synchronous interrupt + when using these calls. *) type mutex - (* mutex: Make a new mutex *) + (*!Make a new mutex *) val mutex: unit -> mutex - (* lock: Lock a mutex. If the mutex is currently locked the thread is + (*!Lock a mutex. If the mutex is currently locked the thread is blocked until it is unlocked. If a thread tries to lock a mutex that it has previously locked the thread will deadlock. - N.B. "lock" is not an interruption point (a point where synchronous + N.B. `thread` is not an interruption point + (a point where synchronous interrupts are delivered) even though a thread can be blocked indefinitely. *) val lock: mutex -> unit - (* unlock: Unlock a mutex and allow any waiting threads to run. The behaviour + (*!Unlock a mutex and allow any waiting threads to run. The behaviour if the mutex was not previously locked by the calling thread is undefined. *) val unlock: mutex -> unit - (* trylock: Attempt to lock the mutex. Returns true if the mutex was not + (*!Attempt to lock the mutex. Returns true if the mutex was not previously locked and has now been locked by the calling thread. Returns false if the mutex was previously locked, including by the calling thread. *) val trylock: mutex -> bool - (* These functions may not work correctly if an asynchronous interrupt - is delivered during the calls. A thread should use synchronous interrupt - when using these calls. *) end structure ConditionVar: sig - (* Condition variables. Condition variables are used to provide communication + (*!Condition variables are used to provide communication between threads. A condition variable is used in conjunction with a mutex and usually a reference to establish and test changes in state. The normal use is for one thread to lock a mutex, test the reference and then wait on the condition variable, releasing the lock on the mutex while it does so. Another thread may then lock the mutex, update the reference, unlock the mutex, and signal the condition variable. This wakes up the first thread and reacquires the lock allowing the thread to test the updated reference with the lock held. More complex communication mechanisms, such as blocking channels, can be written in terms of condition variables. *) type conditionVar - (* conditionVar: Make a new condition variable. *) + (*!Make a new condition variable. *) val conditionVar: unit -> conditionVar - (* wait: Release the mutex and block until the condition variable is - signalled. When wait returns the mutex has been re-acquired. - If thread is handling interrupts synchronously a call to "wait" may cause - an Interrupt exception to be delivered. - (The implementation must ensure that if an Interrupt is delivered as well - as signal waking up a single thread that the interrupted thread does not - consume the "signal".) - The mutex is (re)acquired before Interrupt is delivered. *) + (*!Release the mutex and block until the condition variable is signalled. When + wait returns the mutex will have been re-acquired. + + If the thread is handling interrupts synchronously this function can be interrupted + using the `Thread.interrupt` function or, if the thread is set to + accept broadcast interrupts, `Thread.broadcastInterrupt`. The thread + will re-acquire the mutex before the exception is delivered. An exception + will only be delivered in this case if the interrupt is sent before the condition + variable is signalled. If the interrupt is sent after the condition variable + is signalled the function will return normally even if it has not yet re-acquired + the mutex. The interrupt state will be delivered on the next call to "wait", + `Thread.testInterrupt` or other blocking call. + + A thread should never call this function if it may receive an asynchronous + interrupt. It should always set its interrupt state to either + `InterruptSynch` + or `InterruptDefer` beforehand. + An asynchronous interrupt may leave the condition + variable and the mutex in an indeterminate state and could lead to deadlock. + + A condition variable should only be associated with one mutex at a time. + All the threads waiting on a condition variable should pass the same mutex + as argument.*) val wait: conditionVar * Mutex.mutex -> unit - (* waitUntil: As wait except that it blocks until either the condition + (*!As wait except that it blocks until either the condition variable is signalled or the time (absolute) is reached. Either way the mutex is reacquired so there may be a further delay if it is held by another thread. *) val waitUntil: conditionVar * Mutex.mutex * Time.time -> bool - (* signal: Wake up one thread if any are waiting on the condition variable. *) + (*!Wake up one thread if any are waiting on the condition variable. + If there are several threads waiting for the condition variable one will be + selected to run and will run as soon as it has re-acquired the lock.*) val signal: conditionVar -> unit - (* broadcast: Wake up all threads waiting on the condition variable. *) + (*!Wake up all threads waiting on the condition variable. *) val broadcast: conditionVar -> unit end end; structure Thread :> THREAD = struct exception Thread = RunCall.Thread (* Create non-overwritable mutables for mutexes and condition variables. A non-overwritable mutable in the executable or a saved state is not overwritten when a saved state further down the hierarchy is loaded. *) val nvref = LibrarySupport.noOverwriteRef structure Thread = struct open Thread (* Created in INITIALISE with thread type and self function. *) (* Equality is pointer equality. *) val equal : thread*thread->bool = op = datatype threadAttribute = EnableBroadcastInterrupt of bool | InterruptState of interruptState | MaximumMLStack of int option and interruptState = InterruptDefer | InterruptSynch | InterruptAsynch | InterruptAsynchOnce (* Convert attributes to bits and a mask. *) fun attrsToWord (at: threadAttribute list): Word.word * Word.word = let (* Check that a particular attribute appears only once. As well as accumulating the actual bits in the result we also accumulate the mask of bits. If any of these reappear we raise an exception. *) fun checkRepeat(r, acc, set, mask) = if Word.andb(set, mask) <> 0w0 then raise Thread "The same attribute appears more than once in the list" else convert(r, acc, Word.orb(set, mask)) and convert([], acc, set) = (acc, set) | convert(EnableBroadcastInterrupt true :: r, acc, set) = checkRepeat(r, Word.orb(acc, 0w1), set, 0w1) | convert(EnableBroadcastInterrupt false :: r, acc, set) = checkRepeat(r, acc (* No bit *), set, 0w1) | convert(InterruptState s :: r, acc, set) = checkRepeat(r, Word.orb(setIstateBits s, acc), set, 0w6) | convert(MaximumMLStack _ :: r, acc, set) = convert(r, acc, set) in convert(at, 0w0, 0w0) end and setIstateBits InterruptDefer = 0w0 | setIstateBits InterruptSynch = 0w2 | setIstateBits InterruptAsynch = 0w4 | setIstateBits InterruptAsynchOnce = 0w6 fun getIstateBits(w: Word.word): interruptState = let val ibits = Word.andb(w, 0w6) in if ibits = 0w0 then InterruptDefer else if ibits = 0w2 then InterruptSynch else if ibits = 0w4 then InterruptAsynch else InterruptAsynchOnce end fun wordToAttrs w = let (* Enable broadcast - true if bottom bit is set. *) val bcast = EnableBroadcastInterrupt(Word.andb(w, 0w1) = 0w1) in [bcast, InterruptState(getIstateBits w)] end exception Interrupt = RunCall.Interrupt (* The thread id is opaque outside this structure but is actually a six word mutable object. Word 0: Index into thread table (used inside the RTS only) Word 1: Flags: initialised by the RTS and set by this code Word 2: Thread local store: read and set by this code. Word 3: IntRequest: Set by the RTS if there is an interrupt pending Word 4: Maximum ML stack size. Unlimited is stored here as zero *) val threadIdFlags = 0w1 and threadIdThreadLocal = 0w2 and threadIdIntRequest = 0w3 and threadIdStackSize = 0w4 fun getLocal (t: 'a Universal.tag) : 'a option = let val root: Universal.universal ref list = RunCall.loadWord(self(), threadIdThreadLocal) fun doFind [] = NONE | doFind ((ref v)::r) = if Universal.tagIs t v then SOME(Universal.tagProject t v) else doFind r in doFind root end fun setLocal (t: 'a Universal.tag, newVal: 'a) : unit = let (* See if we already have this in the list. *) val root: Universal.universal ref list = RunCall.loadWord(self(), threadIdThreadLocal) fun doFind [] = (* Not in the list - Add it. *) RunCall.storeWord (self(), threadIdThreadLocal, ref (Universal.tagInject t newVal) :: root) | doFind (v::r) = if Universal.tagIs t (!v) (* If it's in the list update it. *) then v := Universal.tagInject t newVal else doFind r in doFind root end local val threadTestInterrupt: unit -> unit = RunCall.rtsCallFull0 "PolyThreadTestInterrupt" in fun testInterrupt() = (* If there is a pending request the word in the thread object will be non-zero. *) if RunCall.loadWord(self(), threadIdIntRequest) <> 0 then threadTestInterrupt() else () end local fun getAttrWord (me: thread) : Word.word = RunCall.loadWord(me, threadIdFlags) fun getStackSizeAsInt (me: thread) : int = RunCall.loadWord(me, threadIdStackSize) and getStackSize me : int option = case getStackSizeAsInt me of 0 => NONE | s => SOME s fun newStackSize ([], default) = default | newStackSize (MaximumMLStack NONE :: _, _) = 0 | newStackSize (MaximumMLStack (SOME n) :: _, _) = if n <= 0 then raise Thread "The stack size must be greater than zero" else n | newStackSize (_ :: l, default) = newStackSize (l, default) val threadMaxStackSize: int -> unit = RunCall.rtsCallFull1 "PolyThreadMaxStackSize" in (* Set attributes. Only changes the values that are specified. The others remain the same. *) fun setAttributes (attrs: threadAttribute list) : unit = let val me = self() val oldValues: Word.word = getAttrWord me val (newValue, mask) = attrsToWord attrs val stack = newStackSize(attrs, getStackSizeAsInt me) in RunCall.storeWord (self(), threadIdFlags, Word.orb(newValue, Word.andb(Word.notb mask, oldValues))); if stack = getStackSizeAsInt me then () else threadMaxStackSize stack; (* If we are now handling interrupts asynchronously check whether we have a pending interrupt now. This will only be effective if we were previously handling them synchronously or blocking them. *) if Word.andb(newValue, 0w4) = 0w4 then testInterrupt() else () end fun getAttributes() : threadAttribute list = let val me = self() in MaximumMLStack (getStackSize me) :: wordToAttrs(getAttrWord me) end (* These are used in the ConditionVar structure. They affect only the interrupt handling bits. *) fun getInterruptState(): interruptState = getIstateBits(getAttrWord(self())) and setInterruptState(s: interruptState): unit = RunCall.storeWord (self(), threadIdFlags, Word.orb(setIstateBits s, Word.andb(Word.notb 0w6, getAttrWord(self())))) local (* The default for a new thread is to ignore broadcasts and handle explicit interrupts synchronously. *) val (defaultAttrs, _) = attrsToWord[EnableBroadcastInterrupt false, InterruptState InterruptSynch] val threadForkFunction: (unit->unit) * word * int -> thread = RunCall.rtsCallFull3 "PolyThreadForkThread" in fun fork(f:unit->unit, attrs: threadAttribute list): thread = let (* Any attributes specified explicitly override the defaults. *) val (attrWord, mask) = attrsToWord attrs val attrValue = Word.orb(attrWord, Word.andb(Word.notb mask, defaultAttrs)) val stack = newStackSize(attrs, 0 (* Default is unlimited *)) in threadForkFunction(f, attrValue, stack) end end end val exit: unit -> unit = RunCall.rtsCallFull0 "PolyThreadKillSelf" and isActive: thread -> bool = RunCall.rtsCallFast1 "PolyThreadIsActive" and broadcastInterrupt: unit -> unit = RunCall.rtsCallFull0 "PolyThreadBroadcastInterrupt" local (* Send an interrupt to a thread. If it returns false the thread did not exist and this should raise an exception. *) val threadSendInterrupt: thread -> bool = RunCall.rtsCallFast1 "PolyThreadInterruptThread" in fun interrupt(t: thread) = if threadSendInterrupt t then () else raise Thread "Thread does not exist" end local val threadKillThread: thread -> bool = RunCall.rtsCallFast1 "PolyThreadKillThread" in fun kill(t: thread) = if threadKillThread t then () else raise Thread "Thread does not exist" end val numProcessors: unit -> int = RunCall.rtsCallFast0 "PolyThreadNumProcessors" local val numberOfPhysical: unit -> int = RunCall.rtsCallFast0 "PolyThreadNumPhysicalProcessors" in fun numPhysicalProcessors(): int option = (* It is not always possible to get this information *) case numberOfPhysical() of 0 => NONE | n => SOME n end end structure Mutex = struct type mutex = Word.word ref fun mutex() = nvref 0w1; (* Initially unlocked. *) open Thread (* atomicIncr, atomicDecr and atomicReset are set up by Initialise. *) val threadMutexBlock: mutex -> unit = RunCall.rtsCallFull1 "PolyThreadMutexBlock" val threadMutexUnlock: mutex -> unit = RunCall.rtsCallFull1 "PolyThreadMutexUnlock" (* A mutex is implemented as a Word.word ref. It is initially set to 1 and locked by atomically decrementing it. If it was previously unlocked the result will by zero but if it was already locked it will be some negative value. When it is unlocked it is atomically incremented. If there was no contention the result will again be 1 but if some other thread tried to lock it the result will be zero or negative. In that case the unlocking thread needs to call in to the RTS to wake up the blocked thread. The cost of contention on the lock is very high. To try to avoid this we first loop (spin) to see if we can get the lock without contention. *) val spin_cycle = 20000 fun spin (m: mutex, c: int) = if ! m = 0w1 then () else if c = spin_cycle then () else spin(m, c+1); fun lock (m: mutex): unit = let val () = spin(m, 0) val newValue = atomicDecr m in if newValue = 0w0 then () (* We've acquired the lock. *) else (* It's locked. We return when we have the lock. *) ( threadMutexBlock m; lock m (* Try again. *) ) end fun unlock (m: mutex): unit = let val newValue = atomicIncr m in if newValue = 0w1 then () (* No contention. *) else (* Another thread has blocked and we have to release it. We can safely set the value to 1 here to release the lock. If another thread acquires it before we have woken up the other threads that's fine. Equally, if another thread decremented the count and saw it was still locked it will enter the RTS and try to acquire the lock there. It's probably better to reset it here rather than within the RTS since it allows another thread to acquire the lock immediately rather than after the rather long process of entering the RTS. Resetting this needs to be atomic with respect to atomic increment and decrement. That's not a problem on X86 so a simple assignment is sufficient but in the interpreter at least it's necessary to acquire a lock. *) ( atomicReset m; threadMutexUnlock m ) end (* Try to lock the mutex. If it was previously unlocked then lock it and return true otherwise return false. Because we don't block here there is the possibility that the thread that has locked it could release the lock shortly afterwards. The check for !m = 0w1 is an optimisation and nearly all the time it avoids the call to atomicDecr setting m to a negative value. There is a small chance that another thread could lock the mutex between the test for !m = 0w1 and the atomicDecr. In that case the atomicDecr would return a negative value and the function that locked the mutex will have to call into the RTS to reset it when it is unlocked. *) fun trylock (m: mutex): bool = if !m = 0w1 andalso atomicDecr m = 0w0 then true (* We've acquired the lock. *) else false (* The lock was taken. *) end structure ConditionVar = struct open Thread (* A condition variable contains a lock and a list of suspended threads. *) type conditionVar = { lock: Mutex.mutex, threads: thread list ref } fun conditionVar(): conditionVar = { lock = Mutex.mutex(), threads = nvref nil } local val threadCondVarWait: Mutex.mutex -> unit = RunCall.rtsCallFull1 "PolyThreadCondVarWait" and threadCondVarWaitUntil: Mutex.mutex * Time.time -> unit = RunCall.rtsCallFull2 "PolyThreadCondVarWaitUntil" in fun innerWait({lock, threads}: conditionVar, m: Mutex.mutex, t: Time.time option) : bool = let val me = self() (* My thread id. *) fun waitAgain() = let fun doFind [] = false | doFind(h::t) = equal(h, me) orelse doFind t fun removeThis [] = raise Fail "Thread missing in list" | removeThis (h::t) = if equal(h, me) then t else h :: removeThis t val () = case t of SOME time => threadCondVarWaitUntil(lock, time) | NONE => threadCondVarWait lock val () = Mutex.lock lock (* Get the lock again. *) (* Are we still on the list? If so we haven't been explicitly woken up. We've either timed out, been interrupted or simply returned because the RTS needed to process some asynchronous results. *) val stillThere = doFind(!threads) open Time (* For >= *) in if not stillThere then (* We're done. *) ( Mutex.unlock lock; true ) else if (case t of NONE => false | SOME t => Time.now() >= t) then (* We've timed out. *) ( threads := removeThis(! threads); Mutex.unlock lock; false ) else ( (* See if we've been interrupted. If so remove ourselves and exit. *) testInterrupt() handle exn => (threads := removeThis(! threads); Mutex.unlock lock; raise exn); (* Otherwise just keep waiting. *) waitAgain() ) end in Mutex.lock lock; (* Lock the internal mutex. *) Mutex.unlock m; (* Unlock the external mutex *) threads := me :: !threads; (* Add ourselves to the list. *) waitAgain() (* Wait and return the result when we're done. *) end fun doWait(c: conditionVar, m: Mutex.mutex, t: Time.time option) : bool = let val originalIntstate = getInterruptState() (* Set this to handle interrupts synchronously unless we're already ignoring them. *) val () = if originalIntstate = InterruptDefer then () else setInterruptState InterruptSynch; (* Wait for the condition. If it raises an exception we still need to reacquire the lock unless we were handling interrupts asynchronously. *) val result = innerWait(c, m, t) handle exn => ( (* We had an exception. If we were handling exceptions synchronously we reacquire the lock. If it was set to InterruptAsynchOnce this counts as a single asynchronous exception and we restore the state as InterruptSynch. *) case originalIntstate of InterruptDefer => (* Shouldn't happen? *) Mutex.lock m | InterruptSynch => Mutex.lock m | InterruptAsynch => setInterruptState InterruptAsynch | InterruptAsynchOnce => setInterruptState InterruptSynch; raise exn (* Reraise the exception*) ) in (* Restore the original interrupt state first. *) setInterruptState originalIntstate; (* Normal return. Reacquire the lock before returning. *) Mutex.lock m; result end fun wait(c: conditionVar, m: Mutex.mutex) : unit = (doWait(c, m, NONE); ()) and waitUntil(c: conditionVar, m: Mutex.mutex, t: Time.time) : bool = doWait(c, m, SOME t) end local (* This call wakes up the specified thread. If the thread has already been interrupted and is not ignoring interrupts it returns false. Otherwise it wakes up the thread and returns true. We have to use this because we define that if a thread is interrupted before it is signalled then it raises Interrupt. *) val threadCondVarWake: thread -> bool = RunCall.rtsCallFast1 "PolyThreadCondVarWake" (* Wake a single thread if we can (signal). *) fun wakeOne [] = [] | wakeOne (thread::rest) = if threadCondVarWake thread then rest else thread :: wakeOne rest (* Wake all threads (broadcast). *) fun wakeAll [] = [] (* Always returns the empty list. *) | wakeAll (thread::rest) = (threadCondVarWake thread; wakeAll rest) fun signalOrBroadcast({lock, threads}: conditionVar, wakeThreads) : unit = let val originalState = getInterruptState() in (* Set this to handle interrupts synchronously unless we're already ignoring them. We need to do this to avoid an asynchronous interrupt which could leave the internal lock in an inconsistent state. *) if originalState = InterruptDefer then () else setInterruptState InterruptSynch; (* Get the condition var lock. *) Mutex.lock lock; threads := wakeThreads(! threads); Mutex.unlock lock; setInterruptState originalState; (* Restore original state. *) (* Test if we were interrupted while we were handling interrupts synchronously. *) if originalState = InterruptAsynch orelse originalState = InterruptAsynchOnce then testInterrupt() else () end in fun signal cv = signalOrBroadcast(cv, wakeOne) and broadcast cv = signalOrBroadcast(cv, wakeAll) end end end; -structure ThreadLib: -sig - val protect: Thread.Mutex.mutex -> ('a -> 'b) -> 'a -> 'b -end = -struct - (* This applies a function while a mutex is being held. - Although this can be defined in terms of Thread.Thread.getAttributes it's - defined here using the underlying calls. The original version with - getAttributes appeared as a major allocation hot-spot when building the - compiler because "protect" is called round every access to the global - name-space. *) - fun protect m f a = - let - open Thread.Thread Thread.Mutex - open Word - (* Set this to handle interrupts synchronously except if we are blocking - them. We don't want to get an asynchronous interrupt while we are - actually locking or unlocking the mutex but if we have to block to do - IO then we should allow an interrupt at that point. *) - val oldAttrs: Word.word = RunCall.loadWord(self(), 0w1) - val () = - if andb(oldAttrs, 0w6) = 0w0 (* Already deferred? *) - then () - else RunCall.storeWord (self(), 0w1, - orb(andb(notb 0w6, oldAttrs), 0w2)) - fun restoreAttrs() = - ( - RunCall.storeWord (self(), 0w1, oldAttrs); - if andb(oldAttrs, 0w4) = 0w4 then testInterrupt() else () - ) - val () = lock m - val result = f a - handle exn => - ( - unlock m; restoreAttrs(); - (* Reraise the exception preserving the location information. *) - PolyML.Exception.reraise exn - ) - in - unlock m; - restoreAttrs(); - result - end -end; - - local fun prettyMutex _ _ (_: Thread.Mutex.mutex) = PolyML.PrettyString "?" and prettyThread _ _ (_: Thread.Thread.thread) = PolyML.PrettyString "?" and prettyCondVar _ _ (_: Thread.ConditionVar.conditionVar) = PolyML.PrettyString "?" in val () = PolyML.addPrettyPrinter prettyMutex and () = PolyML.addPrettyPrinter prettyThread and () = PolyML.addPrettyPrinter prettyCondVar end; diff --git a/basis/ThreadLib.sml b/basis/ThreadLib.sml new file mode 100644 index 00000000..c9a336bb --- /dev/null +++ b/basis/ThreadLib.sml @@ -0,0 +1,64 @@ +(* + Title: Thread library + Author: David C. J. Matthews + Copyright (c) 2007-2014, 2018, 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 +*) + +structure ThreadLib: +sig + val protect: Thread.Mutex.mutex -> ('a -> 'b) -> 'a -> 'b +end = +struct + (* This applies a function while a mutex is being held. + Although this can be defined in terms of Thread.Thread.getAttributes it's + defined here using the underlying calls. The original version with + getAttributes appeared as a major allocation hot-spot when building the + compiler because "protect" is called round every access to the global + name-space. *) + fun protect m f a = + let + open Thread.Thread Thread.Mutex + open Word + (* Set this to handle interrupts synchronously except if we are blocking + them. We don't want to get an asynchronous interrupt while we are + actually locking or unlocking the mutex but if we have to block to do + IO then we should allow an interrupt at that point. *) + val oldAttrs: Word.word = RunCall.loadWord(self(), 0w1) + val () = + if andb(oldAttrs, 0w6) = 0w0 (* Already deferred? *) + then () + else RunCall.storeWord (self(), 0w1, + orb(andb(notb 0w6, oldAttrs), 0w2)) + fun restoreAttrs() = + ( + RunCall.storeWord (self(), 0w1, oldAttrs); + if andb(oldAttrs, 0w4) = 0w4 then testInterrupt() else () + ) + val () = lock m + val result = f a + handle exn => + ( + unlock m; restoreAttrs(); + (* Reraise the exception preserving the location information. *) + PolyML.Exception.reraise exn + ) + in + unlock m; + restoreAttrs(); + result + end +end; + diff --git a/basis/Universal.ML b/basis/Universal.ML index c9aa3147..f909d8b1 100644 --- a/basis/Universal.ML +++ b/basis/Universal.ML @@ -1,95 +1,113 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(** + The `Universal` structure provides a universal + union type. It allows value of any type to be stored in a single table without + knowing in advance the types to be stored. Note that this is not the same as + a dynamic type. The values are discriminated by the tag, not by the type. There + may be more than one tag that can be used with values of a particular type and + these are treated as completely different. `Universal` + is built in for efficiency reasons but it is perfectly feasible to implement + it in Standard ML using `exception` bindings. +**) + structure Universal :> sig - type universal - type 'a tag - - val tag : unit -> 'a tag - - val tagIs : 'a tag -> universal -> bool - val tagInject : 'a tag -> 'a -> universal - val tagProject : 'a tag -> universal -> 'a + (*!The type of the universal union.*) + type universal + (*!The type of a tag that can be used to mark a value of the argument type.*) + type 'a tag + + (*!Create a tag that can be used to identify a value of a particular type.*) + val tag : unit -> 'a tag + (*!Inject a value into the union. This marks the value with the tag.*) + val tagInject : 'a tag -> 'a -> universal + (*!Test whether the value was marked with the tag.*) + val tagIs : 'a tag -> universal -> bool + (*!Project a value from the union. The tag must match the tag that was used + to create union value otherwise a `Match` + exception will be raised.*) + val tagProject : 'a tag -> universal -> 'a end = struct (* The universal type is based on exn which provides a tagged union. We use opaque signature matching to create a different type. *) type universal = exn type 'a tag = { is: universal -> bool, inject: 'a -> universal, project: universal -> 'a }; (* The Match exception is created in the General structure in the basis library which hasn't been built yet. *) fun tag () : 'a tag = let exception E of 'a; in { inject = fn x => E x, project = fn E x => x | _ => raise RunCall.Match, is = fn E _ => true | _ => false } end ; val tagIs : 'a tag -> universal -> bool = #is val tagInject : 'a tag -> 'a -> universal = #inject val tagProject : 'a tag -> universal -> 'a = #project end; (* This code will test the above structure datatype t = T of int ; datatype x = X of string ; val {is=ist,inject=injectT:t->universal,project=projectT} = tag(); val {is=isx,inject=injectX:x->universal,project=projectX} = tag(); val a = injectT (T 42) ; val b = injectT (T 24) ; val c = injectX (X "hello") ; val d = injectX (X "mike") ; map ist [a,b,c,d] ; map isx [a,b,c,d] ; projectT a ; projectT b ; projectT c ; projectT d ; projectX a ; projectX b ; projectX c ; projectX d ; *) diff --git a/basis/Weak.sml b/basis/Weak.sml index 233328ed..3633ea1f 100644 --- a/basis/Weak.sml +++ b/basis/Weak.sml @@ -1,61 +1,120 @@ (* Title: Weak references Author: David Matthews - Copyright David Matthews 2008, 2015-16, 2019 + Copyright David Matthews 2008, 2015-16, 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 *) (* A weak reference or array contains option values. The SOME variant of the option must contain a reference. This restriction is imposed because they require pointer equality. A weak reference or array behaves just like a normal ref or array with one difference. The garbage collector may set a weak ref or the field of weak array to NONE if it currently contains SOME r but r is not reachable other than through weak references. The one proviso is that if r is contained in the executable it is always reachable. *) +(** + The `Weak` structure contains functions for constructing + *weak* references and arrays. A weak reference is a way of detecting + when a resource is no longer in use and can be recovered. It is, in effect, + a way of extending the concept of garbage-collection to user code. +**) signature WEAK = sig + (** Constructs a weak reference. **) val weak: 'a ref option -> 'a ref option ref + (** Constructs an array containing weak references. **) val weakArray: int * 'a ref option -> 'a ref option array + (** A lock and a condition variable that is broadcast when the garbage collector has recovered a *token*. **) val weakLock: Thread.Mutex.mutex and weakSignal: Thread.ConditionVar.conditionVar + (** Uses the reference without changing it, ensuring that it is reachable at that point. **) val touch : 'a ref -> unit end; structure Weak: WEAK = struct fun weak (v: 'a ref option): 'a ref option ref = RunCall.allocateWordMemory(0w1, 0wx60, v) fun weakArray(n: int, v: 'a ref option): 'a ref option array = let val () = if n < 0 orelse n >= Array.maxLen then raise Size else () val arr = RunCall.allocateWordMemory(Word.fromInt n, 0wx60, v) in arr end val weakLock = Thread.Mutex.mutex() and weakSignal = Thread.ConditionVar.conditionVar() (* touch is considered by the compiler as an access to the ref but doesn't actually do anything with it. The idea is that it ensures that when a ref is used as a token that this will access the ref and avoid the weak reference becoming set to NONE. It's primarily there for long-term security in the event that the compiler is sufficiently clever to work out that something is no longer referenced. *) val touch: 'a ref -> unit = RunCall.touch end; +(** + The idea behind weak references is to allow user library code to recover resources + when they are no longer in use. This is only relevant for resources, such as + file descriptors, that exist outside the Poly/ML memory and need to be recovered. + + The garbage-collector recovers space in the heap by identifying cells that + are reachable from *roots*, generally the stacks of threads, and treating + everything else as garbage. This can be extended to external resources by associating + a *token* with the resource. While the token is reachable the resource + is considered to be in use. Once the token ceases to be reachable the resource + can be recovered. + + A weak reference is used to detect when the token is no longer accessible. + To make use of this the library code must allocate a normal reference value, + the token, whenever it constructs or links to the external resource and include + the token within the data it returns to the client code. The contents of the + reference are not relevant; it can be a `unit ref`, + what matters is the identity of the reference. When the library creates a token + it makes an entry in its own data structure within a weak reference or array. + That entry is set to `SOME token`. Note that the + type of a weak reference is `'a ref option ref` + i.e. it can only contain an option type holding a reference value. + + Provided the client code continues to use the resource and has a reachable + pointer to the token there will be no change to the state. If, though, it discards + the data associated with the resource and hence the pointer to the token the + resource is considered to be released and the library may recover the resource. + If the garbage collector detects that there are no other pointers to the token + except the weak reference it will change the weak reference from `SOME token` to + `NONE`, so there are no longer any pointers at all. + + To actually release the external resource the library must check the weak references + or arrays within its own data structures and look for entries that have been + set to `NONE`. Depending how the library code + works it may be appropriate to do this synchronously whenever a request is made + to allocate a new resource. An alternative would be to create a new thread to + manage the process asynchronously. To aid this the thread should lock the `weakLock` + mutex and suspend itself by calling `Thread.ConditionVar.wait` + or `Thread.ConditionVar.waitUntil`, passing `weakLock` and `weakSignal` + as arguments. The `weakSignal` condition variable + is broadcast after a garbage-collection if the garbage collector has modified + a weak reference. Because there may be several libraries using weak references + the receipt of the signal does not guarantee that a resource associated with + any particular library has been released. + + The garbage-collector is only run when necessary and detection of released + resources may happen very infrequently, depending on factors such as the size + of the heap. To force a collection the library can call `PolyML.fullGC` +**) diff --git a/basis/build.sml b/basis/build.sml index 267f12f3..74ed0aa3 100644 --- a/basis/build.sml +++ b/basis/build.sml @@ -1,183 +1,184 @@ (* Title: Standard Basis Library: Commands to build the library - Copyright David C.J. Matthews 2000, 2005, 2015-16, 2018-19 + Copyright David C.J. Matthews 2000, 2005, 2015-16, 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 *) (* Thread, Weak and Signal are Poly/ML extensions. *) val () = Bootstrap.use "basis/InitialBasis.ML"; val () = Bootstrap.use "basis/Universal.ML"; val () = Bootstrap.use "basis/General.sml"; val () = Bootstrap.use "basis/LibrarySupport.sml"; val () = Bootstrap.use "basis/PolyMLException.sml"; val () = Bootstrap.use "basis/Option.sml"; val () = Bootstrap.use "basis/ListSignature.sml"; val () = Bootstrap.use "basis/List.sml"; val () = Bootstrap.use "basis/VectorOperations.sml"; val () = Bootstrap.use "basis/PolyVectorOperations.sml"; val () = Bootstrap.use "basis/VectorSliceOperations.sml"; val () = Bootstrap.use "basis/MONO_VECTOR.sml"; val () = Bootstrap.use "basis/MONO_VECTOR_SLICE.sml"; val () = Bootstrap.use "basis/MONO_ARRAY.sml"; val () = Bootstrap.use "basis/MONO_ARRAY_SLICE.sml"; val () = Bootstrap.use "basis/StringSignatures.sml"; val () = Bootstrap.use "basis/String.sml"; structure Int = struct type int = int end; val () = Bootstrap.use "basis/INTEGER.sml"; val () = Bootstrap.use "basis/Int.sml"; val () = Bootstrap.use (if Bootstrap.intIsArbitraryPrecision then "basis/IntAsLargeInt.sml" else "basis/IntAsFixedInt.sml"); val () = case FixedInt.precision of SOME 31 => Bootstrap.use "basis/Int31.sml" | SOME 63 => Bootstrap.use "basis/Int63.sml" | _ => (); val () = Bootstrap.use "basis/WordSignature.sml"; val () = Bootstrap.use "basis/LargeWord.sml"; val () = Bootstrap.use "basis/VectorSignature.sml"; val () = Bootstrap.use "basis/VectorSliceSignature.sml"; val () = Bootstrap.use "basis/Vector.sml"; val () = Bootstrap.use "basis/ArraySignature.sml"; val () = Bootstrap.use "basis/ArraySliceSignature.sml"; (* Depends on VectorSlice. *) val () = Bootstrap.use "basis/Array.sml"; val () = Bootstrap.use "basis/Text.sml"; (* Declares Char, String, CharArray, CharVector *) val () = Bootstrap.use "basis/Bool.sml"; val () = Bootstrap.use "basis/ListPair.sml"; (* Declare the appropriate additional structures. *) (* The version of Word32 we use depends on whether this is 32-bit or 64-bit. *) val () = if LargeWord.wordSize = 32 then Bootstrap.use "basis/Word32.sml" else if Word.wordSize >= 32 then Bootstrap.use "basis/Word32In64.sml" else if LargeWord.wordSize = 64 then Bootstrap.use "basis/Word32InLargeWord64.sml" else (); val () = Bootstrap.use "basis/Word16.sml"; val () = Bootstrap.use "basis/Word8.sml"; val () = Bootstrap.use "basis/IntInf.sml"; val () = Bootstrap.use "basis/Int32.sml"; val () = Bootstrap.use "basis/Word8Array.sml"; val () = Bootstrap.use "basis/Byte.sml"; val () = Bootstrap.use "basis/BoolArray.sml"; val () = Bootstrap.use "basis/IntArray.sml"; val () = Bootstrap.use "basis/RealArray.sml"; val () = Bootstrap.use "basis/IEEE_REAL.sml"; val () = Bootstrap.use "basis/IEEEReal.sml"; val () = Bootstrap.use "basis/MATH.sml"; val () = Bootstrap.use "basis/MATH.sml"; structure LargeReal = struct type real = real end; val () = Bootstrap.use "basis/RealSignature.sml"; val () = Bootstrap.use "basis/Real.sml"; val () = Bootstrap.use "basis/Real32.sml"; val () = Bootstrap.use "basis/Time.sml"; -val () = Bootstrap.use "basis/DateSignature.sml"; +val () = Bootstrap.use "basis/DATE.sig"; val () = Bootstrap.use "basis/Date.sml"; val () = Bootstrap.use "basis/Thread.sml"; (* Non-standard. *) +val () = Bootstrap.use "basis/ThreadLib.sml"; (* Non-standard. *) val () = Bootstrap.use "basis/Timer.sml"; val () = Bootstrap.use "basis/CommandLine.sml"; val () = Bootstrap.use "basis/ExnPrinter.sml"; val () = Bootstrap.use "basis/ForeignConstants.sml"; val () = Bootstrap.use "basis/ForeignMemory.sml"; val () = Bootstrap.useWithParms [Bootstrap.Universal.tagInject Bootstrap.maxInlineSizeTag 1000] "basis/Foreign.sml"; val () = Bootstrap.use "basis/IO.sml"; val () = Bootstrap.use "basis/OS.sml"; val () = Bootstrap.use "basis/PRIM_IO.sml"; val () = Bootstrap.use "basis/PrimIO.sml"; (*val () = Bootstrap.use "basis/TextPrimIO.sml"; val () = Bootstrap.use "basis/BinPrimIO.sml"; *) val () = Bootstrap.use "basis/LibraryIOSupport.sml"; val () = Bootstrap.use "basis/STREAM_IO.sml"; val () = Bootstrap.use "basis/BasicStreamIO.sml"; val () = Bootstrap.use "basis/IMPERATIVE_IO.sml"; val () = Bootstrap.use "basis/ImperativeIO.sml"; val () = Bootstrap.use "basis/TextIO.sml"; val () = Bootstrap.use "basis/BinIO.sml"; val () = Bootstrap.use "basis/Socket.sml"; val () = Bootstrap.use "basis/NetProtDB.sml"; val () = Bootstrap.use "basis/NetServDB.sml"; val () = Bootstrap.use "basis/GenericSock.sml"; val () = Bootstrap.use "basis/INetSock.sml"; val () = Bootstrap.use "basis/INet6Sock.sml"; val () = Bootstrap.use "basis/UnixSock.sml"; val () = Bootstrap.use "basis/PackRealBig.sml"; (* also declares PackRealLittle *) val () = Bootstrap.use "basis/PackWord8Big.sml"; (* also declares Pack8Little. ...*) val () = Bootstrap.use "basis/Array2Signature.sml"; val () = Bootstrap.use "basis/Array2.sml"; val () = Bootstrap.use "basis/IntArray2.sml"; val () = Bootstrap.use "basis/SML90.sml"; val () = Bootstrap.use "basis/Weak.sml"; val () = Bootstrap.use "basis/Signal.sml"; val () = Bootstrap.use "basis/BIT_FLAGS.sml"; val () = Bootstrap.use "basis/SingleAssignment.sml"; (* Build Windows or Unix structure as appropriate. *) local val getOS: int = LibrarySupport.getOSType() in val () = if getOS = 0 then ( Bootstrap.use "basis/Posix.sml"; Bootstrap.use "basis/Unix.sml") else if getOS = 1 then (Bootstrap.use "basis/Windows.sml") else () end; val () = Bootstrap.use "basis/HashArray.ML"; val () = Bootstrap.use "basis/UniversalArray.ML"; val () = Bootstrap.use "basis/PrettyPrinter.sml"; (* Add PrettyPrinter to PolyML structure. *) val () = Bootstrap.use "basis/ASN1.sml"; val () = Bootstrap.use "basis/Statistics.ML"; (* Add Statistics to PolyML structure. *) val () = Bootstrap.use "basis/InitialPolyML.ML"; (* Relies on OS. *) val () = Bootstrap.use "basis/FinalPolyML.sml"; val () = Bootstrap.use "basis/TopLevelPolyML.sml"; (* Add rootFunction to Poly/ML. *) val use = PolyML.use; (* Copy everything out of the original name space. *) (* Do this AFTER we've finished compiling PolyML and after adding "use". *) val () = List.app (#enterVal PolyML.globalNameSpace) (#allVal Bootstrap.globalSpace ()) and () = List.app (#enterFix PolyML.globalNameSpace) (#allFix Bootstrap.globalSpace ()) and () = List.app (#enterSig PolyML.globalNameSpace) (#allSig Bootstrap.globalSpace ()) and () = List.app (#enterType PolyML.globalNameSpace) (#allType Bootstrap.globalSpace ()) and () = List.app (#enterFunct PolyML.globalNameSpace) (#allFunct Bootstrap.globalSpace ()) and () = List.app (#enterStruct PolyML.globalNameSpace) (#allStruct Bootstrap.globalSpace ()) (* We don't want Bootstrap copied over. *) val () = PolyML.Compiler.forgetStructure "Bootstrap"; (* Clean out structures and functors which are only used to build the library. *) PolyML.Compiler.forgetValue "it"; PolyML.Compiler.forgetStructure "LibrarySupport"; PolyML.Compiler.forgetStructure "LibraryIOSupport"; PolyML.Compiler.forgetStructure "MachineConstants"; PolyML.Compiler.forgetStructure "ForeignConstants"; PolyML.Compiler.forgetStructure "ForeignMemory"; PolyML.Compiler.forgetFunctor "BasicStreamIO"; PolyML.Compiler.forgetFunctor "VectorOperations"; PolyML.Compiler.forgetFunctor "PolyVectorOperations"; PolyML.Compiler.forgetFunctor "VectorSliceOperations"; PolyML.Compiler.forgetFunctor "BasicImperativeIO"; PolyML.Compiler.forgetFunctor "ASN1"; PolyML.Compiler.forgetSignature "ASN1"; (* Now we've created the new name space we must use PolyML.make/use. N.B. Unlike Bootstrap.use these don't automatically look at the -I option. *) diff --git a/config.h.in b/config.h.in index 75b10412..f942a9ce 100644 --- a/config.h.in +++ b/config.h.in @@ -1,682 +1,685 @@ /* 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 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 the compiler supports __sync_fetch_and_add. */ +#undef HAVE_SYNC_FETCH + /* 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 3864a9bc..c0a9bc1a 100755 --- a/configure +++ b/configure @@ -1,25351 +1,25370 @@ #! /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 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 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports __sync_add_and_fetch" >&5 +$as_echo_n "checking whether the compiler supports __sync_add_and_fetch... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +int main(void) { long i=0; return __sync_fetch_and_add(&i, 0) + __sync_sub_and_fetch(&i, 0); } +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +$as_echo "#define HAVE_SYNC_FETCH 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_exeext conftest.$ac_ext + + 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 # 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 f5f14e18..ee69ebb5 100644 --- a/configure.ac +++ b/configure.ac @@ -1,610 +1,617 @@ # -*- 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 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 ] ) +AC_MSG_CHECKING([whether the compiler supports __sync_add_and_fetch]) +AC_LINK_IFELSE([AC_LANG_SOURCE([[int main(void) { long i=0; return __sync_fetch_and_add(&i, 0) + __sync_sub_and_fetch(&i, 0); } ]])], + [AC_MSG_RESULT([yes])] [AC_DEFINE([HAVE_SYNC_FETCH], [1], + [Define to 1 if the compiler supports __sync_fetch_and_add.])], + [AC_MSG_RESULT([no])]) + + 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 # 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/PolyLib.vcxproj b/libpolyml/PolyLib.vcxproj index 15ec3ede..949fefb4 100644 --- a/libpolyml/PolyLib.vcxproj +++ b/libpolyml/PolyLib.vcxproj @@ -1,893 +1,896 @@  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/cpp.hint b/libpolyml/cpp.hint new file mode 100644 index 00000000..dfcb10ad --- /dev/null +++ b/libpolyml/cpp.hint @@ -0,0 +1,5 @@ +// Hint files help the Visual Studio IDE interpret Visual C++ identifiers +// such as names of functions and macros. +// For more information see https://go.microsoft.com/fwlink/?linkid=865984 +#define POLYEXTERNALSYMBOL __declspec(dllexport) +#define POLYEXTERNALSYMBOL diff --git a/libpolyml/gc_mark_phase.cpp b/libpolyml/gc_mark_phase.cpp index 2af92606..a18dc413 100644 --- a/libpolyml/gc_mark_phase.cpp +++ b/libpolyml/gc_mark_phase.cpp @@ -1,882 +1,888 @@ /* 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 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 { + // Normally a root but this can happen if we're following constants in code. + // In that case we want to make sure that we don't recurse too deeply and + // overflow the C stack. Push the address to the stack before calling + // ScanAddressesInObject so that if we come back here msp will be non-zero. + // ScanAddressesInObject will empty the stack. + PushToStack(obj); 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. + // Code addresses in the native code versions. + // Closure cells are normal (word) objects and code addresses are normal addresses. // 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)) { + // Closure cells in 32-in-64. // 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. 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. 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); 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); 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); 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/heapsizing.cpp b/libpolyml/heapsizing.cpp index ec380b10..e5e981ed 100644 --- a/libpolyml/heapsizing.cpp +++ b/libpolyml/heapsizing.cpp @@ -1,992 +1,998 @@ /* Title: heapsizing.cpp - parameters to adjust heap size Copyright (c) Copyright David C.J. Matthews 2012, 2015, 2017 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ /* This module is intended to deal with heap sizing based on measurements of the time taken in the GC compared with the application code. Currently it is very basic. This also provides GC timing information to the ML code as well as statistics and debugging. */ #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_STRING_H #include #endif #ifdef HAVE_UNISTD_H #include // For sysconf #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_SYSCTL_H #include #endif #ifdef HAVE_FLOAT_H #include #endif #ifdef HAVE_MATH_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #include "globals.h" #include "arb.h" #include "diagnostics.h" #include "rts_module.h" #include "timing.h" #include "heapsizing.h" #include "statistics.h" #include "memmgr.h" // The one and only parameter object HeapSizeParameters gHeapSizeParameters; #ifdef HAVE_WINDOWS_H // There's no (documented) way to get the per-process hard page // count in Windows. Cygwin uses GetProcessMemoryInfo to return the // value in ru_majflt but this is actually incorrect because it returns // the soft page count not the hard page count. We previously used the // undocumented NtQuerySystemInformation call. static long GetPaging(long) { return 0; } #else inline long GetPaging(long rusagePage) { return rusagePage; } #endif HeapSizeParameters::HeapSizeParameters() { startPF = GetPaging(0); fullGCNextTime = false; performSharingPass = false; lastAllocationSucceeded = true; allocationFailedBeforeLastMajorGC = false; minHeapSize = 0; maxHeapSize = 0; // Unlimited lastFreeSpace = 0; pagingLimitSize = 0; highWaterMark = 0; sharingWordsRecovered = 0; cumulativeSharingSaving = 0; // Initial values until we've actually done a sharing pass. sharingRecoveryRate = 0.5; // The structure sharing recovers half the heap. sharingCostFactor = 2; // It doubles the cost } // These macros were originally in globals.h and used more generally. // Since only K_to_words is used now this can be greatly simplified. #define BITSPERWORD (sizeof(PolyWord)*8) #define ROUNDUP_UNITS(m,n) (((m) + (n) - 1) / (n)) #define ROUNDUP(m,n) (ROUNDUP_UNITS(m,n) * (n)) #define K_to_words(k) ROUNDUP((k) * (1024 / sizeof(PolyWord)),BITSPERWORD) // Returns physical memory size in bytes static size_t GetPhysicalMemorySize(void); // These are the maximum values for the number of words. #if (SIZEOF_VOIDP == 4) # define MAXIMUMADDRESS 0x3fffffff /* 4Gbytes as words */ #elif defined(POLYML32IN64) # define MAXIMUMADDRESS 0xffffffff /* 16Gbytes as words */ #else # define MAXIMUMADDRESS 0x1fffffffffffffff #endif // Set the initial size based on any parameters specified on the command line. // Any of these can be zero indicating they should default. void HeapSizeParameters::SetHeapParameters(uintptr_t minsize, uintptr_t maxsize, uintptr_t initialsize, unsigned percent) { minHeapSize = K_to_words(minsize); // If these overflow assume the result will be zero maxHeapSize = K_to_words(maxsize); uintptr_t initialSize = K_to_words(initialsize); uintptr_t memsize = GetPhysicalMemorySize() / sizeof(PolyWord); // If no maximum is given default it to 80% of the physical memory. // This allows some space for the OS and other things. // We now check maxsize so it should never exceed the maximum. if (maxHeapSize == 0 || maxHeapSize > MAXIMUMADDRESS) { if (memsize != 0) maxHeapSize = memsize - memsize / 5; else maxHeapSize = MAXIMUMADDRESS; // But if this must not be smaller than the minimum size. if (maxHeapSize < minHeapSize) maxHeapSize = minHeapSize; if (maxHeapSize < initialSize) maxHeapSize = initialSize; } // The default minimum is zero; in practice the live data size. // The default initial size is the minimum if that has been provided, // otherwise 8M words. There are applications that only require a small // heap and if we set the heap large to begin with we'll never do a // full GC and reduce it. if (initialSize == 0) { if (minHeapSize != 0) initialSize = minHeapSize; else initialSize = 8 * gMem.DefaultSpaceSize(); // But not more than the maximum if (initialSize > maxHeapSize) initialSize = maxHeapSize; } // Together with the constraints on user settings that ensures this holds. ASSERT(initialSize >= minHeapSize && initialSize <= maxHeapSize); // Initially we divide the space equally between the major and // minor heaps. That means that there will definitely be space // for the first minor GC to copy its data. This division can be // changed later on. gMem.SetSpaceForHeap(initialSize); gMem.SetSpaceBeforeMinorGC(initialSize/2); lastFreeSpace = initialSize; highWaterMark = initialSize; if (percent == 0) userGCRatio = 1.0 / 9.0; // Default to 10% GC to 90% application else userGCRatio = (float)percent / (float)(100 - percent); predictedRatio = lastMajorGCRatio = userGCRatio; if (debugOptions & DEBUG_HEAPSIZE) { Log("Heap: Initial settings: Initial heap "); LogSize(initialSize); Log(" minimum "); LogSize(minHeapSize); Log(" maximum "); LogSize(maxHeapSize); Log(" target ratio %f\n", userGCRatio); } } void HeapSizeParameters::SetReservation(uintptr_t rsize) { gMem.SetReservation(K_to_words(rsize)); } // Called in the minor GC if a GC thread needs to grow the heap. // Returns zero if the heap cannot be grown. "space" is the space required for the // object (and length field) in case this is larger than the default size. LocalMemSpace *HeapSizeParameters::AddSpaceInMinorGC(uintptr_t space, bool isMutable) { // See how much space is allocated to the major heap. uintptr_t spaceAllocated = gMem.CurrentHeapSize() - gMem.CurrentAllocSpace(); // The new segment is either the default size or as large as // necessary for the object. uintptr_t spaceSize = gMem.DefaultSpaceSize(); #ifdef POLYML32IN64 // When we allocate a space in NewLocalSpace we take one word to ensure // the that the first length word is on an odd-word boundary. // We need to add one here to ensure there is sufficient space to do that. // See AllocHeapSpace space++; #endif if (space > spaceSize) spaceSize = space; // We allow for extension if the total heap size after extending it // plus one allocation area of the default size would not be more // than the allowed heap size. if (spaceAllocated + spaceSize + gMem.DefaultSpaceSize() <= gMem.SpaceForHeap()) { LocalMemSpace *sp = gMem.NewLocalSpace(spaceSize, isMutable); // Return the space or zero if it failed // If this is the first time the allocation failed report it. if (sp == 0 && (debugOptions & DEBUG_HEAPSIZE) && lastAllocationSucceeded) { Log("Heap: Allocation of new heap segment size "); LogSize(spaceSize); Log(" failed. Limit reached?\n"); } lastAllocationSucceeded = sp != 0; return sp; } return 0; // Insufficient space } // Called in the major GC before the copy phase if the heap is more than // 90% full. This should improve the efficiency of copying. LocalMemSpace *HeapSizeParameters::AddSpaceBeforeCopyPhase(bool isMutable) { LocalMemSpace *sp = gMem.NewLocalSpace(gMem.DefaultSpaceSize(), isMutable); if (sp == 0 && (debugOptions & DEBUG_HEAPSIZE) && lastAllocationSucceeded) Log("Heap: Allocation of new heap segment failed. Limit reached?\n"); lastAllocationSucceeded = sp != 0; return sp; } // The steepness of the curve. #define PAGINGCOSTSTEEPNESS 20.0 // The additional cost at the boundary #define PAGINGCOSTFACTOR 3.0 // The number of pages at the boundary #define PAGINGCOUNTFACTOR 1000.0 // Called at the end of collection. This is where we should do the // fine adjustment of the heap size to minimise the GC time. // Growing the heap is just a matter of adjusting the limits. We // don't actually need to allocate the space here. // See also adjustHeapSizeAfterMinorGC for adjustments after a minor GC. void HeapSizeParameters::AdjustSizeAfterMajorGC(uintptr_t wordsRequired) { // Cumulative times since the last major GC TIMEDATA gc, nonGc; gc.add(majorGCSystemCPU); gc.add(majorGCUserCPU); nonGc.add(majorNonGCSystemCPU); nonGc.add(majorNonGCUserCPU); if (highWaterMark < heapSizeAtStart) highWaterMark = heapSizeAtStart; uintptr_t heapSpace = gMem.SpaceForHeap() < highWaterMark ? gMem.SpaceForHeap() : highWaterMark; currentSpaceUsed = wordsRequired; for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { currentSpaceUsed += (*i)->allocatedSpace(); } // N.B. Normally currentSpaceUsed will be less than the size of the heap // except if wordsRequired is very large. // The times for all the minor GCs up to this. The cost of this (major) GC // is actually in minorGCUserCPU/minorGCSystemCPU. TIMEDATA minorGC; minorGC.add(gc); minorGC.sub(minorGCUserCPU); minorGC.sub(minorGCSystemCPU); if (performSharingPass) { // We ran the sharing pass last time: calculate the actual recovery rate. uintptr_t originalSpaceUsed = currentSpaceUsed + sharingWordsRecovered; sharingRecoveryRate = (double)sharingWordsRecovered / (double)originalSpaceUsed; if (debugOptions & DEBUG_HEAPSIZE) Log("Heap: Sharing recovery rate was %0.3f and cost %0.3f seconds (%0.3f%% of total).\n", sharingRecoveryRate, sharingCPU.toSeconds(), sharingCPU.toSeconds() / gc.toSeconds()); // The cost factor is the ratio of the cost of sharing to the cost without. sharingCostFactor = sharingCPU.toSeconds() / (gc.toSeconds() - sharingCPU.toSeconds()); // Subtract the sharing cost from the GC cost because the initial estimate is // the cost without running the sharing pass. gc.sub(sharingCPU); } if (gc.toSeconds() != 0.0 && nonGc.toSeconds() != 0.0) lastMajorGCRatio = gc.toSeconds() / nonGc.toSeconds(); if (debugOptions & DEBUG_HEAPSIZE) { uintptr_t currentFreeSpace = currentSpaceUsed < heapSpace ? 0: heapSpace - currentSpaceUsed; Log("Heap: GC cpu time %2.3f non-gc time %2.3f ratio %0.3f for free space ", gc.toSeconds(), nonGc.toSeconds(), lastMajorGCRatio); LogSize((lastFreeSpace + currentFreeSpace)/2); Log("\n"); Log("Heap: GC real time %2.3f non-gc time %2.3f ratio %0.3f\n", majorGCReal.toSeconds(), majorNonGCReal.toSeconds(), majorGCReal.toSeconds()/majorNonGCReal.toSeconds()); Log("Heap: Total of minor GCs %2.3f, %2.3f of total\n", minorGC.toSeconds(), minorGC.toSeconds() / gc.toSeconds()); } // Calculate the paging threshold. - if (pagingLimitSize != 0 || majorGCPageFaults != 0) + if (pagingLimitSize != 0 && majorGCPageFaults == 0) + { + if (debugOptions & DEBUG_HEAPSIZE) + Log("No paging seen so resetting pageLimitSize\n"); + pagingLimitSize = 0; + } + else if (pagingLimitSize != 0 || majorGCPageFaults != 0) { if (majorGCPageFaults == 0) majorGCPageFaults = 1; // Less than one // Some paging detected. The expression here is the inverse of the one used to // compute the paging contribution in the cost function. double scaleFactor = 1.0 + log((double)majorGCPageFaults / PAGINGCOUNTFACTOR) / PAGINGCOSTSTEEPNESS; ASSERT(scaleFactor > 0.0); uintptr_t newLimit = (uintptr_t)((double)heapSpace / scaleFactor); if (pagingLimitSize == 0) pagingLimitSize = newLimit; else pagingLimitSize = (newLimit + pagingLimitSize) / 2; } if (allocationFailedBeforeLastMajorGC) { // If the last allocation failed then we may well have reached the // maximum available memory. Set the paging limit to be the current // heap size. We want to avoid hitting the limit because typically // that happens when we try to extend the major heap in a minor GC // resulting in the minor GC failing and a major GC starting. if (pagingLimitSize == 0 || heapSizeAtStart < pagingLimitSize) pagingLimitSize = heapSizeAtStart; } if (pagingLimitSize != 0 && (debugOptions & DEBUG_HEAPSIZE)) { Log("Heap: Paging threshold adjusted to "); LogSize(pagingLimitSize); Log(" with %ld page faults\n", majorGCPageFaults); } // Calculate the new heap size and the predicted cost. uintptr_t newHeapSize; double cost; bool atTarget = getCostAndSize(newHeapSize, cost, false); // If we have been unable to allocate any more memory we may already // be at the limit. if (allocationFailedBeforeLastMajorGC && newHeapSize > heapSizeAtStart) { cost = costFunction(heapSizeAtStart, false, true); atTarget = false; } if (atTarget) { // We are at the target level. We don't want to attempt sharing. performSharingPass = false; cumulativeSharingSaving = 0; } else { uintptr_t newHeapSizeWithSharing; double costWithSharing; // Get the cost and heap size if sharing was enabled. If we are at the // limit, though, we need to work using the size we can achieve. if (! allocationFailedBeforeLastMajorGC) (void)getCostAndSize(newHeapSizeWithSharing, costWithSharing, true); else { newHeapSizeWithSharing = heapSizeAtStart; costWithSharing = costFunction(heapSizeAtStart, true, true); } // Run the sharing pass if that would give a lower cost. // Subtract the cumulative saving that would have been made if the // sharing had been run before. This is an estimate and depends on the // extent to which a reduction in the heap earlier would be carried through // to later GCs. cumulativeSharingSaving = cumulativeSharingSaving * ((double)currentSpaceUsed / (double)heapSpace); if (debugOptions & DEBUG_HEAPSIZE) Log("Heap: Cumulative sharing saving %0.2f\n", cumulativeSharingSaving); if (costWithSharing - cumulativeSharingSaving < cost) { // Run the sharing pass next time. performSharingPass = true; cumulativeSharingSaving = 0; } else { // Don't run the sharing pass next time performSharingPass = false; // Running a sharing pass reduces the heap for subsequent // runs. Add this into the cost. double freeSharingCost = costFunction(newHeapSizeWithSharing, true, false); if (freeSharingCost < cost && freeSharingCost > userGCRatio) { if (debugOptions & DEBUG_HEAPSIZE) Log("Heap: Previous sharing would have saved %0.2f\n", cost - freeSharingCost); cumulativeSharingSaving += cost - freeSharingCost; } } } if (debugOptions & DEBUG_HEAPSIZE) { if (performSharingPass) Log("Heap: Next full GC will enable the sharing pass\n"); Log("Heap: Resizing from "); LogSize(gMem.SpaceForHeap()); Log(" to "); LogSize(newHeapSize); Log(". Estimated ratio %2.2f\n", cost); } // Set the sizes. gMem.SetSpaceForHeap(newHeapSize); // Set the minor space size. It can potentially use the whole of the // rest of the available heap but there could be a problem if that exceeds // the available memory and causes paging. We need to raise the limit carefully. // Also, if we use the whole of the heap we may not then be able to allocate // new areas in the major heap without going over the limit. Restrict it to // half of the available heap. uintptr_t nextLimit = highWaterMark + highWaterMark / 32; if (nextLimit > newHeapSize) nextLimit = newHeapSize; // gMem.CurrentHeapSize() is the live space size. if (gMem.CurrentHeapSize() > nextLimit) gMem.SetSpaceBeforeMinorGC(0); // Run out of space else gMem.SetSpaceBeforeMinorGC((nextLimit-gMem.CurrentHeapSize())/2); lastFreeSpace = newHeapSize - currentSpaceUsed; predictedRatio = cost; } // Called after a minor GC. Currently does nothing. // See also adjustHeapSize for adjustments after a major GC. bool HeapSizeParameters::AdjustSizeAfterMinorGC(uintptr_t spaceAfterGC, uintptr_t spaceBeforeGC) { uintptr_t spaceCopiedOut = spaceAfterGC-spaceBeforeGC; TIMEDATA gc, nonGC; minorGCsSinceMajor++; // Work out the ratio of GC to non-GC time since the last major GC. We can only adjust the heap size // at a major GC. If we're now spending too much time in minor GCs we may need a major GC to adjust // the size. gc.add(minorGCSystemCPU); gc.add(minorGCUserCPU); nonGC.add(minorNonGCSystemCPU); nonGC.add(minorNonGCUserCPU); float g = gc.toSeconds() / nonGC.toSeconds(); if (debugOptions & DEBUG_HEAPSIZE) { Log("Heap: Space before "); LogSize(spaceBeforeGC); Log(", space after "); LogSize(spaceAfterGC); Log("\n"); Log("Heap: Minor resizing factors g = %f, recent pf = %ld, cumulative pf = %ld\n", g, minorGCPageFaults, majorGCPageFaults); } if (highWaterMark < gMem.CurrentHeapSize()) highWaterMark = gMem.CurrentHeapSize(); uintptr_t nextLimit = highWaterMark + highWaterMark / 32; if (nextLimit > gMem.SpaceForHeap()) nextLimit = gMem.SpaceForHeap(); // Set the space available for the allocation area to be the difference between the // total heap size and the allowed heap size together with as much space as we copied // on this GC. That allows for the next minor GC to copy the same amount without // extending the heap. If the next minor GC adds more than this the heap will be // extended and a corresponding amount deducted so that the heap shrinks again. uintptr_t currHeap = gMem.CurrentHeapSize(); uintptr_t currAlloc = gMem.CurrentAllocSpace(); uintptr_t nonAlloc = currHeap - currAlloc + spaceCopiedOut; // TODO: If we have limited the space to the high water mark + 1/32 but that is less // than we really need we should increase it further. uintptr_t allowedAlloc = nonAlloc >= nextLimit ? 0 : nextLimit - nonAlloc; // Normally the allocation area will be empty but if we've failed to copy // everything out, especially a big object, it may not be. uintptr_t allocatedInAlloc = gMem.AllocatedInAlloc(); // If we hit the limit at the last major GC we have to be much more careful. // If the minor GC cannot allocate a major GC space when it needs it the minor // GC will fail immediately and a major GC will be started. It's better to // risk doing more minor GCs than we need by making the allocation area smaller // rather than run out of space. if (allocationFailedBeforeLastMajorGC) allowedAlloc = allowedAlloc / 2; if (gMem.CurrentAllocSpace() - allocatedInAlloc != allowedAlloc) { if (debugOptions & DEBUG_HEAPSIZE) { Log("Heap: Adjusting space for allocation area from "); LogSize(gMem.SpaceBeforeMinorGC()); Log(" to "); LogSize(allowedAlloc); Log("\n"); } gMem.SetSpaceBeforeMinorGC(allowedAlloc); if (allowedAlloc < gMem.DefaultSpaceSize() * 2 || minorGCPageFaults > 100) return false; // Trigger full GC immediately. } // Trigger a full GC if the live data is very large or if we have exceeeded // the target ratio over several GCs (this smooths out small variations). if ((minorGCsSinceMajor > 4 && g > predictedRatio*0.8) || majorGCPageFaults > 100) fullGCNextTime = true; return true; } // Estimate the GC cost for a given heap size. The result is the ratio of // GC time to application time. // This is really guesswork. double HeapSizeParameters::costFunction(uintptr_t heapSize, bool withSharing, bool withSharingCost) { uintptr_t heapSpace = gMem.SpaceForHeap() < highWaterMark ? gMem.SpaceForHeap() : highWaterMark; uintptr_t currentFreeSpace = heapSpace < currentSpaceUsed ? 0: heapSpace - currentSpaceUsed; uintptr_t averageFree = (lastFreeSpace + currentFreeSpace) / 2; uintptr_t spaceUsed = currentSpaceUsed; // N.B. currentSpaceUsed includes the new space we want if (heapSize <= currentSpaceUsed) return 1.0E6; // If we run the sharing pass the live space will be smaller. if (withSharing) spaceUsed -= (uintptr_t)((double)currentSpaceUsed * sharingRecoveryRate); uintptr_t estimatedFree = heapSize - spaceUsed; // The cost scales as the inverse of the amount of free space. double result = lastMajorGCRatio * (double)averageFree / (double)estimatedFree; // If we run the sharing pass the GC cost will increase. if (withSharing && withSharingCost) result += result*sharingCostFactor; // The paging contribution depends on the page limit double pagingCost = 0.0; if (pagingLimitSize != 0) { double factor = ((double)heapSize - (double)pagingLimitSize) / (double)pagingLimitSize * PAGINGCOSTSTEEPNESS; pagingCost = PAGINGCOSTFACTOR * exp(factor); result += pagingCost; } if (debugOptions & DEBUG_HEAPSIZE) { Log("Heap: Cost for heap of size "); LogSize(heapSize); Log(" is %2.2f with paging contributing %2.2f with%s sharing pass.\n", result, pagingCost, withSharing ? "" : "out"); } return result; } // Calculate the size for the minimum cost. Returns true if this is bounded by // the user GC ratio and false if we minimised the cost // TODO: This could definitely be improved although it's not likely to contribute much to // the overall cost of a GC. bool HeapSizeParameters::getCostAndSize(uintptr_t &heapSize, double &cost, bool withSharing) { bool isBounded = false; uintptr_t heapSpace = gMem.SpaceForHeap() < highWaterMark ? gMem.SpaceForHeap() : highWaterMark; // Calculate a new heap size. We allow a maximum doubling or halving of size. // It's probably more important to limit the increase in case we hit paging. uintptr_t sizeMax = heapSpace * 2; if (sizeMax > maxHeapSize) sizeMax = maxHeapSize; uintptr_t sizeMin = heapSpace / 2; if (sizeMin < minHeapSize) sizeMin = minHeapSize; // We mustn't reduce the heap size too far. If the application does a lot // of work with few allocations and particularly if it calls PolyML.fullGC // explicitly we could attempt to shrink the heap below the current live data size. // Add 3*space size here. We require 2* after a minor GC. Add 1 for rounding. uintptr_t minForAllocation = gMem.CurrentHeapSize() + gMem.DefaultSpaceSize() * 3; if (minForAllocation > maxHeapSize) minForAllocation = maxHeapSize; if (sizeMin < minForAllocation) sizeMin = minForAllocation; double costMin = costFunction(sizeMin, withSharing, true); if (costMin <= userGCRatio) // If the cost of the minimum is below or at the target we // use that and don't need to look further. isBounded = true; else { double costMax = costFunction(sizeMax, withSharing, true); while (sizeMax > sizeMin + gMem.DefaultSpaceSize()) { uintptr_t sizeNext = (sizeMin + sizeMax) / 2; double cost = costFunction(sizeNext, withSharing, true); if (cost < userGCRatio) isBounded = true; if (cost < userGCRatio || (costMax > costMin && costMax > userGCRatio)) { sizeMax = sizeNext; costMax = cost; } else { sizeMin = sizeNext; costMin = cost; } ASSERT(costMin >= userGCRatio); } } ASSERT(sizeMin >= minHeapSize && sizeMin <= maxHeapSize); // If we are bounded by the user GC ratio we actually return the size and cost // that is slightly above the user ratio. heapSize = sizeMin; cost = costMin; return isBounded; } bool HeapSizeParameters::RunMajorGCImmediately() { if (fullGCNextTime) { fullGCNextTime = false; return true; } return false; } static bool GetLastStats(TIMEDATA &userTime, TIMEDATA &systemTime, TIMEDATA &realTime, long &pageCount) { #if (defined(_WIN32)) FILETIME kt, ut; FILETIME ct, et; // Unused FILETIME rt; GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut); GetSystemTimeAsFileTime(&rt); userTime = ut; systemTime = kt; realTime = rt; pageCount = GetPaging(0); #else struct rusage rusage; if (getrusage(RUSAGE_SELF, &rusage) != 0) return false; userTime = rusage.ru_utime; systemTime = rusage.ru_stime; struct timeval tv; if (gettimeofday(&tv, NULL) != 0) return false; realTime = tv; pageCount = GetPaging(rusage.ru_majflt); #endif return true; } void HeapSizeParameters::RecordAtStartOfMajorGC() { heapSizeAtStart = gMem.CurrentHeapSize(); allocationFailedBeforeLastMajorGC = !lastAllocationSucceeded; } // This function is called at the beginning and end of garbage // collection to record the time used. // This also reports the GC time if GC debugging is enabled. void HeapSizeParameters::RecordGCTime(gcTime isEnd, const char *stage) { switch (isEnd) { case GCTimeStart: { // Start of GC TIMEDATA userTime, systemTime, realTime; long pageCount; if (! GetLastStats(userTime, systemTime, realTime, pageCount)) break; lastUsageU = userTime; lastUsageS = systemTime; lastRTime = realTime; userTime.sub(startUsageU); // Times since the start systemTime.sub(startUsageS); realTime.sub(startRTime); if (debugOptions & DEBUG_GC) Log("GC: Non-GC time: CPU user: %0.3f system: %0.3f real: %0.3f page faults: %ld\n", userTime.toSeconds(), systemTime.toSeconds(), realTime.toSeconds(), pageCount - startPF); minorNonGCUserCPU.add(userTime); majorNonGCUserCPU.add(userTime); minorNonGCSystemCPU.add(systemTime); majorNonGCSystemCPU.add(systemTime); minorNonGCReal.add(realTime); majorNonGCReal.add(realTime); startUsageU = lastUsageU; startUsageS = lastUsageS; startRTime = lastRTime; // Page faults in the application are included minorGCPageFaults += pageCount - startPF; majorGCPageFaults += pageCount - startPF; startPF = pageCount; break; } case GCTimeIntermediate: // Report intermediate GC time for debugging if (debugOptions & DEBUG_GC) { TIMEDATA userTime, systemTime, realTime; long pageCount; if (! GetLastStats(userTime, systemTime, realTime, pageCount)) break; TIMEDATA nextU = userTime, nextS = systemTime, nextR = realTime; userTime.sub(lastUsageU); systemTime.sub(lastUsageS); realTime.sub(lastRTime); Log("GC: (%s) CPU user: %0.3f system: %0.3f real: %0.3f speed up %0.1f\n", stage, userTime.toSeconds(), systemTime.toSeconds(), realTime.toSeconds(), realTime.toSeconds() == 0.0 ? 0.0 : (userTime.toSeconds() + systemTime.toSeconds()) / realTime.toSeconds()); lastUsageU = nextU; lastUsageS = nextS; lastRTime = nextR; } break; case GCTimeEnd: // End of GC. { TIMEDATA userTime, systemTime, realTime; long pageCount; if (! GetLastStats(userTime, systemTime, realTime, pageCount)) break; lastUsageU = userTime; lastUsageS = systemTime; lastRTime = realTime; userTime.sub(startUsageU); // Times since the start systemTime.sub(startUsageS); realTime.sub(startRTime); totalGCUserCPU.add(userTime); totalGCSystemCPU.add(systemTime); totalGCReal.add(realTime); if (debugOptions & DEBUG_GC) { Log("GC: CPU user: %0.3f system: %0.3f real: %0.3f speed up %0.1f page faults %ld\n", userTime.toSeconds(), systemTime.toSeconds(), realTime.toSeconds(), realTime.toSeconds() == 0.0 ? 0.0 : (userTime.toSeconds() + systemTime.toSeconds()) / realTime.toSeconds(), pageCount - startPF); } minorGCUserCPU.add(userTime); majorGCUserCPU.add(userTime); minorGCSystemCPU.add(systemTime); majorGCSystemCPU.add(systemTime); minorGCReal.add(realTime); majorGCReal.add(realTime); startUsageU = lastUsageU; startUsageS = lastUsageS; startRTime = lastRTime; minorGCPageFaults += pageCount - startPF; majorGCPageFaults += pageCount - startPF; startPF = pageCount; globalStats.copyGCTimes(totalGCUserCPU, totalGCSystemCPU, totalGCReal); } break; } } // Record the recovery rate and cost after running the GC sharing pass. // TODO: We should probably average these because if we've run a full // sharing pass and then a full GC after the recovery rate will be zero. void HeapSizeParameters::RecordSharingData(POLYUNSIGNED recovery) { sharingWordsRecovered = recovery; TIMEDATA userTime, systemTime, realTime; long pageCount; if (! GetLastStats(userTime, systemTime, realTime, pageCount)) return; userTime.sub(startUsageU); // Times since the start systemTime.sub(startUsageS); sharingCPU = userTime; sharingCPU.add(systemTime); } Handle HeapSizeParameters::getGCUtime(TaskData *taskData) const { #if (defined(_WIN32)) return Make_arb_from_Filetime(taskData, totalGCUserCPU); #else return Make_arb_from_pair_scaled(taskData, ((struct timeval)totalGCUserCPU).tv_sec, ((struct timeval)totalGCUserCPU).tv_usec, 1000000); #endif } Handle HeapSizeParameters::getGCStime(TaskData *taskData) const { #if (defined(_WIN32)) return Make_arb_from_Filetime(taskData, totalGCSystemCPU); #else return Make_arb_from_pair_scaled(taskData, ((struct timeval)totalGCSystemCPU).tv_sec, ((struct timeval)totalGCSystemCPU).tv_usec, 1000000); #endif } void HeapSizeParameters::Init() { #if (defined(_WIN32)) // Record an initial time of day to use as the basis of real timing FILETIME s; GetSystemTimeAsFileTime(&s); #else struct timeval s; gettimeofday(&s, NULL); #endif startTime = s; // Overall start time startRTime = startTime; // Start of this non-gc phase resetMajorTimingData(); #if (defined(_WIN32)) startPF = GetPaging(0); #else startPF = GetPaging(0); #endif } void HeapSizeParameters::Final() { // Print the overall statistics if (debugOptions & (DEBUG_GC|DEBUG_HEAPSIZE)) { TIMEDATA userTime, systemTime, realTime; #if (defined(_WIN32)) FILETIME kt, ut; FILETIME ct, et; // Unused FILETIME rt; GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut); GetSystemTimeAsFileTime(&rt); userTime.add(ut); systemTime.add(kt); realTime.add(rt); #else struct rusage rusage; struct timeval tv; if (getrusage(RUSAGE_SELF, &rusage) != 0 || gettimeofday(&tv, NULL) != 0) return; userTime.add(rusage.ru_utime); systemTime.add(rusage.ru_stime); realTime.add(tv); #endif realTime.sub(startTime); userTime.sub(totalGCUserCPU); systemTime.sub(totalGCSystemCPU); realTime.sub(totalGCReal); if (debugOptions & DEBUG_GC) { Log("GC (Total): Non-GC time: CPU user: %0.3f system: %0.3f real: %0.3f\n", userTime.toSeconds(), systemTime.toSeconds(), realTime.toSeconds()); Log("GC (Total): GC time: CPU user: %0.3f system: %0.3f real: %0.3f\n", totalGCUserCPU.toSeconds(), totalGCSystemCPU.toSeconds(), totalGCReal.toSeconds()); } if (debugOptions & DEBUG_HEAPSIZE) { TIMEDATA gc, nonGc; gc.add(totalGCUserCPU); gc.add(totalGCSystemCPU); nonGc.add(userTime); nonGc.add(systemTime); Log("Heap: Total CPU GC time %0.3fsecs, Non-GC %0.3fsecs, ratio %0.3f\n", gc.toSeconds(), nonGc.toSeconds(), gc.toSeconds() / nonGc.toSeconds()); } } } void HeapSizeParameters::resetMinorTimingData(void) { minorNonGCUserCPU.fromSeconds(0); minorNonGCSystemCPU.fromSeconds(0); minorNonGCReal.fromSeconds(0); minorGCUserCPU.fromSeconds(0); minorGCSystemCPU.fromSeconds(0); minorGCReal.fromSeconds(0); minorGCPageFaults = 0; } void HeapSizeParameters::resetMajorTimingData(void) { resetMinorTimingData(); majorNonGCUserCPU.fromSeconds(0); majorNonGCSystemCPU.fromSeconds(0); majorNonGCReal.fromSeconds(0); majorGCUserCPU.fromSeconds(0); majorGCSystemCPU.fromSeconds(0); majorGCReal.fromSeconds(0); majorGCPageFaults = 0; minorGCsSinceMajor = 0; } class HeapSizing: public RtsModule { public: virtual void Init(void); virtual void Stop(void); }; // Declare this. It will be automatically added to the table. static HeapSizing heapSizeModule; void HeapSizing::Init(void) { gHeapSizeParameters.Init(); } void HeapSizing::Stop() { gHeapSizeParameters.Final(); } static size_t GetPhysicalMemorySize(void) { size_t maxMem = (size_t)0-1; // Maximum unsigned value. #if defined(HAVE_WINDOWS_H) // Windows including Cygwin { MEMORYSTATUSEX memStatEx; memset(&memStatEx, 0, sizeof(memStatEx)); memStatEx.dwLength = sizeof(memStatEx); if (! GlobalMemoryStatusEx(&memStatEx)) memStatEx.ullTotalPhys = 0; // Clobber any rubbish since it says it failed. if (memStatEx.ullTotalPhys) // If it's non-zero assume it succeeded { DWORDLONG dwlMax = maxMem; if (memStatEx.ullTotalPhys > dwlMax) return maxMem; else return (size_t)memStatEx.ullTotalPhys; } } #endif #if defined(_SC_PHYS_PAGES) && defined(_SC_PAGESIZE) { // Linux and Solaris. This gives a silly value in Cygwin. long physPages = sysconf(_SC_PHYS_PAGES); long physPagesize = sysconf(_SC_PAGESIZE); if (physPages != -1 && physPagesize != -1) { unsigned long maxPages = maxMem / physPagesize; if ((unsigned long)physPages > maxPages) return maxMem; else // We've checked it won't overflow. return physPages*physPagesize; } } #endif #if defined(HAVE_SYSCTL) && defined(CTL_HW) // FreeBSD and Mac OS X. It seems HW_MEMSIZE has been added to // Max OS X to return a 64-bit value. #ifdef HW_MEMSIZE { static int mib[2] = { CTL_HW, HW_MEMSIZE }; uint64_t physMem = 0; size_t len = sizeof(physMem); if (sysctl(mib, 2, &physMem, &len, NULL, 0) == 0 && len == sizeof(physMem)) { if (physMem > (uint64_t)maxMem) return maxMem; else return (size_t)physMem; } } #endif #ifdef HW_PHYSMEM // If HW_MEMSIZE isn't there or the call failed try this. { static int mib[2] = { CTL_HW, HW_PHYSMEM }; unsigned int physMem = 0; size_t len = sizeof(physMem); if (sysctl(mib, 2, &physMem, &len, NULL, 0) == 0 && len == sizeof(physMem)) { if (physMem > maxMem) return maxMem; else return physMem; } } #endif #endif return 0; // Unable to determine } diff --git a/libpolyml/int_opcodes.h b/libpolyml/int_opcodes.h index b7cf3684..0f381a32 100644 --- a/libpolyml/int_opcodes.h +++ b/libpolyml/int_opcodes.h @@ -1,250 +1,264 @@ /* Title: Definitions for the code-tree instructions. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000 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 */ - -#define INSTR_enter_int 0x00 - -#define INSTR_jump8 0x02 -#define INSTR_jump8false 0x03 -#define INSTR_alloc_ref 0x06 -#define INSTR_case16 0x0a -#define INSTR_stack_container 0x0b -#define INSTR_call_closure 0x0c -#define INSTR_return_w 0x0d -#define INSTR_pad 0x0e -#define INSTR_raise_ex 0x10 -#define INSTR_get_store_w 0x11 -#define INSTR_local_w 0x13 -#define INSTR_indirect_w 0x14 -#define INSTR_move_to_vec_w 0x15 -#define INSTR_set_stack_val_w 0x17 -#define INSTR_reset_w 0x18 -#define INSTR_reset_r_w 0x19 -#define INSTR_constAddr16 0x1a -#define INSTR_const_int_w 0x1b -#define INSTR_callFastRRtoR 0x1c -#define INSTR_callFastRGtoR 0x1d -#define INSTR_jump_back8 0x1e -#define INSTR_return_b 0x1f -#define INSTR_jump_back16 0x20 -#define INSTR_get_store_b 0x21 -#define INSTR_local_b 0x22 +#define INSTR_jump8 0x02 +#define INSTR_jump8false 0x03 +#define INSTR_loadMLWord 0x04 +#define INSTR_storeMLWord 0x05 +#define INSTR_alloc_ref 0x06 +#define INSTR_blockMoveWord 0x07 +#define INSTR_loadUntagged 0x08 +#define INSTR_storeUntagged 0x09 +#define INSTR_case16 0x0a +#define INSTR_call_closure 0x0c +#define INSTR_return_w 0x0d +#define INSTR_stack_containerB 0x0e +#define INSTR_raise_ex 0x10 +#define INSTR_callConstAddr16 0x11 +#define INSTR_callConstAddr8 0x12 +#define INSTR_local_w 0x13 +#define INSTR_callLocalB 0x16 +#define INSTR_constAddr16 0x1a +#define INSTR_const_int_w 0x1b +#define INSTR_jump_back8 0x1e +#define INSTR_return_b 0x1f +#define INSTR_jump_back16 0x20 +#define INSTR_indirectLocalBB 0x21 +#define INSTR_local_b 0x22 #define INSTR_indirect_b 0x23 #define INSTR_move_to_vec_b 0x24 #define INSTR_set_stack_val_b 0x25 #define INSTR_reset_b 0x26 #define INSTR_reset_r_b 0x27 #define INSTR_const_int_b 0x28 #define INSTR_local_0 0x29 #define INSTR_local_1 0x2a #define INSTR_local_2 0x2b #define INSTR_local_3 0x2c #define INSTR_local_4 0x2d #define INSTR_local_5 0x2e #define INSTR_local_6 0x2f #define INSTR_local_7 0x30 #define INSTR_local_8 0x31 #define INSTR_local_9 0x32 #define INSTR_local_10 0x33 #define INSTR_local_11 0x34 #define INSTR_indirect_0 0x35 #define INSTR_indirect_1 0x36 #define INSTR_indirect_2 0x37 #define INSTR_indirect_3 0x38 #define INSTR_indirect_4 0x39 #define INSTR_indirect_5 0x3a #define INSTR_const_0 0x3b #define INSTR_const_1 0x3c #define INSTR_const_2 0x3d #define INSTR_const_3 0x3e #define INSTR_const_4 0x3f #define INSTR_const_10 0x40 -#define INSTR_return_0 0x41 +#define INSTR_return_0Legacy 0x41 #define INSTR_return_1 0x42 #define INSTR_return_2 0x43 #define INSTR_return_3 0x44 +#define INSTR_local_12 0x45 +#define INSTR_jump8True 0x46 +#define INSTR_jump16True 0x47 #define INSTR_reset_1 0x50 #define INSTR_reset_2 0x51 -#define INSTR_get_store_2 0x52 -#define INSTR_get_store_3 0x53 -#define INSTR_get_store_4 0x54 -#define INSTR_tuple_container 0x55 -#define INSTR_floatAbs 0x56 -#define INSTR_floatNeg 0x57 -#define INSTR_fixedIntToFloat 0x58 -#define INSTR_floatToReal 0x59 -#define INSTR_realToFloat 0x5a -#define INSTR_floatEqual 0x5b -#define INSTR_floatLess 0x5c -#define INSTR_floatLessEq 0x5d -#define INSTR_floatGreater 0x5e -#define INSTR_floatGreaterEq 0x5f -#define INSTR_floatAdd 0x60 -#define INSTR_floatSub 0x61 -#define INSTR_floatMult 0x62 -#define INSTR_floatDiv 0x63 +#define INSTR_tuple_containerLegacy 0x55 #define INSTR_reset_r_1 0x64 #define INSTR_reset_r_2 0x65 #define INSTR_reset_r_3 0x66 -#define INSTR_tuple_w 0x67 #define INSTR_tuple_b 0x68 #define INSTR_tuple_2 0x69 #define INSTR_tuple_3 0x6a #define INSTR_tuple_4 0x6b #define INSTR_lock 0x6c #define INSTR_ldexc 0x6d -#define INSTR_realToInt 0x6e -#define INSTR_floatToInt 0x6f -#define INSTR_callFastFtoF 0x70 -#define INSTR_callFastGtoF 0x71 -#define INSTR_callFastFFtoF 0x72 -#define INSTR_callFastFGtoF 0x73 #define INSTR_push_handler 0x78 -#define INSTR_realUnordered 0x79 -#define INSTR_floatUnordered 0x7a #define INSTR_tail_b_b 0x7b #define INSTR_tail 0x7c -#define INSTR_tail_3_b 0x7d -#define INSTR_tail_4_b 0x7e -#define INSTR_tail_3_2 0x7f -#define INSTR_tail_3_3 0x80 +#define INSTR_tail_3_bLegacy 0x7d +#define INSTR_tail_4_bLegacy 0x7e +#define INSTR_tail_3_2Legacy 0x7f +#define INSTR_tail_3_3Legacy 0x80 #define INSTR_setHandler8 0x81 #define INSTR_callFastRTS0 0x83 #define INSTR_callFastRTS1 0x84 #define INSTR_callFastRTS2 0x85 #define INSTR_callFastRTS3 0x86 #define INSTR_callFastRTS4 0x87 #define INSTR_callFastRTS5 0x88 #define INSTR_callFullRTS0 0x89 #define INSTR_callFullRTS1 0x8a #define INSTR_callFullRTS2 0x8b #define INSTR_callFullRTS3 0x8c #define INSTR_callFullRTS4 0x8d #define INSTR_callFullRTS5 0x8e -#define INSTR_callFastRtoR 0x8f -#define INSTR_callFastGtoR 0x90 #define INSTR_notBoolean 0x91 #define INSTR_isTagged 0x92 #define INSTR_cellLength 0x93 #define INSTR_cellFlags 0x94 #define INSTR_clearMutable 0x95 -#define INSTR_stringLength 0x96 #define INSTR_atomicIncr 0x97 #define INSTR_atomicDecr 0x98 -#define INSTR_atomicReset 0x99 -#define INSTR_longWToTagged 0x9a -#define INSTR_signedToLongW 0x9b -#define INSTR_unsignedToLongW 0x9c -#define INSTR_realAbs 0x9d -#define INSTR_realNeg 0x9e -#define INSTR_fixedIntToReal 0x9f #define INSTR_equalWord 0xa0 #define INSTR_lessSigned 0xa2 #define INSTR_lessUnsigned 0xa3 #define INSTR_lessEqSigned 0xa4 #define INSTR_lessEqUnsigned 0xa5 #define INSTR_greaterSigned 0xa6 #define INSTR_greaterUnsigned 0xa7 #define INSTR_greaterEqSigned 0xa8 #define INSTR_greaterEqUnsigned 0xa9 #define INSTR_fixedAdd 0xaa #define INSTR_fixedSub 0xab #define INSTR_fixedMult 0xac #define INSTR_fixedQuot 0xad #define INSTR_fixedRem 0xae -#define INSTR_fixedDiv 0xaf -#define INSTR_fixedMod 0xb0 #define INSTR_wordAdd 0xb1 #define INSTR_wordSub 0xb2 #define INSTR_wordMult 0xb3 #define INSTR_wordDiv 0xb4 #define INSTR_wordMod 0xb5 #define INSTR_wordAnd 0xb7 #define INSTR_wordOr 0xb8 #define INSTR_wordXor 0xb9 #define INSTR_wordShiftLeft 0xba #define INSTR_wordShiftRLog 0xbb -#define INSTR_wordShiftRArith 0xbc #define INSTR_allocByteMem 0xbd -#define INSTR_lgWordEqual 0xbe -#define INSTR_lgWordLess 0xc0 -#define INSTR_lgWordLessEq 0xc1 -#define INSTR_lgWordGreater 0xc2 -#define INSTR_lgWordGreaterEq 0xc3 -#define INSTR_lgWordAdd 0xc4 -#define INSTR_lgWordSub 0xc5 -#define INSTR_lgWordMult 0xc6 -#define INSTR_lgWordDiv 0xc7 -#define INSTR_lgWordMod 0xc8 -#define INSTR_lgWordAnd 0xc9 -#define INSTR_lgWordOr 0xca -#define INSTR_lgWordXor 0xcb -#define INSTR_lgWordShiftLeft 0xcc -#define INSTR_lgWordShiftRLog 0xcd -#define INSTR_lgWordShiftRArith 0xce -#define INSTR_realEqual 0xcf -#define INSTR_realLess 0xd1 -#define INSTR_realLessEq 0xd2 -#define INSTR_realGreater 0xd3 -#define INSTR_realGreaterEq 0xd4 -#define INSTR_realAdd 0xd5 -#define INSTR_realSub 0xd6 -#define INSTR_realMult 0xd7 -#define INSTR_realDiv 0xd8 +#define INSTR_indirectLocalB1 0xc1 +#define INSTR_isTaggedLocalB 0xc2 +#define INSTR_jumpNEqLocalInd 0xc3 +#define INSTR_jumpTaggedLocal 0xc4 +#define INSTR_jumpNEqLocal 0xc5 +#define INSTR_indirect0Local0 0xc6 +#define INSTR_indirectLocalB0 0xc7 #define INSTR_getThreadId 0xd9 #define INSTR_allocWordMemory 0xda -#define INSTR_loadMLWord 0xdb +#define INSTR_loadMLWordLegacy 0xdb #define INSTR_loadMLByte 0xdc -#define INSTR_loadC8 0xdd -#define INSTR_loadC16 0xde -#define INSTR_loadC32 0xdf -#define INSTR_loadC64 0xe0 -#define INSTR_loadCFloat 0xe1 -#define INSTR_loadCDouble 0xe2 -#define INSTR_storeMLWord 0xe3 +#define INSTR_storeMLWordLegacy 0xe3 #define INSTR_storeMLByte 0xe4 -#define INSTR_storeC8 0xe5 -#define INSTR_storeC16 0xe6 -#define INSTR_storeC32 0xe7 -#define INSTR_storeC64 0xe8 -#define INSTR_storeCFloat 0xe9 -#define INSTR_storeCDouble 0xea -#define INSTR_blockMoveWord 0xeb +#define INSTR_blockMoveWordLegacy 0xeb #define INSTR_blockMoveByte 0xec #define INSTR_blockEqualByte 0xed #define INSTR_blockCompareByte 0xee -#define INSTR_loadUntagged 0xef -#define INSTR_storeUntagged 0xf0 +#define INSTR_loadUntaggedLegacy 0xef +#define INSTR_storeUntaggedLegacy 0xf0 #define INSTR_deleteHandler 0xf1 -#define INSTR_jump32 0xf2 -#define INSTR_jump32False 0xf3 -#define INSTR_constAddr32 0xf4 -#define INSTR_setHandler32 0xf5 -#define INSTR_case32 0xf6 #define INSTR_jump16 0xf7 #define INSTR_jump16false 0xf8 #define INSTR_setHandler16 0xf9 #define INSTR_constAddr8 0xfa -#define INSTR_stackSize8 0xfb +#define INSTR_stackSize8Legacy 0xfb #define INSTR_stackSize16 0xfc +#define INSTR_escape 0xfe +#define INSTR_enterIntX86 0xff +// Extended opcodes - preceded by escape +#define EXTINSTR_stack_containerW 0x0b +#define EXTINSTR_indirect_w 0x14 +#define EXTINSTR_move_to_vec_w 0x15 +#define EXTINSTR_set_stack_val_w 0x17 +#define EXTINSTR_reset_w 0x18 +#define EXTINSTR_reset_r_w 0x19 +#define EXTINSTR_callFastRRtoR 0x1c +#define EXTINSTR_callFastRGtoR 0x1d +#define EXTINSTR_jump32True 0x48 +#define EXTINSTR_floatAbs 0x56 +#define EXTINSTR_floatNeg 0x57 +#define EXTINSTR_fixedIntToFloat 0x58 +#define EXTINSTR_floatToReal 0x59 +#define EXTINSTR_realToFloat 0x5a +#define EXTINSTR_floatEqual 0x5b +#define EXTINSTR_floatLess 0x5c +#define EXTINSTR_floatLessEq 0x5d +#define EXTINSTR_floatGreater 0x5e +#define EXTINSTR_floatGreaterEq 0x5f +#define EXTINSTR_floatAdd 0x60 +#define EXTINSTR_floatSub 0x61 +#define EXTINSTR_floatMult 0x62 +#define EXTINSTR_floatDiv 0x63 +#define EXTINSTR_realToInt 0x6e +#define EXTINSTR_tuple_w 0x67 +#define EXTINSTR_floatToInt 0x6f +#define EXTINSTR_callFastFtoF 0x70 +#define EXTINSTR_callFastGtoF 0x71 +#define EXTINSTR_callFastFFtoF 0x72 +#define EXTINSTR_callFastFGtoF 0x73 +#define EXTINSTR_realUnordered 0x79 +#define EXTINSTR_floatUnordered 0x7a +#define EXTINSTR_callFastRtoR 0x8f +#define EXTINSTR_callFastGtoR 0x90 +#define EXTINSTR_atomicReset 0x99 +#define EXTINSTR_longWToTagged 0x9a +#define EXTINSTR_signedToLongW 0x9b +#define EXTINSTR_unsignedToLongW 0x9c +#define EXTINSTR_realAbs 0x9d +#define EXTINSTR_realNeg 0x9e +#define EXTINSTR_fixedIntToReal 0x9f +#define EXTINSTR_fixedDiv 0xaf +#define EXTINSTR_fixedMod 0xb0 +#define EXTINSTR_wordShiftRArith 0xbc +#define EXTINSTR_lgWordEqual 0xbe +#define EXTINSTR_lgWordLess 0xc0 +#define EXTINSTR_lgWordLessEq 0xc1 +#define EXTINSTR_lgWordGreater 0xc2 +#define EXTINSTR_lgWordGreaterEq 0xc3 +#define EXTINSTR_lgWordAdd 0xc4 +#define EXTINSTR_lgWordSub 0xc5 +#define EXTINSTR_lgWordMult 0xc6 +#define EXTINSTR_lgWordDiv 0xc7 +#define EXTINSTR_lgWordMod 0xc8 +#define EXTINSTR_lgWordAnd 0xc9 +#define EXTINSTR_lgWordOr 0xca +#define EXTINSTR_lgWordXor 0xcb +#define EXTINSTR_lgWordShiftLeft 0xcc +#define EXTINSTR_lgWordShiftRLog 0xcd +#define EXTINSTR_lgWordShiftRArith 0xce +#define EXTINSTR_realEqual 0xcf +#define EXTINSTR_realLess 0xd1 +#define EXTINSTR_realLessEq 0xd2 +#define EXTINSTR_realGreater 0xd3 +#define EXTINSTR_realGreaterEq 0xd4 +#define EXTINSTR_realAdd 0xd5 +#define EXTINSTR_realSub 0xd6 +#define EXTINSTR_realMult 0xd7 +#define EXTINSTR_realDiv 0xd8 +#define EXTINSTR_loadC8 0xdd +#define EXTINSTR_loadC16 0xde +#define EXTINSTR_loadC32 0xdf +#define EXTINSTR_loadC64 0xe0 +#define EXTINSTR_loadCFloat 0xe1 +#define EXTINSTR_loadCDouble 0xe2 +#define EXTINSTR_storeC8 0xe5 +#define EXTINSTR_storeC16 0xe6 +#define EXTINSTR_storeC32 0xe7 +#define EXTINSTR_storeC64 0xe8 +#define EXTINSTR_storeCFloat 0xe9 +#define EXTINSTR_storeCDouble 0xea +#define EXTINSTR_jump32 0xf2 +#define EXTINSTR_jump32False 0xf3 +#define EXTINSTR_constAddr32 0xf4 +#define EXTINSTR_setHandler32 0xf5 +#define EXTINSTR_case32 0xf6 diff --git a/libpolyml/interpret.cpp b/libpolyml/interpret.cpp index f9c0fd51..b2ec8231 100644 --- a/libpolyml/interpret.cpp +++ b/libpolyml/interpret.cpp @@ -1,2334 +1,2506 @@ /* 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, 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) {} + IntTaskData(); + ~IntTaskData(); 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 addProfileCount(POLYUNSIGNED words) { addSynchronousCount(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; }; +IntTaskData::IntTaskData() : interrupt_requested(false), overflowPacket(0), dividePacket(0) +{ +} + +IntTaskData::~IntTaskData() +{ +} + // 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++) { + // These are temporary values used where one instruction jumps to + // common code. + POLYUNSIGNED tailCount; + PolyWord* tailPtr; + POLYUNSIGNED returnCount; + POLYUNSIGNED storeWords; + POLYUNSIGNED stackCheck; + PolyObject *closure; + double dv; - case INSTR_enter_int: pc++; /* Skip the argument. */ break; + switch(*pc++) { case INSTR_jump8false: - { - PolyWord u = *sp++; /* Pop argument */ - if (u == True) { pc += 1; break; } - /* else - false - take the jump */ - } + { + PolyWord u = *sp++; + if (u == True) pc += 1; + else pc += *pc + 1; + break; + } case INSTR_jump8: pc += *pc + 1; break; + case INSTR_jump8True: + { + PolyWord u = *sp++; + if (u == False) pc += 1; + else pc += *pc + 1; + break; + } + + case INSTR_jump16True: + // Invert the sense of the test and fall through. + *sp = ((*sp) == True) ? False : True; + 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 */ + if (u >= arg1 || u < 0) pc += 2 + arg1*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: + case INSTR_tail_3_bLegacy: tailCount = 3; tailPtr = sp + tailCount; sp = tailPtr + *pc; goto TAIL_CALL; - case INSTR_tail_3_2: + case INSTR_tail_3_2Legacy: tailCount = 3; tailPtr = sp + tailCount; sp = tailPtr + 2; goto TAIL_CALL; - case INSTR_tail_3_3: + case INSTR_tail_3_3Legacy: tailCount = 3; tailPtr = sp + tailCount; sp = tailPtr + 3; goto TAIL_CALL; - case INSTR_tail_4_b: + case INSTR_tail_4_bLegacy: 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. */ + closure = (*sp++).AsObjPtr(); + goto CALL_CLOSURE; /* 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. */ + closure = (*sp++).AsObjPtr(); + CALL_CLOSURE: + *(--sp) = PolyWord::FromCodePtr(pc); /* Save return address. */ + *(--sp) = closure; + pc = closure->Get(0).AsCodePtr(); /* Get entry point. */ this->taskPc = pc; // Update in case we're profiling - break; + // Check that there at least 128 words on the stack + stackCheck = 128; + goto STACKCHECK; + } + + case INSTR_callConstAddr8: + closure = (*(PolyWord*)(pc + pc[0] + 1)).AsObjPtr(); pc += 1; goto CALL_CLOSURE; + + case INSTR_callConstAddr16: + closure = (*(PolyWord*)(pc + arg1 + 2)).AsObjPtr(); pc += 2; goto CALL_CLOSURE; + + + case INSTR_callLocalB: + { + closure = (sp[*pc++]).AsObjPtr(); + goto CALL_CLOSURE; } 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_0Legacy: 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: + case INSTR_stackSize8Legacy: 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_indirectLocalBB: + { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(*pc++); break; } + + case INSTR_indirectLocalB0: + { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(0); break; } + + case INSTR_indirect0Local0: + { PolyWord u = sp[0]; *(--sp) = u.AsObjPtr()->Get(0); break; } + + case INSTR_indirectLocalB1: + { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(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_local_12: { PolyWord u = sp[12]; *(--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: + case INSTR_stack_containerB: { - POLYUNSIGNED words = arg1; pc += 2; + POLYUNSIGNED words = *pc++; while (words-- > 0) *(--sp) = Zero; sp--; *sp = PolyWord::FromStackAddr(sp + 1); break; } - case INSTR_tuple_container: /* Create a tuple from a container. */ + case INSTR_tuple_containerLegacy: /* 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_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: + case INSTR_equalWord: { - PolyObject *t = this->boxFloat(-(unboxFloat(*sp)), pc, sp); - if (t == 0) goto RAISE_EXCEPTION; - *sp = t; + PolyWord u = *sp++; + *sp = u == (*sp) ? True : False; break; } - case INSTR_fixedIntToReal: + case INSTR_jumpNEqLocal: { - POLYSIGNED u = UNTAGGED(*sp); - PolyObject *t = this->boxDouble((double)u, pc, sp); - if (t == 0) goto RAISE_EXCEPTION; - *sp = (PolyWord)t; + // Compare a local with a constant and jump if not equal. + PolyWord u = sp[pc[0]]; + if (u.IsTagged() && u.UnTagged() == pc[1]) + pc += 3; + else pc += pc[2] + 3; break; } - case INSTR_fixedIntToFloat: + case INSTR_jumpNEqLocalInd: { - POLYSIGNED u = UNTAGGED(*sp); - PolyObject *t = this->boxFloat((float)u, pc, sp); - if (t == 0) goto RAISE_EXCEPTION; - *sp = t; + // Test the union tag value in the first word of a tuple. + PolyWord u = sp[pc[0]]; + u = u.AsObjPtr()->Get(0); + if (u.IsTagged() && u.UnTagged() == pc[1]) + pc += 3; + else pc += pc[2] + 3; break; } - case INSTR_floatToReal: + case INSTR_isTaggedLocalB: { - float u = unboxFloat(*sp); - PolyObject *t = this->boxDouble((double)u, pc, sp); - if (t == 0) goto RAISE_EXCEPTION; - *sp = t; + PolyWord u = sp[*pc++]; + *(--sp) = u.IsTagged() ? True : False; break; } - case INSTR_equalWord: + case INSTR_jumpTaggedLocal: { - PolyWord u = *sp++; - *sp = u == (*sp) ? True : False; + PolyWord u = sp[*pc]; + // Jump if the value is tagged. + if (u.IsTagged()) + pc += pc[1] + 2; + else pc += 2; 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; + case INSTR_getThreadId: + *(--sp) = (PolyWord)this->threadObject; break; - } - case INSTR_lgWordLess: + case INSTR_allocWordMemory: { - uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); - uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); - *sp = (wy < wx) ? True : False; + // 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_lgWordLessEq: + case INSTR_alloc_ref: { - uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); - uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); - *sp = (wy <= wx) ? True : False; + // 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_lgWordGreater: + case INSTR_loadMLWordLegacy: { - uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); - uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); - *sp = (wy > wx) ? True : False; + // 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_lgWordGreaterEq: + case INSTR_loadMLWord: { - uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); - uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); - *sp = (wy >= wx) ? True : False; + POLYUNSIGNED index = UNTAGGED(*sp++); + PolyObject* p = (PolyObject*)((*sp).AsCodePtr()); + *sp = p->Get(index); break; } - case INSTR_lgWordAdd: + case INSTR_loadMLByte: { - 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; + // 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_lgWordSub: + case INSTR_loadUntaggedLegacy: { - 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; + // 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_lgWordMult: + case INSTR_loadUntagged: { - 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; + POLYUNSIGNED index = UNTAGGED(*sp++); + PolyObject* p = (PolyObject*)((*sp).AsCodePtr()); + *sp = TAGGED(p->Get(index).AsUnsigned()); 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: + case INSTR_storeMLWordLegacy: { - double u = unboxDouble(*sp++); - *sp = unboxDouble(*sp) <= u ? True: False; + 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_realGreater: + case INSTR_storeMLWord: { - double u = unboxDouble(*sp++); - *sp = unboxDouble(*sp) > u ? True: False; + PolyWord toStore = *sp++; + POLYUNSIGNED index = UNTAGGED(*sp++); + PolyObject* p = (PolyObject*)((*sp).AsCodePtr()); + p->Set(index, toStore); + *sp = Zero; break; } - case INSTR_realGreaterEq: + case INSTR_storeMLByte: { - double u = unboxDouble(*sp++); - *sp = unboxDouble(*sp) >= u ? True: False; - break; + POLYUNSIGNED toStore = UNTAGGED(*sp++); + POLYUNSIGNED index = UNTAGGED(*sp++); + POLYCODEPTR p = (*sp).AsCodePtr(); + p[index] = (byte)toStore; + *sp = Zero; + break; } - case INSTR_realUnordered: + case INSTR_storeUntaggedLegacy: { - double u = unboxDouble(*sp++); - double v = unboxDouble(*sp); - *sp = (std::isnan(u) || std::isnan(v)) ? True : False; + 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_realAdd: + case INSTR_storeUntagged: { - 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; + PolyWord toStore = PolyWord::FromUnsigned(UNTAGGED_UNSIGNED(*sp++)); + POLYUNSIGNED index = UNTAGGED(*sp++); + PolyObject* p = (PolyObject*)((*sp).AsCodePtr()); + p->Set(index, toStore); + *sp = Zero; break; } - case INSTR_realSub: + case INSTR_blockMoveWordLegacy: { - 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; + // 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_realMult: + case INSTR_blockMoveWord: { - 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; + POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); + POLYUNSIGNED destIndex = UNTAGGED_UNSIGNED(*sp++); + PolyObject* dest = (PolyObject*)((*sp++).AsCodePtr()); + POLYUNSIGNED srcIndex = UNTAGGED_UNSIGNED(*sp++); + PolyObject* src = (PolyObject*)((*sp).AsCodePtr()); + for (POLYUNSIGNED u = 0; u < length; u++) dest->Set(destIndex + u, src->Get(srcIndex + u)); + *sp = Zero; break; } - case INSTR_realDiv: + case INSTR_blockMoveByte: { - 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; + 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_floatEqual: + case INSTR_blockEqualByte: { - float u = unboxFloat(*sp++); - *sp = u == unboxFloat(*sp) ? True : False; + 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_floatLess: + case INSTR_blockCompareByte: { - float u = unboxFloat(*sp++); - *sp = unboxFloat(*sp) < u ? True : False; + 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; } - case INSTR_floatLessEq: - { - float u = unboxFloat(*sp++); - *sp = unboxFloat(*sp) <= u ? True : False; - break; - } + // Backwards compatibility. + // These are either used in the current compiler or compiled by it + // while building the basis library. + case EXTINSTR_stack_containerW: + case EXTINSTR_reset_r_w: + case EXTINSTR_tuple_w: + case EXTINSTR_unsignedToLongW: + case EXTINSTR_signedToLongW: + case EXTINSTR_longWToTagged: + case EXTINSTR_lgWordShiftLeft: + case EXTINSTR_fixedIntToReal: + case EXTINSTR_callFastRtoR: + case EXTINSTR_realMult: + case EXTINSTR_realDiv: + case EXTINSTR_realNeg: + case EXTINSTR_realAbs: + case EXTINSTR_realToFloat: + case EXTINSTR_floatDiv: + case EXTINSTR_floatNeg: + case EXTINSTR_floatAbs: + case EXTINSTR_callFastFtoF: + case EXTINSTR_floatMult: + case EXTINSTR_callFastGtoR: + case EXTINSTR_realUnordered: + case EXTINSTR_realEqual: + case EXTINSTR_lgWordEqual: + case EXTINSTR_lgWordOr: + case EXTINSTR_wordShiftRArith: + case EXTINSTR_lgWordLess: + // Back up and handle them as though they were escaped. + pc--; + + case INSTR_escape: + { + switch (*pc++) { + + case EXTINSTR_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_floatGreater: - { - float u = unboxFloat(*sp++); - *sp = unboxFloat(*sp) > u ? True : False; - break; - } + case EXTINSTR_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_floatGreaterEq: - { - float u = unboxFloat(*sp++); - *sp = unboxFloat(*sp) >= u ? True : False; - break; - } + case EXTINSTR_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_floatUnordered: - { - float u = unboxFloat(*sp++); - float v = unboxFloat(*sp); - *sp = (std::isnan(u) || std::isnan(v)) ? True : False; - break; - } + case EXTINSTR_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_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 EXTINSTR_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_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 EXTINSTR_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_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 EXTINSTR_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_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 EXTINSTR_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_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 EXTINSTR_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_realToInt: - dv = unboxDouble(*sp); - goto realtoint; + case EXTINSTR_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_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; + case EXTINSTR_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; } - POLYSIGNED p; - switch (rMode) + + case EXTINSTR_unsignedToLongW: { - case POLY_ROUND_TONEAREST: - p = (POLYSIGNED)round(dv); + // 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 POLY_ROUND_DOWNWARD: - p = (POLYSIGNED)floor(dv); + } + + case EXTINSTR_realAbs: + { + PolyObject* t = this->boxDouble(fabs(unboxDouble(*sp)), pc, sp); + if (t == 0) goto RAISE_EXCEPTION; + *sp = (PolyWord)t; break; - case POLY_ROUND_UPWARD: - p = (POLYSIGNED)ceil(dv); + } + + case EXTINSTR_realNeg: + { + PolyObject* t = this->boxDouble(-(unboxDouble(*sp)), pc, sp); + if (t == 0) goto RAISE_EXCEPTION; + *sp = (PolyWord)t; 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) + case EXTINSTR_floatAbs: { - *(--sp) = overflowPacket; - goto RAISE_EXCEPTION; + PolyObject* t = this->boxFloat(fabs(unboxFloat(*sp)), pc, sp); + if (t == 0) goto RAISE_EXCEPTION; + *sp = t; + break; } - *sp = TAGGED(p); - break; - } - case INSTR_getThreadId: - *(--sp) = (PolyWord)this->threadObject; - break; + case EXTINSTR_floatNeg: + { + PolyObject* t = this->boxFloat(-(unboxFloat(*sp)), pc, sp); + if (t == 0) goto RAISE_EXCEPTION; + *sp = t; + 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 EXTINSTR_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_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 EXTINSTR_fixedIntToFloat: + { + POLYSIGNED u = UNTAGGED(*sp); + PolyObject* t = this->boxFloat((float)u, pc, sp); + if (t == 0) goto RAISE_EXCEPTION; + *sp = 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 EXTINSTR_floatToReal: + { + float u = unboxFloat(*sp); + PolyObject* t = this->boxDouble((double)u, pc, sp); + if (t == 0) goto RAISE_EXCEPTION; + *sp = t; + 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 EXTINSTR_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_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 EXTINSTR_lgWordEqual: + { + uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); + uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); + *sp = wx == wy ? True : False; + 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]; + case EXTINSTR_lgWordLess: + { + uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); + uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); + *sp = (wy < wx) ? True : False; + break; + } + + case EXTINSTR_lgWordLessEq: + { + uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); + uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); + *sp = (wy <= wx) ? True : False; + break; + } + + case EXTINSTR_lgWordGreater: + { + uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); + uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); + *sp = (wy > wx) ? True : False; + break; + } + + case EXTINSTR_lgWordGreaterEq: + { + uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); + uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); + *sp = (wy >= wx) ? True : False; + break; + } + + case EXTINSTR_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_realEqual: + { + double u = unboxDouble(*sp++); + *sp = u == unboxDouble(*sp) ? True : False; + break; + } + + case EXTINSTR_realLess: + { + double u = unboxDouble(*sp++); + *sp = unboxDouble(*sp) < u ? True : False; + break; + } + + case EXTINSTR_realLessEq: + { + double u = unboxDouble(*sp++); + *sp = unboxDouble(*sp) <= u ? True : False; + break; + } + + case EXTINSTR_realGreater: + { + double u = unboxDouble(*sp++); + *sp = unboxDouble(*sp) > u ? True : False; + break; + } + + case EXTINSTR_realGreaterEq: + { + double u = unboxDouble(*sp++); + *sp = unboxDouble(*sp) >= u ? True : False; + break; + } + + case EXTINSTR_realUnordered: + { + double u = unboxDouble(*sp++); + double v = unboxDouble(*sp); + *sp = (std::isnan(u) || std::isnan(v)) ? True : False; + break; + } + + case EXTINSTR_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_floatEqual: + { + float u = unboxFloat(*sp++); + *sp = u == unboxFloat(*sp) ? True : False; + break; + } + + case EXTINSTR_floatLess: + { + float u = unboxFloat(*sp++); + *sp = unboxFloat(*sp) < u ? True : False; + break; + } + + case EXTINSTR_floatLessEq: + { + float u = unboxFloat(*sp++); + *sp = unboxFloat(*sp) <= u ? True : False; + break; + } + + case EXTINSTR_floatGreater: + { + float u = unboxFloat(*sp++); + *sp = unboxFloat(*sp) > u ? True : False; + break; + } + + case EXTINSTR_floatGreaterEq: + { + float u = unboxFloat(*sp++); + *sp = unboxFloat(*sp) >= u ? True : False; + break; + } + + case EXTINSTR_floatUnordered: + { + float u = unboxFloat(*sp++); + float v = unboxFloat(*sp); + *sp = (std::isnan(u) || std::isnan(v)) ? True : False; + break; + } + + case EXTINSTR_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_realToInt: + dv = unboxDouble(*sp); + goto realtoint; + + case EXTINSTR_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_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); + // 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; + // 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; - } + 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; - } + case EXTINSTR_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 EXTINSTR_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_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_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: - { + case EXTINSTR_storeC32: + { #ifdef IS64BITS - // This is a tagged value in 64-bit mode. - uint32_t toStore = (uint32_t)UNTAGGED(*sp++); + // 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())); + // 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; + 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; - } + case EXTINSTR_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_jump32True: + // Invert the sense of the test and fall through. + *sp = ((*sp) == True) ? False : True; - 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 EXTINSTR_jump32False: + { + PolyWord u = *sp++; /* Pop argument */ + if (u == True) { pc += 4; break; } + /* else - false - take the jump */ + } - 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 EXTINSTR_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_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_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 EXTINSTR_indirect_w: + *sp = (*sp).AsObjPtr()->Get(arg1); pc += 2; break; + + case EXTINSTR_move_to_vec_w: + { + PolyWord u = *sp++; + (*sp).AsObjPtr()->Set(arg1, u); + pc += 2; + break; + } + + case EXTINSTR_set_stack_val_w: + { + PolyWord u = *sp++; + sp[arg1 - 1] = u; + pc += 2; + break; + } + + case EXTINSTR_reset_w: sp += arg1; pc += 2; break; + + case EXTINSTR_reset_r_w: + { + PolyWord u = *sp; + sp += arg1; + *sp = u; + pc += 2; + break; + } + + case EXTINSTR_stack_containerW: + { + POLYUNSIGNED words = arg1; pc += 2; + while (words-- > 0) *(--sp) = Zero; + sp--; + *sp = PolyWord::FromStackAddr(sp + 1); + break; + } + + case EXTINSTR_constAddr32: + { + POLYUNSIGNED offset = pc[0] + (pc[1] << 8) + (pc[2] << 16) + (pc[3] << 24); + *(--sp) = *(PolyWord*)(pc + offset + 4); + pc += 4; + break; + } + + default: Crash("Unknown extended instruction %x\n", pc[-1]); + } - 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); + incrementCountAsynch(taskPc); return true; } } return false; } static Interpreter interpreterObject; MachineDependent *machineDependent = &interpreterObject; diff --git a/libpolyml/objsize.cpp b/libpolyml/objsize.cpp index a39dc18d..cf95f129 100644 --- a/libpolyml/objsize.cpp +++ b/libpolyml/objsize.cpp @@ -1,432 +1,432 @@ /* Title: Object size Copyright (c) 2000 Cambridge University Technical Services Limited Further development David C.J. Matthews 2016, 2017 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #include "globals.h" #include "arb.h" #include "run_time.h" #include "machine_dep.h" #include "objsize.h" #include "scanaddrs.h" #include "polystring.h" #include "save_vec.h" #include "bitmap.h" #include "memmgr.h" #include "mpoly.h" #include "processes.h" #include "rtsentry.h" extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolyObjSize(FirstArgument threadId, PolyWord obj); POLYEXTERNALSYMBOL POLYUNSIGNED PolyShowSize(FirstArgument threadId, PolyWord obj); POLYEXTERNALSYMBOL POLYUNSIGNED PolyObjProfile(FirstArgument threadId, PolyWord obj); } extern FILE *polyStdout; #define MAX_PROF_LEN 100 // Profile lengths between 1 and this class ProcessVisitAddresses: public ScanAddress { public: virtual POLYUNSIGNED ScanAddressAt(PolyWord *pt) { return ShowWord(*pt); } virtual POLYUNSIGNED ScanCodeAddressAt(PolyObject **pt) { return ShowObject(*pt); } virtual PolyObject *ScanObjectAddress(PolyObject *base); POLYUNSIGNED ShowWord(PolyWord w) { if (w.IsTagged() || w == PolyWord::FromUnsigned(0)) return 0; else return ShowObject(w.AsObjPtr()); } POLYUNSIGNED ShowObject(PolyObject *p); ProcessVisitAddresses(bool show); ~ProcessVisitAddresses(); - VisitBitmap *FindBitmap(PolyWord p); + VisitBitmap *FindBitmap(PolyObject *p); void ShowBytes(PolyObject *start); void ShowCode(PolyObject *start); void ShowWords(PolyObject *start); POLYUNSIGNED total_length; bool show_size; VisitBitmap **bitmaps; unsigned nBitmaps; // Counts of objects of each size for mutable and immutable data. unsigned iprofile[MAX_PROF_LEN+1]; unsigned mprofile[MAX_PROF_LEN+1]; }; ProcessVisitAddresses::ProcessVisitAddresses(bool show) { // Need to get the allocation lock here. Another thread // could allocate new local areas resulting in gMem.nlSpaces // and gMem.lSpaces changing under our feet. PLocker lock(&gMem.allocLock); total_length = 0; show_size = show; // Create a bitmap for each of the areas apart from the IO area nBitmaps = (unsigned)(gMem.lSpaces.size()+gMem.pSpaces.size()+gMem.cSpaces.size()); // bitmaps = new VisitBitmap*[nBitmaps]; unsigned bm = 0; for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { MemSpace *space = *i; // Permanent areas are filled with objects from the bottom. bitmaps[bm++] = new VisitBitmap(space->bottom, space->top); } for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *space = *i; bitmaps[bm++] = new VisitBitmap(space->bottom, space->top); } for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { CodeSpace *space = *i; bitmaps[bm++] = new VisitBitmap(space->bottom, space->top); } ASSERT(bm == nBitmaps); // Clear the profile counts. for (unsigned i = 0; i < MAX_PROF_LEN+1; i++) { iprofile[i] = mprofile[i] = 0; } } ProcessVisitAddresses::~ProcessVisitAddresses() { if (bitmaps) { for (unsigned i = 0; i < nBitmaps; i++) delete(bitmaps[i]); delete[](bitmaps); } } // Return the bitmap corresponding to the address or NULL if it isn't there. -VisitBitmap *ProcessVisitAddresses::FindBitmap(PolyWord p) +VisitBitmap *ProcessVisitAddresses::FindBitmap(PolyObject *p) { for (unsigned i = 0; i < nBitmaps; i++) { VisitBitmap *bm = bitmaps[i]; - if (bm->InRange(p.AsStackAddr())) return bm; + if (bm->InRange((PolyWord*)p)) return bm; } return 0; } void ProcessVisitAddresses::ShowBytes(PolyObject *start) { POLYUNSIGNED bytes = start->Length() * sizeof(PolyWord); char *array = (char *) start; putc('\n', polyStdout); if (start->IsMutable()) fprintf(polyStdout, "MUTABLE "); fprintf(polyStdout, "BYTES:%p:%" POLYUFMT "\n", array, bytes); POLYUNSIGNED i, n; for (i = 0, n = 0; n < bytes; n++) { fprintf(polyStdout, "%02x ",array[n] & 0xff); i++; if (i == 16) { putc('\n', polyStdout); i = 0; } } if (i != 0) putc('\n', polyStdout); } #define MAXNAME 500 void ProcessVisitAddresses::ShowCode(PolyObject *start) { POLYUNSIGNED length = start->Length(); putc('\n', polyStdout); if (start->IsMutable()) fprintf(polyStdout, "MUTABLE "); char buffer[MAXNAME+1]; PolyWord *consts = start->ConstPtrForCode(); PolyWord string = consts[0]; if (string == TAGGED(0)) strcpy(buffer, ""); else (void) Poly_string_to_C(string, buffer, sizeof(buffer)); fprintf(polyStdout, "CODE:%p:%" POLYUFMT " %s\n", start, length, buffer); POLYUNSIGNED i, n; for (i = 0, n = 0; n < length; n++) { if (i != 0) putc('\t', polyStdout); fprintf(polyStdout, "%8p ", start->Get(n).AsObjPtr()); i++; if (i == 4) { putc('\n', polyStdout); i = 0; } } if (i != 0) putc('\n', polyStdout); } void ProcessVisitAddresses::ShowWords(PolyObject *start) { POLYUNSIGNED length = start->Length(); putc('\n', polyStdout); if (start->IsMutable()) fprintf(polyStdout, "MUTABLE "); fprintf(polyStdout, "%s:%p:%" POLYUFMT "\n", start->IsClosureObject() ? "CLOSURE" : "WORDS", start, length); POLYUNSIGNED i, n; for (i = 0, n = 0; n < length; ) { if (i != 0) putc('\t', polyStdout); if (start->IsClosureObject() && n == 0) { fprintf(polyStdout, "%8p ", *(PolyObject**)start); n += sizeof(PolyObject*) / sizeof(PolyWord); } else { PolyWord p = start->Get(n); if (p.IsTagged()) fprintf(polyStdout, "%08" POLYUFMT " ", p.AsUnsigned()); else fprintf(polyStdout, "%8p ", p.AsObjPtr()); n++; } i++; if (i == 4) { putc('\n', polyStdout); i = 0; } } if (i != 0) putc('\n', polyStdout); } // This is called initially to print the top-level object. // Since we don't process stacks it probably doesn't get called elsewhere. PolyObject *ProcessVisitAddresses::ScanObjectAddress(PolyObject *base) { POLYUNSIGNED lengthWord = ShowWord(base); if (lengthWord) ScanAddressesInObject(base, lengthWord); return base; } // Handle the normal case. Print the object at this word and // return true is it must be handled recursively. POLYUNSIGNED ProcessVisitAddresses::ShowObject(PolyObject *p) { VisitBitmap *bm = FindBitmap(p); if (bm == 0) { fprintf(polyStdout, "Bad address " ZERO_X "%p found\n", p); return 0; } /* Have we already visited this object? */ if (bm->AlreadyVisited(p)) return 0; bm->SetVisited(p); POLYUNSIGNED obj_length = p->Length(); // Increment the appropriate size profile count. if (p->IsMutable()) { if (obj_length > MAX_PROF_LEN) mprofile[MAX_PROF_LEN]++; else mprofile[obj_length]++; } else { if (obj_length > MAX_PROF_LEN) iprofile[MAX_PROF_LEN]++; else iprofile[obj_length]++; } total_length += obj_length + 1; /* total space needed for object */ if (p->IsByteObject()) { if (show_size) ShowBytes(p); return 0; } else if (p->IsCodeObject()) { PolyWord *cp; POLYUNSIGNED const_count; p->GetConstSegmentForCode(cp, const_count); if (show_size) ShowCode(p); return p->LengthWord(); // Process addresses in it. } else // Word or closure object { if (show_size) ShowWords(p); return p->LengthWord(); // Process addresses in it. } } Handle ObjSize(TaskData *taskData, Handle obj) { ProcessVisitAddresses process(false); process.ScanObjectAddress(obj->WordP()); return Make_arbitrary_precision(taskData, process.total_length); } Handle ShowSize(TaskData *taskData, Handle obj) { ProcessVisitAddresses process(true); process.ScanObjectAddress(obj->WordP()); fflush(polyStdout); /* We need this for Windows at least. */ return Make_arbitrary_precision(taskData, process.total_length); } static void printfprof(unsigned *counts) { for(unsigned i = 0; i < MAX_PROF_LEN+1; i++) { if (counts[i] != 0) { if (i == MAX_PROF_LEN) fprintf(polyStdout, ">%d\t%u\n", MAX_PROF_LEN, counts[i]); else fprintf(polyStdout, "%d\t%u\n", i, counts[i]); } } } POLYUNSIGNED PolyObjSize(FirstArgument threadId, PolyWord obj) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); ProcessVisitAddresses process(false); if (!obj.IsTagged()) process.ScanObjectAddress(obj.AsObjPtr()); Handle result = Make_arbitrary_precision(taskData, process.total_length); taskData->PostRTSCall(); return result->Word().AsUnsigned(); } POLYUNSIGNED PolyShowSize(FirstArgument threadId, PolyWord obj) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); ProcessVisitAddresses process(true); if (!obj.IsTagged()) process.ScanObjectAddress(obj.AsObjPtr()); fflush(polyStdout); /* We need this for Windows at least. */ Handle result = Make_arbitrary_precision(taskData, process.total_length); taskData->PostRTSCall(); return result->Word().AsUnsigned(); } POLYUNSIGNED PolyObjProfile(FirstArgument threadId, PolyWord obj) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); ProcessVisitAddresses process(false); if (!obj.IsTagged()) process.ScanObjectAddress(obj.AsObjPtr()); fprintf(polyStdout, "\nImmutable object sizes and counts\n"); printfprof(process.iprofile); fprintf(polyStdout, "\nMutable object sizes and counts\n"); printfprof(process.mprofile); fflush(polyStdout); /* We need this for Windows at least. */ Handle result = Make_arbitrary_precision(taskData, process.total_length); taskData->PostRTSCall(); return result->Word().AsUnsigned(); } struct _entrypts objSizeEPT[] = { { "PolyObjSize", (polyRTSFunction)&PolyObjSize}, { "PolyShowSize", (polyRTSFunction)&PolyShowSize}, { "PolyObjProfile", (polyRTSFunction)&PolyObjProfile}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/pecoffexport.cpp b/libpolyml/pecoffexport.cpp index c59c41cb..28e23773 100644 --- a/libpolyml/pecoffexport.cpp +++ b/libpolyml/pecoffexport.cpp @@ -1,405 +1,408 @@ /* Title: Export memory as a PE/COFF object Author: David C. J. Matthews. Copyright (c) 2006, 2011, 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 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 #include #include #ifdef HAVE_STDDEF_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_ASSERT_H #include #endif #include #include "globals.h" #include "pecoffexport.h" #include "machine_dep.h" #include "scanaddrs.h" #include "run_time.h" #include "../polyexports.h" #include "version.h" #include "polystring.h" #include "timing.h" #ifdef _DEBUG /* MS C defines _DEBUG for debug builds. */ #define DEBUG #endif #ifdef DEBUG #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #if (SIZEOF_VOIDP == 8) #define DIRECT_WORD_RELOCATION IMAGE_REL_AMD64_ADDR64 #define RELATIVE_32BIT_RELOCATION IMAGE_REL_AMD64_REL32 #else #define DIRECT_WORD_RELOCATION IMAGE_REL_I386_DIR32 #define RELATIVE_32BIT_RELOCATION IMAGE_REL_I386_REL32 #endif +void PECOFFExport::writeRelocation(const IMAGE_RELOCATION* reloc) +{ + fwrite(reloc, sizeof(*reloc), 1, exportFile); + if (relocationCount == 0) + firstRelocation = *reloc; + relocationCount++; +} + void PECOFFExport::addExternalReference(void *relocAddr, const char *name, bool/* isFuncPtr*/) { externTable.makeEntry(name); IMAGE_RELOCATION reloc; // Set the offset within the section we're scanning. setRelocationAddress(relocAddr, &reloc.VirtualAddress); reloc.SymbolTableIndex = symbolNum++; reloc.Type = DIRECT_WORD_RELOCATION; - fwrite(&reloc, sizeof(reloc), 1, exportFile); - relocationCount++; + writeRelocation(&reloc); } // Generate the address relative to the start of the segment. void PECOFFExport::setRelocationAddress(void *p, DWORD *reloc) { unsigned area = findArea(p); DWORD offset = (DWORD)((char*)p - (char*)memTable[area].mtOriginalAddr); *reloc = offset; } // Create a relocation entry for an address at a given location. PolyWord PECOFFExport::createRelocation(PolyWord p, void *relocAddr) { IMAGE_RELOCATION reloc; // Set the offset within the section we're scanning. setRelocationAddress(relocAddr, &reloc.VirtualAddress); void *addr = p.AsAddress(); unsigned addrArea = findArea(addr); POLYUNSIGNED offset = (POLYUNSIGNED)((char*)addr - (char*)memTable[addrArea].mtOriginalAddr); reloc.SymbolTableIndex = addrArea; reloc.Type = DIRECT_WORD_RELOCATION; - fwrite(&reloc, sizeof(reloc), 1, exportFile); - relocationCount++; + writeRelocation(&reloc); return PolyWord::FromUnsigned(offset); } #ifdef SYMBOLS_REQUIRE_UNDERSCORE #define POLY_PREFIX_STRING "_" #else #define POLY_PREFIX_STRING "" #endif void PECOFFExport::writeSymbol(const char *symbolName, __int32 value, int section, bool isExtern, int symType) { // On X86/32 we have to add an underscore to external symbols TempCString fullSymbol; fullSymbol = (char*)malloc(strlen(POLY_PREFIX_STRING) + strlen(symbolName) + 1); if (fullSymbol == 0) throw MemoryException(); sprintf(fullSymbol, "%s%s", POLY_PREFIX_STRING, symbolName); IMAGE_SYMBOL symbol; memset(&symbol, 0, sizeof(symbol)); // Zero the unused part of the string // Short symbol names go in the entry, longer ones go in the string table. if (strlen(fullSymbol) <= 8) strcat((char*)symbol.N.ShortName, fullSymbol); else { symbol.N.Name.Short = 0; // We have to add 4 bytes because the first word written to the file is a length word. symbol.N.Name.Long = stringTable.makeEntry(fullSymbol) + sizeof(unsigned); } symbol.Value = value; symbol.SectionNumber = section; symbol.Type = symType; symbol.StorageClass = isExtern ? IMAGE_SYM_CLASS_EXTERNAL : IMAGE_SYM_CLASS_STATIC; fwrite(&symbol, sizeof(symbol), 1, exportFile); } /* 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 PECOFFExport::ScanConstant(PolyObject *base, byte *addr, ScanRelocationKind code) { #ifndef POLYML32IN64 IMAGE_RELOCATION reloc; 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; setRelocationAddress(addr, &reloc.VirtualAddress); // Set the value at the address to the offset relative to the symbol. uintptr_t offset = (char*)a - (char*)memTable[aArea].mtOriginalAddr; reloc.SymbolTableIndex = aArea; // The value we store here is the offset whichever relocation method // we're using. unsigned maxSize = code == PROCESS_RELOC_I386RELATIVE ? 4: sizeof(PolyWord); for (unsigned i = 0; i < maxSize; i++) { addr[i] = (byte)(offset & 0xff); offset >>= 8; } if (code == PROCESS_RELOC_I386RELATIVE) reloc.Type = RELATIVE_32BIT_RELOCATION; else reloc.Type = DIRECT_WORD_RELOCATION; - fwrite(&reloc, sizeof(reloc), 1, exportFile); - relocationCount++; + writeRelocation(&reloc); #endif } // Set the file alignment. void PECOFFExport::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 PECOFFExport::exportStore(void) { PolyWord *p; IMAGE_FILE_HEADER fhdr; IMAGE_SECTION_HEADER *sections = 0; IMAGE_RELOCATION reloc; unsigned i; // These are written out as the description of the data. exportDescription exports; time_t now = getBuildTime(); sections = new IMAGE_SECTION_HEADER [memTableEntries+1]; // Plus one for the tables. // Write out initial values for the headers. These are overwritten at the end. // File header memset(&fhdr, 0, sizeof(fhdr)); #if (SIZEOF_VOIDP == 8) fhdr.Machine = IMAGE_FILE_MACHINE_AMD64; // x86-64 #else fhdr.Machine = IMAGE_FILE_MACHINE_I386; // i386 #endif fhdr.NumberOfSections = memTableEntries+1; // One for each area plus one for the tables. fhdr.TimeDateStamp = (DWORD)now; //fhdr.NumberOfSymbols = memTableEntries+1; // One for each area plus "poly_exports" fwrite(&fhdr, sizeof(fhdr), 1, exportFile); // Write it for the moment. // External symbols are added after the memory table entries and "poly_exports". symbolNum = memTableEntries+1; // The first external symbol // Section headers. for (i = 0; i < memTableEntries; i++) { memset(§ions[i], 0, sizeof(IMAGE_SECTION_HEADER)); sections[i].SizeOfRawData = (DWORD)memTable[i].mtLength; sections[i].Characteristics = IMAGE_SCN_MEM_READ | IMAGE_SCN_ALIGN_8BYTES; if (memTable[i].mtFlags & MTF_WRITEABLE) { // Mutable data ASSERT(!(memTable[i].mtFlags & MTF_EXECUTABLE)); // Executable areas can't be writable. strcpy((char*)sections[i].Name, ".data"); sections[i].Characteristics |= IMAGE_SCN_MEM_WRITE | IMAGE_SCN_CNT_INITIALIZED_DATA; } else if (memTable[i].mtFlags & MTF_EXECUTABLE) { // Immutable data areas are marked as executable. strcpy((char*)sections[i].Name, ".text"); sections[i].Characteristics |= IMAGE_SCN_MEM_EXECUTE | IMAGE_SCN_CNT_CODE; } else { // Immutable data areas are marked as executable. strcpy((char*)sections[i].Name, ".rdata"); sections[i].Characteristics |= IMAGE_SCN_CNT_INITIALIZED_DATA; } } // Extra section for the tables. memset(§ions[memTableEntries], 0, sizeof(IMAGE_SECTION_HEADER)); sprintf((char*)sections[memTableEntries].Name, ".data"); sections[memTableEntries].SizeOfRawData = sizeof(exports) + (memTableEntries+1)*sizeof(memoryTableEntry); // Don't need write access here but keep it for consistency with other .data sections sections[memTableEntries].Characteristics = IMAGE_SCN_MEM_READ | IMAGE_SCN_ALIGN_8BYTES | IMAGE_SCN_MEM_WRITE | IMAGE_SCN_CNT_INITIALIZED_DATA; fwrite(sections, sizeof(IMAGE_SECTION_HEADER), memTableEntries+1, exportFile); // Write it for the moment. for (i = 0; i < memTableEntries; i++) { - // Relocations. The first entry is special and is only used if - // we have more than 64k relocations. It contains the number of relocations but is - // otherwise ignored. sections[i].PointerToRelocations = ftell(exportFile); - memset(&reloc, 0, sizeof(reloc)); - fwrite(&reloc, sizeof(reloc), 1, exportFile); - relocationCount = 1; + 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; } // If there are more than 64k relocations set this bit and set the value to 64k-1. if (relocationCount >= 65535) { + // We're going to overwrite the first relocation so we have to write the + // copy we saved here. + writeRelocation(&firstRelocation); // Increments relocationCount sections[i].NumberOfRelocations = 65535; sections[i].Characteristics |= IMAGE_SCN_LNK_NRELOC_OVFL; // We have to go back and patch up the first (dummy) relocation entry // which contains the count. fseek(exportFile, sections[i].PointerToRelocations, SEEK_SET); memset(&reloc, 0, sizeof(reloc)); - reloc.VirtualAddress = relocationCount; + reloc.RelocCount = relocationCount; fwrite(&reloc, sizeof(reloc), 1, exportFile); fseek(exportFile, 0, SEEK_END); // Return to the end of the file. } else sections[i].NumberOfRelocations = relocationCount; } // We don't need to handle relocation overflow here. sections[memTableEntries].PointerToRelocations = ftell(exportFile); relocationCount = 0; // Relocations for "exports" and "memTable"; // 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. reloc.Type = DIRECT_WORD_RELOCATION; reloc.SymbolTableIndex = memTableEntries; // Relative to poly_exports reloc.VirtualAddress = offsetof(exportDescription, memTable); fwrite(&reloc, sizeof(reloc), 1, exportFile); relocationCount++; // Address of "rootFunction" within "exports" reloc.Type = DIRECT_WORD_RELOCATION; unsigned rootAddrArea = findArea(rootFunction); reloc.SymbolTableIndex = rootAddrArea; reloc.VirtualAddress = offsetof(exportDescription, rootFunction); fwrite(&reloc, sizeof(reloc), 1, exportFile); relocationCount++; for (i = 0; i < memTableEntries; i++) { reloc.Type = DIRECT_WORD_RELOCATION; reloc.SymbolTableIndex = i; // Relative to base symbol reloc.VirtualAddress = sizeof(exportDescription) + i * sizeof(memoryTableEntry) + offsetof(memoryTableEntry, mtCurrentAddr); fwrite(&reloc, sizeof(reloc), 1, exportFile); relocationCount++; } ASSERT(relocationCount < 65535); // Shouldn't get overflow!! sections[memTableEntries].NumberOfRelocations = relocationCount; // Now the binary data. for (i = 0; i < memTableEntries; i++) { sections[i].PointerToRawData = ftell(exportFile); fwrite(memTable[i].mtOriginalAddr, 1, memTable[i].mtLength, exportFile); } sections[memTableEntries].PointerToRawData = ftell(exportFile); memset(&exports, 0, sizeof(exports)); exports.structLength = sizeof(exportDescription); exports.memTableSize = sizeof(memoryTableEntry); exports.memTableEntries = memTableEntries; exports.memTable = (memoryTableEntry *)sizeof(exports); // It follows immediately after this. exports.rootFunction = (void*)((char*)rootFunction - (char*)memTable[rootAddrArea].mtOriginalAddr); exports.timeStamp = now; 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; fwrite(&exports, sizeof(exports), 1, exportFile); fwrite(memTable, sizeof(memoryTableEntry), memTableEntries, exportFile); // First the symbol table. We have one entry for the exports and an additional // entry for each of the sections. fhdr.PointerToSymbolTable = ftell(exportFile); // The section numbers are one-based. Zero indicates the "common" area. // First write symbols for each section and for poly_exports. for (i = 0; i < memTableEntries; i++) { char buff[50]; sprintf(buff, "area%0d", i); writeSymbol(buff, 0, i+1, false); } // Exported symbol for table. writeSymbol("poly_exports", 0, memTableEntries+1, true); // External references. for (unsigned i = 0; i < externTable.stringSize; i += (unsigned)strlen(externTable.strings+i) + 1) writeSymbol(externTable.strings+i, 0, 0, true, 0x20); fhdr.NumberOfSymbols = symbolNum; // The string table is written immediately after the symbols. // The length is included as the first word. unsigned strSize = stringTable.stringSize + sizeof(unsigned); fwrite(&strSize, sizeof(strSize), 1, exportFile); fwrite(stringTable.strings, stringTable.stringSize, 1, exportFile); // Rewind to rewrite the headers. fseek(exportFile, 0, SEEK_SET); fwrite(&fhdr, sizeof(fhdr), 1, exportFile); fwrite(sections, sizeof(IMAGE_SECTION_HEADER), memTableEntries+1, exportFile); fclose(exportFile); exportFile = NULL; delete[](sections); } diff --git a/libpolyml/pecoffexport.h b/libpolyml/pecoffexport.h index dff6302b..adb15ddc 100644 --- a/libpolyml/pecoffexport.h +++ b/libpolyml/pecoffexport.h @@ -1,61 +1,66 @@ /* Title: Export memory as a PE/COFF object Author: David C. J. Matthews. Copyright (c) 2006, 2013, 2016 David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR 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 */ #ifndef PECOFFEXPORT_H_INCLUDED #define PECOFFEXPORT_H_INCLUDED #include "scanaddrs.h" // For base class #include "exporter.h" #include #include class PECOFFExport: public Exporter, public ScanAddress { public: PECOFFExport(): relocationCount(0), symbolNum(0) {} public: virtual void exportStore(void); 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; } void alignFile(int align); virtual void addExternalReference(void *addr, const char *name, bool isFuncPtr); private: void setRelocationAddress(void *p, DWORD *reloc); PolyWord createRelocation(PolyWord p, void *relocAddr); void writeSymbol(const char *symbolName, __int32 value, int section, bool isExtern, int symType=0); + void writeRelocation(const IMAGE_RELOCATION* reloc); unsigned relocationCount; ExportStringTable stringTable; // Table and count for external references. ExportStringTable externTable; unsigned symbolNum; + + // Copy of the first relocation in case we + // have to overwrite it. + IMAGE_RELOCATION firstRelocation; }; #endif diff --git a/libpolyml/pexport.cpp b/libpolyml/pexport.cpp index c86dda6c..7d2a731d 100644 --- a/libpolyml/pexport.cpp +++ b/libpolyml/pexport.cpp @@ -1,825 +1,873 @@ /* Title: Export and import memory in a portable format Author: David C. J. Matthews. - Copyright (c) 2006-7, 2015-8 David C. J. Matthews + Copyright (c) 2006-7, 2015-8, 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 */ #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 + putc('K', exportFile); // 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); + // Entry point - C null-terminated string. + putc('E', exportFile); + const char* name = (char*)p + sizeof(uintptr_t); + fprintf(exportFile, "%" PRI_SIZET "|%s", strlen(name), name); + *(uintptr_t*)p = 0; // Entry point } } 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++) + /* 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 { - fprintf(exportFile, "%02x", u[i]); + /* 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->writeAble(memSpace->bottom)[0] = PolyWord::FromUnsigned(0); used = 1; } PolyObject *newObj = (PolyObject*)(memSpace->bottom + used + 1); 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; + case 'K': // Single weak reference + nWords = sizeof(uintptr_t)/sizeof(PolyWord); + objBits |= F_BYTE_OBJ; + break; + + case 'E': // Entry point - address followed by string + objBits |= F_BYTE_OBJ; + // The length is the length of the string but it must be null-terminated + fscanf(f, "%" POLYUFMT, &nBytes); + // Add one uintptr_t plus one plus padding to an integral number of words. + nWords = (nBytes + sizeof(uintptr_t) + sizeof(PolyWord)) / sizeof(PolyWord); + break; + default: fprintf(polyStderr, "Invalid object type\n"); return false; } SpaceAlloc* alloc; if (objBits & F_MUTABLE_BIT) alloc = &mutSpace; else if ((objBits & 3) == F_CODE_OBJ) 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. */ 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) + // Legacy: If this is an entry point object set its value. 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'; 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. */ wr->Set(length-1, PolyWord::FromUnsigned(nWords)); if (oldForm) { 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(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; // 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 wr->SetLengthWord(p->Length(), F_CODE_OBJ); break; } + case 'K': + // Weak reference - must be zeroed + *(uintptr_t*)p = 0; + break; + + case 'E': + // Entry point - address followed by string + { + // The length is the number of characters. + *(uintptr_t*)p = 0; + char* b = (char*)p + sizeof(uintptr_t); + POLYUNSIGNED nBytes; + fscanf(f, "%" POLYUFMT, &nBytes); + ch = getc(f); ASSERT(ch == '|'); + for (POLYUNSIGNED i = 0; i < nBytes; i++) + { + ch = getc(f); + *b++ = ch; + } + *b = 0; + ch = getc(f); + ASSERT(ch == '\n'); + bool loadEntryPt = setEntryPoint(p); + ASSERT(loadEntryPt); + 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/process_env.cpp b/libpolyml/process_env.cpp index 5c309476..2c4f7c8e 100644 --- a/libpolyml/process_env.cpp +++ b/libpolyml/process_env.cpp @@ -1,721 +1,723 @@ /* Title: Process environment. - Copyright (c) 2000-8, 2016-17, 2019 + + Copyright (c) 2000-8, 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 */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_SYS_WAIT_H #include #endif #if (defined(__CYGWIN__) || defined(_WIN32)) #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif // Include this next before errors.h since in WinCE at least the winsock errors are defined there. #if (defined(_WIN32)) #include #include #define NOMEMORY ERROR_NOT_ENOUGH_MEMORY #undef ENOMEM #else typedef char TCHAR; #define _tgetenv getenv #define NOMEMORY ENOMEM #endif #include "globals.h" #include "sys.h" #include "run_time.h" #include "process_env.h" #include "arb.h" #include "mpoly.h" #include "gc.h" #include "scanaddrs.h" #include "polystring.h" #include "save_vec.h" #include "process_env.h" #include "rts_module.h" #include "machine_dep.h" #include "processes.h" #include "locking.h" #include "errors.h" #include "rtsentry.h" #include "version.h" extern "C" { POLYEXTERNALSYMBOL void PolyFinish(FirstArgument threadId, PolyWord arg); POLYEXTERNALSYMBOL void PolyTerminate(FirstArgument threadId, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorName(FirstArgument threadId, PolyWord syserr); POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorMessage(FirstArgument threadId, PolyWord syserr); POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorFromString(FirstArgument threadId, PolyWord string); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetMaxAllocationSize(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetMaxStringSize(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetPolyVersionNumber(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetFunctionName(FirstArgument threadId, PolyWord fnAddr); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyCommandLineName(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyCommandLineArgs(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetProcessName(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetCommandlineArguments(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetEnv(FirstArgument threadId, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetEnvironment(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvSuccessValue(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvFailureValue(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvSystem(FirstArgument threadId, PolyWord arg); } #define SAVE(x) taskData->saveVec.push(x) #define ALLOC(n) alloc_and_save(taskData, n) #if (defined(_WIN32)) #define ISPATHSEPARATOR(c) ((c) == '\\' || (c) == '/') #define DEFAULTSEPARATOR "\\" #else #define ISPATHSEPARATOR(c) ((c) == '/') #define DEFAULTSEPARATOR "/" #endif #ifdef _MSC_VER // Don't tell me about ISO C++ changes. #pragma warning(disable:4996) #endif // "environ" is declared in the headers on some systems but not all. // Oddly, declaring it within process_env_dispatch_c causes problems // on mingw where "environ" is actually a function. #if __APPLE__ // On Mac OS X there may be problems accessing environ directly. #include #define environ (*_NSGetEnviron()) #else extern char **environ; #endif /* Functions registered with atExit are added to this list. */ static PolyWord at_exit_list = TAGGED(0); /* Once "exit" is called this flag is set and no further calls to atExit are allowed. */ static bool exiting = false; static PLock atExitLock; // Thread lock for above. #ifdef __CYGWIN__ // Cygwin requires spawnvp to avoid the significant overhead of vfork // but it doesn't seem to be thread-safe. Run it on the main thread // to be sure. class CygwinSpawnRequest: public MainThreadRequest { public: CygwinSpawnRequest(char **argv): MainThreadRequest(MTP_CYGWINSPAWN), spawnArgv(argv) {} virtual void Perform(); char **spawnArgv; int pid; }; void CygwinSpawnRequest::Perform() { pid = spawnvp(_P_NOWAIT, "/bin/sh", spawnArgv); } #endif // These are now just legacy calls. static Handle process_env_dispatch_c(TaskData *taskData, Handle args, Handle code) { unsigned c = get_C_unsigned(taskData, DEREFWORD(code)); switch (c) { case 1: /* Return the argument list. */ return convert_string_list(taskData, userOptions.user_arg_count, userOptions.user_arg_strings); case 18: /* Register function to run at exit. */ { PLocker locker(&atExitLock); if (! exiting) { PolyObject *cell = alloc(taskData, 2); cell->Set(0, at_exit_list); cell->Set(1, args->Word()); at_exit_list = cell; } return Make_fixed_precision(taskData, 0); } case 19: /* Return the next function in the atExit list and set the "exiting" flag to true. */ { PLocker locker(&atExitLock); Handle res; exiting = true; /* Ignore further calls to atExit. */ if (at_exit_list == TAGGED(0)) raise_syscall(taskData, "List is empty", 0); PolyObject *cell = at_exit_list.AsObjPtr(); res = SAVE(cell->Get(1)); at_exit_list = cell->Get(0); return res; } default: { char msg[100]; sprintf(msg, "Unknown environment function: %d", c); raise_exception_string(taskData, EXC_Fail, msg); return 0; } } } // General interface to process-env. Ideally the various cases will be made into // separate functions. POLYUNSIGNED PolyProcessEnvGeneral(FirstArgument threadId, PolyWord code, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCode = taskData->saveVec.push(code); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = process_env_dispatch_c(taskData, pushedArg, pushedCode); } catch (KillException &) { processes->ThreadExit(taskData); // May test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Terminate normally with a result code. void PolyFinish(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); int i = get_C_int(taskData, arg); // Cause the other threads to exit and set the result code. processes->RequestProcessExit(i); // Exit this thread processes->ThreadExit(taskData); // Doesn't return. } // Terminate without running the atExit list or flushing buffers void PolyTerminate(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); int i = get_C_int(taskData, arg); _exit(i); // Doesn't return. } // Get the name of a numeric error message. POLYUNSIGNED PolyProcessEnvErrorName(FirstArgument threadId, PolyWord syserr) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { int e = (int)syserr.AsObjPtr()->Get(0).AsSigned(); // First look to see if we have the name in the error table. They should generally all be there. const char *errorMsg = stringFromErrorCode(e); if (errorMsg != NULL) result = taskData->saveVec.push(C_string_to_Poly(taskData, errorMsg)); else { // If it isn't in the table. char buff[40]; sprintf(buff, "ERROR%0d", e); result = taskData->saveVec.push(C_string_to_Poly(taskData, buff)); } } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } /* Get the explanatory message for an error. */ POLYUNSIGNED PolyProcessEnvErrorMessage(FirstArgument threadId, PolyWord syserr) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = errorMsg(taskData, (int)syserr.AsObjPtr()->Get(0).AsSigned()); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Try to convert an error string to an error number. POLYUNSIGNED PolyProcessEnvErrorFromString(FirstArgument threadId, PolyWord string) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { char buff[40]; // Get the string. Poly_string_to_C(string, buff, sizeof(buff)); // Look the string up in the table. int err = 0; if (errorCodeFromString(buff, &err)) result = Make_sysword(taskData, err); else if (strncmp(buff, "ERROR", 5) == 0) // If we don't find it then it may have been a constructed error name. result = Make_sysword(taskData, atoi(buff+5)); else result = Make_sysword(taskData, 0); // Return 0w0 if it isn't there. } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Return the maximum size of a cell that can be allocated on the heap. POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetMaxAllocationSize() { return TAGGED(MAX_OBJECT_SIZE).AsUnsigned(); } // Return the maximum string size (in bytes). // It is the maximum number of bytes in a segment less one word for the length field. POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetMaxStringSize() { return TAGGED((MAX_OBJECT_SIZE) * sizeof(PolyWord) - sizeof(PolyWord)).AsUnsigned(); } POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetPolyVersionNumber() { return TAGGED(POLY_version_number).AsUnsigned(); } // Return the function name associated with a piece of compiled code. POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetFunctionName(FirstArgument threadId, PolyWord fnAddr) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { if (fnAddr.IsTagged()) raise_fail(taskData, "Not a code pointer"); PolyObject *pt = fnAddr.AsObjPtr(); // In 32-in-64 this may be a closure and the first word is the absolute address of the code. if (pt->IsClosureObject()) { // It may not be set yet. pt = *(PolyObject**)pt; if (((uintptr_t)pt & 1) == 1) raise_fail(taskData, "Not a code pointer"); } if (pt->IsCodeObject()) /* Should now be a code object. */ { /* Compiled code. This is the first constant in the constant area. */ PolyWord *codePt = pt->ConstPtrForCode(); PolyWord name = codePt[0]; /* May be zero indicating an anonymous segment - return null string. */ if (name == PolyWord::FromUnsigned(0)) result = taskData->saveVec.push(C_string_to_Poly(taskData, "")); else result = taskData->saveVec.push(name); } else raise_fail(taskData, "Not a code pointer"); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -/* Return the program name. */ -POLYUNSIGNED PolyCommandLineName(FirstArgument threadId) + +// Get the command line process name. +POLYUNSIGNED PolyGetProcessName(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = taskData->saveVec.push(C_string_to_Poly(taskData, userOptions.programName)); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -/* Return the argument list. */ -POLYUNSIGNED PolyCommandLineArgs(FirstArgument threadId) +// Get the command line arguments. +POLYUNSIGNED PolyGetCommandlineArguments(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = convert_string_list(taskData, userOptions.user_arg_count, userOptions.user_arg_strings); } catch (KillException&) { processes->ThreadExit(taskData); // May test for kill } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } /* Return a string from the environment. */ POLYUNSIGNED PolyGetEnv(FirstArgument threadId, PolyWord arg) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { TempString buff(pushedArg->Word()); if (buff == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); TCHAR * res = _tgetenv(buff); if (res == NULL) raise_syscall(taskData, "Not Found", 0); result = taskData->saveVec.push(C_string_to_Poly(taskData, res)); } catch (KillException&) { processes->ThreadExit(taskData); // May test for kill } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Return the whole environment. Only available in Posix.ProcEnv. POLYUNSIGNED PolyGetEnvironment(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { /* Count the environment strings */ int env_count = 0; while (environ[env_count] != NULL) env_count++; result = convert_string_list(taskData, env_count, environ); } catch (KillException&) { processes->ThreadExit(taskData); // May test for kill } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } /* Return the success value. */ POLYUNSIGNED PolyProcessEnvSuccessValue(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = Make_fixed_precision(taskData, EXIT_SUCCESS); } catch (KillException&) { processes->ThreadExit(taskData); // May test for kill } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } /* Return a failure value. */ POLYUNSIGNED PolyProcessEnvFailureValue(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = Make_fixed_precision(taskData, EXIT_FAILURE); } catch (KillException&) { processes->ThreadExit(taskData); // May test for kill } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } /* Run command. */ POLYUNSIGNED PolyProcessEnvSystem(FirstArgument threadId, PolyWord arg) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { TempString buff(pushedArg->Word()); if (buff == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); int res = -1; #if (defined(_WIN32) && ! defined(__CYGWIN__)) // Windows. TCHAR * argv[4]; argv[0] = _tgetenv(_T("COMSPEC")); // Default CLI. if (argv[0] == 0) argv[0] = (TCHAR*)_T("cmd.exe"); // Win NT etc. argv[1] = (TCHAR*)_T("/c"); argv[2] = buff; argv[3] = NULL; // If _P_NOWAIT is given the result is the process handle. // spawnvp does any necessary path searching if argv[0] // does not contain a full path. intptr_t pid = _tspawnvp(_P_NOWAIT, argv[0], argv); if (pid == -1) raise_syscall(taskData, "Function system failed", errno); #else // Cygwin and Unix char* argv[4]; argv[0] = (char*)"sh"; argv[1] = (char*)"-c"; argv[2] = buff; argv[3] = NULL; #if (defined(__CYGWIN__)) CygwinSpawnRequest request(argv); processes->MakeRootRequest(taskData, &request); int pid = request.pid; if (pid < 0) raise_syscall(taskData, "Function system failed", errno); #else // We need to break this down so that we can unblock signals in the // child process. // The Unix "system" function seems to set SIGINT and SIGQUIT to // SIG_IGN in the parent so that the wait will not be interrupted. // That may make sense in a single-threaded application but is // that right here? int pid = vfork(); if (pid == -1) raise_syscall(taskData, "Function system failed", errno); else if (pid == 0) { // In child sigset_t sigset; sigemptyset(&sigset); sigprocmask(SIG_SETMASK, &sigset, 0); // Reset other signals? execv("/bin/sh", argv); _exit(1); } #endif #endif while (true) { try { // Test to see if the child has returned. #if (defined(_WIN32) && ! defined(__CYGWIN__)) DWORD dwWait = WaitForSingleObject((HANDLE)pid, 0); if (dwWait == WAIT_OBJECT_0) { DWORD dwResult; BOOL fResult = GetExitCodeProcess((HANDLE)pid, &dwResult); if (!fResult) raise_syscall(taskData, "Function system failed", GetLastError()); CloseHandle((HANDLE)pid); result = Make_fixed_precision(taskData, dwResult); break; } else if (dwWait == WAIT_FAILED) raise_syscall(taskData, "Function system failed", GetLastError()); else { // Wait for the process to exit or for the timeout WaitHandle waiter((HANDLE)pid, 1000); processes->ThreadPauseForIO(taskData, &waiter); } #else int wRes = waitpid(pid, &res, WNOHANG); if (wRes > 0) break; else if (wRes < 0) { raise_syscall(taskData, "Function system failed", errno); } // In Unix the best we can do is wait. This may be interrupted // by SIGCHLD depending on where signals are processed. // One possibility is for the main thread to somehow wake-up // the thread when it processes a SIGCHLD. else processes->ThreadPause(taskData); #endif } catch (...) { // Either IOException or KillException. // We're abandoning the wait. This will leave // a zombie in Unix. #if (defined(_WIN32) && ! defined(__CYGWIN__)) CloseHandle((HANDLE)pid); #endif throw; } } result = Make_fixed_precision(taskData, res); } catch (KillException&) { processes->ThreadExit(taskData); // May test for kill } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } struct _entrypts processEnvEPT[] = { { "PolyFinish", (polyRTSFunction)&PolyFinish}, { "PolyTerminate", (polyRTSFunction)&PolyTerminate}, { "PolyProcessEnvGeneral", (polyRTSFunction)&PolyProcessEnvGeneral}, { "PolyProcessEnvErrorName", (polyRTSFunction)&PolyProcessEnvErrorName}, { "PolyProcessEnvErrorMessage", (polyRTSFunction)&PolyProcessEnvErrorMessage}, { "PolyProcessEnvErrorFromString", (polyRTSFunction)&PolyProcessEnvErrorFromString}, { "PolyGetMaxAllocationSize", (polyRTSFunction)&PolyGetMaxAllocationSize }, { "PolyGetMaxStringSize", (polyRTSFunction)&PolyGetMaxStringSize }, { "PolyGetPolyVersionNumber", (polyRTSFunction)&PolyGetPolyVersionNumber }, { "PolyGetFunctionName", (polyRTSFunction)&PolyGetFunctionName }, - { "PolyCommandLineName", (polyRTSFunction)& PolyCommandLineName }, - { "PolyCommandLineArgs", (polyRTSFunction)& PolyCommandLineArgs }, + { "PolyGetProcessName", (polyRTSFunction)&PolyGetProcessName }, + { "PolyGetCommandlineArguments", (polyRTSFunction)&PolyGetCommandlineArguments }, { "PolyGetEnv", (polyRTSFunction)& PolyGetEnv }, { "PolyGetEnvironment", (polyRTSFunction)& PolyGetEnvironment }, { "PolyProcessEnvSuccessValue", (polyRTSFunction)& PolyProcessEnvSuccessValue }, { "PolyProcessEnvFailureValue", (polyRTSFunction)& PolyProcessEnvFailureValue }, { "PolyProcessEnvSystem", (polyRTSFunction)& PolyProcessEnvSystem }, { NULL, NULL} // End of list. }; class ProcessEnvModule: public RtsModule { public: void GarbageCollect(ScanAddress *process); }; // Declare this. It will be automatically added to the table. static ProcessEnvModule processModule; void ProcessEnvModule::GarbageCollect(ScanAddress *process) /* Ensures that all the objects are retained and their addresses updated. */ { if (at_exit_list.IsDataPtr()) { PolyObject *obj = at_exit_list.AsObjPtr(); process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_STRONG); at_exit_list = obj; } } diff --git a/libpolyml/processes.cpp b/libpolyml/processes.cpp index 8d866f69..07a87f21 100644 --- a/libpolyml/processes.cpp +++ b/libpolyml/processes.cpp @@ -1,2200 +1,2198 @@ /* 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); + + // Process the profile queue if necessary. + processProfileQueue(); } 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/profiling.cpp b/libpolyml/profiling.cpp index 92791daa..4030c486 100644 --- a/libpolyml/profiling.cpp +++ b/libpolyml/profiling.cpp @@ -1,564 +1,621 @@ /* Title: Profiling Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000-7 Cambridge University Technical Services Limited - Further development copyright (c) David C.J. Matthews 2011, 2015 + Further development copyright (c) David C.J. Matthews 2011, 2015, 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_STDLIB_H #include #endif #ifdef HAVE_MALLOC_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #include "globals.h" #include "arb.h" #include "processes.h" #include "polystring.h" #include "profiling.h" #include "save_vec.h" #include "rts_module.h" #include "memmgr.h" #include "scanaddrs.h" #include "locking.h" #include "run_time.h" #include "sys.h" #include "rtsentry.h" extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolyProfiling(FirstArgument threadId, PolyWord mode); } -static POLYUNSIGNED mainThreadCounts[MTP_MAXENTRY]; +static long mainThreadCounts[MTP_MAXENTRY]; static const char* const mainThreadText[MTP_MAXENTRY] = { "UNKNOWN", "GARBAGE COLLECTION (sharing phase)", "GARBAGE COLLECTION (mark phase)", "GARBAGE COLLECTION (copy phase)", "GARBAGE COLLECTION (update phase)", "GARBAGE COLLECTION (minor collection)", "Common data sharing", "Exporting", "Saving state", "Loading saved state", "Profiling", "Setting signal handler", "Cygwin spawn", "Storing module", "Loading module" }; // Entries for store profiling enum _extraStore { EST_CODE = 0, EST_STRING, EST_BYTE, EST_WORD, EST_MUTABLE, EST_MUTABLEBYTE, EST_MAX_ENTRY }; static POLYUNSIGNED extraStoreCounts[EST_MAX_ENTRY]; static const char * const extraStoreText[EST_MAX_ENTRY] = { "Function code", "Strings", "Byte data (long precision ints etc)", "Unidentified word data", "Unidentified mutable data", "Mutable byte data (profiling counts)" }; // Poly strings for "standard" counts. These are generated from the C strings // above the first time profiling is activated. static PolyWord psRTSString[MTP_MAXENTRY], psExtraStrings[EST_MAX_ENTRY], psGCTotal; ProfileMode profileMode; // If we are just profiling a single thread, this is the thread data. static TaskData *singleThreadProfile = 0; +// The queue is processed every 400ms and an entry can be +// added every ms of CPU time by each thread. +#define PCQUEUESIZE 4000 + +static long queuePtr = 0; +static POLYCODEPTR pcQueue[PCQUEUESIZE]; + +// Increment, returning the original value. +static int incrAtomically(long & p) +{ +#if (defined(HAVE_SYNC_FETCH)) + return __sync_fetch_and_add(&p, 1); +#elif (defined(_WIN32)) + long newValue = InterlockedIncrement(&p); + return newValue - 1; +#else + return p++; +#endif +} + +// Decrement and return new value. +static int decrAtomically(long & p) +{ +#if (defined(HAVE_SYNC_FETCH)) + return __sync_sub_and_fetch(&p, 1); +#elif (defined(_WIN32)) + return InterlockedDecrement(&p); +#else + return --p; +#endif +} + typedef struct _PROFENTRY { POLYUNSIGNED count; PolyWord functionName; struct _PROFENTRY *nextEntry; } PROFENTRY, *PPROFENTRY; class ProfileRequest: public MainThreadRequest { public: ProfileRequest(unsigned prof, TaskData *pTask): MainThreadRequest(MTP_PROFILING), mode(prof), pCallingThread(pTask), pTab(0), errorMessage(0) {} ~ProfileRequest(); virtual void Perform(); Handle extractAsList(TaskData *taskData); private: void getResults(void); void getProfileResults(PolyWord *bottom, PolyWord *top); PPROFENTRY newProfileEntry(void); private: unsigned mode; TaskData *pCallingThread; PPROFENTRY pTab; public: const char *errorMessage; }; ProfileRequest::~ProfileRequest() { PPROFENTRY p = pTab; while (p != 0) { PPROFENTRY toFree = p; p = p->nextEntry; free(toFree); } } // Lock to serialise updates of counts. Only used during update. // Not required when we print the counts since there's only one thread // running then. static PLock countLock; // Get the profile object associated with a piece of code. Returns null if // there isn't one, in particular if this is in the old format. static PolyObject *getProfileObjectForCode(PolyObject *code) { ASSERT(code->IsCodeObject()); PolyWord *consts; POLYUNSIGNED constCount; code->GetConstSegmentForCode(consts, constCount); if (constCount < 3 || ! consts[2].IsDataPtr()) return 0; PolyObject *profObject = consts[2].AsObjPtr(); if (profObject->IsMutable() && profObject->IsByteObject() && profObject->Length() == 1) return profObject; else return 0; } // Adds incr to the profile count for the function pointed at by // pc or by one of its callers. -// This is called from a signal handler in the case of time profiling. -void add_count(TaskData *taskData, POLYCODEPTR fpc, POLYUNSIGNED incr) +void addSynchronousCount(POLYCODEPTR fpc, POLYUNSIGNED incr) { // Check that the pc value is within the heap. It could be // in the assembly code. PolyObject *codeObj = gMem.FindCodeObject(fpc); if (codeObj) { PolyObject *profObject = getProfileObjectForCode(codeObj); PLocker locker(&countLock); if (profObject) profObject->Set(0, PolyWord::FromUnsigned(profObject->Get(0).AsUnsigned() + incr)); return; } // Didn't find it. { PLocker locker(&countLock); - mainThreadCounts[MTP_USER_CODE] += incr; + incrAtomically(mainThreadCounts[MTP_USER_CODE]); } } // newProfileEntry - Make a new entry in the list PPROFENTRY ProfileRequest::newProfileEntry(void) { PPROFENTRY newEntry = (PPROFENTRY)malloc(sizeof(PROFENTRY)); if (newEntry == 0) { errorMessage = "Insufficient memory"; return 0; } newEntry->nextEntry = pTab; pTab = newEntry; return newEntry; } // We don't use ScanAddress here because we're only interested in the // objects themselves not the addresses in them. // We have to build the list of results in C memory rather than directly in // ML memory because we can't allocate in ML memory in the root thread. void ProfileRequest::getProfileResults(PolyWord *bottom, PolyWord *top) { PolyWord *ptr = bottom; while (ptr < top) { ptr++; // Skip the length word PolyObject *obj = (PolyObject*)ptr; if (obj->ContainsForwardingPtr()) { // This used to be necessary when code objects were held in the // general heap. Now that we only ever scan code and permanent // areas it's probably not needed. while (obj->ContainsForwardingPtr()) obj = obj->GetForwardingPtr(); ASSERT(obj->ContainsNormalLengthWord()); ptr += obj->Length(); } else { ASSERT(obj->ContainsNormalLengthWord()); if (obj->IsCodeObject()) { PolyWord *firstConstant = obj->ConstPtrForCode(); PolyWord name = firstConstant[0]; PolyObject *profCount = getProfileObjectForCode(obj); if (profCount) { POLYUNSIGNED count = profCount->Get(0).AsUnsigned(); if (count != 0) { if (name != TAGGED(0)) { PPROFENTRY pEnt = newProfileEntry(); if (pEnt == 0) return; pEnt->count = count; pEnt->functionName = name; } profCount->Set(0, PolyWord::FromUnsigned(0)); } } } /* code object */ ptr += obj->Length(); } /* else */ } /* while */ } void ProfileRequest::getResults(void) // Print profiling information and reset profile counts. { for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { MemSpace *space = *i; // Permanent areas are filled with objects from the bottom. getProfileResults(space->bottom, space->top); // Bottom to top } for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { CodeSpace *space = *i; getProfileResults(space->bottom, space->top); } { POLYUNSIGNED gc_count = mainThreadCounts[MTP_GCPHASESHARING]+ mainThreadCounts[MTP_GCPHASEMARK]+ mainThreadCounts[MTP_GCPHASECOMPACT] + mainThreadCounts[MTP_GCPHASEUPDATE] + mainThreadCounts[MTP_GCQUICK]; if (gc_count) { PPROFENTRY pEnt = newProfileEntry(); if (pEnt == 0) return; // Report insufficient memory? pEnt->count = gc_count; pEnt->functionName = psGCTotal; } } for (unsigned k = 0; k < MTP_MAXENTRY; k++) { if (mainThreadCounts[k]) { PPROFENTRY pEnt = newProfileEntry(); if (pEnt == 0) return; // Report insufficient memory? pEnt->count = mainThreadCounts[k]; pEnt->functionName = psRTSString[k]; mainThreadCounts[k] = 0; } } for (unsigned l = 0; l < EST_MAX_ENTRY; l++) { if (extraStoreCounts[l]) { PPROFENTRY pEnt = newProfileEntry(); if (pEnt == 0) return; // Report insufficient memory? pEnt->count = extraStoreCounts[l]; pEnt->functionName = psExtraStrings[l]; extraStoreCounts[l] = 0; } } } // Extract the accumulated results as an ML list of pairs of the count and the string. Handle ProfileRequest::extractAsList(TaskData *taskData) { Handle saved = taskData->saveVec.mark(); Handle list = taskData->saveVec.push(ListNull); for (PPROFENTRY p = pTab; p != 0; p = p->nextEntry) { Handle pair = alloc_and_save(taskData, 2); Handle countValue = Make_arbitrary_precision(taskData, p->count); pair->WordP()->Set(0, countValue->Word()); pair->WordP()->Set(1, p->functionName); Handle next = alloc_and_save(taskData, sizeof(ML_Cons_Cell) / sizeof(PolyWord)); DEREFLISTHANDLE(next)->h = pair->Word(); DEREFLISTHANDLE(next)->t =list->Word(); taskData->saveVec.reset(saved); list = taskData->saveVec.push(next->Word()); } return list; } +// We have had an asynchronous interrupt and found a potential PC but +// we're in a signal handler. +void incrementCountAsynch(POLYCODEPTR pc) +{ + int q = incrAtomically(queuePtr); + if (q < PCQUEUESIZE) pcQueue[q] = pc; +} + +// Called by the main thread to process the queue of PC values +void processProfileQueue() +{ + if (queuePtr == 0) return; + while (1) + { + int q = queuePtr; + if (q >= PCQUEUESIZE) + incrAtomically(mainThreadCounts[MTP_USER_CODE]); + else addSynchronousCount(pcQueue[q], 1); + if (decrAtomically(queuePtr) == 0) break; + } +} + +// Handle a SIGVTALRM or the simulated equivalent in Windows. This may be called +// at any time so we have to be careful. In particular in Linux this may be +// executed by a thread while holding a mutex so we must not do anything, such +// calling malloc, that could require locking. void handleProfileTrap(TaskData *taskData, SIGNALCONTEXT *context) { if (singleThreadProfile != 0 && singleThreadProfile != taskData) return; /* If we are in the garbage-collector add the count to "gc_count" otherwise try to find out where we are. */ if (mainThreadPhase == MTP_USER_CODE) { if (taskData == 0 || ! taskData->AddTimeProfileCount(context)) - mainThreadCounts[MTP_USER_CODE]++; + incrAtomically(mainThreadCounts[MTP_USER_CODE]); // On Mac OS X all virtual timer interrupts seem to be directed to the root thread // so all the counts will be "unknown". } - else mainThreadCounts[mainThreadPhase]++; + else incrAtomically(mainThreadCounts[mainThreadPhase]); } // Called from the GC when allocation profiling is on. void AddObjectProfile(PolyObject *obj) { ASSERT(obj->ContainsNormalLengthWord()); POLYUNSIGNED length = obj->Length(); if (obj->IsWordObject() && OBJ_HAS_PROFILE(obj->LengthWord())) { // It has a profile pointer. The last word should point to the // closure or code of the allocating function. Add the size of this to the count. ASSERT(length != 0); PolyWord profWord = obj->Get(length-1); ASSERT(profWord.IsDataPtr()); PolyObject *profObject = profWord.AsObjPtr(); ASSERT(profObject->IsMutable() && profObject->IsByteObject() && profObject->Length() == 1); profObject->Set(0, PolyWord::FromUnsigned(profObject->Get(0).AsUnsigned() + length + 1)); } // If it doesn't have a profile pointer add it to the appropriate count. else if (obj->IsMutable()) { if (obj->IsByteObject()) extraStoreCounts[EST_MUTABLEBYTE] += length+1; else extraStoreCounts[EST_MUTABLE] += length+1; } else if (obj->IsCodeObject()) extraStoreCounts[EST_CODE] += length+1; else if (obj->IsClosureObject()) { ASSERT(0); } else if (obj->IsByteObject()) { // Try to separate strings from other byte data. This is only // approximate. if (OBJ_IS_NEGATIVE(obj->LengthWord())) extraStoreCounts[EST_BYTE] += length+1; else { PolyStringObject *possString = (PolyStringObject*)obj; POLYUNSIGNED bytes = length * sizeof(PolyWord); // If the length of the string as given in the first word is sufficient // to fit in the exact number of words then it's probably a string. if (length >= 2 && possString->length <= bytes - sizeof(POLYUNSIGNED) && possString->length > bytes - 2 * sizeof(POLYUNSIGNED)) extraStoreCounts[EST_STRING] += length+1; else { extraStoreCounts[EST_BYTE] += length+1; } } } else extraStoreCounts[EST_WORD] += length+1; } // Called from ML to control profiling. static Handle profilerc(TaskData *taskData, Handle mode_handle) /* Profiler - generates statistical profiles of the code. The parameter is an integer which determines the value to be profiled. When profiler is called it always resets the profiling and prints out any values which have been accumulated. If the parameter is 0 this is all it does, if the parameter is 1 then it produces time profiling, if the parameter is 2 it produces store profiling. 3 - arbitrary precision emulation traps. */ { unsigned mode = get_C_unsigned(taskData, mode_handle->Word()); { // Create any strings we need. We only need to do this once but // it must be done by a non-root thread since it needs a taskData object. // Don't bother locking. At worst we'll create some garbage. for (unsigned k = 0; k < MTP_MAXENTRY; k++) { if (psRTSString[k] == TAGGED(0)) psRTSString[k] = C_string_to_Poly(taskData, mainThreadText[k]); } for (unsigned k = 0; k < EST_MAX_ENTRY; k++) { if (psExtraStrings[k] == TAGGED(0)) psExtraStrings[k] = C_string_to_Poly(taskData, extraStoreText[k]); } if (psGCTotal == TAGGED(0)) psGCTotal = C_string_to_Poly(taskData, "GARBAGE COLLECTION (total)"); } // All these actions are performed by the root thread. Only profile // printing needs to be performed with all the threads stopped but it's // simpler to serialise all requests. ProfileRequest request(mode, taskData); processes->MakeRootRequest(taskData, &request); if (request.errorMessage != 0) raise_exception_string(taskData, EXC_Fail, request.errorMessage); return request.extractAsList(taskData); } POLYUNSIGNED PolyProfiling(FirstArgument threadId, PolyWord mode) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedMode = taskData->saveVec.push(mode); Handle result = 0; try { result = profilerc(taskData, pushedMode); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // This is called from the root thread when all the ML threads have been paused. void ProfileRequest::Perform() { if (mode != kProfileOff && profileMode != kProfileOff) { // Profiling must be stopped first. errorMessage = "Profiling is currently active"; return; } singleThreadProfile = 0; // Unless kProfileTimeThread is given this should be 0 switch (mode) { case kProfileOff: // Turn off old profiling mechanism and print out accumulated results profileMode = kProfileOff; processes->StopProfiling(); getResults(); // Remove all the bitmaps to free up memory gMem.RemoveProfilingBitmaps(); break; case kProfileTimeThread: singleThreadProfile = pCallingThread; // And drop through to kProfileTime case kProfileTime: profileMode = kProfileTime; processes->StartProfiling(); break; case kProfileStoreAllocation: profileMode = kProfileStoreAllocation; break; case kProfileEmulation: profileMode = kProfileEmulation; break; case kProfileLiveData: profileMode = kProfileLiveData; break; case kProfileLiveMutables: profileMode = kProfileLiveMutables; break; case kProfileMutexContention: profileMode = kProfileMutexContention; break; default: /* do nothing */ break; } } struct _entrypts profilingEPT[] = { // Profiling { "PolyProfiling", (polyRTSFunction)&PolyProfiling}, { NULL, NULL} // End of list. }; class Profiling: public RtsModule { public: virtual void Init(void); virtual void GarbageCollect(ScanAddress *process); }; // Declare this. It will be automatically added to the table. static Profiling profileModule; void Profiling::Init(void) { // Reset profiling counts. profileMode = kProfileOff; for (unsigned k = 0; k < MTP_MAXENTRY; k++) mainThreadCounts[k] = 0; } void Profiling::GarbageCollect(ScanAddress *process) { // Process any strings in the table. for (unsigned k = 0; k < MTP_MAXENTRY; k++) process->ScanRuntimeWord(&psRTSString[k]); for (unsigned k = 0; k < EST_MAX_ENTRY; k++) process->ScanRuntimeWord(&psExtraStrings[k]); process->ScanRuntimeWord(&psGCTotal); } diff --git a/libpolyml/profiling.h b/libpolyml/profiling.h index 1ef90c7a..412765fb 100644 --- a/libpolyml/profiling.h +++ b/libpolyml/profiling.h @@ -1,52 +1,60 @@ /* Title: profiling.h Copyright (c) 2000 Cambridge University Technical Services Limited Further development copyright (c) David C.J. Matthews 2011, 2-15 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 _PROFILING_H_DEFINED #define _PROFILING_H_DEFINED 1 class SaveVecEntry; typedef SaveVecEntry *Handle; class TaskData; // Current profiling mode typedef enum { kProfileOff = 0, kProfileTime, kProfileStoreAllocation, kProfileEmulation, // No longer used kProfileLiveData, kProfileLiveMutables, kProfileTimeThread, kProfileMutexContention } ProfileMode; extern ProfileMode profileMode; #include "processes.h" // For SIGNALCONTEXT +// Handle a SIGVTALRM or the simulated equivalent in Windows. extern void handleProfileTrap(TaskData *taskData, SIGNALCONTEXT *context); -extern void add_count(TaskData *taskData, POLYCODEPTR pc,POLYUNSIGNED incr); +// Add count. Must not be called from a signal handler. +extern void addSynchronousCount(POLYCODEPTR pc, POLYUNSIGNED incr); +// Add one to the timing counter. May occur at any time. +extern void incrementCountAsynch(POLYCODEPTR pc); +// Process the queue of profile pc values if we're time profiling. +// Only called by the main thread. +extern void processProfileQueue(); + extern void AddObjectProfile(PolyObject *obj); extern struct _entrypts profilingEPT[]; #endif /* _PROFILING_H_DEFINED */ diff --git a/libpolyml/x86_dep.cpp b/libpolyml/x86_dep.cpp index e0d592f7..780281ae 100644 --- a/libpolyml/x86_dep.cpp +++ b/libpolyml/x86_dep.cpp @@ -1,1467 +1,1468 @@ /* 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); } + { addSynchronousCount(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); 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; 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. +// N.B. This must not call malloc since we're in a signal handler. 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 = (stackItem*)context->uc_mcontext->ss.esp; #elif(defined(HAVE_STRUCT___DARWIN_MCONTEXT32___SS)) pc = (byte*)context->uc_mcontext->__ss.__eip; 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 = (stackItem*)context->uc_mcontext->ss.rsp; #elif(defined(HAVE_STRUCT___DARWIN_MCONTEXT64___SS)) pc = (byte*)context->uc_mcontext->__ss.__rip; 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 = (stackItem*)context->sc_rsp; #else // !HOSTARCHITEXTURE_X86_64 || !defined(__OpenBSD__) pc = (byte*)context->sc_pc; 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); + incrementCountAsynch(pc); 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); + incrementCountAsynch(pc); 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); + incrementCountAsynch(pc); 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++) { 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 } diff --git a/libpolyml/xwindows.cpp b/libpolyml/xwindows.cpp index 6e04773a..692caf96 100644 --- a/libpolyml/xwindows.cpp +++ b/libpolyml/xwindows.cpp @@ -1,9636 +1,9608 @@ /* Title: X-Windows/Motif Interface. Copyright (c) 2000 Cambridge University Technical Services Limited This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #if (defined(WITH_XWINDOWS)) // X-Windows is required. /* xwindows.c */ /* Removed indirection from get_C_* functions SPF 31/10/93 */ /* Added Handle type 2/11/93 */ /* Fixed "GetString can only be used once" bug 17/11/93 */ /* Dealing with gcc warning messages SPF 6/1/94 */ /* Retrofit to old Sun cc SPF 7/1/94 */ /* 25/1/94 SPF Fixed bug in EmptyVisual (core-dump when v==NULL) */ /* Comment added 4/11/93 SPF Global Invariants: (1) Get functions promise not to allocate on the Poly/ML heap (2) The Poly/ML heap contains pointers into the C heap! As these are only valid for one session, the run-time system records which Poly/ML objects have been created in the current session. Only these objects contain valid C pointers, and so may be dereferenced. The "bad" Poly/ML objects are: Flags Object Bad Field Access Function ----- ------ --------- --------------- M X_GC_Object GC *gc GetGC X_Font_Object Font *font GetFont ditto XFontStruct **fs GetFS X_Cursor_Object Cursor *cursor GetCursor BM X_Window_Object Drawable *drawable GetDrawable, GetPixmap X_Pixmap_Object Pixmap *pixmap GetDrawable, GetPixmap X_Colormap_Object Colormap *cmap GetColormap X_Visual_Object Visual **visual GetVisual (* FISHY *) B X_Display_Object Display *display (?) GetDisplay (?) ditto XtAppContext app_context NONE(?) M X_Widget_Object Widget *widget GetWidget, GetNWidget B X_Trans_Object XtTranslations table GetTrans B X_Acc_Object XtAccelerators acc GetAcc WARNING: the above list of unsafe fields was created by SPF and may be incomplete. The function CheckExists should be called on these objects before it is safe to use any of the above fields. That's because the object may have been created in a previous ML session, so the pointers that it contains may no longer be valid. Using the appropriate access function listed above guarantees that CheckExists is called. Exception: the fields can safely be tested against C's zero (None, Null) even if CheckExists hasn't been called. Note that this is only database-safe because this value is used for uninitialised fields, so it doesn't confuse the garbage-collector. For all the above fields EXCEPT display, app_context, table, acc the run-time system creates an indirection object in the Poly heap. These fields don't need an indirection object because the object which contains them is itself a BYTE object. This indirection is a byte-object. The indirection is necessary because the garbage collector would object to finding a C pointer in a standard ML labelled record. The alternative would be to store the C pointer as an ML integer, but then we would have to convert back to a C pointer befor we could dereference it. For similar reasons, eventMask is also stored as a boxed PolyWord. abstype Colormap = Colormap with end; (* X_Colormap_Object *) abstype Cursor = Cursor with end; (* X_Cursor_Object *) abstype Drawable = Drawable with end; (* X_Window_Object, XPixmap_Object *) abstype Font = Font with end; (* X_Font_Object *) abstype GC = GC with end; (* X_GC_Object *) abstype Visual = Visual with end; (* X_Visual_Object *) abstype Display = Display with end; (* X_Display_Object *) abstype Widget = Widget of int with end; abstype XtAccelerators = XtAccelerators of int with end; abstype XtTranslations = XtTranslations of int with end; */ /* MLXPoint, MLXRectangle, MLXArc, MLPair, MLTriple added 31/10/93 SPF */ #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_SIGNAL_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_CTYPE_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_ASSERT_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_ALLOCA_H #include #endif #ifdef HAVE_ERRNO_H #include #endif /* what goes wrong? ... gid, fd, private15 inaccessible */ /* THIS NEEDS TO BE FIXED!!!! */ #define XLIB_ILLEGAL_ACCESS 1 /* We need access to some opaque structures */ /* use prototypes, but make sure we get Booleans, not ints */ #define NeedWidePrototypes 0 #include #include /* IsCursorKey, IsFunctionKey, et cetera */ #include /* needed for protocol names such as X_CreateWindow */ #include /* XA_ATOM, et cetera */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include /* Motif 1.2 */ #include /* for XmIsDesktopObject */ #include /* for XmIsExtObject */ #include /* for XmIsShellExt */ #include /* for XmIsVendorShellExt */ #include #if(0) /* for XmIsWorldObject */ /* This is not supported in FreeBSD or Solaris 8. */ #include #endif #include "globals.h" #include "sys.h" #include "xwindows.h" #include "run_time.h" #include "arb.h" #include "mpoly.h" #include "gc.h" #include "xcall_numbers.h" #include "diagnostics.h" #include "processes.h" #include "save_vec.h" #include "polystring.h" #include "scanaddrs.h" #include "memmgr.h" #include "machine_dep.h" #include "processes.h" #include "rts_module.h" #include "rtsentry.h" extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolyXWindowsGeneral(FirstArgument threadId, PolyWord params); } /* The following are only forward so we can declare attributes */ static void RaiseXWindows(TaskData *taskData, const char *s) __attribute__((noreturn)); #define ButtonClickMask (((unsigned)1 << 29)) #define XMASK(m) ((m) &~ButtonClickMask) #undef SIZEOF #define debug1(fmt,p1) { /*EMPTY*/ } #undef debug1 #define debug1(fmt,p1) {if (debugOptions & DEBUG_X) printf(fmt,p1);} #define debug3(fmt,p1,p2,p3) {if (debugOptions & DEBUG_X) printf(fmt,p1,p2,p3);} #define debugCreate(type,value) debug1("%lx " #type " created\n",(unsigned long)(value)) #define debugReclaim(type,value) debug1("%lx " #type " reclaimed\n",(unsigned long)(value)) #define debugReclaimRef(type,value) debug1("%lx " #type " reference reclaimed\n",(unsigned long)(value)) #define debugRefer(type,value) debug1("%lx " #type " referenced\n",(unsigned long)(value)) #define debugCreateCallback(MLValue,CValue,CListCell) debug3("%p Widget callback reference created (%p,%p)\n",CValue,CListCell,MLValue) #define debugReclaimCallback(MLValue,CValue,CListCell) debug3("%p Widget callback reference removed (%p,%p)\n",CValue,CListCell,MLValue) /* forward declarations */ static Atom WM_DELETE_WINDOW(Display *d); /* was int SPF 6/1/94 */ #define DEREFDISPLAYHANDLE(h) ((X_Display_Object *)DEREFHANDLE(h)) #define DEREFWINDOWHANDLE(h) ((X_Window_Object *)DEREFHANDLE(h)) #define DEREFXOBJECTHANDLE(h) ((X_Object *)DEREFHANDLE(h)) #define SAVE(x) taskData->saveVec.push(x) #define Make_int(x) Make_arbitrary_precision(taskData, x) #define Make_string(s) SAVE(C_string_to_Poly(taskData, s)) #define Make_bool(b) Make_arbitrary_precision(taskData, (b) != 0) #define SIZEOF(x) (sizeof(x)/sizeof(PolyWord)) #define min(a,b) (a < b ? a : b) #define max(a,b) (a > b ? a : b) #define ISNIL(p) (ML_Cons_Cell::IsNull(p)) #define NONNIL(p) (!ISNIL(p)) typedef Handle EventHandle; /********************************************************************************/ /* Objects are created MUTABLE and are FINISHED when all their fields have been */ /* filled in (assuming they are immutable objects). This is so that we can */ /* consider the possibility of storing immutable objects in read-only memory */ /* segments (not currently implemented). SPF 7/12/93 */ /********************************************************************************/ static Handle FINISHED(TaskData *taskData, Handle P) { PolyObject *pt = DEREFHANDLE(P); assert(taskData->saveVec.isValidHandle(P)); assert(pt->IsMutable()); POLYUNSIGNED lengthW = pt->LengthWord(); pt->SetLengthWord(lengthW & ~_OBJ_MUTABLE_BIT); return P; } static void RaiseXWindows(TaskData *taskData, const char *s) { if (mainThreadPhase == MTP_USER_CODE) { raise_exception_string(taskData, EXC_XWindows,s); } else { /* Crash added 7/7/94 SPF */ Crash("Tried to raise exception (XWindows \"%s\") during garbage collection\n",s); } /*NOTREACHED*/ } /* bugfixed 6/12/94 SPF */ #define RaiseXWindows2(varmessage,constmessage) \ { \ const char message[] = constmessage; \ int n1 = strlen(varmessage); \ int n2 = strlen(message); \ char *mess = (char *)alloca(n1 + n2 + 1); \ strcat(strncpy(mess,varmessage,n1),message); \ RaiseXWindows(taskData, mess); \ /*NOTREACHED*/ \ } static void RaiseRange(TaskData *taskData) { raise_exception0(taskData, EXC_size); } typedef unsigned char uchar; static uchar get_C_uchar(TaskData *taskData, PolyWord a) { unsigned u = get_C_ushort(taskData, a); if (u >= 256) RaiseRange(taskData); return u; } /******************************************************************************/ /* */ /* String */ /* */ /******************************************************************************/ //#define String PolyStringObject //#define GetString(s) _GetString((PolyWord *)(s)) /* can only be called TABLESIZE times per X opcode */ static PolyStringObject *GetString(PolyWord s) { #define TABLESIZE 5 static PolyStringObject string[TABLESIZE]; static int index = 0; if (! s.IsTagged()) return (PolyStringObject *) s.AsObjPtr(); index = (index + 1) % TABLESIZE; string[index].length = 1; string[index].chars[0] = UNTAGGED(s); return &string[index]; #undef TABLESIZE } /******************************************************************************/ /* */ /* XObjects (Type definitions) */ /* */ /******************************************************************************/ /* We keep a list of all objects created by calls to X. */ /* When an object is created we add an entry to the list and */ /* return the entry. If the entry becomes inaccessible */ /* by the garbage collector then we free the object. */ /* The list is created by malloc so that it is not in the heap. */ // Types of objects. These are tagged when they are stored // in objects because some objects are not byte objects. typedef enum { X_GC = 111, X_Font = 222, X_Cursor = 333, X_Window = 444, X_Pixmap = 555, X_Colormap = 666, X_Visual = 777, X_Display = 888, X_Widget = 999, X_Trans = 1111, X_Acc = 2222 } X_types; class X_Object: public PolyObject { public: X_Object(): type(TAGGED(1)) {} // Just to keep gcc happy PolyWord type; }; class X_Trans_Object: public X_Object /* BYTE object */ { public: XtTranslations table; /* C value */ }; class X_Acc_Object: public X_Object /* BYTE object */ { public: XtAccelerators acc; /* C value */ }; class X_Display_Object: public X_Object /* BYTE object */ { public: Display *display; /* C value */ unsigned screen; /* C value */ XtAppContext app_context; /* C value */ } ; class X_Font_Object: public X_Object { public: Font *font; /* Token for C value */ XFontStruct **fs; /* Token for C value */ X_Display_Object *ds; /* Token */ } ; class X_Cursor_Object: public X_Object { public: Cursor *cursor; /* Token for C value */ X_Display_Object *ds; /* Token */ } ; class X_Pixmap_Object: public X_Object { public: Pixmap *pixmap; /* Token for C value */ X_Display_Object *ds; /* Token */ } ; class X_Colormap_Object: public X_Object { public: Colormap *cmap; /* Token for C value */ X_Display_Object *ds; /* Token */ } ; class X_Widget_Object: public X_Object /* MUTABLE */ { public: Widget *widget; /* Token for C value */ PolyWord callbackList; /* mutable */ PolyWord state; /* mutable */ X_Display_Object *ds; /* Token */ } ; class X_Visual_Object: public X_Object { public: Visual **visual; /* Token for C value */ X_Display_Object *ds; /* Token */ } ; class X_GC_Object: public X_Object /* MUTABLE */ { public: GC *gc; /* Token for C value */ X_Font_Object *font_object; /* mutable; may be 0 */ X_Pixmap_Object *tile; /* mutable; may be 0 */ X_Pixmap_Object *stipple; /* mutable; may be 0 */ X_Pixmap_Object *clipMask; /* mutable; may be 0 */ X_Display_Object *ds; /* Token */ } ; class X_Window_Struct: public X_Object /* MUTABLE */ { public: Drawable *drawable; /* Token for C value */ PolyWord handler; /* mutable? */ PolyWord state; /* mutable? */ PolyObject *eventMask; /* Token for C value; token itself is mutable */ X_Colormap_Object *colormap_object; /* mutable; may be 0 */ X_Cursor_Object *cursor_object; /* mutable; may be 0 */ X_Pixmap_Object *backgroundPixmap; /* mutable; may be 0 */ X_Pixmap_Object *borderPixmap; /* mutable; may be 0 */ X_Window_Struct *parent; /* may be 0 */ X_Display_Object *ds; /* Token */ }; typedef X_Window_Struct X_Window_Object; /******************************************************************************/ /* */ /* Forward declarations */ /* */ /******************************************************************************/ static Font GetFont(TaskData *taskData, X_Object *P); static Cursor GetCursor(TaskData *taskData,X_Object *P); static Colormap GetColormap(TaskData *taskData,X_Object *P); static Visual *GetVisual(TaskData *taskData,X_Object *P); static XtTranslations GetTrans(TaskData *taskData,X_Object *P); static XtAccelerators GetAcc(TaskData *taskData,X_Object *P); static Pixmap GetPixmap(TaskData *, X_Object *P); static Widget GetNWidget(TaskData *, X_Object *P); static Window GetWindow(TaskData *, X_Object *P); static Display *GetDisplay(TaskData *, X_Object *P); static void DestroyWindow(X_Object *W); static void DestroySubwindows(X_Object *W); static X_GC_Object *GCObject(X_Object *P); static X_Pixmap_Object *PixmapObject(X_Object *P); static X_Widget_Object *WidgetObject(TaskData *, X_Object *P); static X_Window_Object *WindowObject(X_Object *P); /******************************************************************************/ /* */ /* C lists (Type definitions) */ /* */ /******************************************************************************/ typedef struct X_List_struct X_List; struct X_List_struct { X_List *next; /* pointer into C heap */ X_Object *object; /* pointer into Poly heap; weak */ }; typedef struct timeval TimeVal; /* In C heap */ typedef struct T_List_struct T_List; struct T_List_struct { T_List *next; /* pointer into C heap */ TimeVal timeout; /* here */ X_Window_Object *window_object; /* pointer into Poly heap, or 0; weak */ X_Widget_Object *widget_object; /* pointer into Poly heap, or 0; strong */ PolyObject *alpha; /* pointer into Poly heap; strong */ PolyObject *handler; /* pointer into Poly heap; strong */ int expired; /* here */ }; /* NB precisely one of window_object and widget_object should be non-zero */ /* In C heap */ typedef struct C_List_struct C_List; struct C_List_struct { PolyObject *function; /* pointer into Poly heap; strong */ X_Widget_Object *widget_object; /* pointer into Poly heap; strong */ C_List *next; /* pointer into C heap */ }; /* lists of X objects currently in Poly heap i.e. those created in this session */ #define XLISTSIZE 1001 /* must be coprime to 4 ('cos pointers are PolyWord-aligned) */ static X_List *XList[XLISTSIZE] = {0}; static T_List *TList = 0; /* C pending messages list, ordered by arrival time */ static C_List *CList = 0; /* Acts as root for objects "owned" by C callbacks */ static PolyWord FList = TAGGED(0); /* ML Callback list - acts as a Root for the Heap */ static PolyWord GList = TAGGED(0); /* ML Event list - acts as a Root for the Heap */ static Bool callbacks_enabled = False; /******************************************************************************/ /* */ /* High-speed XList routines */ /* */ /******************************************************************************/ /* maps an (X_Object *) to an (unsigned); this mapping from must give the same */ /* (unsigned) for each (X_Object) for an entire Poly/ML session, even though its */ /* address may change at every garbage collection. */ /* The way we achieve this is by returning the address of the corresponding C */ /* object. Note that since the ML object doesn't necessarily correspond to a real*/ /* C object, this value may be neither valid nor sensible (but it WILL be a */ /* constant). */ /* Unfortunately, we can't do this for GCs or VISUALS, since the actual C object */ /* contains the id we want, and we can't access the id if we haven't got the */ /* object. For these, we return a constant instead. */ static unsigned long hashId(X_Object *P) { #define HASH_GC 0 #define HASH_VISUAL 1 switch(UNTAGGED(P->type)) { case X_GC: return HASH_GC; case X_Font: return (unsigned long)(*(((X_Font_Object*)P)->font)); case X_Cursor: return (unsigned long)(*(((X_Cursor_Object*)P)->cursor)); case X_Window: return (unsigned long)(*(((X_Window_Struct*)P)->drawable)); case X_Pixmap: return (unsigned long)(*(((X_Pixmap_Object*)P)->pixmap)); case X_Colormap: return (unsigned long)(*(((X_Colormap_Object*)P)->cmap)); case X_Visual: return HASH_VISUAL; case X_Display: return (unsigned long)(((X_Display_Object*)P)->display); case X_Widget: return (unsigned long)(*(((X_Widget_Object*)P)->widget)); case X_Trans: return (unsigned long)(((X_Trans_Object*)P)->table); case X_Acc: return (unsigned long)(((X_Acc_Object*)P)->acc); default: Crash ("Bad X_Object type (%d) in hashId",UNTAGGED(P->type)); } /*NOTREACHED*/ } static void initXList(void) { int i; for (i = 0; i < XLISTSIZE; i++) { XList[i] = NULL; } } static X_List **hashXList(X_Object *P) { unsigned long id = hashId(P); unsigned n = (id % XLISTSIZE); /* a poor hash function, but good enough for now */ return &(XList[n]); } static X_List *findXList(unsigned long id) { unsigned n = (id % XLISTSIZE); /* a poor hash function, but good enough for now */ return XList[n]; } /******************************************************************************/ /* */ /* C lists (Polymorphic functions) */ /* */ /******************************************************************************/ // Creates a list from a vector of items. static Handle CreateList4(TaskData *taskData, unsigned n, void *p, unsigned objSize, Handle (*f)(TaskData *, void *)) { Handle saved = taskData->saveVec.mark(); Handle list = SAVE(ListNull); // Process the vector in reverse order. That way we can make the // cells as immutable objects rather than having to create them as // mutable and then lock them. while (n) { n--; byte *objP = (byte*)p + objSize*n; Handle value = (* f)(taskData, objP); Handle next = alloc_and_save(taskData, SIZEOF(ML_Cons_Cell)); DEREFLISTHANDLE(next)->h = DEREFWORDHANDLE(value); DEREFLISTHANDLE(next)->t = DEREFLISTHANDLE(list); /* reset save vector to stop it overflowing */ taskData->saveVec.reset(saved); list = SAVE(DEREFHANDLE(next)); } return list; } static Handle CreateList4I(TaskData *taskData, unsigned n, void *p, unsigned objSize, Handle (*f)(TaskData *, void *, unsigned i)) { Handle saved = taskData->saveVec.mark(); Handle list = SAVE(ListNull); while (n) { n--; byte *objP = (byte*)p + objSize*n; Handle value = (* f)(taskData, objP, n); Handle next = alloc_and_save(taskData, SIZEOF(ML_Cons_Cell)); DEREFLISTHANDLE(next)->h = DEREFWORDHANDLE(value); DEREFLISTHANDLE(next)->t = DEREFLISTHANDLE(list); /* reset save vector to stop it overflowing */ taskData->saveVec.reset(saved); list = SAVE(DEREFHANDLE(next)); } return list; } static Handle CreateList5(TaskData *taskData, POLYUNSIGNED n, void *p, POLYUNSIGNED objSize, Handle (*f)(TaskData *, void *, Handle), Handle a1) { Handle saved = taskData->saveVec.mark(); Handle list = SAVE(ListNull); // Process the vector in reverse order. That way we can make the // cells as immutable objects rather than having to create them as // mutable and then lock them. while (n) { n--; byte *objP = (byte*)p + objSize*n; Handle value = (* f)(taskData, objP, a1); Handle next = alloc_and_save(taskData, SIZEOF(ML_Cons_Cell)); DEREFLISTHANDLE(next)->h = DEREFWORDHANDLE(value); DEREFLISTHANDLE(next)->t = DEREFLISTHANDLE(list); /* reset save vector to stop it overflowing */ taskData->saveVec.reset(saved); list = SAVE(DEREFHANDLE(next)); } return list; } static void GetList4(TaskData *taskData, PolyWord list, void *v, unsigned bytes, void (*get)(TaskData *, PolyWord, void*, unsigned)) { unsigned i = 0; byte *s = (byte*)v; for(PolyWord p = list; NONNIL(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { (* get)(taskData, ((ML_Cons_Cell*)p.AsObjPtr())->h, s, i); s += bytes; i++; } } /* ListLength no longer requires indirection via handle SPF 4/11/93 */ static unsigned ListLength(PolyWord list) { unsigned n = 0; for(PolyWord p = list; NONNIL(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) n++; return n; } /******************************************************************************/ /* */ /* TList Purge Functions (SPF 29/11/93) */ /* */ /******************************************************************************/ static void PurgePendingWidgetMessages(X_Widget_Object *P) { T_List **T = &TList; while(*T) { T_List *t = *T; if (t->widget_object == P) /* clear out pending messages for this widget */ { *T = t->next; free(t); } else T = &t->next; } } static void PurgePendingWindowMessages(X_Window_Object *P) { T_List **T = &TList; while(*T) { T_List *t = *T; if (t->window_object == P) /* clear out pending messages for this window */ { *T = t->next; free(t); } else T = &t->next; } } /******************************************************************************/ /* */ /* CList Purge Functions (SPF 29/2/96) */ /* */ /******************************************************************************/ static void PurgeCCallbacks(X_Widget_Object *P, Widget w) { C_List **C = &CList; while(*C) { C_List *c = *C; if (c->widget_object == P) /* clear out callback info for this widget */ { debugReclaimCallback(P,w,c); *C = c->next; free(c); } else C = &c->next; } } /******************************************************************************/ /* */ /* XObjects (Polymorphic functions 1) */ /* */ /******************************************************************************/ static int ResourceExists(X_Object *P) { X_List *L; for(L = *hashXList(P); L; L = L->next) { if (L->object == P) return 1; } return 0; } /* SafeResourceExists is like ResourceExists but doesn't assume that we actually have a valid X object, so it doesn't use hashing. SPF 6/4/95 */ static int SafeResourceExists(X_Object *P) { unsigned n; for (n = 0; n < XLISTSIZE; n++) { X_List *L; for(L = XList[n]; L; L = L->next) { if (L->object == P) return 1; } } return 0; } static void DestroyXObject(X_Object *P) { TaskData *taskData = processes->GetTaskDataForThread(); X_List **X = hashXList(P); switch(UNTAGGED(P->type)) { case X_GC: { X_GC_Object *G = GCObject(P); GC gc = *G->gc; Display *d = G->ds->display; if (gc == DefaultGC(d,G->ds->screen)) { debugReclaimRef(GC,gc->gid); } else { debugReclaim(GC,gc->gid); XFreeGC(d,gc); /* SAFE(?) */ } break; } case X_Font: { Font f = GetFont(taskData, P); if (f == None) { debugReclaimRef(Font,f); } else { debugReclaim(Font,f); #if NEVER XUnloadFont(GetDisplay(taskData, P),f); #endif } break; } case X_Cursor: { Cursor cursor = GetCursor(taskData, P); if (cursor == None) { debugReclaimRef(Cursor,cursor); } else { debugReclaim(Cursor,cursor); #if NEVER XFreeCursor(GetDisplay(taskData, P),cursor); #endif } break; } case X_Window: { /* added 29/11/93 SPF */ PurgePendingWindowMessages(WindowObject(P)); if (((X_Window_Object *)P)->parent != 0) /* this clients window */ { debugReclaim(Window,GetWindow(taskData, P)); DestroyWindow(P); } else /* None, ParentRelative, and other clients windows */ { debugReclaimRef(Window,GetWindow(taskData, P)); } break; } case X_Pixmap: { Pixmap pixmap = GetPixmap(taskData, P); if (pixmap == None) { debugReclaimRef(Pixmap,pixmap); } else { debugReclaim(Pixmap,pixmap); #if NEVER XFreePixmap(GetDisplay(taskData, P),pixmap); #endif } break; } case X_Colormap: { Colormap cmap = GetColormap(taskData, P); if (cmap == None) { debugReclaimRef(Colormap,cmap); } else { debugReclaim(Colormap,cmap); #if NEVER XFreeColormap(GetDisplay(taskData, P),cmap); #endif } break; } case X_Visual: { Visual *visual = GetVisual(taskData, P); debugReclaimRef(Visual,visual->visualid); break; } case X_Widget: { Widget widget = GetNWidget(taskData, P); PurgePendingWidgetMessages(WidgetObject(taskData, P)); debugReclaimRef(Widget,widget); break; } case X_Trans: { XtTranslations table = GetTrans(taskData, P); debugReclaimRef(Trans,table); break; } case X_Acc: { XtAccelerators acc = GetAcc(taskData, (X_Object *)P); debugReclaimRef(Acc,acc); break; } default: Crash ("Unknown X_Object type %d",UNTAGGED(P->type)); } while(*X) { X_List *L = *X; if (L->object == P) { *X = L->next; free(L); return; } else X = &L->next; } printf("DestroyXObject: destroy failed\n"); } #define CheckExists(P,resource) \ {\ if (! ResourceExists(P)) RaiseXWindows(taskData, (char*) "Non-existent " #resource); \ } static X_Font_Object *FontObject(X_Object *P) { assert(UNTAGGED(P->type) == X_Font); return (X_Font_Object *)P; } static X_Object *FindResource ( Handle dsHandle, /* Handle to (X_Display_Object *) */ X_types type, unsigned long id, unsigned long hashid ) { X_List *L; X_Display_Object *d = (type == X_Widget) ? NULL : DEREFDISPLAYHANDLE(dsHandle); for(L = findXList(hashid); L; L = L->next) { X_Object *P = L->object; if (UNTAGGED(P->type) == type) { switch(type) { case X_GC: if (((X_GC_Object*)P)->ds == d && (*((X_GC_Object*)P)->gc)->gid == id) return P; break; case X_Font: if (((X_Font_Object*)P)->ds == d && (*((X_Font_Object*)P)->font) == id) return P; break; case X_Cursor: if (((X_Cursor_Object*)P)->ds == d && (*((X_Cursor_Object*)P)->cursor) == id) return P; break; case X_Window: if (((X_Window_Object*)P)->ds == d && (*((X_Window_Object*)P)->drawable) == id) return P; break; case X_Pixmap: if (((X_Pixmap_Object*)P)->ds == d && (*((X_Pixmap_Object*)P)->pixmap) == id) return P; break; case X_Colormap: if (((X_Colormap_Object*)P)->ds == d && (*((X_Colormap_Object*)P)->cmap) == id) return P; break; case X_Visual: if (((X_Visual_Object*)P)->ds == d && (*((X_Visual_Object*)P)->visual)->visualid == id) return P; break; case X_Widget: if (*(((X_Widget_Object*)P)->widget) == (Widget) id) return P; break; case X_Display: break; case X_Trans: break; case X_Acc: break; default: Crash ("Bad X_Object type (%d) in FindResource", type); } } } return 0; } // Why are there these casts to unsigned here???? #define FindWindow(d,id) ((X_Window_Object *) FindResource(d,X_Window,(unsigned long)id,(unsigned long)id)) #define FindPixmap(d,id) ((X_Pixmap_Object *) FindResource(d,X_Pixmap,(unsigned long)id,(unsigned long)id)) #define FindCursor(d,id) ((X_Cursor_Object *) FindResource(d,X_Cursor,(unsigned long)id,(unsigned long)id)) #define FindFont(d,id) ((X_Font_Object *) FindResource(d,X_Font,(unsigned long)id,(unsigned long)id)) #define FindColormap(d,id) ((X_Colormap_Object *) FindResource(d,X_Colormap,(unsigned long)id,(unsigned long)id)) #define FindWidget(id) ((X_Widget_Object *) FindResource((Handle)NULL,X_Widget,(unsigned long)id,(unsigned long)id)) /* can't use id for hashing in the following, so use arbitrary values instead */ #define FindGC(d,id) ((X_GC_Object *) FindResource(d,X_GC,(unsigned long)id,HASH_GC)) #define FindVisual(d,id) ((X_Visual_Object *) FindResource(d,X_Visual,(unsigned long)id,HASH_VISUAL)) static Handle AddXObject(Handle objectHandle) { X_List **X = hashXList(DEREFXOBJECTHANDLE(objectHandle)); X_List *L = (X_List *) malloc(sizeof(X_List)); L->next = *X; L->object = (X_Object *)DEREFHANDLE(objectHandle); *X = L; return objectHandle; } /******************************************************************************/ /* */ /* MLXPoint - implements ML XPoint datatype */ /* */ /******************************************************************************/ typedef struct /* depends on XPoint datatype + ML compiler hash function */ { PolyWord x; /* ML int */ PolyWord y; /* ML int */ } MLXPoint; inline MLXPoint * Point(PolyWord p) { return (MLXPoint *) p.AsObjPtr(); } /* shouldn't these be long values? */ inline short GetPointX(TaskData *taskData, PolyWord p) { return get_C_short(taskData, Point(p)->x); } inline short GetPointY(TaskData *taskData, PolyWord p) { return get_C_short(taskData, Point(p)->y); } inline short GetOffsetX(TaskData *taskData, PolyWord p) { return get_C_ushort(taskData, Point(p)->x); } inline short GetOffsetY(TaskData *taskData, PolyWord p) { return get_C_ushort(taskData, Point(p)->y); } static Handle CreatePoint(TaskData *taskData, int x, int y) { Handle pointHandle = alloc_and_save(taskData, SIZEOF(MLXPoint), F_MUTABLE_BIT); /* Still allocating, so must use explicit DEREF for each element */ #define point ((MLXPoint *)DEREFHANDLE(pointHandle)) point->x = DEREFWORD(Make_int(x)); point->y = DEREFWORD(Make_int(y)); #undef point return FINISHED(taskData, pointHandle); } static void GetPoints(TaskData *taskData, PolyWord p, void *v, unsigned) { XPoint *A = (XPoint *)v; A->x = GetPointX(taskData, p); A->y = GetPointY(taskData, p); } /******************************************************************************/ /* */ /* MLXRectangle - implements ML XRectangle datatype */ /* */ /******************************************************************************/ typedef struct /* depends on XRectangle datatype + ML compiler hash function */ { PolyWord top; /* ML int */ PolyWord left; /* ML int */ PolyWord right; /* ML int */ PolyWord bottom; /* ML int */ } MLXRectangle; inline MLXRectangle *Rect(PolyWord R) { return (MLXRectangle *) R.AsObjPtr(); } inline short GetRectTop(TaskData *taskData, PolyWord R) { return get_C_short(taskData, Rect(R)->top); } inline short GetRectLeft(TaskData *taskData, PolyWord R) { return get_C_short(taskData, Rect(R)->left); } inline short GetRectRight(TaskData *taskData, PolyWord R) { return get_C_short(taskData, Rect(R)->right); } inline short GetRectBottom(TaskData *taskData, PolyWord R) { return get_C_short(taskData, Rect(R)->bottom); } #define GetRectX(taskData, R) GetRectLeft(taskData, R) #define GetRectY(taskData, R) GetRectTop(taskData, R) /* functions added 29/10/93 SPF */ static unsigned GetRectW(TaskData *taskData, PolyWord R) { long result = GetRectRight(taskData, R) - GetRectLeft(taskData, R); if (result < 0) RaiseRange(taskData); return (unsigned)result; } static unsigned GetRectH(TaskData *taskData, PolyWord R) { long result = GetRectBottom(taskData, R) - GetRectTop(taskData, R); if (result < 0) RaiseRange(taskData); return (unsigned)result; } /* static MLXRectangle **CreateRect(top,left,bottom,right) */ static Handle CreateRect(TaskData *taskData, int top, int left, int bottom, int right) { Handle rectHandle = alloc_and_save(taskData, SIZEOF(MLXRectangle), F_MUTABLE_BIT); /* Still allocating, so must use explicit DEREF for each element */ #define rect ((MLXRectangle *)DEREFHANDLE(rectHandle)) rect->top = DEREFWORD(Make_int(top)); rect->left = DEREFWORD(Make_int(left)); rect->right = DEREFWORD(Make_int(right)); rect->bottom = DEREFWORD(Make_int(bottom)); #undef rect return FINISHED(taskData, rectHandle); } #define CreateArea(w,h) CreateRect(taskData, 0,0,(int)h,(int)w) static void GetRects(TaskData *taskData, PolyWord p, void *v, unsigned) { XRectangle *A = (XRectangle *)v; A->x = GetRectX(taskData, p); A->y = GetRectY(taskData, p); A->width = GetRectW(taskData, p); A->height = GetRectH(taskData, p); } static void CheckZeroRect(TaskData *taskData, PolyWord R) { unsigned x = GetRectX(taskData, R); unsigned y = GetRectY(taskData, R); unsigned w = GetRectW(taskData, R); unsigned h = GetRectH(taskData, R); if (x != 0 || y != 0 || /* w <= 0 || h <= 0 || w,h now unsigned SPF 29/10/93 */ w == 0 || h == 0 || w > 65535 || h > 65535) RaiseRange(taskData); } /******************************************************************************/ /* */ /* MLXArc - implements ML XArc datatype */ /* */ /******************************************************************************/ /* MLXArc added 31/10/93 SPF; depends on ML XArc datatype */ typedef struct { PolyWord r; /* MMLXRectangle* */ PolyWord a1; /* ML int */ PolyWord a2; /* ML int */ } MLXArc; inline MLXArc *Arc(PolyWord A) { return (MLXArc *) A.AsObjPtr(); } inline PolyWord GetArcR(PolyWord A) { return Arc(A)->r; } inline short GetArcA1(TaskData *taskData, PolyWord A) { return get_C_short(taskData, Arc(A)->a1); } inline short GetArcA2(TaskData *taskData, PolyWord A) { return get_C_short(taskData, Arc(A)->a2); } static void GetArcs(TaskData *taskData, PolyWord p, void *v, unsigned) { XArc *A = (XArc *)v; A->x = GetRectX(taskData, GetArcR(p)); A->y = GetRectY(taskData, GetArcR(p)); A->width = GetRectW(taskData, GetArcR(p)); A->height = GetRectH(taskData, GetArcR(p)); A->angle1 = GetArcA1(taskData, p); A->angle2 = GetArcA2(taskData, p); } /******************************************************************************/ /* */ /* Colormap */ /* */ /******************************************************************************/ static X_Colormap_Object *ColormapObject(X_Object *P) { assert(UNTAGGED(P->type) == X_Colormap); return (X_Colormap_Object *)P; } static Colormap GetColormap(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Colormap); /* val NoColormap = xcall (23,0) : Colormap; */ /* special case for NoColormap - correct(?) */ if ( *(((X_Colormap_Object *)P)->cmap) == None) return None; CheckExists(P,colormap); return *(((X_Colormap_Object *)P)->cmap); } static Handle EmptyColormap ( TaskData *taskData, Handle dsHandle /* Handle to (X_Display_Object *) */, Colormap id ) { X_Colormap_Object *E = FindColormap(dsHandle,id); if (E) { return SAVE(E); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Colormap_Object), F_MUTABLE_BIT); Handle cmapHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT | F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Colormap_Object *object = (X_Colormap_Object *)DEREFHANDLE(objectHandle); Colormap *cmap = (Colormap *)DEREFHANDLE(cmapHandle); *cmap = id; FINISHED(taskData, cmapHandle); object->type = TAGGED(X_Colormap); object->cmap = cmap; object->ds = DEREFDISPLAYHANDLE(dsHandle); debugRefer(Colormap,id); return AddXObject(FINISHED(taskData, objectHandle)); } } /******************************************************************************/ /* */ /* Visual */ /* */ /******************************************************************************/ static Visual *GetVisual(TaskData *taskData, X_Object *P) { static Visual EMPTYVISUAL = { 0 }; assert(UNTAGGED(P->type) == X_Visual); /* val NoVisual = xcall (24,0) : Visual; */ /* special case for NoVisual */ if (*(((X_Visual_Object *)P)->visual) == None) return &EMPTYVISUAL; /* FISHY (?) */ CheckExists(P,visual); return *(((X_Visual_Object *)P)->visual); } static Handle EmptyVisual ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Visual *v ) { if (v != None) { X_Visual_Object *E = FindVisual(dsHandle,v->visualid); if (E) return SAVE(E); } /* else */ { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Visual_Object), F_MUTABLE_BIT); Handle visualHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Visual_Object *object = (X_Visual_Object *)DEREFHANDLE(objectHandle); Visual **visual = (Visual **)DEREFHANDLE(visualHandle); *visual = v; FINISHED(taskData, visualHandle); object->type = TAGGED(X_Visual); object->visual = visual; object->ds = DEREFDISPLAYHANDLE(dsHandle); debugRefer(Visual,(v == None) ? None : v->visualid); return AddXObject(FINISHED(taskData, objectHandle)); } } /******************************************************************************/ /* */ /* GC */ /* */ /******************************************************************************/ static X_GC_Object *GCObject(X_Object *P) { assert(UNTAGGED(P->type) == X_GC); return (X_GC_Object *)P; } static GC GetGC(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_GC); CheckExists(P,gc); return *(((X_GC_Object *)P)->gc); } static Handle GetDefaultGC(TaskData *taskData, Handle dsHandle /* Handle to (X_Display_Object *) */) { GC defaultGC = DefaultGC(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen); X_GC_Object *G = FindGC(dsHandle,defaultGC->gid); if (G) { return SAVE(G); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_GC_Object), F_MUTABLE_BIT); Handle GCHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_GC_Object *object = (X_GC_Object *)DEREFHANDLE(objectHandle); GC *gc = (GC *)DEREFHANDLE(GCHandle); *gc = defaultGC; FINISHED(taskData, GCHandle); debugRefer(GC,defaultGC->gid); object->type = TAGGED(X_GC); object->gc = gc; object->ds = DEREFDISPLAYHANDLE(dsHandle); /* object->font_object = 0; object->tile = 0; object->stipple = 0; object->clipMask = 0; */ return AddXObject(objectHandle); /* must stay MUTABLE */ } } static void ChangeGC(TaskData *taskData, X_GC_Object *G, unsigned n, PolyWord P) { XGCValues v; unsigned mask = 1 << n; switch(mask) { case GCFunction: v.function = get_C_ushort(taskData, P); break; case GCPlaneMask: v.plane_mask = get_C_ulong (taskData, P); break; case GCForeground: v.foreground = get_C_ulong (taskData, P); break; case GCBackground: v.background = get_C_ulong (taskData, P); break; case GCLineWidth: v.line_width = get_C_short (taskData, P); break; case GCLineStyle: v.line_style = get_C_ushort(taskData, P); break; case GCCapStyle: v.cap_style = get_C_ushort(taskData, P); break; case GCJoinStyle: v.join_style = get_C_ushort(taskData, P); break; case GCFillStyle: v.fill_style = get_C_ushort(taskData, P); break; case GCFillRule: v.fill_rule = get_C_ushort(taskData, P); break; case GCTileStipXOrigin: v.ts_x_origin = get_C_short (taskData, P); break; case GCTileStipYOrigin: v.ts_y_origin = get_C_short (taskData, P); break; case GCSubwindowMode: v.subwindow_mode = get_C_ushort(taskData, P); break; case GCGraphicsExposures: v.graphics_exposures = get_C_ushort(taskData, P); break; case GCClipXOrigin: v.clip_x_origin = get_C_short (taskData, P); break; case GCClipYOrigin: v.clip_y_origin = get_C_short (taskData, P); break; case GCDashOffset: v.dash_offset = get_C_ushort(taskData, P); break; case GCDashList: v.dashes = get_C_uchar (taskData, P); break; case GCArcMode: v.arc_mode = get_C_ushort(taskData, P); break; case GCFont: v.font = GetFont(taskData, (X_Object *)P.AsObjPtr()); G->font_object = FontObject((X_Object *)P.AsObjPtr()); break; case GCTile: v.tile = GetPixmap(taskData, (X_Object *)P.AsObjPtr()); G->tile = PixmapObject((X_Object *)P.AsObjPtr()); break; case GCStipple: v.stipple = GetPixmap(taskData, (X_Object *)P.AsObjPtr()); G->stipple = PixmapObject((X_Object *)P.AsObjPtr()); break; case GCClipMask: v.clip_mask = GetPixmap(taskData, (X_Object *)P.AsObjPtr()); G->clipMask = PixmapObject((X_Object *)P.AsObjPtr()); break; default: Crash ("Bad gc mask %u",mask); } XChangeGC(GetDisplay(taskData, (X_Object *)G),GetGC(taskData, (X_Object *)G),mask,&v); } static Handle CreateGC ( TaskData *taskData, Handle dsHandle /* Handle to (X_Display_Object *) */, Drawable w ) { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_GC_Object), F_MUTABLE_BIT); Handle GCHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_GC_Object *object = (X_GC_Object *)DEREFHANDLE(objectHandle); GC *gc = (GC *)DEREFHANDLE(GCHandle); *gc = XCreateGC(DEREFDISPLAYHANDLE(dsHandle)->display,w,0,0); FINISHED(taskData, GCHandle); debugCreate(GC,(*gc)->gid); object->type = TAGGED(X_GC); object->gc = gc; object->ds = DEREFDISPLAYHANDLE(dsHandle); /* object->font_object = 0; object->tile = 0; object->stipple = 0; object->clipMask = 0; */ return AddXObject(objectHandle); /* must remain MUTABLE */ } /******************************************************************************/ /* */ /* Window */ /* */ /******************************************************************************/ static X_Window_Object *WindowObject(X_Object *P) { assert(UNTAGGED(P->type) == X_Window); return (X_Window_Object *)P; } static Window GetWindow(TaskData *taskData, X_Object *P) { if (UNTAGGED(P->type) == X_Pixmap) { if (*((X_Pixmap_Object*)P)->pixmap == None) return None; RaiseXWindows(taskData, "Not a window"); } assert(UNTAGGED(P->type) == X_Window); CheckExists(P,window); return *(((X_Window_Object*)P)->drawable); } static Handle EmptyWindow ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w ) { X_Window_Object *W = FindWindow(dsHandle,w); if (W) { return SAVE(W); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Window_Object), F_MUTABLE_BIT); Handle eventMaskHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); Handle drawableHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Window_Object *object = DEREFWINDOWHANDLE(objectHandle); Drawable *drawable = (Drawable *)DEREFHANDLE(drawableHandle); PolyObject *eventMask = DEREFHANDLE(eventMaskHandle); *drawable = w; FINISHED(taskData, drawableHandle); #ifdef nodef /* DCJM: This gets in the way of trying to handle ButtonPress events - get rid of it. */ /* so that Motif windows get ButtonClick XEvent structures */ eventMask->Set(0, PolyWord::FromUnsigned(ButtonClickMask)); /* eventMask must remain MUTABLE */ #else eventMask->Set(0, PolyWord::FromUnsigned(0)); #endif object->type = TAGGED(X_Window); object->drawable = drawable; object->handler = TAGGED(0); object->state = TAGGED(0); object->eventMask = eventMask; /* object->colormap_object = 0; object->cursor_object = 0; object->backgroundPixmap = 0; object->borderPixmap = 0; object->parent = 0; */ object->ds = DEREFDISPLAYHANDLE(dsHandle); debugRefer(Window,w); return AddXObject(objectHandle); /* must remain MUTABLE */ } } /******************************************************************************/ /* */ /* Pixmap */ /* */ /******************************************************************************/ static X_Pixmap_Object *PixmapObject(X_Object *P) { assert(UNTAGGED(P->type) == X_Pixmap); return (X_Pixmap_Object *)P; } static Pixmap GetPixmap(TaskData *taskData, X_Object *P) { if (UNTAGGED(P->type) == X_Window) { if (! ResourceExists(P)) { debug1("Non-existent window %lx\n",(long)P); } if (*(((X_Window_Object*)P)->drawable) == None) return None; RaiseXWindows(taskData, "Not a pixmap"); } assert(UNTAGGED(P->type) == X_Pixmap); /* val NoDrawable = xcall (20,0) : Drawable; */ /* val ParentRelative = xcall (20,1) : Drawable; */ /* special case for NoDrawable */ if (*((X_Pixmap_Object*)P)->pixmap == 0) return None; /* special case for ParentRelative */ if (*((X_Pixmap_Object*)P)->pixmap == 1) return None; CheckExists(P,pixmap); return *(((X_Pixmap_Object*)P)->pixmap); } static Handle EmptyPixmap ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Pixmap id ) { X_Pixmap_Object *E = FindPixmap(dsHandle,id); if (E) { return SAVE(E); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Pixmap_Object), F_MUTABLE_BIT); Handle pixmapHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Pixmap_Object *object = (X_Pixmap_Object *)DEREFHANDLE(objectHandle); Pixmap *pixmap = (Pixmap *)DEREFHANDLE(pixmapHandle); *pixmap = id; FINISHED(taskData, pixmapHandle); object->type = TAGGED(X_Pixmap); object->pixmap = pixmap; object->ds = DEREFDISPLAYHANDLE(dsHandle); debugCreate(Pixmap,id); return AddXObject(FINISHED(taskData, objectHandle)); } } /******************************************************************************/ /* */ /* Drawable */ /* */ /******************************************************************************/ static Drawable GetDrawable(TaskData *taskData, X_Object *P) { CheckExists(P,drawable); switch(UNTAGGED(P->type)) { case X_Window: return *(((X_Window_Object*)P)->drawable); case X_Pixmap: return *(((X_Pixmap_Object*)P)->pixmap); default: Crash ("Bad X_Object type (%d) in GetDrawable",UNTAGGED(P->type)); } /*NOTREACHED*/ } /******************************************************************************/ /* */ /* DS / Display */ /* */ /******************************************************************************/ static Handle GetDS(TaskData *taskData, X_Object *P) { X_Display_Object *ds; CheckExists(P,resource); switch(UNTAGGED(P->type)) { case X_GC: ds = ((X_GC_Object*)P)->ds; break; case X_Font: ds = ((X_Font_Object*)P)->ds; break; case X_Cursor: ds = ((X_Cursor_Object*)P)->ds; break; case X_Window: ds = ((X_Window_Object*)P)->ds; break; case X_Pixmap: ds = ((X_Pixmap_Object*)P)->ds; break; case X_Colormap: ds = ((X_Colormap_Object*)P)->ds; break; case X_Visual: ds = ((X_Visual_Object*)P)->ds; break; case X_Widget: ds = ((X_Widget_Object*)P)->ds; break; case X_Display: ds = (X_Display_Object*)P; break; /* i.e. P cast to the right type */ default: Crash ("Bad X_Object type (%d) in GetDS",UNTAGGED(P->type)); } assert((PolyWord)ds != TAGGED(0)); return SAVE(ds); } static Display *GetDisplay(TaskData *taskData, X_Object *P) { CheckExists(P,resource); switch(UNTAGGED(P->type)) { case X_GC: return ((X_GC_Object*)P)->ds->display; case X_Font: return ((X_Font_Object*)P)->ds->display; case X_Cursor: return ((X_Cursor_Object*)P)->ds->display; case X_Window: return ((X_Window_Object*)P)->ds->display; case X_Pixmap: return ((X_Pixmap_Object*)P)->ds->display; case X_Colormap: return ((X_Colormap_Object*)P)->ds->display; case X_Visual: return ((X_Visual_Object*)P)->ds->display; case X_Widget: return ((X_Widget_Object*)P)->ds->display; case X_Display: return ((X_Display_Object*)P)->display; default: Crash ("Bad X_Object type (%d) in GetDisplay",UNTAGGED(P->type)); } /*NOTREACHED*/ } /******************************************************************************/ /* */ /* FS / Font */ /* */ /******************************************************************************/ static Font GetFont(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Font); /* val NoFont = xcall (22,0) : Font; */ /* special case for NoFont - valid(?) */ if (*(((X_Font_Object *)P)->font) == None) return None; CheckExists(P,font); return *(((X_Font_Object *)P)->font); } static Handle EmptyFont ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Font id, XFontStruct *fs ) { X_Font_Object *E = FindFont(dsHandle,id); if (E && (fs == NULL || *(E->fs) == fs)) { return SAVE(E); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Font_Object), F_MUTABLE_BIT); Handle fontHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); Handle FSHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Font_Object *object = (X_Font_Object *)DEREFHANDLE(objectHandle); Font *font = (Font *)DEREFHANDLE(fontHandle); XFontStruct **xfstr = (XFontStruct **)DEREFHANDLE(FSHandle); *font = id; FINISHED(taskData, fontHandle); *xfstr = fs; FINISHED(taskData, FSHandle); object->type = TAGGED(X_Font); object->font = font; object->fs = xfstr; object->ds = DEREFDISPLAYHANDLE(dsHandle); debugCreate(Font,id); return AddXObject(FINISHED(taskData, objectHandle)); } } /******************************************************************************/ /* */ /* Cursor */ /* */ /******************************************************************************/ static X_Cursor_Object *CursorObject(X_Object *P) { assert(UNTAGGED(P->type) == X_Cursor); return (X_Cursor_Object *)P; } static Cursor GetCursor(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Cursor); /* val NoCursor = xcall (21,0) : Cursor; */ /* special case for NoCursor */ if (*(((X_Cursor_Object *)P)->cursor) == None) return None; CheckExists(P,cursor); return *(((X_Cursor_Object *)P)->cursor); } static Handle EmptyCursor ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Cursor id ) { X_Cursor_Object *E = FindCursor(dsHandle,id); if (E) { return SAVE(E); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Cursor_Object), F_MUTABLE_BIT); Handle cursorHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Cursor_Object *object = (X_Cursor_Object *)DEREFHANDLE(objectHandle); Cursor *cursor = (Cursor *)DEREFHANDLE(cursorHandle); *cursor = id; FINISHED(taskData, cursorHandle); object->type = TAGGED(X_Cursor); object->cursor = cursor; object->ds = DEREFDISPLAYHANDLE(dsHandle); debugRefer(Cursor,id); return AddXObject(FINISHED(taskData, objectHandle)); } } static Handle CreateFontCursor ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ unsigned shape ) { return EmptyCursor(taskData, dsHandle,XCreateFontCursor(DEREFDISPLAYHANDLE(dsHandle)->display,shape)); } static Handle CreateGlyphCursor ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Font sf, Font mf, unsigned sc, unsigned mc, XColor *foreground, XColor *background ) { return EmptyCursor(taskData, dsHandle,XCreateGlyphCursor(DEREFDISPLAYHANDLE(dsHandle)->display,sf,mf,sc,mc,foreground,background)); } static Handle CreatePixmapCursor ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Pixmap source, Pixmap mask, XColor *foreground, XColor *background, unsigned x, unsigned y ) { return EmptyCursor(taskData, dsHandle,XCreatePixmapCursor(DEREFDISPLAYHANDLE(dsHandle)->display,source,mask,foreground,background,x,y)); } /******************************************************************************/ /* */ /* Widget */ /* */ /******************************************************************************/ static Widget GetNWidget(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Widget); if (*(((X_Widget_Object *)P)->widget) == NULL) return NULL; CheckExists(P,widget); return *(((X_Widget_Object *)P)->widget); } static Widget GetWidget(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Widget); if (*(((X_Widget_Object *)P)->widget) == NULL) { RaiseXWindows(taskData, "Not a real widget"); } CheckExists(P,widget); return *(((X_Widget_Object *)P)->widget); } /* added 6/11/94 SPF */ static Widget GetRealizedWidget(TaskData *taskData, char *where, X_Object *P) { Widget w; assert(UNTAGGED(P->type) == X_Widget); w = *(((X_Widget_Object *)P)->widget); if (w == NULL) { RaiseXWindows2(where,": not a real widget"); } CheckExists(P,widget); if (XtIsRealized(w) == False) { RaiseXWindows2(where,": widget is not realized"); } return w; } /* P is a pointer to an X_Widget_Object */ static X_Widget_Object *WidgetObjectToken(X_Object *P) { assert(UNTAGGED(P->type) == X_Widget); return (X_Widget_Object *)P; } /* P is a pointer to an X_Widget_Object, which is bound to a C widget */ static X_Widget_Object *WidgetObject(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Widget); CheckExists(P,widget); return (X_Widget_Object *)P; } static Handle EmptyWidget ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget id ) { X_Widget_Object *E = FindWidget(id); if (E) { return SAVE(E); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Widget_Object), F_MUTABLE_BIT); Handle widgetHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Widget_Object *object = (X_Widget_Object *)DEREFHANDLE(objectHandle); Widget *widget = (Widget *)DEREFHANDLE(widgetHandle); *widget = id; FINISHED(taskData, widgetHandle); object->type = TAGGED(X_Widget); object->widget = widget; object->callbackList = ListNull; object->state = TAGGED(0); object->ds = DEREFDISPLAYHANDLE(dsHandle); debugRefer(Widget,id); return AddXObject(objectHandle); /* Must stay MUTABLE */ } } static Handle NewWidget ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget id ) { X_Widget_Object *E = FindWidget(id); if (E) DestroyXObject((X_Object *)E); return EmptyWidget(taskData, dsHandle,id); } /******************************************************************************/ /* */ /* Text Widgets */ /* */ /******************************************************************************/ static Widget GetTextWidget(TaskData *taskData, char *funcname, X_Object *P) { Widget w = GetWidget(taskData, P); if (XmIsText(w)) return w; /* Text operations are also legal on TextField widgets */ if (XmIsTextField(w)) return w; RaiseXWindows2(funcname,": not a Text or TextField widget"); /*NOTREACHED*/ } /******************************************************************************/ /* */ /* TextField Widgets */ /* */ /******************************************************************************/ static Widget GetTextFieldWidget(TaskData *taskData, char *funcname, X_Object *P) { Widget w = GetWidget(taskData, P); if (XmIsTextField(w)) return w; RaiseXWindows2(funcname,": not a TextField widget"); /*NOTREACHED*/ } /******************************************************************************/ /* */ /* List Widgets */ /* */ /******************************************************************************/ static Widget GetListWidget(TaskData *taskData, char *funcname, X_Object *P) { Widget w = GetWidget(taskData, P); if (XmIsList(w)) return w; RaiseXWindows2(funcname,": not a List widget"); /*NOTREACHED*/ } /******************************************************************************/ /* */ /* Window */ /* */ /******************************************************************************/ static void RemoveWindowEvents(Display *d, Window w) { XEvent event; XSync(d,False); while(XCheckWindowEvent(d,w,~0,&event)) { /* do nothing */ } } static Handle AddWindow ( TaskData *taskData, Window W, Handle handlerHandle, /* Handle to (PolyWord *) (?) */ Handle stateHandle, /* Handle to (PolyWord *) (?) */ Handle parentHandle /* Handle to (X_Window_Object *) */ ) { XWMHints hints; Atom deleteWindow; /* was int SPF 6/1/94 */ Display *d = GetDisplay(taskData, DEREFXOBJECTHANDLE(parentHandle)); Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Window_Object), F_MUTABLE_BIT); Handle eventMaskHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); Handle drawableHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Window_Object *object = DEREFWINDOWHANDLE(objectHandle); Drawable *drawable = (Drawable *)DEREFHANDLE(drawableHandle); PolyObject *eventMask = DEREFHANDLE(eventMaskHandle); eventMask->Set(0, PolyWord::FromUnsigned(0)); /* eventMask must remain MUTABLE */ *drawable = W; FINISHED(taskData, drawableHandle); hints.flags = InputHint; hints.input = True; XSetWMHints(d,W,&hints); deleteWindow = WM_DELETE_WINDOW(d); if (deleteWindow != None) XSetWMProtocols(d,W,&deleteWindow,1); debugCreate(Window,W); object->type = TAGGED(X_Window); object->drawable = drawable; object->eventMask = eventMask; object->handler = DEREFHANDLE(handlerHandle); object->state = DEREFHANDLE(stateHandle); object->parent = DEREFWINDOWHANDLE(parentHandle); object->ds = DEREFWINDOWHANDLE(parentHandle)->ds; /* Tidy up (?) */ /* object->colormap_object = 0; object->cursor_object = 0; object->backgroundPixmap = 0; object->borderPixmap = 0; */ if (ISNIL(DEREFHANDLE(handlerHandle))) Crash ("No handler set"); return AddXObject(objectHandle); /* object must remain MUTABLE */ } static void DestroyWindow(X_Object *W /* Should be a Window Object! */) { TaskData *taskData = processes->GetTaskDataForThread(); Window w = GetWindow(taskData, W); Display *d = GetDisplay(taskData, W); debugReclaim(Window,w); XUnmapWindow(d,w); DestroySubwindows(W); XDestroyWindow(d,w); RemoveWindowEvents(d,w); } static Handle CreateSimpleWindow ( TaskData *taskData, Handle parent, /* Handle to (X_Window_Object *) */ int x, int y, unsigned w, unsigned h, unsigned borderWidth, unsigned border, unsigned background, Handle handler, /* Handle to (PolyWord *) (?) */ Handle state /* Handle to (PolyWord *) (?) */ ) { Window W = XCreateSimpleWindow(GetDisplay(taskData, DEREFXOBJECTHANDLE(parent)), GetWindow(taskData, DEREFXOBJECTHANDLE(parent)), x,y,w,h, borderWidth,border,background); if (W == 0) RaiseXWindows(taskData, "XCreateSimpleWindow failed"); return AddWindow(taskData,W,handler,state,parent); } static Handle CreateWindow ( TaskData *taskData, Handle parent, /* Handle to (X_Window_Object *) */ int x, int y, unsigned w, unsigned h, unsigned borderWidth, unsigned depth, unsigned clas, Visual *visual, Handle handler, /* Handle to (PolyWord *) (?) */ Handle state /* Handle to (PolyWord *) (?) */ ) { Window W; W = XCreateWindow(GetDisplay(taskData, DEREFXOBJECTHANDLE(parent)), GetWindow(taskData, DEREFXOBJECTHANDLE(parent)), x,y,w,h, borderWidth,depth,clas,visual,0,0); if (W == 0) RaiseXWindows(taskData, "XCreateWindow failed"); return AddWindow(taskData,W,handler,state,parent); } static void DestroySubwindows(X_Object *W /* should be a Window object! */) { TaskData *taskData = processes->GetTaskDataForThread(); Window root,parent,*children; unsigned n; int s; Window w = GetWindow(taskData, W); Display *d = GetDisplay(taskData, W); s = XQueryTree(d,w,&root,&parent,&children,&n); if (s == 0) { RaiseXWindows(taskData, "XDestroySubwindows failed"); return; } XUnmapSubwindows(d,w); if (n) { Handle dsHandle = GetDS(taskData, W); while(n--) { X_Window_Object *child = FindWindow(dsHandle,children[n]); if (child) DestroyXObject((X_Object *)child); } XFree((char *)children); } XDestroySubwindows(d,w); } /******************************************************************************/ /* */ /* Translations / Accelerators */ /* */ /******************************************************************************/ static Handle EmptyTrans(TaskData *taskData, XtTranslations table) { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Trans_Object), F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Trans_Object *object = (X_Trans_Object *)DEREFHANDLE(objectHandle); /* OK to store C values because this is a byte object */ object->type = TAGGED(X_Trans); object->table = table; debugRefer(Trans,table); return AddXObject(FINISHED(taskData, objectHandle)); } static XtTranslations GetTrans(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Trans); CheckExists(P,trans); return ((X_Trans_Object *)P)->table; } static Handle EmptyAcc(TaskData *taskData, XtTranslations acc) { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Acc_Object), F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Acc_Object *object = (X_Acc_Object *)DEREFHANDLE(objectHandle); /* OK to store C values because this is a byte object */ object->type = TAGGED(X_Acc); object->acc = acc; debugRefer(Acc,acc); return AddXObject(FINISHED(taskData, objectHandle)); } static XtAccelerators GetAcc(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Acc); CheckExists(P,acc); return ((X_Acc_Object *)P)->acc; } /******************************************************************************/ /* */ /* Utility functions */ /* */ /******************************************************************************/ static XtGrabKind GetXtGrabKind(TaskData *taskData, PolyWord P) { int i = get_C_long(taskData, P); /* This encoding must be the same as that used in Motif/ml_bind.ML */ switch (i) { case 0: return XtGrabNone; case 1: return XtGrabNonexclusive; case 2: return XtGrabExclusive; default: Crash ("Bad XtGrabKind index (%d) in GetXtGrabKind",i); } return XtGrabNone; /* to keep lint/gcc happy */ } /******************************************************************************/ /* */ /* MLXStandardColormap - implements ML XStandardColormap datatype */ /* */ /******************************************************************************/ typedef struct { X_Colormap_Object *Colormap; PolyWord redMax; /* ML int */ PolyWord redMult; /* ML int */ PolyWord greenMax; /* ML int */ PolyWord greenMult; /* ML int */ PolyWord blueMax; /* ML int */ PolyWord blueMult; /* ML int */ PolyWord basePixel; /* ML int */ X_Visual_Object *visual; } MLXStandardColormap; static void GetStandardColormap(TaskData *taskData, PolyWord p, void *v, unsigned) { MLXStandardColormap *P = (MLXStandardColormap *)p.AsObjPtr(); XStandardColormap *s = (XStandardColormap *)v; s->colormap = GetColormap(taskData, (X_Object *)P->Colormap); s->red_max = get_C_ulong(taskData, P->redMax); s->red_mult = get_C_ulong(taskData, P->redMult); s->green_max = get_C_ulong(taskData, P->greenMax); s->green_mult = get_C_ulong(taskData, P->greenMult); s->blue_max = get_C_ulong(taskData, P->blueMax); s->blue_mult = get_C_ulong(taskData, P->blueMult); s->base_pixel = get_C_ulong(taskData, P->basePixel); s->visualid = GetVisual(taskData, (X_Object *)P->visual)->visualid; /* UNSAFE(?) */ s->killid = None; } static Handle CreateStandardColormap ( TaskData *taskData, void *v, Handle dsHandle /* Handle to (X_Display_Object *) */ ) { XStandardColormap *s = (XStandardColormap *)v; XVisualInfo T; XVisualInfo *info; int count; Handle tupleHandle = alloc_and_save(taskData, SIZEOF(MLXStandardColormap), F_MUTABLE_BIT); T.visualid = s->visualid; T.visual = None; info = XGetVisualInfo(DEREFDISPLAYHANDLE(dsHandle)->display,VisualIDMask,&T,&count); if (info) { T.visual = info->visual; XFree((char *)info); } /* Still allocating, so must use explicit DEREF for each element */ #define tuple /* hack */((MLXStandardColormap *)DEREFHANDLE(tupleHandle)) tuple->Colormap = (X_Colormap_Object *)DEREFHANDLE(EmptyColormap(taskData, dsHandle,s->colormap)); tuple->redMax = DEREFWORD(Make_arbitrary_precision(taskData, s->red_max)); tuple->redMult = DEREFWORD(Make_arbitrary_precision(taskData, s->red_mult)); tuple->greenMax = DEREFWORD(Make_arbitrary_precision(taskData, s->green_max)); tuple->greenMult = DEREFWORD(Make_arbitrary_precision(taskData, s->green_mult)); tuple->blueMax = DEREFWORD(Make_arbitrary_precision(taskData, s->blue_max)); tuple->blueMult = DEREFWORD(Make_arbitrary_precision(taskData, s->blue_mult)); tuple->basePixel = DEREFWORD(Make_arbitrary_precision(taskData, s->base_pixel)); tuple->visual = (X_Visual_Object *)DEREFHANDLE(EmptyVisual(taskData, dsHandle,T.visual)); #undef tuple return FINISHED(taskData, tupleHandle); } /******************************************************************************/ /* */ /* Polymorphic pairs */ /* */ /******************************************************************************/ class MLPair: public PolyObject { public: PolyWord x0; /* first value */ PolyWord x1; /* second value */ }; /* Polymorphic pair creation */ static Handle CreatePair(TaskData *taskData, Handle p1, Handle p2) { Handle pairHandle = alloc_and_save(taskData, SIZEOF(MLPair), F_MUTABLE_BIT); /* Still allocating, so must use explicit DEREF for each element */ #define pair ((MLPair *)DEREFHANDLE(pairHandle)) pair->x0 = DEREFWORD(p1); pair->x1 = DEREFWORD(p2); #undef pair return FINISHED(taskData, pairHandle); } /******************************************************************************/ /* */ /* Polymorphic triples */ /* */ /******************************************************************************/ class MLTriple: public PolyObject { public: PolyWord x0; /* first value */ PolyWord x1; /* second value */ PolyWord x2; /* third value */ }; inline PolyWord FST(PolyWord P) { return ((MLTriple*)P.AsObjPtr())->x0; } inline PolyWord SND(PolyWord P) { return ((MLTriple*)P.AsObjPtr())->x1; } inline PolyWord THIRD(PolyWord P) { return ((MLTriple*)P.AsObjPtr())->x2; } static Handle CreateTriple(TaskData *taskData, Handle p1, Handle p2, Handle p3) { Handle tripleHandle = alloc_and_save(taskData, SIZEOF(MLTriple), F_MUTABLE_BIT); /* Still allocating, so must use explicit DEREF for each element */ #define triple ((MLTriple *)DEREFHANDLE(tripleHandle)) triple->x0 = DEREFWORD(p1); triple->x1 = DEREFWORD(p2); triple->x2 = DEREFWORD(p3); #undef triple return FINISHED(taskData, tripleHandle); } /******************************************************************************/ /* */ /* MLXImage - Implements ML XImage datatype */ /* */ /******************************************************************************/ typedef struct { PolyWord data; /* ML (abstype containing) string */ PolyWord size; /* MLXRectangle * */ PolyWord depth; /* ML int */ PolyWord format; /* (short ML int) XYBitmap | XYPixmap | ZPixmap */ PolyWord xoffset; /* ML int */ PolyWord bitmapPad; /* ML int */ PolyWord byteOrder; /* (short ML int) LSBFirst | MSBFirst */ PolyWord bitmapUnit; /* ML int */ PolyWord bitsPerPixel; /* ML int */ PolyWord bytesPerLine; /* ML int */ PolyWord visualRedMask; /* ML int */ PolyWord bitmapBitOrder; /* (short ML int) LSBFirst | MSBFirst */ PolyWord visualBlueMask; /* ML int */ PolyWord visualGreenMask; /* ML int */ } MLXImage; #define MLImageFormat(n) (n+1) #define MLImageOrder(n) (n+1) #define CImageFormat(n) (n-1) #define CImageOrder(n) (n-1) static unsigned ImageBytes(XImage *image) { unsigned dsize = image->bytes_per_line * image->height; if (image->format == XYPixmap) dsize = dsize * image->depth; return dsize; } static XImage *GetXImage(TaskData *taskData, Display *d, PolyWord p) /* can only be called once per X opcode */ { MLXImage *I = (MLXImage *)p.AsObjPtr(); static XImage image = { 0 }; PolyStringObject *data = GetString(I->data); unsigned width = GetRectW(taskData, I->size); unsigned height = GetRectH(taskData, I->size); unsigned depth = get_C_ulong(taskData, I->depth); unsigned format = get_C_ulong(taskData, I->format); int xoffset = get_C_short(taskData, I->xoffset); int bitmapPad = get_C_short(taskData, I->bitmapPad); int bytesPerLine = get_C_long (taskData, I->bytesPerLine); unsigned byteOrder = get_C_ulong(taskData, I->byteOrder); unsigned bitmapUnit = get_C_ulong(taskData, I->bitmapUnit); unsigned bitsPerPixel = get_C_ulong(taskData, I->bitsPerPixel); unsigned bitmapBitOrder = get_C_ulong(taskData, I->bitmapBitOrder); format = CImageFormat(format); byteOrder = CImageOrder(byteOrder); bitmapBitOrder = CImageOrder(bitmapBitOrder); image.width = width; image.height = height; image.xoffset = xoffset; image.format = format; image.data = data->chars; image.byte_order = byteOrder; image.bitmap_unit = bitmapUnit; image.bitmap_bit_order = bitmapBitOrder; image.bitmap_pad = bitmapPad; image.depth = depth; image.bytes_per_line = bytesPerLine; image.bits_per_pixel = bitsPerPixel; image.red_mask = get_C_ulong(taskData, I->visualRedMask); image.green_mask = get_C_ulong(taskData, I->visualGreenMask); image.blue_mask = get_C_ulong(taskData, I->visualBlueMask); if (ImageBytes(&image) != data->length) RaiseXWindows(taskData, "Bad image string length"); XInitImage(&image); return ℑ } static Handle CreateImage(TaskData *taskData, XImage *image) { Handle XHandle = alloc_and_save(taskData, SIZEOF(MLXImage), F_MUTABLE_BIT); int dsize = ImageBytes(image); /* Still allocating, so must use explicit DEREF for each element */ #define X ((MLXImage *)DEREFHANDLE(XHandle)) X->data = C_string_to_Poly(taskData, image->data,dsize); X->size = DEREFWORD(CreateArea(image->width,image->height)); X->depth = DEREFWORD(Make_arbitrary_precision(taskData, image->depth)); X->format = DEREFWORD(Make_arbitrary_precision(taskData, MLImageFormat(image->format))); X->xoffset = DEREFWORD(Make_int(image->xoffset)); X->bitmapPad = DEREFWORD(Make_int(image->bitmap_pad)); X->byteOrder = DEREFWORD(Make_arbitrary_precision(taskData, MLImageOrder(image->byte_order))); X->bitmapUnit = DEREFWORD(Make_arbitrary_precision(taskData, image->bitmap_unit)); X->bitsPerPixel = DEREFWORD(Make_arbitrary_precision(taskData, image->bits_per_pixel)); X->bytesPerLine = DEREFWORD(Make_int(image->bytes_per_line)); X->visualRedMask = DEREFWORD(Make_arbitrary_precision(taskData, image->red_mask)); X->bitmapBitOrder = DEREFWORD(Make_arbitrary_precision(taskData, MLImageOrder(image->bitmap_bit_order))); X->visualBlueMask = DEREFWORD(Make_arbitrary_precision(taskData, image->blue_mask)); X->visualGreenMask = DEREFWORD(Make_arbitrary_precision(taskData, image->green_mask)); #undef X XDestroyImage(image); return FINISHED(taskData, XHandle); } static Handle GetImage ( TaskData *taskData, Display *d, Drawable drawable, int x, int y, unsigned w, unsigned h, unsigned /* long */ mask, int format ) { XImage *image = XGetImage(d,drawable,x,y,w,h,mask,CImageFormat(format)); if (image == 0) RaiseXWindows(taskData, "XGetImage failed"); return CreateImage(taskData, image); } static Handle SubImage ( TaskData *taskData, XImage *image, int x, int y, unsigned w, unsigned h ) { XImage *subimage = XSubImage(image,x,y,w,h); if (subimage == 0) RaiseXWindows(taskData, "XSubImage failed"); return CreateImage(taskData, subimage); } /******************************************************************************/ /* */ /* XImage */ /* */ /******************************************************************************/ static void GetSubImage ( Display *d, Drawable drawable, int sx, int sy, unsigned sw, unsigned sh, unsigned /* long */ mask, int format, XImage *image, int dx, int dy ) { XGetSubImage(d,drawable,sx,sy,sw,sh,mask,CImageFormat(format),image,dx,dy); /* XFree((char *)image); */ } static void PutImage ( Display *d, Drawable drawable, GC gc, XImage *image, int sx, int sy, int dx, int dy, unsigned dw, unsigned dh ) { XPutImage(d,drawable,gc,image,sx,sy,dx,dy,dw,dh); /* XFree((char *)image); */ } static Handle GetPixel(TaskData *taskData, XImage *image, int x, int y) { unsigned pixel = XGetPixel(image,x,y); /* XFree((char *)image); */ return Make_arbitrary_precision(taskData, pixel); } static void PutPixel(XImage *image, int x, int y, unsigned pixel) { XPutPixel(image,x,y,pixel); /* XFree((char *)image); */ } static void AddPixel(XImage *image, unsigned value) { XAddPixel(image,value); /* XFree((char *)image); */ } /******************************************************************************/ /* */ /* TimeVal */ /* */ /******************************************************************************/ static int DoubleClickTime = 250; /* Double click time in milliseconds */ static int MouseDrift = 5; /* Mouse movement allowed in button events */ static void NormaliseTime(TimeVal *t) { while(t->tv_usec >= 1000000) { t->tv_usec -= 1000000; t->tv_sec++; } while(t->tv_usec < 0) { t->tv_usec += 1000000; t->tv_sec--; } } static void TimeAdd(TimeVal *a, TimeVal *b, TimeVal *t) { t->tv_sec = a->tv_sec + b->tv_sec; t->tv_usec = a->tv_usec + b->tv_usec; NormaliseTime(t); } static int TimeLt(TimeVal *a, TimeVal *b) { return ((a->tv_sec < b->tv_sec) || ((a->tv_sec == b->tv_sec) && (a->tv_usec < b->tv_usec))); } static int TimeLeq(TimeVal *a, TimeVal *b) { return ((a->tv_sec < b->tv_sec) || ((a->tv_sec == b->tv_sec) && (a->tv_usec <= b->tv_usec))); } /******************************************************************************/ /* */ /* (?) */ /* */ /******************************************************************************/ typedef struct { XButtonEvent *button; /* initial button press event */ int up,down; /* count of button transitions */ } PredicateArgs; static Bool SameClickEvent(Display *dpy, XEvent *ev, XPointer arg) { PredicateArgs *A = (PredicateArgs *)arg; switch(ev->type) { case MotionNotify: { int dx = ev->xmotion.x - A->button->x; int dy = ev->xmotion.y - A->button->y; if (ev->xmotion.window != A->button->window) return False; if (abs(dx) > MouseDrift) return False; if (abs(dy) > MouseDrift) return False; return True; } case ButtonPress: case ButtonRelease: { int dx = ev->xbutton.x - A->button->x; int dy = ev->xbutton.y - A->button->y; if (ev->xbutton.window != A->button->window) return False; if (ev->xbutton.button != A->button->button) return False; if (abs(dx) > MouseDrift) return False; if (abs(dy) > MouseDrift) return False; if (ev->type == ButtonPress) A->down++; else A->up++; return True; } } return False; } static void WaitDoubleClickTime(Handle dsHandle, PredicateArgs *A) { XEvent N; TimeVal start_time,end_time,dt; Display *d = DEREFDISPLAYHANDLE(dsHandle)->display; /* AIX doesn't document support for NULL pointers in the select call, so we have to initialise empty fd_sets instead. SPF 30/10/95 */ fd_set read_fds, write_fds, except_fds; FD_ZERO(&read_fds); FD_ZERO(&write_fds); FD_ZERO(&except_fds); { int fd = d->fd; assert (0 <= fd && fd < FD_SETSIZE); FD_SET(fd,&read_fds); } gettimeofday(&start_time, NULL); dt.tv_sec = 0; dt.tv_usec = DoubleClickTime * 1000; TimeAdd(&start_time,&dt,&end_time); for (;;) { int extended = 0; while(XCheckIfEvent(d,&N,SameClickEvent,(char *) A)) { if (DEREFDISPLAYHANDLE(dsHandle)->app_context) XtDispatchEvent(&N); extended = 1; } if (QLength(d)) break; /* some other event to be processed next */ if (extended) /* button event extended, so extend time period */ { dt.tv_sec = 0; dt.tv_usec = DoubleClickTime * 1000; TimeAdd(&end_time,&dt,&end_time); } if (TimeLeq(&end_time,&start_time)) break; /* the time period has elapsed */ select(FD_SETSIZE,&read_fds,&write_fds,&except_fds,&dt); gettimeofday(&start_time, NULL); } } static Handle GetKeyVector(TaskData *taskData, void *k, unsigned i) { uchar *keys = (uchar*)k; unsigned index = i / 8; unsigned mask = 1 << (i % 8); return Make_bool(keys[index] & mask); } static Handle QueryKeymap(TaskData *taskData, Display *d) { char keys[32]; XQueryKeymap(d, keys); return CreateList4I(taskData, 256,keys,0,GetKeyVector); } /******************************************************************************/ /* */ /* EventName */ /* */ /******************************************************************************/ typedef struct { const char *name; int type; } EventName; static EventName EventNames[] = { { "KeyPress",KeyPress }, { "KeyRelease",KeyRelease }, { "ButtonPress",ButtonPress }, { "ButtonRelease",ButtonRelease }, { "MotionNotify",MotionNotify }, { "EnterNotify",EnterNotify }, { "LeaveNotify",LeaveNotify }, { "FocusIn",FocusIn }, { "FocusOut",FocusOut }, { "KeymapNotify",KeymapNotify }, { "Expose",Expose }, { "GraphicsExpose",GraphicsExpose }, { "NoExpose",NoExpose }, { "VisibilityNotify",VisibilityNotify }, { "CreateNotify",CreateNotify }, { "DestroyNotify",DestroyNotify }, { "UnmapNotify",UnmapNotify }, { "MapNotify",MapNotify }, { "MapRequest",MapRequest }, { "ReparentNotify",ReparentNotify }, { "ConfigureNotify",ConfigureNotify }, { "ConfigureRequest",ConfigureRequest }, { "GravityNotify",GravityNotify }, { "ResizeRequest",ResizeRequest }, { "CirculateNotify",CirculateNotify }, { "CirculateRequest",CirculateRequest }, { "PropertyNotify",PropertyNotify }, { "SelectionClear",SelectionClear }, { "SelectionRequest",SelectionRequest }, { "SelectionNotify",SelectionNotify }, { "ColormapNotify",ColormapNotify }, { "ClientMessage",ClientMessage }, { "MappingNotify",MappingNotify }, }; #define NEVENTS (sizeof(EventNames)/sizeof(EventName)) static const char *DebugEventName(int type) { for(unsigned i = 0; i < NEVENTS; i++) { if (EventNames[i].type == type) return EventNames[i].name; } return "** BAD EVENT **"; } static int WM_PROTOCOLS(Display *d) { static int protocols = None; if (protocols == None) protocols = XInternAtom(d,"WM_PROTOCOLS",True); return protocols; } static Atom WM_DELETE_WINDOW(Display *d) { static Atom deleteWindow = None; if (deleteWindow == None) deleteWindow = XInternAtom(d,"WM_DELETE_WINDOW",True); return deleteWindow; } /******************************************************************************/ /* */ /* Structures used by CreateEvent function. */ /* */ /* These typedefs should correspond with the tuples used by MakeXKeyEvent etc */ /* */ /******************************************************************************/ typedef struct { X_Window_Object *root; X_Window_Object *subwindow; PolyWord time; /* ML int */ MLXPoint *pointer; MLXPoint *rootPointer; PolyWord modifiers; /* ML modifier (int) */ PolyWord keycode; /* ML int */ } ML_KeyEvent_Data; typedef struct { X_Window_Object *root; X_Window_Object *subwindow; PolyWord time; /* ML int */ MLXPoint *pointer; MLXPoint *rootPointer; PolyWord modifiers; /* ML modifier (int) */ PolyWord button; /* ML int */ } ML_ButtonEvent_Data; typedef struct { X_Window_Object *root; X_Window_Object *subwindow; PolyWord time; /* ML int */ MLXPoint *pointer; MLXPoint *rootPointer; PolyWord modifiers; /* ML modifier (int) */ PolyWord button; /* ML int */ PolyWord up; /* ML int */ PolyWord down; /* ML int */ } ML_ButtonClick_Data; typedef struct { X_Window_Object *root; X_Window_Object *subwindow; PolyWord time; /* ML int */ MLXPoint *pointer; MLXPoint *rootPointer; PolyWord modifiers; /* ML modifier (int) */ PolyWord isHint; /* ML bool */ } ML_MotionEvent_Data; typedef struct { X_Window_Object *root; X_Window_Object *subwindow; PolyWord time; /* ML int */ MLXPoint *pointer; MLXPoint *rootPointer; PolyWord mode; /* ? */ PolyWord detail; /* ? */ PolyWord focus; /* ? */ PolyWord modifiers; /* ML modifier (int) */ } ML_CrossingEvent_Data; typedef struct { MLXRectangle *region; PolyWord count; /* ML int */ } ML_ExposeEvent_Data; typedef struct { X_Window_Object *window; MLXPoint *position; MLXRectangle *size; PolyWord borderWidth; /* ML int */ X_Window_Object *above; PolyWord overrideRedirect; /* ML bool */ } ML_ConfigureNotify_Data; typedef struct { X_Window_Object *window; MLXPoint *position; MLXRectangle *size; PolyWord borderWidth; X_Window_Object *above; PolyWord detail; /* ? */ } ML_ConfigureRequest_Data; typedef struct { MLXRectangle *region; PolyWord count; /* ML int */ PolyWord code; /* ML int */ } ML_GraphicsExposeEvent_Data; typedef struct { PolyWord mode; /* ML int ? */ PolyWord detail; /* ML int ? */ } ML_FocusChangeEvent_Data; typedef struct { X_Window_Object *window; MLXPoint *position; MLXRectangle *size; PolyWord borderWidth; /* ML int */ PolyWord overrideRedirect; /* ML bool */ } ML_CreateEvent_Data; typedef struct { X_Window_Object *window; PolyWord fromConfigure; /* ML bool */ } ML_UnmapEvent_Data; typedef struct { X_Window_Object *window; PolyWord overrideRedirect; /* ML bool */ } ML_MapEvent_Data; typedef struct { X_Window_Object *window; X_Window_Object *parent; MLXPoint *position; PolyWord overrideRedirect; /* ML bool */ } ML_ReparentEvent_Data; typedef struct { X_Window_Object *window; MLXPoint *position; } ML_GravityEvent_Data; typedef struct { X_Window_Object *window; PolyWord place; } ML_CirculateEvent_Data; typedef struct { X_Colormap_Object *colormap_object; PolyWord c_new; /* ML bool */ PolyWord installed; /* ML bool */ } ML_ColormapEvent_Data; typedef struct { PolyWord selection; /* ML int */ PolyWord time; /* ML int */ } ML_SelectionClear_Data; typedef struct { X_Window_Object *requestor; PolyWord selection; /* ML int */ PolyWord target; /* ML int */ PolyWord property; /* ML int */ PolyWord time; /* ML int */ } ML_SelectionRequest_Data; typedef struct { PolyWord selection; /* ML int */ PolyWord target; /* ML int */ PolyWord property; /* ML int */ PolyWord time; /* ML int */ } ML_Selection_Data; class ML_Event: public PolyObject { public: PolyWord type; /* ML (?) */ PolyWord sendEvent; /* ML bool */ PolyWord window; /* X_Window_Object* */ PolyWord data; /* pointer to event-specific data, in ML_XXX_Data format */ PolyWord callbacks; /* ML list of something */ PolyWord events; /* ML list */ }; /******************************************************************************/ /* */ /* CreateEvent function */ /* */ /******************************************************************************/ static Handle CreateEvent ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ XEvent *ev, Handle W /* Handle to (X_Window_Object *) */ ) { Handle eventHandle = alloc_and_save(taskData, SIZEOF(ML_Event), F_MUTABLE_BIT); Display *d = DEREFDISPLAYHANDLE(dsHandle)->display; int type = ev->xany.type; int send_event = ev->xany.send_event; assert(d == ev->xany.display); if (debugOptions & DEBUG_X) { printf("CreateEvent called, type=%s,", DebugEventName(type)); printf(" window=%lx\n", ev->xany.window); } #define event ((ML_Event *)DEREFHANDLE(eventHandle)) event->type = DEREFWORD(Make_arbitrary_precision(taskData, type)); event->sendEvent = DEREFWORD(Make_bool(send_event)); event->window = DEREFWINDOWHANDLE(W); switch(type) { case KeyPress: case KeyRelease: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_KeyEvent_Data), F_MUTABLE_BIT); #define data ((ML_KeyEvent_Data *)DEREFHANDLE(dataHandle)) data->root = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xkey.root)); data->subwindow = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xkey.subwindow)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xkey.time)); data->pointer = (MLXPoint *)DEREFHANDLE(CreatePoint(taskData, ev->xkey.x,ev->xkey.y)); data->rootPointer = (MLXPoint *)DEREFHANDLE(CreatePoint(taskData, ev->xkey.x_root,ev->xkey.y_root)); data->modifiers = DEREFWORD(Make_arbitrary_precision(taskData, ev->xkey.state)); data->keycode = DEREFWORD(Make_arbitrary_precision(taskData, ev->xkey.keycode)); #undef data event->data = DEREFHANDLE(FINISHED(taskData, dataHandle)); break; } case ButtonPress: case ButtonRelease: { if (DEREFWINDOWHANDLE(W)->eventMask->Get(0).AsUnsigned() & ButtonClickMask) { Handle dataHandle; PredicateArgs A; A.button = &ev->xbutton; A.up = (ev->type == ButtonRelease); A.down = (ev->type == ButtonPress); WaitDoubleClickTime(dsHandle,&A); dataHandle = alloc_and_save(taskData, SIZEOF(ML_ButtonClick_Data), F_MUTABLE_BIT); #define data ((ML_ButtonClick_Data *)DEREFHANDLE(dataHandle)) data->root = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xbutton.root)); data->subwindow = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xbutton.subwindow)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.time)); data->pointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xbutton.x,ev->xbutton.y)); data->rootPointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xbutton.x_root,ev->xbutton.y_root)); data->modifiers = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.state)); data->button = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.button)); data->up = DEREFWORD(Make_arbitrary_precision(taskData, A.up)); data->down = DEREFWORD(Make_arbitrary_precision(taskData, A.down)); #undef data event->type = DEREFWORD(Make_arbitrary_precision(taskData, 42)); /* What's this for? */ event->data = DEREFWORD(FINISHED(taskData, dataHandle)); } else { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_ButtonEvent_Data), F_MUTABLE_BIT); #define data ((ML_ButtonEvent_Data *)DEREFHANDLE(dataHandle)) data->root = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xbutton.root)); data->subwindow = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xbutton.subwindow)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.time)); data->pointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xbutton.x,ev->xbutton.y)); data->rootPointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xbutton.x_root,ev->xbutton.y_root)); data->modifiers = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.state)); data->button = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.button)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); } break; } case MotionNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_MotionEvent_Data), F_MUTABLE_BIT); #define data ((ML_MotionEvent_Data *)DEREFHANDLE(dataHandle)) data->root = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xmotion.root)); data->subwindow = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xmotion.subwindow)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xmotion.time)); data->pointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xmotion.x,ev->xmotion.y)); data->rootPointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xmotion.x_root,ev->xmotion.y_root)); data->modifiers = DEREFWORD(Make_arbitrary_precision(taskData, ev->xmotion.state)); data->isHint = DEREFWORD(Make_arbitrary_precision(taskData, ev->xmotion.is_hint)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case EnterNotify: case LeaveNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_CrossingEvent_Data), F_MUTABLE_BIT); #define data ((ML_CrossingEvent_Data *)DEREFHANDLE(dataHandle)) data->root = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xcrossing.root)); data->subwindow = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xcrossing.subwindow)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xcrossing.time)); data->pointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xcrossing.x,ev->xcrossing.y)); data->rootPointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xcrossing.x_root,ev->xcrossing.y_root)); data->mode = DEREFWORD(Make_arbitrary_precision(taskData, ev->xcrossing.mode)); data->detail = DEREFWORD(Make_arbitrary_precision(taskData, ev->xcrossing.detail)); data->focus = DEREFWORD(Make_bool(ev->xcrossing.focus)); data->modifiers = DEREFWORD(Make_arbitrary_precision(taskData, ev->xcrossing.state)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case Expose: { int left = ev->xexpose.x; int top = ev->xexpose.y; int right = left + ev->xexpose.width; int bottom = top + ev->xexpose.height; Handle dataHandle; while(XCheckTypedWindowEvent(d,ev->xexpose.window,Expose,ev)) { int L = ev->xexpose.x; int T = ev->xexpose.y; int R = L + ev->xexpose.width; int B = T + ev->xexpose.height; assert(ev->type == Expose); left = min(left,L); top = min(top,T); right = max(right,R); bottom = max(bottom,B); } dataHandle = alloc_and_save(taskData, SIZEOF(ML_ExposeEvent_Data), F_MUTABLE_BIT); #define data ((ML_ExposeEvent_Data *)DEREFHANDLE(dataHandle)) data->region = (MLXRectangle *)DEREFHANDLE(CreateRect(taskData, top,left,bottom,right)); data->count = DEREFWORD(Make_arbitrary_precision(taskData, 0)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case GraphicsExpose: { int left = ev->xgraphicsexpose.x; int top = ev->xgraphicsexpose.y; int right = left + ev->xgraphicsexpose.width; int bottom = top + ev->xgraphicsexpose.height; Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_GraphicsExposeEvent_Data), F_MUTABLE_BIT); #define data ((ML_GraphicsExposeEvent_Data *)DEREFHANDLE(dataHandle)) data->region = (MLXRectangle *)DEREFHANDLE(CreateRect(taskData, top,left,bottom,right)); data->count = DEREFWORD(Make_arbitrary_precision(taskData, ev->xgraphicsexpose.count)); data->code = DEREFWORD(Make_arbitrary_precision(taskData, ev->xgraphicsexpose.major_code)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case NoExpose: { event->data = DEREFWORD(Make_arbitrary_precision(taskData, ev->xnoexpose.major_code)); break; } case ConfigureNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_ConfigureNotify_Data), F_MUTABLE_BIT); #define data ((ML_ConfigureNotify_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xconfigure.window)); data->position = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xconfigure.x,ev->xconfigure.y)); data->size = (MLXRectangle *) DEREFHANDLE(CreateArea(ev->xconfigure.width,ev->xconfigure.height)); data->borderWidth = DEREFWORD(Make_int(ev->xconfigure.border_width)); data->above = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xconfigure.above)); data->overrideRedirect = DEREFWORD(Make_bool(ev->xconfigure.override_redirect)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case FocusIn: case FocusOut: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_FocusChangeEvent_Data), F_MUTABLE_BIT); #define data ((ML_FocusChangeEvent_Data *)DEREFHANDLE(dataHandle)) data->mode = DEREFWORD(Make_int(ev->xfocus.mode)); data->detail = DEREFWORD(Make_int(ev->xfocus.detail)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case VisibilityNotify: { event->data = DEREFWORD(Make_int(ev->xvisibility.state)); break; } case CreateNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_CreateEvent_Data), F_MUTABLE_BIT); #define data ((ML_CreateEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xcreatewindow.window)); data->position = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xcreatewindow.x,ev->xcreatewindow.y)); data->size = (MLXRectangle *) DEREFHANDLE(CreateArea(ev->xcreatewindow.width,ev->xcreatewindow.height)); data->borderWidth = DEREFWORD(Make_int(ev->xcreatewindow.border_width)); data->overrideRedirect = DEREFWORD(Make_bool(ev->xcreatewindow.override_redirect)); #undef data event->data = DEREFHANDLE(FINISHED(taskData, dataHandle)); break; } case DestroyNotify: { debugReclaim(Window,ev->xdestroywindow.window); event->data = DEREFWORD(EmptyWindow(taskData, dsHandle,ev->xdestroywindow.window)); break; } case UnmapNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_UnmapEvent_Data), F_MUTABLE_BIT); #define data ((ML_UnmapEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xunmap.window)); data->fromConfigure = DEREFWORD(Make_bool(ev->xunmap.from_configure)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case MapNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_MapEvent_Data), F_MUTABLE_BIT); #define data ((ML_MapEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xmap.window)); data->overrideRedirect = DEREFWORD(Make_bool(ev->xmap.override_redirect)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case MapRequest: { event->data = DEREFWORD(EmptyWindow(taskData, dsHandle,ev->xmaprequest.window)); break; } case ReparentNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_ReparentEvent_Data), F_MUTABLE_BIT); #define data ((ML_ReparentEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xreparent.window)); data->parent = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xreparent.parent)); data->position = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xreparent.x,ev->xreparent.y)); data->overrideRedirect = DEREFWORD(Make_bool(ev->xreparent.override_redirect)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case ConfigureRequest: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_ConfigureRequest_Data), F_MUTABLE_BIT); #define data ((ML_ConfigureRequest_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xconfigurerequest.window)); data->position = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xconfigurerequest.x,ev->xconfigurerequest.y)); data->size = (MLXRectangle *) DEREFHANDLE(CreateArea(ev->xconfigurerequest.width,ev->xconfigurerequest.height)); data->borderWidth = DEREFWORD(Make_int(ev->xconfigurerequest.border_width)); data->above = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xconfigurerequest.above)); data->detail = DEREFWORD(Make_int(ev->xconfigurerequest.detail)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case GravityNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_GravityEvent_Data), F_MUTABLE_BIT); #define data ((ML_GravityEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xgravity.window)); data->position = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xgravity.x,ev->xgravity.y)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case ResizeRequest: { event->data = DEREFWORD(CreateArea(ev->xresizerequest.width,ev->xresizerequest.height)); break; } case CirculateNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_CirculateEvent_Data), F_MUTABLE_BIT); #define data ((ML_CirculateEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xcirculate.window)); data->place = DEREFWORD(Make_int(ev->xcirculate.place)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case CirculateRequest: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_CirculateEvent_Data), F_MUTABLE_BIT); #define data ((ML_CirculateEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xcirculaterequest.window)); data->place = DEREFWORD(Make_int(ev->xcirculaterequest.place)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case ColormapNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_ColormapEvent_Data), F_MUTABLE_BIT); #define data ((ML_ColormapEvent_Data *)DEREFHANDLE(dataHandle)) data->colormap_object = (X_Colormap_Object *)DEREFHANDLE(EmptyColormap(taskData, dsHandle,ev->xcolormap.colormap)); data->c_new = DEREFWORD(Make_bool(ev->xcolormap.c_new)); data->installed = DEREFWORD(Make_bool(ev->xcolormap.state == ColormapInstalled)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case MappingNotify: { XRefreshKeyboardMapping((XMappingEvent *)ev); /* cast added SPF 6/1/94 */ return 0; /* HACK !!!! */ } case SelectionClear: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_SelectionClear_Data), F_MUTABLE_BIT); #define data ((ML_SelectionClear_Data *)DEREFHANDLE(dataHandle)) data->selection = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionclear.selection)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionclear.time)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case SelectionNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_Selection_Data), F_MUTABLE_BIT); #define data ((ML_Selection_Data *)DEREFHANDLE(dataHandle)) data->selection = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselection.selection)); data->target = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselection.target)); data->property = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselection.property)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselection.time)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case SelectionRequest: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_SelectionRequest_Data), F_MUTABLE_BIT); #define data ((ML_SelectionRequest_Data *)DEREFHANDLE(dataHandle)) data->requestor = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xselectionrequest.requestor)); data->selection = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionrequest.selection)); data->target = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionrequest.target)); data->property = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionrequest.property)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionrequest.time)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case ClientMessage: { unsigned protocols = WM_PROTOCOLS(d); int deleteWindow = WM_DELETE_WINDOW(d); if (protocols != None && deleteWindow != None && ev->xclient.message_type == protocols && ev->xclient.format == 32 && ev->xclient.data.l[0] == deleteWindow) { event->type = DEREFWORD(Make_arbitrary_precision(taskData, 43)); /* (?) */ break; } else return 0; } case PropertyNotify: return 0; case KeymapNotify: return 0; /* Broken: the window field does not tell me the window requesting this event */ default: Crash ("Bad event type %x",ev->type); } event->callbacks = FList; /* Safe, since FList is a Root */ FList = TAGGED(0); event->events = GList; /* Safe, since GList is a Root */ GList = TAGGED(0); return FINISHED(taskData, eventHandle); #undef event } /******************************************************************************/ /* */ /* HERE */ /* */ /******************************************************************************/ static Handle LookupString(TaskData *taskData, Display *d, unsigned keycode, unsigned modifiers) { XKeyEvent ev; int n; KeySym keysym; /* was int SPF 6/1/94 */ char buffer[500]; ev.display = d; ev.keycode = keycode; ev.state = modifiers; n = XLookupString(&ev,buffer,sizeof(buffer)-1,&keysym,NULL); buffer[n] = '\0'; return CreatePair(taskData, Make_string(buffer),Make_arbitrary_precision(taskData, keysym)); } static Handle GetScreenSaver(TaskData *taskData, Display *d) { int timeout,interval,blanking,exposures; Handle tuple; XGetScreenSaver(d,&timeout,&interval,&blanking,&exposures); tuple = alloc_and_save(taskData, 4, F_MUTABLE_BIT); #define data DEREFHANDLE(tuple) data->Set(0, DEREFWORD(Make_int(timeout))); data->Set(1, DEREFWORD(Make_int(interval))); data->Set(2, DEREFWORD(Make_arbitrary_precision(taskData, blanking))); data->Set(3, DEREFWORD(Make_arbitrary_precision(taskData, exposures))); #undef data return FINISHED(taskData, tuple); } static Handle TranslateCoordinates ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window src, Window dst, int x, int y ) { Window child; int dx,dy,s; s = XTranslateCoordinates(DEREFDISPLAYHANDLE(dsHandle)->display,src,dst,x,y,&dx,&dy,&child); if (s == 0) RaiseXWindows(taskData, "XTranslateCoordinates failed"); return CreatePair(taskData, CreatePoint(taskData, dx,dy),EmptyWindow(taskData, dsHandle,child)); } static Handle QueryBest ( TaskData *taskData, int (*f)(Display*, Drawable, unsigned, unsigned, unsigned *, unsigned *), Display *d, Drawable drawable, unsigned width, unsigned height ) { unsigned W,H; int s = (* f)(d,drawable,width,height,&W,&H); if (s == 0) RaiseXWindows(taskData, "XQueryBest failed"); return CreateArea(W,H); } static Handle QueryPointer ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w ) { Window root,child; int rootX,rootY; int winX,winY; unsigned mask; int s; Handle tuple; s = XQueryPointer(DEREFDISPLAYHANDLE(dsHandle)->display,w,&root,&child,&rootX,&rootY,&winX,&winY,&mask); tuple = alloc_and_save(taskData, 6, F_MUTABLE_BIT); #define data DEREFHANDLE(tuple) data->Set(0, DEREFWORD(Make_arbitrary_precision(taskData, s))); data->Set(1, DEREFWORD(EmptyWindow(taskData, dsHandle,root))); data->Set(2, DEREFWORD(EmptyWindow(taskData, dsHandle,child))); data->Set(3, DEREFWORD(CreatePoint(taskData, rootX,rootY))); data->Set(4, DEREFWORD(CreatePoint(taskData, winX,winY))); data->Set(5, DEREFWORD(Make_arbitrary_precision(taskData, mask))); #undef data return FINISHED(taskData, tuple); } static Handle ReadBitmap ( TaskData *taskData, Handle dsHandle, /* handle to (X_Display_Object *) */ Drawable w, PolyStringObject *string ) { unsigned width,height; char name[500]; int s,xhot,yhot; Pixmap pixmap; Handle tuple; Poly_string_to_C(string,name,sizeof(name)); s = XReadBitmapFile(DEREFDISPLAYHANDLE(dsHandle)->display,w,name,&width,&height,&pixmap,&xhot,&yhot); tuple = alloc_and_save(taskData, 4, F_MUTABLE_BIT); #define data DEREFHANDLE(tuple) data->Set(0,DEREFWORD(Make_arbitrary_precision(taskData, s))); if (s == BitmapSuccess) { data->Set(1, DEREFWORD(EmptyPixmap(taskData, dsHandle,pixmap))); data->Set(2, DEREFWORD(CreateArea(width,height))); data->Set(3, DEREFWORD(CreatePoint(taskData, xhot,yhot))); } /******************** What if we don't succeed? Badly-formed tuple !!!! */ #undef data return FINISHED(taskData, tuple); } static Handle WriteBitmapFile ( TaskData *taskData, PolyStringObject *string, Display *d, Pixmap bitmap, unsigned w, unsigned h, int x, int y ) { char name[500]; int s; Poly_string_to_C(string,name,sizeof(name)); s = XWriteBitmapFile(d,name,bitmap,w,h,x,y); return Make_arbitrary_precision(taskData, s); } static Handle GetDefault(TaskData *taskData, Display *d, PolyStringObject *s1, PolyStringObject *s2) { char program[500]; char option[500]; char *s; Poly_string_to_C(s1,program,sizeof(program)); Poly_string_to_C(s2,option ,sizeof(option)); s = XGetDefault(d,program,option); if (s == NULL) RaiseXWindows(taskData, "XGetDefault failed"); return Make_string(s); } static void GetWindows(TaskData *taskData, PolyWord p, void *w, unsigned) { *(Window *)w = GetWindow(taskData, (X_Object *)p.AsObjPtr()); } static void GetSegments(TaskData *taskData, PolyWord pp, void *w, unsigned) { XSegment *A = (XSegment *)w; PolyObject *p = pp.AsObjPtr(); A->x1 = GetPointX(taskData, p->Get(0)); A->y1 = GetPointY(taskData, p->Get(0)); A->x2 = GetPointX(taskData, p->Get(1)); A->y2 = GetPointY(taskData, p->Get(1)); } static void GetChar2(TaskData *taskData, PolyWord p, void *v, unsigned) { XChar2b *A = (XChar2b *)v; unsigned short u = get_C_ushort(taskData, p); A->byte1 = u >> 8; A->byte2 = u &0xFF; } static void CopyString(TaskData *, PolyWord w, void *v, unsigned) { char **p = (char**)v; PolyStringObject *s = GetString(w); POLYUNSIGNED n = s->length+1; *p = (char*)malloc(n); Poly_string_to_C(s,*p,n); } static void GetText(TaskData *taskData, PolyWord p, void *w, unsigned) { XTextItem *A = (XTextItem *)w; PolyObject *obj = p.AsObjPtr(); CopyString(taskData, obj->Get(0), &A->chars, 0); A->nchars = strlen(A->chars); A->delta = get_C_short(taskData, obj->Get(1)); A->font = GetFont(taskData, (X_Object *)obj->Get(2).AsObjPtr()); } static void GetText16(TaskData *taskData, PolyWord p, void *v, unsigned) { XTextItem16 *A = (XTextItem16 *)v; PolyObject *obj = p.AsObjPtr(); unsigned N = ListLength(obj->Get(0)); XChar2b *L = (XChar2b *) malloc(N * sizeof(XChar2b)); GetList4(taskData,obj->Get(0),L,sizeof(XChar2b),GetChar2); A->chars = L; A->nchars = N; A->delta = get_C_short(taskData, obj->Get(1)); A->font = GetFont(taskData, (X_Object *)obj->Get(2).AsObjPtr()); } typedef void (*GetFunc)(TaskData *taskData, PolyWord, void*, unsigned); static void SetClipRectangles ( TaskData *taskData, Display *d, GC gc, int x, int y, Handle list, unsigned order ) { if (ISNIL(DEREFWORD(list))) { XSetClipRectangles(d,gc,x,y,NULL,0,order); } else { unsigned N = ListLength(DEREFWORD(list)); XRectangle *L = (XRectangle *) alloca(N * sizeof(XRectangle)); GetList4(taskData, DEREFWORD(list),L,sizeof(XRectangle),GetRects); XSetClipRectangles(d,gc,x,y,L,N,order); } } static void GetUChars(TaskData *taskData, PolyWord p, void *u, unsigned) { *(uchar*)u = get_C_uchar(taskData, p); } static void SetDashes ( TaskData *taskData, Display *d, GC gc, unsigned offset, Handle list ) { if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); char *D = (char *) alloca(N); GetList4(taskData,DEREFWORD(list),D,sizeof(uchar),GetUChars); XSetDashes(d,gc,offset,D,N); } } static Handle CreateDrawable ( TaskData *taskData, void *p, Handle dsHandle /* Handle to (X_Display_Object *) */ ) { return EmptyWindow(taskData, dsHandle,*(Window*)p); } static Handle QueryTree ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w ) { Window root,parent,*children; unsigned n; Handle data; int s = XQueryTree(DEREFDISPLAYHANDLE(dsHandle)->display,w,&root,&parent,&children,&n); if (s == 0) RaiseXWindows(taskData, "XQueryTree failed"); data = CreateTriple(taskData, EmptyWindow(taskData, dsHandle,root), EmptyWindow(taskData, dsHandle,parent), CreateList5(taskData, n,children,sizeof(Window),CreateDrawable,dsHandle)); if (n) XFree((char *)children); return data; } static void RestackWindows(TaskData *taskData, Handle list /* handle to list of X_Window_Objects (?) */) { if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); Window *W = (Window *) alloca(N * sizeof(Window)); Display *d = GetDisplay(taskData, (X_Object *)DEREFLISTHANDLE(list)->h.AsObjPtr()); GetList4(taskData, DEREFWORD(list),W,sizeof(Window),GetWindows); XRestackWindows(d,W,N); } } static Handle GetGeometry ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Drawable w ) { int x,y; unsigned width,height,borderWidth,depth; Window root; Handle dataHandle; int s = XGetGeometry(DEREFDISPLAYHANDLE(dsHandle)->display,w,&root,&x,&y,&width,&height,&borderWidth,&depth); if (s == 0) RaiseXWindows(taskData, "XGetGeometry failed"); dataHandle = alloc_and_save(taskData, 5, F_MUTABLE_BIT); #define data DEREFHANDLE(dataHandle) data->Set(0, DEREFWORD(EmptyWindow(taskData, dsHandle,root))); data->Set(1, DEREFWORD(CreatePoint(taskData, x,y))); data->Set(2, DEREFWORD(CreateArea(width,height))); data->Set(3, DEREFWORD(Make_arbitrary_precision(taskData, borderWidth))); data->Set(4, DEREFWORD(Make_arbitrary_precision(taskData, depth))); #undef data return FINISHED(taskData, dataHandle); } static Handle GetWindowAttributes ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Drawable w ) { XWindowAttributes wa; Handle dataHandle; int s = XGetWindowAttributes(DEREFDISPLAYHANDLE(dsHandle)->display,w,&wa); if (s == 0) RaiseXWindows(taskData, "XGetWindowAttributes failed"); dataHandle = alloc_and_save(taskData, 20, F_MUTABLE_BIT); /* HACKY - should define struct? */ DEREFHANDLE(dataHandle)->Set( 0, DEREFWORD(CreatePoint(taskData, wa.x,wa.y))); DEREFHANDLE(dataHandle)->Set( 1, DEREFWORD(CreateArea(wa.width,wa.height))); DEREFHANDLE(dataHandle)->Set( 2, DEREFWORD(Make_int(wa.border_width))); DEREFHANDLE(dataHandle)->Set( 3, DEREFWORD(Make_arbitrary_precision(taskData, wa.depth))); DEREFHANDLE(dataHandle)->Set( 4, DEREFWORD(EmptyVisual(taskData, dsHandle,wa.visual))); DEREFHANDLE(dataHandle)->Set( 5, DEREFWORD(EmptyWindow(taskData, dsHandle,wa.root))); DEREFHANDLE(dataHandle)->Set( 6, DEREFWORD(Make_arbitrary_precision(taskData, wa.c_class))); DEREFHANDLE(dataHandle)->Set( 7, DEREFWORD(Make_arbitrary_precision(taskData, wa.bit_gravity))); DEREFHANDLE(dataHandle)->Set( 8, DEREFWORD(Make_arbitrary_precision(taskData, wa.win_gravity))); DEREFHANDLE(dataHandle)->Set( 9, DEREFWORD(Make_arbitrary_precision(taskData, wa.backing_store))); DEREFHANDLE(dataHandle)->Set(10, DEREFWORD(Make_arbitrary_precision(taskData, wa.backing_planes))); DEREFHANDLE(dataHandle)->Set(11, DEREFWORD(Make_arbitrary_precision(taskData, wa.backing_pixel))); DEREFHANDLE(dataHandle)->Set(12, DEREFWORD(Make_bool(wa.save_under))); DEREFHANDLE(dataHandle)->Set(13, DEREFWORD(EmptyColormap(taskData, dsHandle,wa.colormap))); DEREFHANDLE(dataHandle)->Set(14, DEREFWORD(Make_bool(wa.map_installed))); DEREFHANDLE(dataHandle)->Set(15, DEREFWORD(Make_arbitrary_precision(taskData, wa.map_state))); DEREFHANDLE(dataHandle)->Set(16, DEREFWORD(Make_arbitrary_precision(taskData, wa.all_event_masks))); DEREFHANDLE(dataHandle)->Set(17, DEREFWORD(Make_arbitrary_precision(taskData, wa.your_event_mask))); DEREFHANDLE(dataHandle)->Set(18, DEREFWORD(Make_arbitrary_precision(taskData, wa.do_not_propagate_mask))); DEREFHANDLE(dataHandle)->Set(19, DEREFWORD(Make_bool(wa.override_redirect))); return FINISHED(taskData, dataHandle); } static void ChangeWindowAttributes ( TaskData *taskData, X_Window_Object *W, unsigned n, PolyWord P ) { XSetWindowAttributes a; unsigned mask = 1 << n; switch(mask) { case CWBitGravity: a.bit_gravity = get_C_ulong(taskData, P); break; case CWWinGravity: a.win_gravity = get_C_ulong(taskData, P); break; case CWBackingStore: a.backing_store = get_C_ulong(taskData, P); break; case CWBackingPlanes: a.backing_planes = get_C_ulong(taskData, P); break; case CWBackingPixel: a.backing_pixel = get_C_ulong(taskData, P); break; case CWOverrideRedirect: a.override_redirect = get_C_ulong(taskData, P); break; case CWSaveUnder: a.save_under = get_C_ulong(taskData, P); break; case CWEventMask: a.event_mask = get_C_ulong(taskData, P); break; case CWDontPropagate: a.do_not_propagate_mask = get_C_ulong(taskData, P); break; case CWBackPixel: a.background_pixel = get_C_ulong(taskData, P); W->backgroundPixmap = 0; break; case CWBackPixmap: a.background_pixmap = GetPixmap(taskData, (X_Object *)P.AsObjPtr()); W->backgroundPixmap = PixmapObject((X_Object *)P.AsObjPtr()); break; case CWBorderPixel: a.border_pixel = get_C_ulong(taskData, P); W->borderPixmap = 0; break; case CWBorderPixmap: a.border_pixmap = GetPixmap(taskData, (X_Object *)P.AsObjPtr()); W->borderPixmap = PixmapObject((X_Object *)P.AsObjPtr()); break; case CWColormap: a.colormap = GetColormap(taskData, (X_Object *)P.AsObjPtr()); W->colormap_object = ColormapObject((X_Object *)P.AsObjPtr()); break; case CWCursor: a.cursor = GetCursor(taskData, (X_Object *)P.AsObjPtr()); W->cursor_object = CursorObject((X_Object *)P.AsObjPtr()); break; default: Crash ("Bad window mask %u",mask); } XChangeWindowAttributes(GetDisplay(taskData, (X_Object *)W),GetWindow(taskData, (X_Object *)W),mask,&a); } static void ConfigureWindow ( TaskData *taskData, Display *d, Window w, PolyWord tup /* (P,S,w,d,s,flags) */ ) { PolyObject *tuple = tup.AsObjPtr(); XWindowChanges wc; unsigned mask = get_C_ulong(taskData, tuple->Get(5)); CheckZeroRect(taskData, tuple->Get(1)); wc.x = GetPointX (taskData,tuple->Get(0)); wc.y = GetPointY (taskData,tuple->Get(0)); wc.width = GetRectW (taskData,tuple->Get(1)); wc.height = GetRectH (taskData,tuple->Get(1)); wc.border_width = get_C_ulong(taskData, tuple->Get(2)); wc.sibling = GetWindow (taskData,(X_Object *)tuple->Get(3).AsObjPtr()); wc.stack_mode = get_C_ulong(taskData, tuple->Get(4)); XConfigureWindow(d,w,mask,&wc); } /* The order of these depends on the XColor datatype */ typedef struct { PolyWord red; /* ML bool */ PolyWord blue; /* ML bool */ PolyWord doRed; /* ML bool */ PolyWord green; /* ML int */ PolyWord pixel; /* ML int */ PolyWord doBlue; /* ML int */ PolyWord doGreen; /* ML int */ } MLXColor; /* in Poly heap */ static void ClearXColor(XColor *x) { x->red = x->green = x->blue = x->pixel = x->flags = 0; } static Handle CreateXColor(TaskData *taskData, XColor *x) { Handle XHandle = alloc_and_save(taskData, SIZEOF(MLXColor), F_MUTABLE_BIT); #define X ((MLXColor *)DEREFHANDLE(XHandle)) X->red = DEREFWORD(Make_arbitrary_precision(taskData, x->red)); X->green = DEREFWORD(Make_arbitrary_precision(taskData, x->green)); X->blue = DEREFWORD(Make_arbitrary_precision(taskData, x->blue)); X->pixel = DEREFWORD(Make_arbitrary_precision(taskData, x->pixel)); X->doRed = DEREFWORD(Make_bool(x->flags &DoRed)); X->doGreen = DEREFWORD(Make_bool(x->flags &DoGreen)); X->doBlue = DEREFWORD(Make_bool(x->flags &DoBlue)); #undef X return FINISHED(taskData, XHandle); } static Handle CreateXColorF(TaskData *taskData, void *p) { return CreateXColor(taskData, (XColor*)p); } static XColor xcolor1 = { 0 }; static XColor xcolor2 = { 0 }; static void GetXColor(TaskData *taskData, PolyWord p, void *v, unsigned) { MLXColor *P = (MLXColor *)p.AsObjPtr(); XColor *x = (XColor *)v; x->red = get_C_ushort(taskData, P->red); x->green = get_C_ushort(taskData, P->green); x->blue = get_C_ushort(taskData, P->blue); x->pixel = get_C_ulong (taskData, P->pixel); x->flags = (DoRed * get_C_ulong(taskData, P->doRed)) | (DoGreen * get_C_ulong(taskData, P->doGreen)) | (DoBlue * get_C_ulong(taskData, P->doBlue)); } static XColor *GetXColor1(TaskData *taskData, PolyWord P) { GetXColor(taskData, P, &xcolor1, 0); return &xcolor1; } static XColor *GetXColor2(TaskData *taskData, PolyWord P) { GetXColor(taskData, P, &xcolor2, 0); return &xcolor2; } static Handle AllocColor(TaskData *taskData, Display *d, Colormap cmap, XColor *x) { int s = XAllocColor(d,cmap,x); if (s == 0) RaiseXWindows(taskData, "XAllocColor failed"); return CreateXColor(taskData, x); } static Handle CreateUnsigned(TaskData *taskData, void *q) { unsigned *p = (unsigned *)q; return Make_arbitrary_precision(taskData, *p); } static Handle CreateUnsignedLong(TaskData *taskData, void *p) { return Make_arbitrary_precision(taskData, *(unsigned long*)p); } static Handle AllocColorCells ( TaskData *taskData, Display *d, Colormap cmap, unsigned contig, unsigned nplanes, unsigned ncolors ) { unsigned long *masks; /* was unsigned SPF 6/1/94 */ unsigned long *pixels; /* was unsigned SPF 6/1/94 */ int s; if (ncolors < 1) RaiseRange(taskData); masks = (unsigned long *) alloca(nplanes * sizeof(unsigned long)); pixels = (unsigned long *) alloca(ncolors * sizeof(unsigned long)); s = XAllocColorCells(d,cmap,contig,masks,nplanes,pixels,ncolors); if (s == 0) RaiseXWindows (taskData, "XAllocColorCells failed"); return CreatePair(taskData, CreateList4(taskData,nplanes,masks ,sizeof(unsigned long),CreateUnsignedLong), CreateList4(taskData,ncolors,pixels,sizeof(unsigned long),CreateUnsignedLong)); } static Handle AllocColorPlanes ( TaskData *taskData, Display *d, Colormap cmap, unsigned contig, unsigned ncolors, unsigned nreds, unsigned ngreens, unsigned nblues ) { unsigned long rmask; /* was unsigned SPF 6/1/94 */ unsigned long gmask; /* was unsigned SPF 6/1/94 */ unsigned long bmask; /* was unsigned SPF 6/1/94 */ unsigned long *pixels; /* was unsigned SPF 6/1/94 */ Handle tuple; int s; if (ncolors < 1) RaiseRange(taskData); pixels = (unsigned long *) alloca(ncolors * sizeof(unsigned long)); s = XAllocColorPlanes(d,cmap,contig,pixels,ncolors,nreds,ngreens,nblues,&rmask,&gmask,&bmask); if (s == 0) RaiseXWindows (taskData, "XAllocColorPlanes failed"); tuple = alloc_and_save(taskData, 4, F_MUTABLE_BIT); #define data DEREFHANDLE(tuple) data->Set(0, DEREFWORD(CreateList4(taskData,ncolors,pixels,sizeof(unsigned long),CreateUnsignedLong))); data->Set(1, DEREFWORD(Make_arbitrary_precision(taskData, rmask))); data->Set(2, DEREFWORD(Make_arbitrary_precision(taskData, gmask))); data->Set(3, DEREFWORD(Make_arbitrary_precision(taskData, bmask))); #undef data return FINISHED(taskData, tuple); } static Handle AllocNamedColor(TaskData *taskData, Display *d, Colormap cmap, PolyStringObject *string) { char name[500]; int s; XColor hardware; XColor database; ClearXColor(&hardware); ClearXColor(&database); Poly_string_to_C(string,name,sizeof(name)); s = XAllocNamedColor(d,cmap,name,&hardware,&database); if (s == 0) RaiseXWindows (taskData, "XAllocNamedColor failed"); return CreatePair(taskData, CreateXColor(taskData, &hardware),CreateXColor(taskData, &database)); } static Handle LookupColor(TaskData *taskData, Display *d, Colormap cmap, PolyStringObject *string) { char name[500]; int s; XColor hardware; XColor database; ClearXColor(&hardware); ClearXColor(&database); Poly_string_to_C(string,name,sizeof(name)); s = XLookupColor(d,cmap,name,&database,&hardware); if (s == 0) RaiseXWindows (taskData, "XLookupColor failed"); return CreatePair(taskData, CreateXColor(taskData, &database),CreateXColor(taskData, &hardware)); } static Handle ParseColor(TaskData *taskData, Display *d, Colormap cmap, PolyStringObject *string) { char name[500]; int s; XColor x; ClearXColor(&x); Poly_string_to_C(string,name,sizeof(name)); s = XParseColor(d,cmap,name,&x); if (s == 0) RaiseXWindows(taskData, "XParseColor failed"); return CreateXColor(taskData, &x); } static Handle QueryColor(TaskData *taskData, Display *d, Colormap cmap, unsigned pixel) { XColor x; ClearXColor(&x); x.pixel = pixel; XQueryColor(d,cmap,&x); return CreateXColor(taskData, &x); } static void GetXPixel(TaskData *taskData, PolyWord p, void *v, unsigned) { XColor *X = (XColor *)v; ClearXColor(X); X->pixel = get_C_ulong(taskData, p); } static Handle QueryColors(TaskData *taskData, Display *d, Colormap cmap, Handle list) { unsigned N = ListLength(DEREFWORD(list)); XColor *P = (XColor *) alloca(N * sizeof(XColor)); GetList4(taskData, DEREFWORD(list),P,sizeof(XColor),GetXPixel); XQueryColors(d,cmap,P,N); return CreateList4(taskData,N,P,sizeof(XColor),CreateXColorF); } static void StoreNamedColor ( Display *d, Colormap cmap, PolyStringObject *string, unsigned pixel, unsigned doRed, unsigned doGreen, unsigned doBlue ) { unsigned flags = (DoRed * doRed) | (DoGreen * doGreen) | (DoBlue * doBlue); char name[500]; Poly_string_to_C(string,name,sizeof(name)); XStoreNamedColor(d,cmap,name,pixel,flags); } static void StoreColors(TaskData *taskData, Display *d, Colormap cmap, Handle list) { unsigned N = ListLength(DEREFWORD(list)); XColor *P = (XColor *) alloca(N * sizeof(XColor)); GetList4(taskData, DEREFWORD(list),P,sizeof(XColor),GetXColor); XStoreColors(d,cmap,P,N); } static void GetUnsigned(TaskData *taskData, PolyWord p, void *v, unsigned) { unsigned *u = (unsigned *)v; *u = get_C_ulong(taskData, p); } static void GetUnsignedLong(TaskData *taskData, PolyWord p, void *v, unsigned) { unsigned long *u = (unsigned long *)v; *u = get_C_ulong(taskData, p); } static void FreeColors ( TaskData *taskData, Display *d, Colormap cmap, Handle list, unsigned planes ) { unsigned N = ListLength(DEREFWORD(list)); unsigned long *P = (unsigned long *) alloca(N * sizeof(unsigned long)); GetList4(taskData,DEREFWORD(list),P,sizeof(unsigned long),GetUnsignedLong); XFreeColors(d,cmap,P,N,planes); } static Handle CreateColormap ( TaskData *taskData, void *p, Handle dsHandle /* handle to (X_Display_Object *) */ ) { return EmptyColormap(taskData, dsHandle,*(Colormap *)p); } static Handle ListInstalledColormaps ( TaskData *taskData, Handle dsHandle, /* handle to (X_Display_Object *) */ Drawable drawable ) { int count; Colormap *cmaps; Handle list; cmaps = XListInstalledColormaps(DEREFDISPLAYHANDLE(dsHandle)->display,drawable,&count); if (cmaps == 0) RaiseXWindows(taskData, "XListInstalledColormaps failed"); list = CreateList5(taskData,count,cmaps,sizeof(Colormap),CreateColormap,dsHandle); XFree((char *)cmaps); return list; } static Handle GetTimeOfDay(TaskData *taskData) { TimeVal now; gettimeofday(&now, NULL); return CreatePair(taskData, Make_arbitrary_precision(taskData, now.tv_sec),Make_arbitrary_precision(taskData, now.tv_usec)); } static Handle GetState(TaskData *taskData, X_Window_Object *P) { assert(UNTAGGED(P->type) == X_Window); CheckExists((X_Object *)P,window); if (ISNIL(P->handler)) Crash ("No handler set"); return CreatePair(taskData, SAVE(P->handler),SAVE(P->state)); } static void SetState(X_Window_Object *W, PolyWord handler, PolyWord state) { if (! ResourceExists((X_Object *)W)) return; assert(W->type == TAGGED(X_Window)); if (NONNIL(handler)) { /* we are setting the handler and initial state */ /* so we need to remove all pending messages for */ /* this window since they will have the wrong type */ PurgePendingWindowMessages(W); W->handler = handler; W->state = state; } else W->state = state; /* just update state */ } /* Check if the first timer event has already expired. */ static void CheckTimerQueue(void) { if (TList) { TimeVal now; gettimeofday(&now, NULL); TList->expired = TimeLeq(&TList->timeout,&now); } } static void InsertTimeout ( TaskData *taskData, X_Window_Object *window_object, unsigned ms, PolyWord alpha, PolyWord handler ) { T_List **tail; T_List *newp; TimeVal now; assert(window_object->type == TAGGED(X_Window)); CheckExists((X_Object *)window_object,window); if (ISNIL(window_object->handler)) Crash ("No handler set"); if (window_object->handler != handler) RaiseXWindows(taskData, "Handler mismatch"); { /* find insertion point in list */ TimeVal dt; gettimeofday(&now, NULL); dt.tv_sec = ms / 1000; dt.tv_usec = 1000 * (ms % 1000); newp = (T_List *) malloc(sizeof(T_List)); TimeAdd(&now,&dt,&newp->timeout); /* We use TimeLt here, not TimeLeq, because we want to add new messages AFTER existing ones. SPF 21/3/97 */ for(tail = &TList; *tail; tail = &(*tail)->next) { if (TimeLt(&newp->timeout,&(*tail)->timeout)) break; } } newp->next = *tail; newp->window_object = window_object; newp->widget_object = (X_Widget_Object *)0; newp->alpha = alpha.AsObjPtr(); newp->handler = handler.AsObjPtr(); newp->expired = 0; *tail = newp; } /* called when a widget is destroyed by Xt/Motif */ static void DestroyWidgetCallback ( Widget widget, XtPointer client_data, XtPointer call_data ) { /* find the ML widget (if any) associated with the C widget */ X_Widget_Object *widget_object = FindWidget(widget); if (widget_object != NULL) { /* Destroy the ML widget representations */ DestroyXObject((X_Object *)widget_object); /* Assume we can't get a C callback from a destroyed widget */ PurgeCCallbacks(widget_object,widget); } debugReclaim(Widget,widget); } #if 0 #define CheckRealized(Widget,Where)\ { \ if (XtIsRealized(Widget) == False) \ RaiseXWindows(taskData, #Where ": widget is not realized"); \ } static Window WindowOfWidget(TaskData *taskData, Widget widget) { CheckRealized(widget,WindowOfWidget); return XtWindowOfObject(widget); } #endif /* Now returns NULL (None) for unrealized widgets SPF 1/2/94 */ static Window WindowOfWidget(Widget widget) { return XtIsRealized(widget) ? XtWindowOfObject(widget) : None; } static void InsertWidgetTimeout ( TaskData *taskData, X_Widget_Object *widget_object, unsigned ms, PolyWord alpha, PolyWord handler ) { T_List **tail; T_List *newp; TimeVal now; assert(widget_object->type == TAGGED(X_Widget)); CheckExists((X_Object *)widget_object,widget); #if NEVER CheckRealized(GetWidget(taskData, (X_Object *)widget_object),InsertWidgetTimeout); #endif /* check that handler occurs in widget's callback list */ { PolyWord p = widget_object->callbackList; for(; NONNIL(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { MLPair *q = (MLPair *)((ML_Cons_Cell*)p.AsObjPtr())->h.AsObjPtr(); if (SND(q) == handler) break; } if (ISNIL(p)) RaiseXWindows(taskData, "Handler mismatch"); } { TimeVal dt; gettimeofday(&now, NULL); dt.tv_sec = ms / 1000; dt.tv_usec = 1000 * (ms % 1000); newp = (T_List *) malloc(sizeof(T_List)); TimeAdd(&now,&dt,&newp->timeout); /* We use TimeNegative here, not TimeExpired, because we want to add new messages AFTER existing ones. SPF 21/3/97 */ for(tail = &TList; *tail; tail = &(*tail)->next) { if (TimeLt(&newp->timeout,&(*tail)->timeout)) break; } } newp->next = *tail; newp->window_object = (X_Window_Object *)0; newp->widget_object = widget_object; newp->alpha = alpha.AsObjPtr(); newp->handler = handler.AsObjPtr(); newp->expired = 0; *tail = newp; } -// Test whether input is available and block if it is not. -// N.B. There may be a GC while in here. -// This was previously in basicio.cpp but has been moved here -// since this is the only place it's used now. -static void process_may_block(TaskData *taskData, int fd) -{ -#ifdef __CYGWIN__ - static struct timeval poll = {0,1}; -#else - static struct timeval poll = {0,0}; -#endif - fd_set read_fds; - int selRes; - - while (1) - { - - FD_ZERO(&read_fds); - FD_SET(fd,&read_fds); - - /* If there is something there we can return. */ - selRes = select(FD_SETSIZE, &read_fds, NULL, NULL, &poll); - if (selRes > 0) return; /* Something waiting. */ - else if (selRes < 0 && errno != EINTR) // Maybe another thread closed descr - raise_syscall(taskData, "select failed", errno); - WaitInputFD waiter(fd); - processes->ThreadPauseForIO(taskData, &waiter); - } -} - static Handle NextEvent(TaskData *taskData, Handle dsHandle /* handle to (X_Display_Object *) */) { for (;;) { /* Added here SPF 23/2/95 - check whether a timer event has expired */ CheckTimerQueue(); if (TList && TList->expired) { T_List *next = TList->next; EventHandle E = alloc_and_save(taskData, SIZEOF(ML_Event), F_MUTABLE_BIT); #define event ((ML_Event *)DEREFHANDLE(E)) event->type = DEREFWORD(Make_arbitrary_precision(taskData, 99)); event->sendEvent = DEREFWORD(Make_bool(True)); event->data = TList->alpha; if (TList->window_object != 0) { assert(TList->widget_object == 0); event->window = TList->window_object; event->callbacks = ListNull; event->events = ListNull; assert(TList->window_object->handler == TList->handler); } else /* it is a Widget message */ { /* TList->widget_object etc. act like Roots */ assert(TList->widget_object != 0); { Window w = WindowOfWidget(GetWidget(taskData, (X_Object *)TList->widget_object)); event->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, GetDS(taskData, (X_Object *)TList->widget_object),w)); } { /* create callback list - allocates storage */ Handle tailHandle = SAVE(ListNull); Handle widgetHandle = SAVE(TList->widget_object); Handle handlerHandle = SAVE(TList->handler); Handle pairHandle = CreatePair(taskData, widgetHandle,handlerHandle); event->callbacks = DEREFLISTHANDLE(CreatePair(taskData, pairHandle,tailHandle)); event->events = ListNull; } } #undef event free(TList); TList = next; return FINISHED(taskData, E); } else /* ! (TList && TList->expired) */ if (DEREFDISPLAYHANDLE(dsHandle)->app_context == 0) /* use XNextEvent to get next event */ { Display *display = DEREFDISPLAYHANDLE(dsHandle)->display; int pending = XPending(display); if (pending == 0) { - process_may_block(taskData, display->fd); + WaitInputFD waiter(display->fd); + processes->ThreadPauseForIO(taskData, &waiter); } else /* X Event arrived */ { XEvent ev; X_Window_Object *W; XNextEvent(display,&ev); W = FindWindow(dsHandle,ev.xany.window); if (W && NONNIL(W->handler)) { EventHandle E = CreateEvent(taskData, dsHandle,&ev,SAVE(W)); if (E) return E; } } } else /* use XtAppNextEvent to get next event */ { /* should use Xt to do time events as well */ int pending = XtAppPending(DEREFDISPLAYHANDLE(dsHandle)->app_context); if (pending == 0) { - process_may_block(taskData, DEREFDISPLAYHANDLE(dsHandle)->display->fd); + WaitInputFD waiter(DEREFDISPLAYHANDLE(dsHandle)->display->fd); + processes->ThreadPauseForIO(taskData, &waiter); } else { if ((pending & XtIMXEvent) == 0) /* not an X Event, probably an Xt timer event */ { assert(FList == TAGGED(0)); callbacks_enabled = True; XtAppProcessEvent(DEREFDISPLAYHANDLE(dsHandle)->app_context,pending); callbacks_enabled = False; if (FList != TAGGED(0)) { EventHandle E = alloc_and_save(taskData, SIZEOF(ML_Event), F_MUTABLE_BIT); #define event ((ML_Event *)DEREFHANDLE(E)) event->type = DEREFWORD(Make_arbitrary_precision(taskData, 100)); event->sendEvent = DEREFWORD(Make_bool(True)); event->window = TAGGED(0); event->data = TAGGED(0); event->callbacks = FList; /* FList != 0 */ event->events = GList; #undef event FList = TAGGED(0); GList = TAGGED(0); return FINISHED(taskData, E); } } else /* Xt Event arrived */ { XEvent ev; int dispatched; assert(FList == TAGGED(0)); XtAppNextEvent(DEREFDISPLAYHANDLE(dsHandle)->app_context,&ev); callbacks_enabled = True; dispatched = XtDispatchEvent(&ev); callbacks_enabled = False; if (!dispatched) { X_Window_Object *W = FindWindow(dsHandle,ev.xany.window); assert(FList == TAGGED(0) && GList == TAGGED(0)); if (W && NONNIL(W->handler)) { EventHandle E = CreateEvent(taskData, dsHandle,&ev,SAVE(W)); if (E) return E; } } else if (! FList.IsTagged() || ! GList.IsTagged()) { EventHandle E = CreateEvent(taskData, dsHandle,&ev,EmptyWindow(taskData, dsHandle,ev.xany.window)); if (E) return E; } } } } } } static Handle GetInputFocus(TaskData *taskData, Handle dsHandle /* handle to (X_Display_Object *) */) { Window focus; int revertTo; XGetInputFocus(DEREFDISPLAYHANDLE(dsHandle)->display,&focus,&revertTo); return CreatePair(taskData, EmptyWindow(taskData, dsHandle,focus),Make_arbitrary_precision(taskData, revertTo)); } static void SetSelectionOwner ( Handle dsHandle, /* handle to (X_Display_Object *) */ unsigned selection, Window owner, unsigned time ) { Window old = XGetSelectionOwner(DEREFDISPLAYHANDLE(dsHandle)->display,selection); if (old != owner) { /* SelectionClear is only sent by the server when the ownership of a */ /* selection passes from one client to another. We want every ML */ /* window to behave like a separate client, so when the ownership of */ /* a selection passes from one ML window to another we have to send */ /* the SelectionClear ourselves. */ X_Window_Object *W = FindWindow(dsHandle,old); if (W && NONNIL(W->handler)) /* this clients window */ { XEvent event; /* was XSelectionClearEvent SPF 6/1/94 */ event.xselectionclear.type = SelectionClear; event.xselectionclear.serial = 0; event.xselectionclear.send_event = True; event.xselectionclear.display = DEREFDISPLAYHANDLE(dsHandle)->display; event.xselectionclear.window = old; event.xselectionclear.selection = selection; event.xselectionclear.time = time; XSendEvent(DEREFDISPLAYHANDLE(dsHandle)->display,old,True,0,&event); } } XSetSelectionOwner(DEREFDISPLAYHANDLE(dsHandle)->display,selection,owner,time); } static void SendSelectionNotify ( Display *d, unsigned selection, unsigned target, unsigned property, Window requestor, unsigned time ) { XEvent event; /* was XSelectionEvent SPF 6/1/94 */ event.xselection.type = SelectionNotify; event.xselection.serial = 0; event.xselection.send_event = True; event.xselection.display = d; event.xselection.requestor = requestor; event.xselection.selection = selection; event.xselection.target = target; event.xselection.property = property; event.xselection.time = time; XSendEvent(d,requestor,True,0,&event); } static Handle InternAtom ( TaskData *taskData, Display *d, PolyStringObject *string, Bool only_if_exists ) { char name[500]; Poly_string_to_C(string,name,sizeof(name)); return Make_arbitrary_precision(taskData, XInternAtom(d,name,only_if_exists)); } static Handle GetAtomName(TaskData *taskData, Display *d, unsigned atom) { Handle s; char *name = XGetAtomName(d,atom); if (name == NULL) RaiseXWindows(taskData, "XGetAtomName failed"); s = Make_string(name); XFree((char *)name); return s; } /* The order of these depends on the XCharStruct datatype */ typedef struct { PolyWord width; /* ML int */ PolyWord ascent; /* ML int */ PolyWord descent; /* ML int */ PolyWord lbearing; /* ML int */ PolyWord rbearing; /* ML int */ PolyWord attributes; /* ML int */ } MLXCharStruct; static Handle CreateCharStruct(TaskData *taskData, void *v) { XCharStruct *cs = (XCharStruct *)v; Handle dataHandle = alloc_and_save(taskData, SIZEOF(MLXCharStruct), F_MUTABLE_BIT); #define data ((MLXCharStruct *)DEREFHANDLE(dataHandle)) data->width = DEREFWORD(Make_int(cs->width)); data->ascent = DEREFWORD(Make_int(cs->ascent)); data->descent = DEREFWORD(Make_int(cs->descent)); data->lbearing = DEREFWORD(Make_int(cs->lbearing)); data->rbearing = DEREFWORD(Make_int(cs->rbearing)); data->attributes = DEREFWORD(Make_arbitrary_precision(taskData, cs->attributes)); #undef data return FINISHED(taskData, dataHandle); } /* The order of these depends on the XFontStruct datatype */ typedef struct { X_Font_Object *font_object; PolyWord ascent; /* ML int */ PolyWord descent; /* ML int */ PolyWord maxChar; /* ML int */ PolyWord minChar; /* ML int */ PolyWord perChar; /* ML XCharStruct list */ PolyWord maxByte1; /* ML int */ PolyWord minByte1; /* ML int */ PolyWord direction; /* (short ML int) FontLeftToRight | FontRightToLeft */ MLXCharStruct *maxBounds; MLXCharStruct *minBounds; PolyWord defaultChar; /* ML int */ PolyWord allCharsExist; /* ML bool */ } MLXFontStruct; static Handle CreateFontStruct ( TaskData *taskData, void *v, Handle dsHandle /* Handle to (X_Display_Object *) */ ) { XFontStruct *fs = (XFontStruct *)v; Handle dataHandle = alloc_and_save(taskData, SIZEOF(MLXFontStruct), F_MUTABLE_BIT); int n = fs->max_char_or_byte2 - fs->min_char_or_byte2 + 1; if (fs->per_char == 0) n = 0; #define data ((MLXFontStruct *)DEREFHANDLE(dataHandle)) data->font_object = (X_Font_Object *)DEREFHANDLE(EmptyFont(taskData, dsHandle,fs->fid,fs)); data->ascent = DEREFWORD(Make_int(fs->ascent)); data->descent = DEREFWORD(Make_int(fs->descent)); data->maxChar = DEREFWORD(Make_arbitrary_precision(taskData, fs->max_char_or_byte2)); data->minChar = DEREFWORD(Make_arbitrary_precision(taskData, fs->min_char_or_byte2)); data->perChar = DEREFHANDLE(CreateList4(taskData,n,fs->per_char,sizeof(XCharStruct),CreateCharStruct)); data->maxByte1 = DEREFWORD(Make_arbitrary_precision(taskData, fs->max_byte1)); data->minByte1 = DEREFWORD(Make_arbitrary_precision(taskData, fs->min_byte1)); data->direction = DEREFWORD(Make_arbitrary_precision(taskData, (fs->direction == FontLeftToRight) ? 1 : 2)); data->maxBounds = (MLXCharStruct *)DEREFHANDLE(CreateCharStruct(taskData, &fs->max_bounds)); data->minBounds = (MLXCharStruct *)DEREFHANDLE(CreateCharStruct(taskData, &fs->min_bounds)); data->defaultChar = DEREFWORD(Make_arbitrary_precision(taskData, fs->default_char)); data->allCharsExist = DEREFWORD(Make_bool(fs->all_chars_exist)); #undef data return FINISHED(taskData, dataHandle); } static XFontStruct *GetFS(TaskData *taskData, X_Font_Object *P) { assert(UNTAGGED(P->type) == X_Font); if (*(P->fs) == NULL) RaiseXWindows(taskData, "Not a real XFontStruct"); CheckExists((X_Object *)P,font); return *(P->fs); } static XFontStruct *GetFontStruct(TaskData *taskData,PolyWord p) { MLXFontStruct *P = (MLXFontStruct *)p.AsObjPtr(); return GetFS(taskData,P->font_object); } static Handle CreateString(TaskData *taskData, void *s) { return Make_string(*(char **)s); } static Handle GetFontPath(TaskData *taskData, Display *d) { Handle list; char **names; int count; names = XGetFontPath(d,&count); if (names == 0) RaiseXWindows(taskData, "XGetFontPath failed"); list = CreateList4(taskData,count,names,sizeof(char *),CreateString); XFreeFontNames(names); return list; } static void FreeStrings(char **s, int n) { while(n--) free(*s++); return; } static void SetFontPath(TaskData *taskData, Display *d, Handle list) { if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); char **D = (char **) alloca(N * sizeof(char *)); GetList4(taskData, DEREFWORD(list),D,sizeof(char *),CopyString); XSetFontPath(d,D,N); FreeStrings(D,N); } return; } static Handle ListFonts(TaskData *taskData,Display *d, PolyStringObject *string, unsigned maxnames) { char name[500]; Handle list; char **names; int count; Poly_string_to_C(string,name,sizeof(name)); names = XListFonts(d,name,maxnames,&count); if (names == 0) RaiseXWindows(taskData, "XListFonts failed"); list = CreateList4(taskData,count,names,sizeof(char *),CreateString); XFreeFontNames(names); return list; } static Handle ListFontsWithInfo ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ PolyStringObject *string, unsigned maxnames ) { char name[500]; char **names; int count; XFontStruct *info; Handle pair; Poly_string_to_C(string,name,sizeof(name)); names = XListFontsWithInfo(DEREFDISPLAYHANDLE(dsHandle)->display,name,maxnames,&count,&info); if (names == 0) RaiseXWindows(taskData, "XListFontsWithInfo failed"); pair = CreatePair(taskData, CreateList4(taskData,count,names,sizeof(char *),CreateString), CreateList5(taskData,count,info,sizeof(XFontStruct),CreateFontStruct,dsHandle)); XFree((char *)info); XFreeFontNames(names); return pair; } static Handle LoadFont ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ PolyStringObject *string ) { char name[500]; Font font; Poly_string_to_C(string,name,sizeof(name)); font = XLoadFont(DEREFDISPLAYHANDLE(dsHandle)->display,name); if (font == 0) RaiseXWindows(taskData, "XLoadFont failed"); return EmptyFont(taskData, dsHandle,font,(XFontStruct *)NULL); } static Handle LoadQueryFont ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ PolyStringObject *string ) { char name[500]; XFontStruct *fs; Poly_string_to_C(string,name,sizeof(name)); fs = XLoadQueryFont(DEREFDISPLAYHANDLE(dsHandle)->display,name); if (fs == 0) RaiseXWindows(taskData, "XLoadQueryFont failed"); return CreateFontStruct(taskData,fs,dsHandle); } static Handle QueryFont ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Font font ) { XFontStruct *fs; fs = XQueryFont(DEREFDISPLAYHANDLE(dsHandle)->display,font); if (fs == 0) RaiseXWindows(taskData, "XQueryFont failed"); return CreateFontStruct(taskData,fs,dsHandle); } static Handle TextExtents(TaskData *taskData, XFontStruct *fs, PolyStringObject *s) { Handle dataHandle = alloc_and_save(taskData, 4, F_MUTABLE_BIT); int direction,ascent,descent; XCharStruct overall; XTextExtents(fs,s->chars,s->length,&direction,&ascent,&descent,&overall); #define data DEREFHANDLE(dataHandle) data->Set(0, DEREFWORD(Make_arbitrary_precision(taskData, (direction == FontLeftToRight) ? 1 : 2))); data->Set(1, DEREFWORD(Make_int(ascent))); data->Set(2, DEREFWORD(Make_int(descent))); data->Set(3, DEREFWORD(CreateCharStruct(taskData, &overall))); #undef data return FINISHED(taskData, dataHandle); } static Handle TextExtents16(TaskData *taskData, XFontStruct *fs, Handle list) { Handle dataHandle = alloc_and_save(taskData, 4, F_MUTABLE_BIT); int direction,ascent,descent; XCharStruct overall; unsigned N = ListLength(DEREFWORD(list)); XChar2b *L = (XChar2b *) alloca(N * sizeof(XChar2b)); GetList4(taskData,DEREFWORD(list),L,sizeof(XChar2b),GetChar2); XTextExtents16(fs,L,N,&direction,&ascent,&descent,&overall); #define data DEREFHANDLE(dataHandle) data->Set(0, DEREFWORD(Make_arbitrary_precision(taskData, (direction == FontLeftToRight) ? 1 : 2))); data->Set(1, DEREFWORD(Make_int(ascent))); data->Set(2, DEREFWORD(Make_int(descent))); data->Set(3, DEREFWORD(CreateCharStruct(taskData, &overall))); #undef data return FINISHED(taskData, dataHandle); } static Handle TextWidth(TaskData *taskData, XFontStruct *fs, PolyStringObject *s) { if (fs->per_char == 0) return Make_int(s->length * fs->max_bounds.width); return Make_int(XTextWidth(fs,s->chars,s->length)); } static Handle TextWidth16(TaskData *taskData, XFontStruct *fs, Handle list) { unsigned N = ListLength(DEREFWORD(list)); XChar2b *L = (XChar2b *) alloca(N * sizeof(XChar2b)); GetList4(taskData, DEREFWORD(list),L,sizeof(XChar2b),GetChar2); return Make_int(XTextWidth16(fs,L,N)); } static Handle GetTextProperty(TaskData *taskData, Display *d, Window w, unsigned property) { XTextProperty T; Handle tuple; int s = XGetTextProperty(d,w,&T,property); if (s == 0) RaiseXWindows(taskData, "XGetTextProperty failed"); tuple = alloc_and_save(taskData, 4, F_MUTABLE_BIT); #define data DEREFHANDLE(tuple) data->Set(0, C_string_to_Poly(taskData, (char *)T.value,T.nitems * T.format / 8)); data->Set(1, DEREFWORD(Make_arbitrary_precision(taskData, T.encoding))); data->Set(2, DEREFWORD(Make_int(T.format))); data->Set(3, DEREFWORD(Make_arbitrary_precision(taskData, T.nitems))); #undef data return FINISHED(taskData, tuple); } static void GetXWMHints(TaskData *taskData, PolyWord p, void *v, unsigned) { PolyObject *P = p.AsObjPtr(); XWMHints *H = (XWMHints *)v; H->input = get_C_ulong(taskData, P->Get(0)); H->initial_state = get_C_ulong(taskData, P->Get(1)); H->icon_pixmap = GetPixmap(taskData, (X_Object *)P->Get(2).AsObjPtr()); H->icon_window = GetWindow(taskData, (X_Object *)P->Get(3).AsObjPtr()); H->icon_x = GetPointX(taskData, P->Get(4)); H->icon_y = GetPointY(taskData, P->Get(4)); H->icon_mask = GetPixmap(taskData, (X_Object *)P->Get(5).AsObjPtr()); H->flags = get_C_ulong(taskData, P->Get(6)); H->window_group = 0; } typedef struct { PolyWord x0; PolyWord x1; PolyWord x2; PolyWord x3; PolyWord x4; PolyWord x5; /* pair of points */ PolyWord x6; PolyWord x7; PolyWord x8; } MLXWMSizeHintsTuple; static void GetXWMSizeHints(TaskData *taskData, PolyWord p, void *v, unsigned) { MLXWMSizeHintsTuple *P = (MLXWMSizeHintsTuple *)p.AsObjPtr(); XSizeHints *H = (XSizeHints *)v; CheckZeroRect(taskData, P->x1); CheckZeroRect(taskData, P->x2); CheckZeroRect(taskData, P->x3); CheckZeroRect(taskData, P->x4); CheckZeroRect(taskData, P->x6); H->x = GetPointX(taskData, P->x0); H->y = GetPointY(taskData, P->x0); H->width = GetRectW(taskData, P->x1); H->height = GetRectH(taskData, P->x1); H->min_width = GetRectW(taskData, P->x2); H->min_height = GetRectH(taskData, P->x2); H->max_width = GetRectW(taskData, P->x3); H->max_height = GetRectH(taskData, P->x3); H->width_inc = GetRectW(taskData, P->x4); H->height_inc = GetRectH(taskData, P->x4); H->min_aspect.x = GetPointX(taskData, FST(P->x5)); H->min_aspect.y = GetPointY(taskData, FST(P->x5)); H->max_aspect.x = GetPointX(taskData, SND(P->x5)); H->max_aspect.y = GetPointY(taskData, SND(P->x5)); H->base_width = GetRectW(taskData, P->x6); H->base_height = GetRectH(taskData, P->x6); H->win_gravity = get_C_ulong(taskData, P -> x7); H->flags = get_C_ulong(taskData, P -> x8); } static void GetIconSize(TaskData *taskData, PolyWord p, void *v, unsigned) { MLTriple *P = (MLTriple *)p.AsObjPtr(); XIconSize *s = (XIconSize *)v; CheckZeroRect(taskData, FST(P)); CheckZeroRect(taskData, SND(P)); CheckZeroRect(taskData, THIRD(P)); s->min_width = GetRectW(taskData, FST(P)); s->min_height = GetRectH(taskData, FST(P)); s->max_width = GetRectW(taskData, SND(P)); s->max_height = GetRectH(taskData, SND(P)); s->width_inc = GetRectW(taskData, THIRD(P)); s->height_inc = GetRectH(taskData, THIRD(P)); } static void GetSigned(TaskData *taskData, PolyWord p, void *i, unsigned) { *(int*)i = get_C_long(taskData, p); } static void GetPixmaps(TaskData *taskData, PolyWord pp, void *m, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(Pixmap *)m = GetPixmap(taskData, p); } static void GetColormaps(TaskData *taskData, PolyWord pp, void *v, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(Colormap *)v = GetColormap(taskData, p); } static void GetCursors(TaskData *taskData, PolyWord pp, void *c, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(Cursor *)c = GetCursor(taskData, p); } static void GetDrawables(TaskData *taskData, PolyWord pp, void *d, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(Drawable *)d = GetDrawable(taskData, p); } static void GetFonts(TaskData *taskData, PolyWord pp, void *f, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(Font *)f = GetFont(taskData, p); } static void GetVisualIds(TaskData *taskData, PolyWord pp, void *u, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(unsigned *)u = GetVisual(taskData, p)->visualid; } static void SetProperty ( TaskData *taskData, Display *d, Window w, unsigned property, unsigned target, Handle list, unsigned encoding ) { unsigned format; unsigned bytes; uchar *value; /* SPF 7/7/94 - XA_STRING pulled out as special case; this enables */ /* gcc to understand the previously data-dependant control flow. */ if (encoding == XA_STRING) { PolyStringObject *s = GetString (DEREFHANDLE(list)); format = 8; bytes = s->length; value = (uchar *) s->chars; } else { unsigned length = ListLength(DEREFWORD(list)); unsigned size; GetFunc get; switch(encoding) { case XA_ATOM: size = sizeof(unsigned); get = GetUnsigned; format = 32; break; case XA_BITMAP: size = sizeof(Pixmap); get = GetPixmaps; format = 32; break; case XA_COLORMAP: size = sizeof(Colormap); get = GetColormaps; format = 32; break; case XA_CURSOR: size = sizeof(Cursor); get = GetCursors; format = 32; break; case XA_DRAWABLE: size = sizeof(Drawable); get = GetDrawables; format = 32; break; case XA_FONT: size = sizeof(Font); get = GetFonts; format = 32; break; case XA_PIXMAP: size = sizeof(Pixmap); get = GetPixmaps; format = 32; break; case XA_VISUALID: size = sizeof(unsigned); get = GetVisualIds; format = 32; break; case XA_CARDINAL: size = sizeof(unsigned); get = GetUnsigned; format = 32; break; case XA_INTEGER: size = sizeof(int); get = GetSigned; format = 32; break; case XA_WINDOW: size = sizeof(Window); get = GetWindows; format = 32; break; case XA_ARC: size = sizeof(XArc); get = GetArcs; format = 16; break; case XA_POINT: size = sizeof(XPoint); get = GetPoints; format = 16; break; case XA_RECTANGLE: size = sizeof(XRectangle); get = GetRects; format = 16; break; case XA_RGB_COLOR_MAP: size = sizeof(XStandardColormap); get = GetStandardColormap; format = 32; break; case XA_WM_HINTS: size = sizeof(XWMHints); get = GetXWMHints; format = 32; break; case XA_WM_SIZE_HINTS: size = sizeof(XSizeHints); get = GetXWMSizeHints; format = 32; break; case XA_WM_ICON_SIZE: size = sizeof(XIconSize); get = GetIconSize; format = 32; break; default: Crash ("Bad property type %x",encoding); /*NOTREACHED*/ } bytes = length * size; value = (uchar *) alloca(bytes); GetList4(taskData, DEREFWORD(list),value,(int)size,get); } { XTextProperty T; T.value = value; T.encoding = target; T.format = format; T.nitems = (bytes * 8) / format; XSetTextProperty(d,w,&T,property); } } static Handle GetWMHints ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w ) { Handle tuple = alloc_and_save(taskData, 7, F_MUTABLE_BIT); XWMHints *H = XGetWMHints(DEREFDISPLAYHANDLE(dsHandle)->display,w); if (H) { #define data DEREFHANDLE(tuple) data->Set(0, DEREFWORD(Make_arbitrary_precision(taskData, H->input))); data->Set(1, DEREFWORD(Make_arbitrary_precision(taskData, H->initial_state))); data->Set(2, DEREFWORD(EmptyPixmap(taskData, dsHandle,H->icon_pixmap))); data->Set(3, DEREFWORD(EmptyWindow(taskData, dsHandle,H->icon_window))); data->Set(4, DEREFWORD(CreatePoint(taskData, H->icon_x,H->icon_y))); data->Set(5, DEREFWORD(EmptyPixmap(taskData, dsHandle,H->icon_mask))); data->Set(6, DEREFWORD(Make_arbitrary_precision(taskData, H->flags))); #undef data XFree((char *)H); } /* else what (?) */ return FINISHED(taskData, tuple); } static Handle GetWMSizeHints ( TaskData *taskData, Display *d, Window w, unsigned property ) { XSizeHints H; long supplied; /* was unsigned SPF 6/1/94 */ Handle tuple = alloc_and_save(taskData, 9, F_MUTABLE_BIT); int s = XGetWMSizeHints(d,w,&H,&supplied,property); if (s) { Handle p1 = CreatePoint(taskData, H.min_aspect.x,H.min_aspect.y); Handle p2 = CreatePoint(taskData, H.max_aspect.x,H.max_aspect.y); #define data DEREFHANDLE(tuple) data->Set(0, DEREFWORD(CreatePoint(taskData, H.x,H.y))); data->Set(1, DEREFWORD(CreateArea(H.width,H.height))); data->Set(2, DEREFWORD(CreateArea(H.min_width,H.min_height))); data->Set(3, DEREFWORD(CreateArea(H.max_width,H.max_height))); data->Set(4, DEREFWORD(CreateArea(H.width_inc,H.height_inc))); data->Set(5, DEREFWORD(CreatePair(taskData, p1,p2))); data->Set(6, DEREFWORD(CreateArea(H.base_width,H.base_height))); data->Set(7, DEREFWORD(Make_arbitrary_precision(taskData, H.win_gravity))); data->Set(8, DEREFWORD(Make_arbitrary_precision(taskData, H.flags))); #undef data } /* else (?) */ return FINISHED(taskData, tuple); } #if 0 typedef struct { MLPair *x0; /* pair of points */ MLXRectangle *x1; PolyWord x2; /* ML int */ } MLWMGeometryTriple; #endif static Handle WMGeometry ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ PolyStringObject *user, PolyStringObject *def, unsigned borderWidth, PolyWord P ) { XSizeHints H; int x,y,width,height,gravity,mask; char userGeometry[500],defaultGeometry[500]; GetXWMSizeHints(taskData, P, &H, 0); Poly_string_to_C(user,userGeometry ,sizeof(userGeometry)); Poly_string_to_C(def ,defaultGeometry,sizeof(defaultGeometry)); mask = XWMGeometry(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen, userGeometry, defaultGeometry, borderWidth, &H,&x,&y,&width,&height,&gravity); return CreateTriple(taskData, CreatePoint(taskData, x,y),CreateArea(width,height),Make_arbitrary_precision(taskData, gravity)); } static Handle CreateIconSize(TaskData *taskData, void *v) { XIconSize *s = (XIconSize *)v; return CreateTriple(taskData, CreateArea(s->min_width,s->min_height), CreateArea(s->max_width,s->max_height), CreateArea(s->width_inc,s->height_inc)); } static Handle GetIconSizes(TaskData *taskData, Display *d, Window w) { XIconSize *sizes; int count; int s = XGetIconSizes(d,w,&sizes,&count); if (s) { Handle list = CreateList4(taskData,count,sizes,sizeof(XIconSize),CreateIconSize); XFree((char *)sizes); return list; } return SAVE(ListNull); } static Handle GetTransientForHint ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w ) { Window p; int s = XGetTransientForHint(DEREFDISPLAYHANDLE(dsHandle)->display,w,&p); if (s == 0) RaiseXWindows(taskData, "XGetTransientForHint failed"); return EmptyWindow(taskData, dsHandle,p); } static Handle GetWMColormapWindows ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window parent ) { Window *windows; int count; int s = XGetWMColormapWindows(DEREFDISPLAYHANDLE(dsHandle)->display,parent,&windows,&count); if (s) { Handle list = CreateList5(taskData,count,windows,sizeof(Window),CreateDrawable,dsHandle); XFree((char *)windows); return list; } return SAVE(ListNull); } static Handle GetRGBColormaps ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w, unsigned property ) { XStandardColormap *maps; int count; int s = XGetRGBColormaps(DEREFDISPLAYHANDLE(dsHandle)->display,w,&maps,&count,property); if (s) { Handle list = CreateList5(taskData,count,maps,sizeof(XStandardColormap),CreateStandardColormap,dsHandle); XFree((char *)maps); return list; } return SAVE(ListNull); } static Handle GetID(TaskData *taskData, X_Object *P) { switch(UNTAGGED(P->type)) { case X_GC: return Make_arbitrary_precision(taskData, GetGC(taskData, P)->gid); /* GCID */ case X_Font: return Make_arbitrary_precision(taskData, GetFont(taskData, P)); /* FontID */ case X_Cursor: return Make_arbitrary_precision(taskData, GetCursor(taskData, P)); /* CursorId */ case X_Window: return Make_arbitrary_precision(taskData, GetWindow(taskData, P)); /* DrawableID */ case X_Pixmap: return Make_arbitrary_precision(taskData, GetPixmap(taskData, P)); /* DrawableID */ case X_Colormap: return Make_arbitrary_precision(taskData, GetColormap(taskData, P)); /* ColormapID */ case X_Visual: return Make_arbitrary_precision(taskData, GetVisual(taskData, P)->visualid); /* VisualID */ case X_Widget: return Make_arbitrary_precision(taskData, (unsigned long)GetNWidget(taskData, P)); /* Widget -- SAFE(?) */ default: Crash ("Bad X_Object type (%d) in GetID",UNTAGGED(P->type)) /*NOTREACHED*/; } } static Handle OpenDisplay(TaskData *taskData, PolyStringObject *string) { char name[500]; Display *display; Handle dsHandle /* Handle to (X_Display_Object *) */; Poly_string_to_C(string,name,sizeof(name)); display = XOpenDisplay(name); if (display == 0) RaiseXWindows(taskData, "XOpenDisplay failed"); /* I don't think this is needed. DCJM 26/5/2000. */ /* add_file_descr(display->fd); */ dsHandle = alloc_and_save(taskData, SIZEOF(X_Display_Object), F_MUTABLE_BIT|F_BYTE_OBJ); debug1 ("%s display opened\n",DisplayString(display)); debug1 ("%x display fd\n",display->fd); #define ds DEREFDISPLAYHANDLE(dsHandle) /* Ok to store C values because this is a byte object */ ds->type = TAGGED(X_Display); ds->display = display; ds->screen = DefaultScreen(display); ds->app_context = 0; #undef ds return AddXObject(FINISHED(taskData, dsHandle)); } /* indirection removed SPF 11/11/93 */ static XmFontList GetXmFontList(PolyWord p /* NOT a handle */) { if (NONNIL(p)) { char charset[500]; XmFontList L; MLPair *q = (MLPair *)(((ML_Cons_Cell*)p.AsObjPtr())->h.AsObjPtr()); Poly_string_to_C(SND(q),charset,sizeof(charset)); L = XmFontListCreate((XFontStruct *)FST(q).AsObjPtr(),charset); /* cast added SPF 6/1/94 */ p = ((ML_Cons_Cell*)p.AsObjPtr())->t; while(NONNIL(p)) { q = (MLPair *)(((ML_Cons_Cell*)p.AsObjPtr())->h.AsObjPtr()); Poly_string_to_C(SND(q),charset,sizeof(charset)); L = XmFontListAdd(L,(XFontStruct *)FST(q).AsObjPtr(),charset); /* cast added SPF 6/1/94 */ p = ((ML_Cons_Cell*)p.AsObjPtr())->t; } return L; } return 0; } /* datatype CType = CAccelerators of XtAccelerators | CBool of bool | CColormap of Colormap | CCursor of Cursor | CDimension of int | CFontList of (XFontStruct * string) list | CInt of int | CIntTable of int list | CKeySym of int | CPixmap of Drawable | CPosition of int | CString of string | CStringTable of string list | CTrans of XtTranslations | CUnsignedChar of int | CUnsignedTable of int list | CVisual of Visual | CWidget of Widget | CWidgetList of Widget list | CXmString of XmString | CXmStringTable of XmString list; */ #define CAccelerators 1 #define CBool 2 #define CColormap 3 #define CCursor 4 #define CDimension 5 #define CFontList 6 #define CInt 7 #define CIntTable 8 #define CKeySym 9 #define CPixmap 10 #define CPosition 11 #define CString 12 #define CStringTable 13 #define CTrans 14 #define CUnsignedChar 15 #define CUnsignedTable 16 #define CVisual 17 #define CWidget 18 #define CWidgetList 19 #define CXmString 20 #define CXmStringTable 21 typedef struct { unsigned tag; unsigned N; char *name; union { XtAccelerators acc; Boolean boolean; Colormap cmap; Cursor cursor; Dimension dim; XmFontList F; int i; int *I; KeySym keysym; Pixmap pixmap; Position posn; char *string; char **S; XtTranslations trans; uchar u; uchar *U; Visual *visual; Widget widget; WidgetList W; XmString xmString; XmString *X; } u; } ArgType; static void GetXmString(TaskData *taskData, PolyWord w, void *v, unsigned ) { XmString *p = (XmString *)v; char *s; CopyString(taskData, w, &s, 0); *p = XmStringCreateLtoR(s, (char *)XmSTRING_DEFAULT_CHARSET); free(s); } static void GetXmStrings(TaskData *taskData, PolyWord list, ArgType *T) { T->N = 0; T->u.X = 0; if (NONNIL(list)) { T->N = ListLength(list); T->u.X = (XmString *) malloc(T->N * sizeof(XmString)); GetList4(taskData, list,T->u.X,sizeof(XmString),GetXmString); } } static void GetStrings(TaskData *taskData, PolyWord list, ArgType *T) { T->N = 0; T->u.S = 0; if (NONNIL(list)) { T->N = ListLength(list); T->u.S = (char **) malloc(T->N * sizeof(char *)); GetList4(taskData, list,T->u.S,sizeof(char *),CopyString); } } static void FreeXmStrings(ArgType *T) { for(unsigned i = 0; i < T->N; i++) XmStringFree (T->u.X[i]); free(T->u.X); } static void GetITable(TaskData *taskData, PolyWord list, ArgType *T) { T->N = 0; T->u.I = 0; if (NONNIL(list)) { T->N = ListLength(list); T->u.I = (int *) malloc(T->N * sizeof(int)); GetList4(taskData, list,T->u.I,sizeof(int),GetUnsigned); } } static void GetUTable(TaskData *taskData, PolyWord list, ArgType *T) { T->N = 0; T->u.U = 0; if (NONNIL(list)) { T->N = ListLength(list); T->u.U = (uchar *)malloc(T->N * sizeof(uchar)); GetList4(taskData, list,T->u.U,sizeof(uchar),GetUChars); } } /* case CIntTable: GetITable ((ML_Cons_Cell *)v,T); break; case CUnsignedTable: GetUTable ((ML_Cons_Cell *)v,T); break; case CString: CopyString (v,&T->u.string); break; case CStringTable: GetStrings ((ML_Cons_Cell *)v,T); break; case CXmString: GetXmString (v,&T->u.xmString); break; case CXmStringTable: GetXmStrings((ML_Cons_Cell *)v,T); break; */ static void FreeArgs(ArgType *T, unsigned N) { while(N--) { free(T->name); switch(T->tag) { case CAccelerators: break; case CBool: break; case CColormap: break; case CCursor: break; case CDimension: break; case CFontList: XmFontListFree(T->u.F); break; case CInt: break; case CIntTable: break; case CKeySym: break; case CPixmap: break; case CPosition: break; case CString: XtFree(T->u.string); break; case CStringTable: FreeStrings(T->u.S,T->N); free(T->u.S); break; case CTrans: break; case CUnsignedChar: break; case CUnsignedTable: break; case CVisual: break; case CWidget: break; case CWidgetList: break; case CXmString: XmStringFree (T->u.xmString); break; case CXmStringTable: FreeXmStrings(T); break; default: Crash ("Bad arg type %x",T->tag); } T++; } } /* type Arg sharing type Arg = exn; val Exn: Arg -> Exn = Cast; val Arg: Exn -> Arg = Cast; datatype Exn = EXN of unit ref * string * unit; */ /* (string,(v,tag)) */ static void SetArgTypeP(TaskData *taskData, PolyWord fst, PolyWord snd, ArgType *T) { PolyWord v = FST(snd); T->tag = UNTAGGED(SND(snd)); T->N = 0; T->u.i = 0; CopyString(taskData, fst, &T->name, 0); switch(T->tag) { case CAccelerators: T->u.acc = GetAcc (taskData, (X_Object *)v.AsObjPtr()); break; case CBool: T->u.boolean = get_C_ulong (taskData, v); break; case CColormap: T->u.cmap = GetColormap (taskData, (X_Object *)v.AsObjPtr()); break; case CCursor: T->u.cursor = GetCursor (taskData, (X_Object *)v.AsObjPtr()); break; case CDimension: T->u.dim = get_C_ushort (taskData, v); break; case CFontList: T->u.F = GetXmFontList(v); break; case CInt: T->u.i = get_C_long (taskData, v); break; case CKeySym: T->u.keysym = get_C_ulong (taskData, v); break; case CPixmap: T->u.pixmap = GetPixmap (taskData, (X_Object *)v.AsObjPtr()); break; case CPosition: T->u.posn = get_C_short (taskData, v); break; case CTrans: T->u.trans = GetTrans (taskData, (X_Object *)v.AsObjPtr()); break; case CUnsignedChar: T->u.u = get_C_uchar (taskData, v); break; case CVisual: T->u.visual = GetVisual (taskData, (X_Object *)v.AsObjPtr()); break; case CWidget: T->u.widget = GetNWidget (taskData, (X_Object *)v.AsObjPtr()); break; /* The following types allocate memory, but only in the C heap */ case CIntTable: GetITable (taskData, v,T); break; case CUnsignedTable: GetUTable (taskData, v,T); break; case CString: CopyString (taskData, v, &T->u.string, 0); break; case CStringTable: GetStrings (taskData, v,T); break; case CXmString: GetXmString (taskData, v, &T->u.xmString, 0); break; case CXmStringTable: GetXmStrings(taskData, v,T); break; default: Crash ("Bad arg type %x",T->tag); } } static void SetArgType(TaskData *taskData, PolyWord p, void *v, unsigned) { ArgType *T = (ArgType *)v; SetArgTypeP(taskData, FST(p), SND(p), T); } static void SetArgs(Arg *A, ArgType *T, unsigned N) { while(N--) { A->name = T->name; switch(T->tag) { case CAccelerators: A->value = (XtArgVal) T->u.acc; break; case CBool: A->value = (XtArgVal) T->u.boolean; break; case CColormap: A->value = (XtArgVal) T->u.cmap; break; case CCursor: A->value = (XtArgVal) T->u.cursor; break; case CDimension: A->value = (XtArgVal) T->u.dim; break; case CFontList: A->value = (XtArgVal) T->u.F; break; case CInt: A->value = (XtArgVal) T->u.i; break; case CIntTable: A->value = (XtArgVal) T->u.I; break; case CKeySym: A->value = (XtArgVal) T->u.keysym; break; case CPixmap: A->value = (XtArgVal) T->u.pixmap; break; case CPosition: A->value = (XtArgVal) T->u.posn; break; case CString: A->value = (XtArgVal) T->u.string; break; case CStringTable: A->value = (XtArgVal) T->u.S; break; case CTrans: A->value = (XtArgVal) T->u.trans; break; case CUnsignedChar: A->value = (XtArgVal) T->u.u; break; case CUnsignedTable: A->value = (XtArgVal) T->u.U; break; case CVisual: A->value = (XtArgVal) T->u.visual; break; case CWidget: A->value = (XtArgVal) T->u.widget; break; case CXmString: A->value = (XtArgVal) T->u.xmString; break; case CXmStringTable: A->value = (XtArgVal) T->u.X; break; default: Crash ("Bad arg type %x",T->tag); } A++; T++; } } /* add current callback to (pending?) FList */ static void RunWidgetCallback(Widget w, XtPointer closure, XtPointer call_data) { C_List *C = (C_List *)closure; if (callbacks_enabled) { // Only synchronous callbacks are handled. TaskData *taskData = processes->GetTaskDataForThread(); Handle tailHandle = SAVE(FList); Handle widgetHandle = SAVE(C->widget_object); Handle functionHandle = SAVE(C->function); Handle pairHandle = CreatePair(taskData, widgetHandle,functionHandle); FList = DEREFWORD(CreatePair(taskData, pairHandle,tailHandle)); } #if 0 else printf("Ignoring event for widget %p\n",C->widget_object); #endif } static void SetCallbacks(TaskData *taskData, X_Widget_Object *W, PolyWord list, PolyWord initial) { char name[100]; Widget w = GetWidget(taskData, (X_Object *)W); assert(w != NULL); /* SPF */ assert(w != (Widget)1); /* SPF */ for(PolyWord pp = W->callbackList; NONNIL(pp); pp = ((ML_Cons_Cell*)pp.AsObjPtr())->t) { MLPair *q = (MLPair *)((ML_Cons_Cell*)pp.AsObjPtr())->h.AsObjPtr(); Poly_string_to_C(FST(q),name,sizeof(name)); if (strcmp(name,"messageCallback") != 0 && strcmp(name,XtNdestroyCallback) != 0) { XtRemoveAllCallbacks(w,name); } } #if 0 /* We no longer need the old callback data for this widget, assuming we've replaced all the callbacks. But what if we've only replaced some of them? It's probably better to allow this space leak that to delete vital callback data. I'll have to think about this hard sometime. (Of course, the user isn't supposed to call XtSetCallbacks more than once, in which case the problem doesn't even arise.) SPF 29/2/96 */ PurgeCCallbacks(W,w); #endif for(PolyWord p = list; NONNIL(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { C_List *C = (C_List *)malloc(sizeof(C_List)); MLPair *q = (MLPair *)((ML_Cons_Cell*)p.AsObjPtr())->h.AsObjPtr(); C->function = SND(q).AsObjPtr(); C->widget_object = W; C->next = CList; debugCreateCallback(W,w,C); CList = C; Poly_string_to_C(FST(q),name,sizeof(name)); if (strcmp(name,"messageCallback") != 0 && strcmp(name,XtNdestroyCallback) != 0) { XtAddCallback(w,name,RunWidgetCallback,C); } } W->state = initial; W->callbackList = list; } static void RunWidgetEventhandler (Widget w, XtPointer p, XEvent *ev, Boolean *c) { C_List *C = (C_List *)p; if ( callbacks_enabled ) { TaskData *taskData = processes->GetTaskDataForThread(); Handle tailHandle = SAVE(GList); Handle widgetHandle = SAVE(C->widget_object); Handle functionHandle = SAVE(C->function); Handle pairHandle = CreatePair(taskData, widgetHandle,functionHandle); GList = (ML_Cons_Cell *)DEREFHANDLE(CreatePair(taskData, pairHandle,tailHandle)); } } static void AddEventhandler ( TaskData *taskData, X_Widget_Object *W, EventMask EventM, Boolean nonmask, Handle p) { Widget w = GetWidget(taskData, (X_Object *)W) ; C_List *C = (C_List *) malloc ( sizeof(C_List) ) ; /* Add the function to the callback list, so that it will not be G.C'ed away. */ C->function = DEREFHANDLE(p); C->widget_object = W ; C->next = CList ; CList = C ; XtAddEventHandler (w, EventM, nonmask, RunWidgetEventhandler, C); } static Handle AppInitialise ( TaskData *taskData, PolyWord s1, PolyWord s2, PolyWord s3, Handle fallbackHead, Handle argHead ) { char displayName[500]; char appName[500]; char appClass[500]; XtAppContext app_context; Display *display; Widget shell; Handle dsHandle /* Handle to (X_Display_Object *) */; int argc = 0; /* an "int" for Solaris, but should be "unsigned" for SunOS */ unsigned F = ListLength(DEREFWORD(fallbackHead)) + 1; unsigned N = ListLength(DEREFWORD(argHead)); char **S = (char **) alloca(F * sizeof(char *)); Arg *R = (Arg *) alloca(N * sizeof(Arg)); ArgType *T = (ArgType *) alloca(N * sizeof(ArgType)); Poly_string_to_C(s1,displayName ,sizeof(displayName)); Poly_string_to_C(s2,appName ,sizeof(appName)); Poly_string_to_C(s3,appClass ,sizeof(appClass)); app_context = XtCreateApplicationContext(); GetList4(taskData, DEREFWORD(fallbackHead),S,sizeof(char *),CopyString); S[F-1] = NULL; /* list must be NULL terminated */ XtAppSetFallbackResources(app_context,S); display = XtOpenDisplay(app_context,displayName,appName,appClass,NULL,0,&argc,0); if (display == 0) RaiseXWindows(taskData, "XtAppInitialise failed (can't open display)"); /* I don't think this is needed. DCJM 26/5/2000 */ /* add_file_descr(display->fd); */ debug1 ("%s display opened\n",DisplayString(display)); debug1 ("%x display fd\n",display->fd); /* ok to store C values because this is a BYTE object */ dsHandle = alloc_and_save(taskData, SIZEOF(X_Display_Object), F_MUTABLE_BIT|F_BYTE_OBJ); DEREFDISPLAYHANDLE(dsHandle)->type = TAGGED(X_Display); DEREFDISPLAYHANDLE(dsHandle)->display = display; DEREFDISPLAYHANDLE(dsHandle)->screen = DefaultScreen(display); DEREFDISPLAYHANDLE(dsHandle)->app_context = app_context; AddXObject(FINISHED(taskData, dsHandle)); GetList4(taskData, DEREFWORD(argHead),T,sizeof(ArgType),SetArgType); SetArgs(R,T,N); shell = XtAppCreateShell(appName,appClass,applicationShellWidgetClass,display,R,N); FreeArgs(T,N); if (shell == 0) RaiseXWindows(taskData, "XtAppInitialise failed (can't create application shell)"); /* added 7/12/94 SPF */ XtAddCallback(shell,XtNdestroyCallback,DestroyWidgetCallback,NULL); return NewWidget(taskData, dsHandle,shell); } static Handle CreatePopupShell ( TaskData *taskData, PolyStringObject *s, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget parent, Handle list ) { char name[100]; Widget shell; unsigned N = ListLength(DEREFWORD(list)); Arg *A = (Arg *) alloca(N * sizeof(Arg)); ArgType *T = (ArgType *) alloca(N * sizeof(ArgType)); GetList4(taskData, DEREFWORD(list),T,sizeof(ArgType),SetArgType); SetArgs(A,T,N); Poly_string_to_C(s,name,sizeof(name)); shell = XtCreatePopupShell(name,applicationShellWidgetClass,parent,A,N); FreeArgs(T,N); if (shell == 0) RaiseXWindows(taskData, "XtCreatePopupShell failed"); /* added 7/12/94 SPF */ XtAddCallback(shell,XtNdestroyCallback,DestroyWidgetCallback,NULL); return NewWidget(taskData, dsHandle,shell); } static Handle CreateXm ( TaskData *taskData, Widget (*create)(Widget, String, ArgList, Cardinal), char *failed, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget parent, PolyStringObject *s, Handle list /* Handle to (ML_Cons_Cell *) */ ) { char name[100]; Widget w; unsigned N = ListLength(DEREFWORD(list)); Arg *A = (Arg *) alloca(N * sizeof(Arg)); ArgType *T = (ArgType *) alloca(N * sizeof(ArgType)); GetList4(taskData, DEREFWORD(list),T,sizeof(ArgType),SetArgType); SetArgs(A,T,N); Poly_string_to_C(s,name,sizeof(name)); w = (* create)(parent,name,A,N); FreeArgs(T,N); if (w == 0) RaiseXWindows(taskData, failed); XtAddCallback(w,XtNdestroyCallback,DestroyWidgetCallback,NULL); return NewWidget(taskData, dsHandle,w); } static void SetValues(TaskData *taskData, Widget w, Handle list) { unsigned N = ListLength(DEREFWORD(list)); Arg *A = (Arg *) alloca(N * sizeof(Arg)); ArgType *T = (ArgType *) alloca(N * sizeof(ArgType)); GetList4(taskData, DEREFWORD(list),T,sizeof(ArgType),SetArgType); SetArgs(A,T,N); XtSetValues(w,A,N); FreeArgs(T,N); } typedef struct { const char *listName; char *intName; } StringPair; static StringPair listTypes[] = { {"argv" ,(char *) "argc"}, {"buttonAccelerators" ,(char *) "buttonCount"}, {"buttonAcceleratorText" ,(char *) "buttonCount"}, {"buttonMnemonicCharSets",(char *) "buttonCount"}, {"buttonMnemonics" ,(char *) "buttonCount"}, {"buttons" ,(char *) "buttonCount"}, {"buttonType" ,(char *) "buttonCount"}, {"children" ,(char *) "numChildren"}, {"dirListItems" ,(char *) "dirListItemCount"}, {"fileListItems" ,(char *) "fileListItemCount"}, {"historyItems" ,(char *) "historyItemCount"}, {"items" ,(char *) "itemCount"}, {"listItems" ,(char *) "listItemCount"}, {"selectedItems" ,(char *) "selectedItemCount"}, {"selectionArray" ,(char *) "selectionArrayCount"}, }; #define MAXListTYPES (sizeof(listTypes)/sizeof(listTypes[0])) /* (string,(v,tag)) - ML (string*Ctype) */ static void GetArgType ( TaskData *taskData, PolyWord p, ArgType *T, int i, /* not used; needed to keep function type right */ Widget w ) { T->tag = UNTAGGED(SND(SND(p))); T->N = 0; T->u.i = 0; CopyString(taskData, FST(p), &T->name, 0); if (T->tag == CIntTable || T->tag == CUnsignedTable || T->tag == CWidgetList || T->tag == CStringTable || T->tag == CXmStringTable) /* if it is a list type we need to get the length from another resource */ { Arg arg; unsigned i; int result; for(i = 0; i < MAXListTYPES; i++) { if (strcmp(listTypes[i].listName,T->name) == 0) break; } if (i == MAXListTYPES) Crash ("Bad list resource name %s",T->name); arg.name = listTypes[i].intName; arg.value = (XtArgVal) &result; /* Bug fix here which only appeared in OpenMotif and LessTif. We need to pass the address of an integer here to receive the result. DCJM 17/5/02. */ XtGetValues(w, &arg, 1); T->N = result; } } static Handle CreateWidget(TaskData *taskData, void *p, Handle dsHandle /* Handle to (X_Display_Object *) */) { return EmptyWidget(taskData, dsHandle, *(Widget*)p); } static Handle CreateXmString(TaskData *taskData, void *t) { char *s; Handle S; XmStringGetLtoR(*(XmString *)t,(char *) XmSTRING_DEFAULT_CHARSET,&s); S = Make_string(s); XtFree(s); return S; } static Handle CreateFontList ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ XmFontList F ) { XmFontContext C; XmStringCharSet charset; XFontStruct *fs; Handle list = 0; Handle tail = 0; if (XmFontListInitFontContext(&C,F) == False) return SAVE(ListNull); // TODO: This previously reset the save vector each time to make sure it // didn't overflow. I've removed that code but it needs to be put back. while (XmFontListGetNextFont(C,&charset,&fs)) { Handle L = alloc_and_save(taskData, SIZEOF(ML_Cons_Cell), F_MUTABLE_BIT); if (list == 0) list = L; // This is the first. if (tail != 0) { DEREFLISTHANDLE(tail)->t = DEREFWORD(L); FINISHED(taskData, tail); } tail = L; /* the new list element is joined on, but not filled in */ DEREFLISTHANDLE(tail)->h = DEREFWORD(CreatePair(taskData, CreateFontStruct(taskData,fs,dsHandle),Make_string(charset))); DEREFLISTHANDLE(tail)->t = ListNull; } XmFontListFreeFontContext(C); if (tail != 0) FINISHED(taskData, tail); return list; } static Handle CreateUChar(TaskData *taskData, void *p) { return Make_arbitrary_precision(taskData, *(uchar *)p); } static Handle CreateArg(TaskData *taskData, void *v, Handle dsHandle /* Handle to (X_Display_Object *) */) { ArgType *T = (ArgType *)v; Handle value; switch(T->tag) { case CAccelerators: value = EmptyAcc (taskData, T->u.acc); break; case CBool: value = Make_bool (T->u.boolean); break; case CColormap: value = EmptyColormap (taskData, dsHandle,T->u.cmap); break; case CCursor: value = EmptyCursor (taskData, dsHandle,T->u.cursor); break; case CDimension: value = Make_int (T->u.dim); break; case CFontList: value = CreateFontList(taskData, dsHandle,T->u.F); break; case CInt: value = Make_int (T->u.i); break; case CKeySym: value = Make_arbitrary_precision (taskData, T->u.keysym); break; case CPixmap: value = EmptyPixmap (taskData, dsHandle,T->u.pixmap); break; case CPosition: value = Make_int (T->u.posn); break; case CString: value = Make_string (T->u.string); break; case CTrans: value = EmptyTrans (taskData, T->u.trans); break; case CUnsignedChar: value = Make_arbitrary_precision (taskData, T->u.u); break; case CVisual: value = EmptyVisual (taskData, dsHandle,T->u.visual); break; case CWidget: value = EmptyWidget (taskData, dsHandle,T->u.widget); break; case CXmString: value = CreateXmString(taskData, &T->u.xmString); break; case CIntTable: value = CreateList4(taskData, T->N,T->u.I,sizeof(int), CreateUnsigned); break; case CUnsignedTable: value = CreateList4(taskData, T->N,T->u.U,sizeof(uchar), CreateUChar); break; case CStringTable: value = CreateList4(taskData, T->N,T->u.S,sizeof(char *), CreateString); break; case CWidgetList: value = CreateList5(taskData,T->N,T->u.W,sizeof(Widget), CreateWidget,dsHandle); break; case CXmStringTable: value = CreateList4(taskData, T->N,T->u.X,sizeof(XmString),CreateXmString); break; default: Crash ("Bad arg type %x",T->tag); /*NOTREACHED*/ } return value; } static Handle GetValue ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget w, PolyWord pair /* ML (string*Ctype) */ ) { Arg A; ArgType T; XmString *X = (XmString *) 0x55555555; XmString *Y = (XmString *) 0xAAAAAAAA; GetArgType(taskData,pair,&T,0,w); A.name = T.name; A.value = (XtArgVal) &T.u; T.u.X = X; /* The value is set to X. If it is left set to X */ /* then this may be a value this widget doesn't have. */ XtGetValues(w,&A,1); if (T.u.X == X) { T.u.X = Y; XtGetValues(w,&A,1); if (T.u.X == Y) { char buffer[500]; sprintf(buffer,"XtGetValues (%s) failed",T.name); RaiseXWindows(taskData, buffer); } } return CreateArg(taskData, &T,dsHandle); } /* What is the real ML type of p? (string*Ctype*string*string*string*Ctype) */ static void GetResource ( TaskData *taskData, PolyWord pp, XtResource *R, int i, ArgType *T, ArgType *D, Widget w ) { PolyObject *p = pp.AsObjPtr(); GetArgType(taskData,pp,&T[i],0,w); /* HACK !!! */ CopyString(taskData, p->Get(0), &R->resource_name, 0); CopyString(taskData, p->Get(2), &R->resource_class, 0); CopyString(taskData, p->Get(3), &R->resource_type, 0); R->resource_size = 4; R->resource_offset = (byte*)(&T[i].u) - (byte*)(T); SetArgTypeP(taskData, p->Get(4), p->Get(5), &D[i]); /* This was a hack. I hope I converted it correctly. DCJM */ R->default_type = D[i].name; if (UNTAGGED(p->Get(5).AsObjPtr()->Get(1)) == CString) R->default_addr = (XtPointer) D[i].u.string; else R->default_addr = (XtPointer) &D[i].u; } static Handle GetSubresources ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget w, PolyStringObject *s1, PolyStringObject *s2, Handle list ) { char name [100]; char clas[100]; unsigned N = ListLength(DEREFWORD(list)); ArgType *T = (ArgType *) alloca(N * sizeof(ArgType)); ArgType *D = (ArgType *) alloca(N * sizeof(ArgType)); XtResource *R = (XtResource *) alloca(N * sizeof(XtResource)); { unsigned i = 0; for(PolyWord p = DEREFWORD(list); NONNIL(p); p = ((ML_Cons_Cell *)p.AsObjPtr())->t) { GetResource(taskData,((ML_Cons_Cell *)p.AsObjPtr())->h,&R[i],i,T,D,w); i++; } } Poly_string_to_C(s1,name ,sizeof(name)); Poly_string_to_C(s2,clas,sizeof(clas)); XtGetSubresources(w,T,name,clas,R,N,NULL,0); return CreateList5(taskData,N,T,sizeof(ArgType),CreateArg,dsHandle); } static Handle GetApplicationResources (TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget w, Handle list ) { unsigned N = ListLength (DEREFLISTHANDLE(list)) ; ArgType *T = (ArgType *) alloca ( N * sizeof(ArgType) ) ; ArgType *D = (ArgType *) alloca ( N * sizeof(ArgType) ) ; XtResource *R = (XtResource *) alloca ( N * sizeof(XtResource) ) ; { unsigned i = 0; for(PolyWord p = DEREFWORD(list); NONNIL(p); p = ((ML_Cons_Cell *)p.AsObjPtr())->t) { GetResource(taskData,((ML_Cons_Cell *)p.AsObjPtr())->h,&R[i],i,T,D,w); i++; } } XtGetApplicationResources ( w,T,R,N,NULL,0 ) ; return CreateList5 (taskData, N,T,sizeof(ArgType),CreateArg,dsHandle ) ; } static void GetChild(TaskData *taskData, PolyWord p, void *v, unsigned) { Widget *w = (Widget *)v; *w = GetWidget(taskData, (X_Object *)p.AsObjPtr()); if (XtParent(*w) == NULL) RaiseXWindows(taskData, "not a child"); } static void ManageChildren(TaskData *taskData, Handle list) { unsigned N = ListLength(DEREFWORD(list)); Widget *W = (Widget *) alloca(N * sizeof(Widget)); GetList4(taskData, DEREFWORD(list),W,sizeof(Widget),GetChild); XtManageChildren(W,N); } static void UnmanageChildren(TaskData *taskData, Handle list) { unsigned N = ListLength(DEREFWORD(list)); Widget *W = (Widget *) alloca(N * sizeof(Widget)); GetList4(taskData, DEREFWORD(list),W,sizeof(Widget),GetChild); XtUnmanageChildren(W,N); } static Handle ParseTranslationTable(TaskData *taskData, PolyStringObject *s) { XtTranslations table; int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); table = XtParseTranslationTable(buffer); return EmptyTrans(taskData, table); } static void CommandError(TaskData *taskData, Widget w, PolyWord s) { XmString p; GetXmString(taskData, s, &p, 0); XmCommandError(w,p); XmStringFree (p); } static void FileSelectionDoSearch(TaskData *taskData, Widget w, PolyWord s) { XmString p; GetXmString(taskData, s, &p, 0); XmFileSelectionDoSearch(w,p); XmStringFree (p); } static void MenuPosition (Widget w, int x, int y) { XButtonPressedEvent ev; memset (&ev, 0, sizeof(ev)); ev.type = 4; /* Must be button. */ ev.x_root = x; ev.y_root = y; ev.button = 3; /* Is this required? */ ev.same_screen = 1; /* Assume this. */ XmMenuPosition (w, &ev); } static Handle XmIsSomething(TaskData *taskData, unsigned is_code, Widget widget) { unsigned i; switch(is_code) { case 1: i = XmIsArrowButton (widget); break; case 2: i = XmIsArrowButtonGadget (widget); break; case 3: i = XmIsBulletinBoard (widget); break; case 4: i = XmIsCascadeButton (widget); break; case 5: i = XmIsCascadeButtonGadget(widget); break; case 6: i = XmIsCommand (widget); break; case 7: i = XmIsDesktopObject (widget); break; /* ok - SPF 9/8/94 */ case 8: i = XmIsDialogShell (widget); break; /* Unsupported in Motif 1.2 case 9: i = XmIsDisplayObject (widget); break; */ case 10: i = XmIsDrawingArea (widget); break; case 11: i = XmIsDrawnButton (widget); break; case 12: i = XmIsExtObject (widget); break; /* ok - SPF 9/8/94 */ case 13: i = XmIsFileSelectionBox (widget); break; case 14: i = XmIsForm (widget); break; case 15: i = XmIsFrame (widget); break; case 16: i = XmIsGadget (widget); break; case 17: i = XmIsLabel (widget); break; case 18: i = XmIsLabelGadget (widget); break; case 19: i = XmIsList (widget); break; case 20: i = XmIsMainWindow (widget); break; case 21: i = XmIsManager (widget); break; case 22: i = XmIsMenuShell (widget); break; case 23: i = XmIsMessageBox (widget); break; case 24: i = XmIsMotifWMRunning (widget); break; case 25: i = XmIsPanedWindow (widget); break; case 26: i = XmIsPrimitive (widget); break; case 27: i = XmIsPushButton (widget); break; case 28: i = XmIsPushButtonGadget (widget); break; case 29: i = XmIsRowColumn (widget); break; case 30: i = XmIsScale (widget); break; /* Unsupported in Motif 1.2 case 31: i = XmIsScreenObject (widget); break; */ case 32: i = XmIsScrollBar (widget); break; case 33: i = XmIsScrolledWindow (widget); break; case 34: i = XmIsSelectionBox (widget); break; case 35: i = XmIsSeparator (widget); break; case 36: i = XmIsSeparatorGadget (widget); break; #ifdef LESSTIF_VERSION /* This is not supported in LessTif, at least not 0.89. */ case 37: RaiseXWindows(taskData, "XmIsShellExt: not implemented"); #else case 37: i = XmIsShellExt (widget); break; /* ok - SPF 9/8/94 */ #endif case 38: i = XmIsText (widget); break; case 39: i = XmIsTextField (widget); break; case 40: i = XmIsToggleButton (widget); break; case 41: i = XmIsToggleButtonGadget (widget); break; case 42: i = XmIsVendorShell (widget); break; case 43: i = XmIsVendorShellExt (widget); break; /* ok - SPF 9/8/94 */ /* Unsupported in Motif 1.2 case 44: i = XmIsWorldObject (widget); break; */ default: Crash ("Bad code (%d) in XmIsSomething",is_code); /* NOTREACHED*/ } return Make_bool(i); } /******************************************************************************/ /* */ /* Wrappers for standard widget operations */ /* */ /******************************************************************************/ /************************* 0 parameters, no result ****************************/ /* widget -> unit */ static void WidgetAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData,func_name,arg1); applyFunc(w); } /************************* 1 parameter, no result *****************************/ /* widget -> bool -> unit */ static void WidgetBoolAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, Boolean), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); Boolean b = (get_C_short(taskData, arg2) != 0); applyFunc(w,b); } /* widget -> int -> unit */ static void WidgetIntAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, int), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); int i = get_C_long(taskData, arg2); applyFunc(w,i); } /* widget -> int -> unit */ static void WidgetLongAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, long), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); long i = get_C_long(taskData, arg2); applyFunc(w,i); } /* widget -> string -> unit */ static void WidgetXmstringAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, XmString), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); XmString s; GetXmString(taskData, arg2, &s, 0); applyFunc(w,s); XmStringFree(s); } /* widget -> string list -> unit */ static void WidgetXmstringlistAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, XmString *, int), X_Object *arg1, ML_Cons_Cell *arg2 ) { Widget w = getWidget(taskData,func_name,arg1); unsigned n = ListLength(arg2); XmString *strings = (XmString *)alloca(n * sizeof(XmString)); GetList4(taskData, arg2,strings,sizeof(XmString),GetXmString); applyFunc(w,strings,n); for (unsigned i = 0; i < n; i ++) XmStringFree(strings[i]); } /************************* 2 parameters, no result ****************************/ /* widget -> int -> bool -> unit */ static void WidgetIntBoolAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, int, Boolean), X_Object *arg1, PolyWord arg2, PolyWord arg3 ) { Widget w = getWidget(taskData,func_name,arg1); int i = get_C_long(taskData, arg2); Boolean b = (get_C_ushort(taskData, arg3) != 0); applyFunc(w,i,b); } /* widget -> int -> int -> unit */ static void WidgetIntIntAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, int, int), X_Object *arg1, PolyWord arg2, PolyWord arg3 ) { Widget w = getWidget(taskData,func_name,arg1); int x = get_C_long(taskData, arg2); int y = get_C_long(taskData, arg3); applyFunc(w,x,y); } /* widget -> string -> bool -> unit */ static void WidgetXmstringBoolAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, XmString, Boolean), X_Object *arg1, PolyWord arg2, PolyWord arg3 ) { Widget w = getWidget(taskData,func_name,arg1); XmString s; Boolean b = (get_C_ushort(taskData, arg3) != 0); GetXmString(taskData, arg2, &s, 0); applyFunc(w,s,b); XmStringFree(s); } /* widget -> string -> int -> unit */ static void WidgetXmstringIntAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, XmString, int), X_Object *arg1, PolyWord arg2, PolyWord arg3 ) { Widget w = getWidget(taskData,func_name,arg1); XmString s; int i = get_C_long(taskData, arg3); GetXmString(taskData, arg2, &s, 0); applyFunc(w,s,i); XmStringFree(s); } /* widget -> string list -> int -> unit */ static void WidgetXmstringlistIntAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, XmString *, int, int), X_Object *arg1, ML_Cons_Cell *arg2, PolyWord arg3 ) { Widget w = getWidget(taskData,func_name,arg1); unsigned n = ListLength(arg2); int i = get_C_long(taskData, arg3); XmString *strings = (XmString *)alloca(n * sizeof(XmString)); GetList4(taskData, arg2,strings,sizeof(XmString),GetXmString); applyFunc(w,strings,n,i); for (unsigned i = 0; i < n; i ++) XmStringFree(strings[i]); } /************************* n parameters, some result **************************/ static Handle int_ptr_to_arb(TaskData *taskData, void *p) { return Make_arbitrary_precision(taskData, *(int *)p); } /* widget -> int */ static Handle WidgetToInt ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), int applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData, func_name,arg1); int res = applyFunc(w); return(Make_arbitrary_precision(taskData, res)); } /* widget -> int */ static Handle WidgetToLong ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *taskData, char *, X_Object *), long applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData, func_name,arg1); long res = applyFunc(w); return(Make_arbitrary_precision(taskData, res)); } #if 0 /* widget -> int */ static Handle WidgetToUnsigned ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), unsigned applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData, func_name,arg1); unsigned res = applyFunc(w); return(Make_arbitrary_precision(taskData, res)); } #endif /* widget -> bool */ static Handle WidgetToBool ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), Boolean applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData, func_name,arg1); Boolean res = applyFunc(w); return(Make_bool(res)); } /* widget -> string */ static Handle WidgetToString ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), char *applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData, func_name,arg1); char *s = applyFunc(w); Handle res = Make_string(s); /* safe, even if C pointer is NULL */ XtFree(s); return(res); } /* widget -> int list */ static Handle WidgetToIntlist ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), Boolean applyFunc(Widget, int**, int *), X_Object *arg1 ) { int item_count, *items; Boolean non_empty; Widget w = getWidget(taskData,func_name,arg1); non_empty = applyFunc(w, &items, &item_count); if (non_empty != TRUE) /* nothing found, and Motif hasn't allocated any space */ /* so just retun nil */ { return (SAVE(ListNull)); } else /* copy the list into the ML heap, then free it */ { Handle res = CreateList4(taskData, item_count,items,sizeof(int),int_ptr_to_arb); XtFree((char *)items); return res; } } /* widget -> string -> int list */ static Handle WidgetXmstringToIntlist ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), Boolean applyFunc(Widget, XmString, int**, int *), X_Object *arg1, PolyWord arg2 ) { int item_count, *items; Boolean non_empty; Widget w = getWidget(taskData,func_name,arg1); XmString s; GetXmString(taskData, arg2, &s, 0); non_empty = applyFunc(w, s, &items, &item_count); XmStringFree(s); if (non_empty != TRUE) /* nothing found, so just retun nil */ { return (SAVE(ListNull)); } else /* copy the list into the ML heap, then free it */ { Handle res = CreateList4(taskData, item_count,items,sizeof(int),int_ptr_to_arb); XtFree((char *)items); return res; } } /* widget -> string -> int */ static Handle WidgetXmstringToInt ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), int applyFunc(Widget, XmString), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); XmString s; int res; GetXmString(taskData, arg2, &s, 0); res = applyFunc(w, s); XmStringFree(s); return (Make_int(res)); } /* widget -> string -> bool */ static Handle WidgetXmstringToBool ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), Boolean applyFunc(Widget, XmString), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); XmString s; Boolean res; GetXmString(taskData, arg2, &s, 0); res = applyFunc(w, s); XmStringFree(s); return (Make_bool(res)); } /******************************************************************************/ /* code added SPF 25/2/95 */ static bool isPossibleString(PolyObject *P) { if (!OBJ_IS_DATAPTR(P)) return false; POLYUNSIGNED L = P->LengthWord(); if (! OBJ_IS_BYTE_OBJECT(L)) return false; /* get object PolyWord count */ POLYUNSIGNED n = OBJ_OBJECT_LENGTH(L); if (n < 1) return false; /* get string byte count */ POLYUNSIGNED m = P->Get(0).AsUnsigned(); /* number of words to hold the bytes */ m = (m + 3) / 4; /* number of words to hold the bytes, plus the byte count */ m = m + 1; /* If that's the same as the object PolyWord count, we've probably got a genuine string! */ return (m == n); } /* Prints out the contents of a PolyWord in the X interface tuple */ static void DebugPrintWord(PolyWord P /* was X_Object *P */) { TaskData *taskData = processes->GetTaskDataForThread(); if (IS_INT((P))) { printf("Short %d", (int)UNTAGGED(P)); return; } if (isPossibleString(P.AsObjPtr())) { if (((PolyStringObject*)P.AsObjPtr())->length <= 40) { printf("String: \""); print_string((PolyStringObject*) P.AsObjPtr()); printf("\""); return; } else { printf("Long String: %p", P.AsAddress()); return; } } /* The problem with the following code was that we can't be sure that the object we have is really an X_Object - it might just look like one. If this is the case, when we try to validate the object using ResourceExists we may get a core dump because ResourceExists assumes it has a valid X_Object and calls hashId which dereferences fields within the so-called X_object. That's why we redefine ResourceExists to be SafeResourceExists which doesn't make any assumptions about the contents of the so-called X_object. SPF 6/4/95 */ #define XP ((X_Object *)P.AsObjPtr()) #define ResourceExists SafeResourceExists { switch(UNTAGGED(XP->type)) { case X_GC: (ResourceExists(XP) ? printf("GC %lx", GetGC(taskData, XP)->gid) : printf("Old GC <%lx>",P.AsUnsigned())); return; case X_Font: (ResourceExists(XP) ? printf("Font %lx",GetFont(taskData, XP)) : printf("Old Font <%x>",(int)P.AsUnsigned())); return; case X_Cursor: (ResourceExists(XP) ? printf("Cursor %lx",GetCursor(taskData, XP)) : printf("Old Cursor <%x>",(int)P.AsUnsigned())); return; case X_Window: (ResourceExists(XP) ? printf("Window %lx",GetWindow(taskData, XP)) : printf("Old Window <%p>",P.AsAddress())); return; case X_Pixmap: (ResourceExists(XP) ? printf("Pixmap %lx",GetPixmap(taskData, XP)) : printf("Old Pixmap <%p>",P.AsAddress())); return; case X_Colormap: (ResourceExists(XP) ? printf("Colormap %lx",GetColormap(taskData, XP)) : printf("Old Colormap <%p>",P.AsAddress())); return; case X_Visual: (ResourceExists(XP) ? printf("Visual %lx",GetVisual(taskData, XP)->visualid) : printf("Old Visual <%p>",P.AsAddress())); return; case X_Widget: (ResourceExists(XP) ? printf("Widget %p",GetNWidget(taskData, XP)) : printf("Old Widget <%p>",P.AsAddress())); return; case X_Trans: (ResourceExists(XP) ? printf("Trans %p",GetTrans(taskData, XP)) : printf("Old Trans <%p>",P.AsAddress())); return; case X_Acc: (ResourceExists(XP) ? printf("Acc %p",GetAcc(taskData, XP)) : printf("Old Acc <%p>",P.AsAddress())); return; case X_Display: (ResourceExists(XP) ? printf("Display %s", DisplayString(GetDisplay(taskData, XP))) + printf(":%x", GetDisplay(taskData, XP)->fd) : printf("Old Display <%p>",P.AsAddress())); return; default: printf("Pointer "ZERO_X"%p",P.AsAddress()); return; } } #undef ResourceExists #undef XP } /* Prints out the contents of the X interface tuple */ static void DebugPrintCode(PolyObject *pt) { POLYUNSIGNED N = pt->Length(); POLYUNSIGNED i = 1; assert(IS_INT(pt->Get(0))); printf("%ld:(", UNTAGGED(pt->Get(0))); while(i < N) { DebugPrintWord(pt->Get(i++)); if (i < N) printf(","); } printf(")\n"); } #define P0 DEREFHANDLE(params)->Get(0) #define P1 DEREFHANDLE(params)->Get(1) #define P2 DEREFHANDLE(params)->Get(2) #define P3 DEREFHANDLE(params)->Get(3) #define P4 DEREFHANDLE(params)->Get(4) #define P5 DEREFHANDLE(params)->Get(5) #define P6 DEREFHANDLE(params)->Get(6) #define P7 DEREFHANDLE(params)->Get(7) #define P8 DEREFHANDLE(params)->Get(8) #define P9 DEREFHANDLE(params)->Get(9) #define P10 DEREFHANDLE(params)->Get(10) #define P11 DEREFHANDLE(params)->Get(11) #define P12 DEREFHANDLE(params)->Get(12) #define XP1 ((X_Object *)P1.AsObjPtr()) #define XP2 ((X_Object *)P2.AsObjPtr()) #define XP3 ((X_Object *)P3.AsObjPtr()) #define XP4 ((X_Object *)P4.AsObjPtr()) #define XP5 ((X_Object *)P5.AsObjPtr()) #define XP6 ((X_Object *)P6.AsObjPtr()) #define XP7 ((X_Object *)P7.AsObjPtr()) /* Xwindows_c gets passed the address of an object in save_vec, */ /* which is itself a pointer to a tuple in the Poly heap. */ Handle XWindows_c(TaskData *taskData, Handle params) { int code = get_C_short(taskData, P0); if ((debugOptions & DEBUG_X)) DebugPrintCode(DEREFHANDLE(params)); switch(code) { case XCALL_Not: return Make_arbitrary_precision(taskData, ~ get_C_ulong(taskData, P1)); case XCALL_And: return Make_arbitrary_precision(taskData, get_C_ulong(taskData, P1) & get_C_ulong(taskData, P2)); case XCALL_Or: return Make_arbitrary_precision(taskData, get_C_ulong(taskData, P1) | get_C_ulong(taskData, P2)); case XCALL_Xor: return Make_arbitrary_precision(taskData, get_C_ulong(taskData, P1) ^ get_C_ulong(taskData, P2)); case XCALL_DownShift: return Make_arbitrary_precision(taskData, get_C_ulong(taskData, P1) >> get_C_ulong(taskData, P2)); case XCALL_UpShift: return Make_arbitrary_precision(taskData, get_C_ulong(taskData, P1) << get_C_ulong(taskData, P2)); case XCALL_NoDrawable: return EmptyPixmap(taskData, SAVE(ListNull),(Pixmap)get_C_ulong(taskData, P1)); case XCALL_NoCursor: return EmptyCursor(taskData, SAVE(ListNull),(Cursor)None); case XCALL_NoFont: return EmptyFont(taskData, SAVE(ListNull),(Font)None,(XFontStruct *)NULL); case XCALL_NoColormap: return EmptyColormap(taskData, SAVE(ListNull),(Colormap) None); case XCALL_NoVisual: return EmptyVisual(taskData, SAVE(ListNull),(Visual *)None); case XCALL_GetTimeOfDay: return GetTimeOfDay(taskData); /* Colorcells 100 */ case XCALL_XAllocColor: return AllocColor(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),GetXColor1(taskData, P2)); case XCALL_XAllocColorCells: return AllocColorCells(taskData, GetDisplay(taskData, XP1), GetColormap(taskData, XP1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), get_C_ulong(taskData, P4)); case XCALL_XAllocColorPlanes: return AllocColorPlanes(taskData, GetDisplay(taskData, XP1), GetColormap(taskData, XP1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), get_C_ulong(taskData, P4), get_C_ulong(taskData, P5), get_C_ulong(taskData, P6)); case XCALL_XAllocNamedColor: return AllocNamedColor(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),GetString(P2)); case XCALL_XFreeColors: FreeColors(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),SAVE(P2),get_C_ulong(taskData, P3)); break; case XCALL_XLookupColor: return LookupColor(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),GetString(P2)); case XCALL_XParseColor: return ParseColor(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),GetString(P2)); case XCALL_XQueryColor: return QueryColor(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),get_C_ulong(taskData, P2)); case XCALL_XQueryColors: return QueryColors(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),SAVE(P2)); case XCALL_XStoreColor: XStoreColor(GetDisplay(taskData, XP1),GetColormap(taskData, XP1),GetXColor1(taskData, P2)); break; case XCALL_XStoreColors: StoreColors(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),SAVE(P2)); break; case XCALL_XStoreNamedColor: StoreNamedColor(GetDisplay(taskData, XP1), GetColormap(taskData, XP1), GetString(P2), get_C_ulong(taskData, P3), get_C_ulong(taskData, P4), get_C_ulong(taskData, P5), get_C_ulong(taskData, P6)); break; case XCALL_BlackPixel: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, BlackPixel(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } case XCALL_WhitePixel: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, WhitePixel(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } /* Colormaps 150 */ case XCALL_XCopyColormapAndFree: return EmptyColormap(taskData, GetDS(taskData, XP1),XCopyColormapAndFree(GetDisplay(taskData, XP1),GetColormap(taskData, XP1))); case XCALL_XCreateColormap: return EmptyColormap(taskData, GetDS(taskData, XP1),XCreateColormap(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetVisual(taskData, XP2),get_C_ulong(taskData, P3))); case XCALL_XInstallColormap: XInstallColormap(GetDisplay(taskData, XP1),GetColormap(taskData, XP1)); break; case XCALL_XListInstalledColormaps: return ListInstalledColormaps(taskData, GetDS(taskData, XP1),GetDrawable(taskData, XP1)); case XCALL_XUninstallColormap: XUninstallColormap(GetDisplay(taskData, XP1),GetColormap(taskData, XP1)); break; case XCALL_DefaultColormap: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return EmptyColormap(taskData, dsHandle, DefaultColormap(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } case XCALL_DefaultVisual: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return EmptyVisual(taskData, dsHandle, DefaultVisual(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } case XCALL_DisplayCells: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, DisplayCells(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } case XCALL_VisualClass: return Make_arbitrary_precision(taskData, GetVisual(taskData, XP1)->c_class); case XCALL_VisualRedMask: return Make_arbitrary_precision(taskData, GetVisual(taskData, XP1)->red_mask); case XCALL_VisualGreenMask: return Make_arbitrary_precision(taskData, GetVisual(taskData, XP1)->green_mask); case XCALL_VisualBlueMask: return Make_arbitrary_precision(taskData, GetVisual(taskData, XP1)->blue_mask); /* Cursors 200 */ case XCALL_XCreateFontCursor: return CreateFontCursor(taskData, GetDS(taskData, XP1),get_C_ulong(taskData, P2)); case XCALL_XCreateGlyphCursor: return CreateGlyphCursor(taskData, GetDS(taskData, XP1), GetFont(taskData, XP1), GetFont(taskData, XP2), get_C_ulong(taskData, P3), get_C_ulong(taskData, P4), GetXColor1(taskData, P5), GetXColor2(taskData, P6)); case XCALL_XCreatePixmapCursor: return CreatePixmapCursor(taskData, GetDS(taskData, XP1), GetPixmap(taskData, XP1), /* source */ GetPixmap(taskData, XP2), /* mask */ GetXColor1(taskData, P3), /* foreground */ GetXColor2(taskData, P4), /* background */ GetOffsetX(taskData, P5), /* x */ GetOffsetY(taskData, P5) /* y */); case XCALL_XDefineCursor: XDefineCursor(GetDisplay(taskData, XP1),GetWindow(taskData, XP1),GetCursor(taskData, XP2)); WindowObject(XP1)->cursor_object = CursorObject(XP2); break; case XCALL_XQueryBestCursor: CheckZeroRect(taskData, P2); return QueryBest(taskData, XQueryBestCursor, GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetRectW(taskData, P2), GetRectH(taskData, P2)); case XCALL_XRecolorCursor: XRecolorCursor(GetDisplay(taskData, XP1), GetCursor(taskData, XP1), GetXColor1(taskData, P2), GetXColor2(taskData, P3)); break; case XCALL_XUndefineCursor: XUndefineCursor(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); WindowObject(XP1)->cursor_object = 0; break; /* Display Specifications 250 */ case XCALL_XOpenDisplay: return OpenDisplay(taskData, GetString(XP1)); #define DODISPLAYOP(op) \ {\ Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1);\ return Make_arbitrary_precision(taskData, op(DEREFDISPLAYHANDLE(dsHandle)->display,\ DEREFDISPLAYHANDLE(dsHandle)->screen));\ } case XCALL_CellsOfScreen: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, CellsOfScreen(ScreenOfDisplay(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen))); } case XCALL_DefaultDepth: DODISPLAYOP(DefaultDepth) case XCALL_DisplayHeight: DODISPLAYOP(DisplayHeight) case XCALL_DisplayHeightMM: DODISPLAYOP(DisplayHeightMM) case XCALL_DisplayPlanes: DODISPLAYOP(DisplayPlanes) case XCALL_DisplayString: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_string(DisplayString(DEREFDISPLAYHANDLE(dsHandle)->display)); } case XCALL_DisplayWidth: DODISPLAYOP(DisplayWidth) case XCALL_DisplayWidthMM: DODISPLAYOP(DisplayWidthMM) #undef DODISPLAYOP #define DODISPLAYSCREENOP(op) \ {\ Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1);\ return Make_arbitrary_precision(taskData, op(ScreenOfDisplay(DEREFDISPLAYHANDLE(dsHandle)->display,\ DEREFDISPLAYHANDLE(dsHandle)->screen)));\ } case XCALL_DoesBackingStore: DODISPLAYSCREENOP(DoesBackingStore) case XCALL_DoesSaveUnders: DODISPLAYSCREENOP(DoesSaveUnders) case XCALL_EventMaskOfScreen: DODISPLAYSCREENOP(EventMaskOfScreen) case XCALL_MaxCmapsOfScreen: DODISPLAYSCREENOP(MaxCmapsOfScreen) case XCALL_MinCmapsOfScreen: DODISPLAYSCREENOP(MinCmapsOfScreen) #undef DODISPLAYSCREENOP case XCALL_ProtocolRevision: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, ProtocolRevision(DEREFDISPLAYHANDLE(dsHandle)->display)); } case XCALL_ProtocolVersion: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, ProtocolVersion(DEREFDISPLAYHANDLE(dsHandle)->display)); } case XCALL_ServerVendor: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_string (ServerVendor(DEREFDISPLAYHANDLE(dsHandle)->display)); } case XCALL_VendorRelease: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, VendorRelease(DEREFDISPLAYHANDLE(dsHandle)->display)); } /* Drawing Primitives 300 */ case XCALL_XClearArea: XClearArea(GetDisplay(taskData, XP1), GetWindow(taskData, XP1), GetRectX(taskData, P2), GetRectY(taskData, P2), GetRectW(taskData, P2), GetRectH(taskData, P2), get_C_ulong(taskData, P3)); break; case XCALL_XClearWindow: XClearWindow(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XCopyArea: XCopyArea(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetDrawable(taskData, XP2), GetGC(taskData, XP3), GetPointX(taskData, P4), GetPointY(taskData, P4), GetRectW(taskData, P5), GetRectH(taskData, P5), GetRectX(taskData, P5), GetRectY(taskData, P5)); break; case XCALL_XCopyPlane: XCopyPlane(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetDrawable(taskData, XP2), GetGC(taskData, XP3), GetPointX(taskData, P4), GetPointY(taskData, P4), GetRectW(taskData, P5), GetRectH(taskData, P5), GetRectX(taskData, P5), GetRectY(taskData, P5), get_C_ulong(taskData, P6)); break; case XCALL_XDrawArc: XDrawArc(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetRectX(taskData, GetArcR(P3)), GetRectY(taskData, GetArcR(P3)), GetRectW(taskData, GetArcR(P3)), GetRectH(taskData, GetArcR(P3)), GetArcA1(taskData, P3), GetArcA2(taskData, P3)); break; case XCALL_XDrawArcs: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XArc *L = (XArc *)alloca(N * sizeof(XArc)); GetList4(taskData, DEREFWORD(list), L, sizeof(XArc), GetArcs); XDrawArcs(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), L, N); } } break; case XCALL_XDrawImageString: XDrawImageString(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3), GetString(P4)->chars, GetString(P4)->length); break; case XCALL_XDrawImageString16: { Handle list = SAVE(P4); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XChar2b *L = (XChar2b *)alloca(N * sizeof(XChar2b)); GetList4(taskData, DEREFWORD(list),L, sizeof(XChar2b), GetChar2); XDrawImageString16(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),GetPointX(taskData, P3),GetPointY(taskData, P3),L,N); } } break; case XCALL_XDrawLine: XDrawLine(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3), GetPointX(taskData, P4), GetPointY(taskData, P4)); break; case XCALL_XDrawLines: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XPoint *L = (XPoint *)alloca(N * sizeof(XPoint)); GetList4(taskData, DEREFWORD(list), L, sizeof(XPoint), GetPoints); XDrawLines(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), L, N, get_C_ulong(taskData, P4)); } } break; case XCALL_XDrawPoint: XDrawPoint(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3)); break; case XCALL_XDrawPoints: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XPoint *L = (XPoint *)alloca(N * sizeof(XPoint)); GetList4(taskData, DEREFWORD(list),L,sizeof(XPoint),GetPoints); XDrawPoints(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), L, N, get_C_ulong(taskData, P4)); } } break; case XCALL_XDrawRectangle: XDrawRectangle(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetRectX(taskData, P3), GetRectY(taskData, P3), GetRectW(taskData, P3), GetRectH(taskData, P3)); break; case XCALL_XDrawRectangles: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XRectangle *L = (XRectangle *)alloca(N * sizeof(XRectangle)); GetList4(taskData, DEREFWORD(list),L,sizeof(XRectangle),GetRects); XDrawRectangles(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),L,N); } } break; case XCALL_XDrawSegments: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XSegment *L = (XSegment *)alloca(N * sizeof(XSegment)); GetList4(taskData, DEREFWORD(list),L,sizeof(XSegment),GetSegments); XDrawSegments(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),L,N); } } break; case XCALL_XDrawString: XDrawString(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3), GetString(P4)->chars, GetString(P4)->length); break; case XCALL_XDrawString16: { Handle list = SAVE(P4); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XChar2b *L = (XChar2b *)alloca(N * sizeof(XChar2b)); GetList4(taskData, DEREFWORD(list),L,sizeof(XChar2b),GetChar2); XDrawString16(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),GetPointX(taskData, P3),GetPointY(taskData, P3),L,N); } } break; case XCALL_XDrawText: { Handle list = SAVE(P4); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XTextItem *L = (XTextItem *)alloca(N * sizeof(XTextItem)); GetList4(taskData, DEREFWORD(list),L,sizeof(XTextItem),GetText); XDrawText(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),GetPointX(taskData, P3),GetPointY(taskData, P3),L,N); while (N--) { free(L->chars); L++; } } } break; case XCALL_XDrawText16: { Handle list = SAVE(P4); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XTextItem16 *L = (XTextItem16 *)alloca(N * sizeof(XTextItem16)); GetList4(taskData, DEREFWORD(list),L,sizeof(XTextItem16), GetText16); XDrawText16(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),GetPointX(taskData, P3),GetPointY(taskData, P3),L,N); while (N--) { free(L->chars); L++; } } } break; case XCALL_XFillArc: XFillArc(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetRectX(taskData, GetArcR(P3)), GetRectY(taskData, GetArcR(P3)), GetRectW(taskData, GetArcR(P3)), GetRectH(taskData, GetArcR(P3)), GetArcA1(taskData, P3), GetArcA2(taskData, P3)); break; case XCALL_XFillArcs: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XArc *L = (XArc *)alloca(N * sizeof(XArc)); GetList4(taskData, DEREFWORD(list),L,sizeof(XArc),GetArcs); XFillArcs(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),L,N); } } break; case XCALL_XFillPolygon: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XPoint *L = (XPoint *)alloca(N * sizeof(XPoint)); GetList4(taskData, DEREFWORD(list),L,sizeof(XPoint),GetPoints); XFillPolygon(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),L,N,get_C_ulong(taskData, P4),get_C_ulong(taskData, P5)); } } break; case XCALL_XFillRectangle: XFillRectangle(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetRectX(taskData, P3), GetRectY(taskData, P3), GetRectW(taskData, P3), GetRectH(taskData, P3)); break; case XCALL_XFillRectangles: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XRectangle *L = (XRectangle *)alloca(N * sizeof(XRectangle)); GetList4(taskData, DEREFWORD(list),L,sizeof(XRectangle),GetRects); XFillRectangles(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),L,N); } } break; /* Events 350 */ case XCALL_XSelectInput: (WindowObject(XP1))->eventMask->Set(0, PolyWord::FromUnsigned(get_C_ulong(taskData, P2))); XSelectInput(GetDisplay(taskData, XP1),GetWindow(taskData, XP1),XMASK((WindowObject(XP1))->eventMask->Get(0).AsUnsigned())); break; case XCALL_XSynchronize: XSynchronize(GetDisplay(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_GetState: return GetState(taskData, WindowObject(XP1)); /* WindowObject added SPF */ case XCALL_SetState: SetState(WindowObject(XP1),P2,P3); /* WindowObject added SPF */ break; case XCALL_NextEvent: return NextEvent(taskData, GetDS(taskData, XP1)); case XCALL_InsertTimeout: InsertTimeout(taskData, WindowObject(XP1),get_C_ulong(taskData, P2),P3,P4); /* WindowObject added SPF */ break; case XCALL_XSetInputFocus: XSetInputFocus(GetDisplay(taskData, XP1),GetWindow(taskData, XP2),get_C_ulong(taskData, P3),get_C_ulong(taskData, P4)); break; case XCALL_XGetInputFocus: return GetInputFocus(taskData, GetDS(taskData, XP1)); case XCALL_XSetSelectionOwner: SetSelectionOwner(GetDS(taskData, XP1),get_C_ulong(taskData, P2),GetWindow(taskData, XP3),get_C_ulong(taskData, P4)); break; case XCALL_XGetSelectionOwner: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return EmptyWindow(taskData, dsHandle,XGetSelectionOwner(DEREFDISPLAYHANDLE(dsHandle)->display, get_C_ulong(taskData, P2))); } case XCALL_XConvertSelection: XConvertSelection(GetDisplay(taskData, XP4), get_C_ulong(taskData, P1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), GetWindow(taskData, XP4), get_C_ulong(taskData, P5)); break; case XCALL_XSendSelectionNotify: SendSelectionNotify(GetDisplay(taskData, XP4), get_C_ulong(taskData, P1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), GetWindow(taskData, XP4), get_C_ulong(taskData, P5)); break; case XCALL_XDeleteProperty: XDeleteProperty(GetDisplay(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_XInternAtom: return InternAtom(taskData, GetDisplay(taskData, XP1),GetString(P2),get_C_long(taskData, P3)); case XCALL_XGetAtomName: return GetAtomName(taskData, GetDisplay(taskData, XP1),get_C_ulong(taskData, P2)); /* Fonts 400 */ case XCALL_XGetFontPath: return GetFontPath(taskData, GetDisplay(taskData, XP1)); case XCALL_XListFonts: return ListFonts(taskData, GetDisplay(taskData, XP1),GetString(P2),get_C_ulong(taskData, P3)); case XCALL_XListFontsWithInfo: return ListFontsWithInfo(taskData, GetDS(taskData, XP1),GetString(P2),get_C_ulong(taskData, P3)); case XCALL_XLoadFont: return LoadFont(taskData, GetDS(taskData, XP1),GetString(P2)); case XCALL_XLoadQueryFont: return LoadQueryFont(taskData, GetDS(taskData, XP1),GetString(P2)); case XCALL_XQueryFont: return QueryFont(taskData, GetDS(taskData, XP1),GetFont(taskData, XP1)); case XCALL_XSetFontPath: SetFontPath(taskData, GetDisplay(taskData, XP1),SAVE(P2)); break; /* Grabbing 450 */ /* Graphics Context 500 */ case XCALL_DefaultGC: return GetDefaultGC(taskData, GetDS(taskData, XP1)); case XCALL_UpdateGC: ChangeGC(taskData, GCObject(XP1),get_C_ulong(taskData, P2),P3); break; case XCALL_XCreateGC: return CreateGC(taskData, GetDS(taskData, XP1),GetDrawable(taskData, XP1)); case XCALL_XSetClipRectangles: SetClipRectangles(taskData, GetDisplay(taskData, XP1), GetGC(taskData, XP1), GetPointX(taskData, P2), GetPointY(taskData, P2), SAVE(P3), get_C_ulong(taskData, P4)); break; case XCALL_XSetDashes: SetDashes(taskData, GetDisplay(taskData, XP1), GetGC(taskData, XP1), get_C_ulong(taskData, P2), SAVE(P3)); break; /* Images 550 */ case XCALL_XAddPixel: AddPixel(GetXImage(taskData, GetDisplay(taskData, XP1),P2),get_C_ulong(taskData, P3)); break; case XCALL_XGetImage: return GetImage(taskData, GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetRectX(taskData, P2), GetRectY(taskData, P2), GetRectW(taskData, P2), GetRectH(taskData, P2), get_C_ulong(taskData, P3), get_C_long(taskData, P4)); case XCALL_XGetPixel: return GetPixel(taskData, GetXImage(taskData, GetDisplay(taskData, XP1),P2), GetPointX(taskData, P3), GetPointY(taskData, P3)); case XCALL_XGetSubImage: GetSubImage(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetRectX(taskData, P2), GetRectY(taskData, P2), GetRectW(taskData, P2), GetRectH(taskData, P2), get_C_ulong(taskData, P3), get_C_long(taskData, P4), GetXImage(taskData, GetDisplay(taskData, XP1),P5), GetPointX(taskData, P6), GetPointY(taskData, P6)); break; case XCALL_XPutImage: PutImage(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetXImage(taskData, GetDisplay(taskData, XP1),P3), GetPointX(taskData, P4), GetPointY(taskData, P4), GetRectX(taskData, P5), GetRectY(taskData, P5), GetRectW(taskData, P5), GetRectH(taskData, P5)); break; case XCALL_XPutPixel: PutPixel(GetXImage(taskData, GetDisplay(taskData, XP1),P2), GetPointX(taskData, P3), GetPointY(taskData, P3), get_C_ulong(taskData, P4)); break; case XCALL_XSubImage: return SubImage(taskData, GetXImage(taskData, GetDisplay(taskData, XP1),P2), GetRectX(taskData, P3), GetRectY(taskData, P3), GetRectW(taskData, P3), GetRectH(taskData, P3)); case XCALL_BitmapBitOrder: return Make_arbitrary_precision(taskData, MLImageOrder(BitmapBitOrder(GetDisplay(taskData, XP1)))); case XCALL_BitmapPad: return Make_arbitrary_precision(taskData, BitmapPad(GetDisplay(taskData, XP1))); case XCALL_BitmapUnit: return Make_arbitrary_precision(taskData, BitmapUnit(GetDisplay(taskData, XP1))); case XCALL_ByteOrder: return Make_arbitrary_precision(taskData, MLImageOrder(ImageByteOrder(GetDisplay(taskData, XP1)))); /* Keyboard 600 */ case XCALL_XLookupString: return LookupString(taskData, GetDisplay(taskData, XP1),get_C_ulong(taskData, P2),get_C_ulong(taskData, P3)); case XCALL_XQueryKeymap: return QueryKeymap(taskData, GetDisplay(taskData, XP1)); case XCALL_IsCursorKey: return Make_bool(IsCursorKey(get_C_ulong(taskData, P1))); case XCALL_IsFunctionKey: return Make_bool(IsFunctionKey(get_C_ulong(taskData, P1))); case XCALL_IsKeypadKey: return Make_bool(IsKeypadKey(get_C_ulong(taskData, P1))); case XCALL_IsMiscFunctionKey: return Make_bool(IsMiscFunctionKey(get_C_ulong(taskData, P1))); case XCALL_IsModifierKey: return Make_bool(IsModifierKey(get_C_ulong(taskData, P1))); case XCALL_IsPFKey: return Make_bool(IsPFKey(get_C_ulong(taskData, P1))); /* Output Buffer 650 */ case XCALL_XFlush: XFlush(GetDisplay(taskData, XP1)); break; case XCALL_XSync: XSync(GetDisplay(taskData, XP1),get_C_ulong(taskData, P2)); break; /* Pointers 700 */ case XCALL_XQueryPointer: return QueryPointer(taskData, GetDS(taskData, XP1),GetWindow(taskData, XP1)); /* Regions 750*/ /* SAVE Set 800 */ /* Screen Saver 850 */ case XCALL_XActivateScreenSaver: XActivateScreenSaver(GetDisplay(taskData, XP1)); break; case XCALL_XForceScreenSaver: XForceScreenSaver(GetDisplay(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_XGetScreenSaver: return GetScreenSaver(taskData, GetDisplay(taskData, XP1)); case XCALL_XResetScreenSaver: XResetScreenSaver(GetDisplay(taskData, XP1)); break; case XCALL_XSetScreenSaver: XSetScreenSaver(GetDisplay(taskData, XP1), get_C_long(taskData, P2), get_C_long(taskData, P3), get_C_ulong(taskData, P4), get_C_ulong(taskData, P5)); break; /* Standard Geometry 900 */ case XCALL_XTranslateCoordinates: return TranslateCoordinates(taskData, GetDS(taskData, XP1), GetWindow(taskData, XP1), GetWindow(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3)); /* Text 950 */ case XCALL_XTextExtents: return TextExtents(taskData, GetFontStruct(taskData, P1),GetString(P2)); case XCALL_XTextExtents16: return TextExtents16(taskData, GetFontStruct(taskData, P1),SAVE(P2)); case XCALL_XTextWidth: return TextWidth(taskData, GetFontStruct(taskData, P1),GetString(P2)); case XCALL_XTextWidth16: return TextWidth16(taskData, GetFontStruct(taskData, P1),SAVE(P2)); /* Tiles, Pixmaps, Stipples and Bitmaps 1000 */ case XCALL_XCreateBitmapFromData: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); CheckZeroRect(taskData, P3); return EmptyPixmap(taskData, dsHandle, XCreateBitmapFromData( DEREFDISPLAYHANDLE(dsHandle)->display, GetDrawable(taskData, XP1), /* drawable */ GetString(P2)->chars, /* data */ GetRectW(taskData, P3), /* width */ GetRectH(taskData, P3))); /* height */ } case XCALL_XCreatePixmap: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); CheckZeroRect(taskData, P2); return EmptyPixmap(taskData, dsHandle, XCreatePixmap( DEREFDISPLAYHANDLE(dsHandle)->display, GetDrawable(taskData, XP1), /* drawable */ GetRectW(taskData, P2), /* width */ GetRectH(taskData, P2), /* height */ get_C_ulong(taskData, P3))); /* depth */ } case XCALL_XCreatePixmapFromBitmapData: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); CheckZeroRect(taskData, P3); return EmptyPixmap(taskData, dsHandle, XCreatePixmapFromBitmapData( DEREFDISPLAYHANDLE(dsHandle)->display, GetDrawable(taskData, XP1), /* drawable */ GetString(P2)->chars, /* data */ GetRectW(taskData, P3), /* width */ GetRectH(taskData, P3), /* height */ get_C_ulong(taskData, P4), /* foreground */ get_C_ulong(taskData, P5), /* background */ get_C_ulong(taskData, P6))); /* depth */ } case XCALL_XQueryBestStipple: CheckZeroRect(taskData, P2); return QueryBest(taskData, XQueryBestStipple, GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetRectW(taskData, P2), GetRectH(taskData, P2)); case XCALL_XQueryBestTile: CheckZeroRect(taskData, P2); return QueryBest(taskData, XQueryBestTile, GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetRectW(taskData, P2), GetRectH(taskData, P2)); case XCALL_XReadBitmapFile: return ReadBitmap(taskData, GetDS(taskData, XP1),GetDrawable(taskData, XP1),GetString(P2)); case XCALL_XWriteBitmapFile: CheckZeroRect(taskData, P3); return WriteBitmapFile(taskData, GetString(XP1), GetDisplay(taskData, XP2), GetPixmap(taskData, XP2), GetRectW(taskData, P3), GetRectH(taskData, P3), GetPointX(taskData, P4), GetPointY(taskData, P4)); /* User Preferences 1050 */ case XCALL_XAutoRepeatOff: XAutoRepeatOff(GetDisplay(taskData, XP1)); break; case XCALL_XAutoRepeatOn: XAutoRepeatOn (GetDisplay(taskData, XP1)); break; case XCALL_XBell: XBell(GetDisplay(taskData, XP1),get_C_short(taskData, P2)); break; case XCALL_XGetDefault: return GetDefault(taskData, GetDisplay(taskData, XP1),GetString(P2),GetString(P3)); /* Window Attributes 1100 */ case XCALL_ChangeWindow: ChangeWindowAttributes(taskData, WindowObject(XP1),get_C_ulong(taskData, P2),P3); break; case XCALL_XGetGeometry: return GetGeometry(taskData, GetDS(taskData, XP1),GetDrawable(taskData, XP1)); case XCALL_XGetWindowAttributes: return GetWindowAttributes(taskData, GetDS(taskData, XP1),GetDrawable(taskData, XP1)); case XCALL_XSetWindowBorderWidth: XSetWindowBorderWidth(GetDisplay(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); break; /* Window Configuration 1150 */ case XCALL_XCirculateSubwindows: XCirculateSubwindows(GetDisplay(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_XConfigureWindow: ConfigureWindow(taskData, GetDisplay(taskData, XP1),GetWindow(taskData, XP1), P2); break; case XCALL_XLowerWindow: XLowerWindow(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XMapRaised: XMapRaised(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XMapSubwindows: XMapSubwindows(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XMapWindow: XMapWindow(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XMoveResizeWindow: CheckZeroRect(taskData, P3); XMoveResizeWindow(GetDisplay(taskData, XP1), GetWindow(taskData, XP1), GetPointX(taskData, P2), GetPointY(taskData, P2), GetRectW(taskData, P3), GetRectH(taskData, P3)); break; case XCALL_XMoveWindow: XMoveWindow(GetDisplay(taskData, XP1), GetWindow(taskData, XP1), GetPointX(taskData, P2), GetPointY(taskData, P2)); break; case XCALL_XQueryTree: return QueryTree(taskData,GetDS(taskData, XP1),GetWindow(taskData, XP1)); case XCALL_XRaiseWindow: XRaiseWindow(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XReparentWindow: XReparentWindow(GetDisplay(taskData, XP1), GetWindow(taskData, XP1), GetWindow(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3)); break; case XCALL_XResizeWindow: CheckZeroRect(taskData, P2); XResizeWindow(GetDisplay(taskData, XP1), GetWindow(taskData, XP1), GetRectW(taskData, P2), GetRectH(taskData, P2)); break; case XCALL_XRestackWindows: RestackWindows(taskData, SAVE(P1)); break; case XCALL_XUnmapSubwindows: XUnmapSubwindows(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XUnmapWindow: XUnmapWindow(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; /* Window Existence 1200 */ case XCALL_RootWindow: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return EmptyWindow(taskData, dsHandle, RootWindow(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } case XCALL_DestroyXObject: DestroyXObject(XP1); break; case XCALL_XDestroySubwindows: DestroySubwindows(XP1); break; case XCALL_XCreateSimpleWindow: CheckZeroRect(taskData, P3); return CreateSimpleWindow(taskData, SAVE(XP1), /* parent */ GetPointX(taskData, P2), /* x */ GetPointY(taskData, P2), /* y */ GetRectW(taskData, P3), /* w */ GetRectH(taskData, P3), /* h */ get_C_ulong(taskData, P4), /* borderWidth */ get_C_ulong(taskData, P5), /* border */ get_C_ulong(taskData, P6), /* background */ SAVE(P7), /* handler */ SAVE(P8)); /* state */ case XCALL_XCreateWindow: CheckZeroRect(taskData, P3); return CreateWindow(taskData, SAVE(XP1), /* parent */ GetPointX(taskData, P2), /* x */ GetPointY(taskData, P2), /* y */ GetRectW(taskData, P3), /* w */ GetRectH(taskData, P3), /* h */ get_C_ulong(taskData, P4), /* borderWidth */ get_C_ulong(taskData, P5), /* depth */ get_C_ulong(taskData, P6), /* class */ GetVisual(taskData, XP7), /* visual */ SAVE(P8), /* handler */ SAVE(P9)); /* state */ /* Window Manager 1250 */ case XCALL_XSetProperty: SetProperty(taskData, GetDisplay(taskData, XP1), GetWindow(taskData, XP1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), SAVE(P4), get_C_ulong(taskData, P5)); break; case XCALL_XGetTextProperty: return GetTextProperty(taskData, GetDisplay(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); case XCALL_XGetWMHints: return GetWMHints(taskData, GetDS(taskData, XP1),GetWindow(taskData, XP1)); case XCALL_XGetWMSizeHints: return GetWMSizeHints(taskData, GetDisplay(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); case XCALL_XGetIconSizes: return GetIconSizes(taskData, GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); case XCALL_XGetTransientForHint: return GetTransientForHint(taskData, GetDS(taskData, XP1),GetWindow(taskData, XP1)); case XCALL_XGetWMColormapWindows: return GetWMColormapWindows(taskData, GetDS(taskData, XP1),GetWindow(taskData, XP1)); case XCALL_XGetRGBColormaps: return GetRGBColormaps(taskData, GetDS(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); case XCALL_XWMGeometry: return WMGeometry(taskData, GetDS(taskData, XP1), GetString(P2), GetString(P3), get_C_ulong(taskData, P4), P5); /* Miscellaneous 1300 */ case XCALL_GetID: return GetID(taskData, XP1); case XCALL_ResourceExists: return Make_bool(ResourceExists(XP1)); case XCALL_GetDisplay: return GetDS(taskData, XP1); /******************************************************************************/ /* */ /* Xt Calls */ /* */ /******************************************************************************/ case XCALL_NoWidget: return EmptyWidget(taskData, SAVE(ListNull), (Widget)NULL); case XCALL_AppInitialise: return AppInitialise(taskData, P1, /* display name */ P2, /* application name */ P3, /* application class */ SAVE(P4), /* Fallback list */ SAVE(P5) /* Arg list */); case XCALL_XtRealizeWidget: XtRealizeWidget(GetWidget(taskData, XP1)); break; case XCALL_XtManageChildren: ManageChildren(taskData, SAVE(P1)); break; case XCALL_XtUnmanageChildren: UnmanageChildren(taskData, SAVE(P1)); break; case XCALL_XtDestroyWidget: { Widget w = GetWidget(taskData, XP1); XtDestroyWidget(w); /* The following test seems necessary - sometimes the callback from */ /* the above call destroys the widget, sometimes it doesn't. I think */ /* it always should, and I can't work out why this strange behaviour */ /* occurs. SPF 9/12/93 */ if (ResourceExists(XP1)) { DestroyXObject(XP1); PurgeCCallbacks((X_Widget_Object *)XP1,w); } break; } case XCALL_SetCallbacks: SetCallbacks (taskData, WidgetObject(taskData, XP1),P2,P3); break; /* WidgetObject added SPF */ case XCALL_XtSetValues: SetValues(taskData, GetWidget(taskData, XP1),SAVE(P2)); break; case XCALL_GetValue: return GetValue(taskData, GetDS(taskData, XP1),GetWidget(taskData, XP1),P2); case XCALL_XtParent: return EmptyWidget(taskData, GetDS(taskData, XP1),XtParent(GetWidget(taskData, XP1))); case XCALL_XtWindow: return EmptyWindow(taskData, GetDS(taskData, XP1),WindowOfWidget(GetWidget(taskData, XP1))); case XCALL_XtDisplay: return GetDS(taskData, XP1); case XCALL_XtUnrealizeWidget: XtUnrealizeWidget(GetWidget(taskData, XP1)); break; case XCALL_XtName: return Make_string(XtName(GetWidget(taskData, XP1))); case XCALL_XtParseTranslationTable: return ParseTranslationTable(taskData, GetString(XP1)); case XCALL_XtOverrideTranslations: XtOverrideTranslations(GetWidget(taskData, XP1),GetTrans(taskData, XP2)); break; case XCALL_XtAugmentTranslations: XtAugmentTranslations(GetWidget(taskData, XP1),GetTrans(taskData, XP2)); break; case XCALL_XtUninstallTranslations: XtUninstallTranslations(GetWidget(taskData, XP1)); break; /* case XCALL_XtTranslateTablePrint: _XtTranslateTablePrint(GetTrans(taskData, XP1)); break; */ case XCALL_XtCreatePopupShell: return CreatePopupShell(taskData, GetString(XP1),GetDS(taskData, XP2),GetWidget(taskData, XP2),SAVE(P3)); case XCALL_InsertWidgetTimeout: InsertWidgetTimeout(taskData, WidgetObject(taskData, XP1),get_C_ulong(taskData, P2),P3,P4); break; /* WidgetObject added SPF */ case XCALL_GetWidgetState: return SAVE(WidgetObjectToken(XP1)->state); /* was WidgetObject(XP1) (SPF) */ case XCALL_SetWidgetState: WidgetObjectToken(XP1)->state = P2; break; /* was WidgetObject(XP1) (SPF) */ case XCALL_XtSetSensitive: XtSetSensitive(GetWidget(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_XtIsSensitive: return Make_bool(XtIsSensitive(GetWidget(taskData, XP1))); case XCALL_GetSubresources: return GetSubresources(taskData, GetDS(taskData, XP1), GetWidget(taskData, XP1), GetString(P2), GetString(P3), SAVE(P4)); case XCALL_Cast: return SAVE(P1); case XCALL_XtPopup: XtPopup(GetWidget(taskData, XP1),GetXtGrabKind(taskData, P2)); break; case XCALL_XtPopdown: XtPopdown(GetWidget(taskData, XP1)); break; case XCALL_XtMapWidget: XtMapWidget(GetRealizedWidget(taskData, (char *) "XtMapWidget",XP1)); break; case XCALL_XtUnmapWidget: XtUnmapWidget(GetRealizedWidget(taskData, (char *) "XtUnmapWidget",XP1)); break; case XCALL_XtIsManaged: return Make_bool(XtIsManaged(GetWidget(taskData, XP1))); case XCALL_XtIsRealized: return Make_bool(XtIsRealized(GetWidget(taskData, XP1))); /* Added DCJM. */ case XCALL_XtGetApplicationResources: return GetApplicationResources (taskData, GetDS(taskData, XP1),GetWidget(taskData, XP1),SAVE(P2) ) ; case XCALL_XtAddEventHandler: AddEventhandler (taskData, WidgetObject(taskData, XP1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), SAVE(P4)); break; /******************************************************************************/ /* */ /* Motif Calls - widget creation */ /* */ /******************************************************************************/ /* Motif 4000 */ #define XMCREATE(number,name) \ case number: return CreateXm(taskData, name, (char *) \ #name " failed", \ GetDS(taskData, XP1), \ GetWidget(taskData, XP1), \ GetString(P2), \ SAVE(P3)) XMCREATE(XCALL_XmCreateArrowButton,XmCreateArrowButton); XMCREATE(XCALL_XmCreateArrowButtonGadget,XmCreateArrowButtonGadget); XMCREATE(XCALL_XmCreateBulletinBoard,XmCreateBulletinBoard); XMCREATE(XCALL_XmCreateBulletinBoardDialog,XmCreateBulletinBoardDialog); XMCREATE(XCALL_XmCreateCascadeButton,XmCreateCascadeButton); XMCREATE(XCALL_XmCreateCascadeButtonGadget,XmCreateCascadeButtonGadget); XMCREATE(XCALL_XmCreateCommand,XmCreateCommand); XMCREATE(XCALL_XmCreateDialogShell,XmCreateDialogShell); XMCREATE(XCALL_XmCreateDrawingArea,XmCreateDrawingArea); XMCREATE(XCALL_XmCreateDrawnButton,XmCreateDrawnButton); XMCREATE(XCALL_XmCreateErrorDialog,XmCreateErrorDialog); XMCREATE(XCALL_XmCreateFileSelectionBox,XmCreateFileSelectionBox); XMCREATE(XCALL_XmCreateFileSelectionDialog,XmCreateFileSelectionDialog); XMCREATE(XCALL_XmCreateForm,XmCreateForm); XMCREATE(XCALL_XmCreateFormDialog,XmCreateFormDialog); XMCREATE(XCALL_XmCreateFrame,XmCreateFrame); XMCREATE(XCALL_XmCreateInformationDialog,XmCreateInformationDialog); XMCREATE(XCALL_XmCreateLabel,XmCreateLabel); XMCREATE(XCALL_XmCreateLabelGadget,XmCreateLabelGadget); XMCREATE(XCALL_XmCreateList,XmCreateList); XMCREATE(XCALL_XmCreateMainWindow,XmCreateMainWindow); XMCREATE(XCALL_XmCreateMenuBar,XmCreateMenuBar); XMCREATE(XCALL_XmCreateMenuShell,XmCreateMenuShell); XMCREATE(XCALL_XmCreateMessageBox,XmCreateMessageBox); XMCREATE(XCALL_XmCreateMessageDialog,XmCreateMessageDialog); XMCREATE(XCALL_XmCreateOptionMenu,XmCreateOptionMenu); XMCREATE(XCALL_XmCreatePanedWindow,XmCreatePanedWindow); XMCREATE(XCALL_XmCreatePopupMenu,XmCreatePopupMenu); XMCREATE(XCALL_XmCreatePromptDialog,XmCreatePromptDialog); XMCREATE(XCALL_XmCreatePulldownMenu,XmCreatePulldownMenu); XMCREATE(XCALL_XmCreatePushButton,XmCreatePushButton); XMCREATE(XCALL_XmCreatePushButtonGadget,XmCreatePushButtonGadget); XMCREATE(XCALL_XmCreateQuestionDialog,XmCreateQuestionDialog); XMCREATE(XCALL_XmCreateRadioBox,XmCreateRadioBox); XMCREATE(XCALL_XmCreateRowColumn,XmCreateRowColumn); XMCREATE(XCALL_XmCreateScale,XmCreateScale); XMCREATE(XCALL_XmCreateScrollBar,XmCreateScrollBar); XMCREATE(XCALL_XmCreateScrolledList,XmCreateScrolledList); XMCREATE(XCALL_XmCreateScrolledText,XmCreateScrolledText); XMCREATE(XCALL_XmCreateScrolledWindow,XmCreateScrolledWindow); XMCREATE(XCALL_XmCreateSelectionBox,XmCreateSelectionBox); XMCREATE(XCALL_XmCreateSelectionDialog,XmCreateSelectionDialog); XMCREATE(XCALL_XmCreateSeparator,XmCreateSeparator); XMCREATE(XCALL_XmCreateSeparatorGadget,XmCreateSeparatorGadget); XMCREATE(XCALL_XmCreateSimpleCheckBox,XmCreateSimpleCheckBox); XMCREATE(XCALL_XmCreateSimpleMenuBar,XmCreateSimpleMenuBar); XMCREATE(XCALL_XmCreateSimpleOptionMenu,XmCreateSimpleOptionMenu); XMCREATE(XCALL_XmCreateSimplePopupMenu,XmCreateSimplePopupMenu); XMCREATE(XCALL_XmCreateSimplePulldownMenu,XmCreateSimplePulldownMenu); XMCREATE(XCALL_XmCreateSimpleRadioBox,XmCreateSimpleRadioBox); XMCREATE(XCALL_XmCreateText,XmCreateText); XMCREATE(XCALL_XmCreateTextField,XmCreateTextField); XMCREATE(XCALL_XmCreateToggleButton,XmCreateToggleButton); XMCREATE(XCALL_XmCreateToggleButtonGadget,XmCreateToggleButtonGadget); XMCREATE(XCALL_XmCreateWarningDialog,XmCreateWarningDialog); XMCREATE(XCALL_XmCreateWorkArea,XmCreateWorkArea); XMCREATE(XCALL_XmCreateWorkingDialog,XmCreateWorkingDialog); #undef XMCREATE /******************************************************************************/ /* */ /* Motif Calls - miscellaneous */ /* */ /******************************************************************************/ case XCALL_XmCascadeButtonHighlight: XmCascadeButtonHighlight(GetWidget(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_XmCommandError: CommandError(taskData, GetWidget(taskData, XP1),P2); break; case XCALL_XmCommandGetChild: return EmptyWidget(taskData, GetDS(taskData, XP1), XmCommandGetChild(GetWidget(taskData, XP1),get_C_ulong(taskData, P2))); case XCALL_XmFileSelectionBoxGetChild: return EmptyWidget(taskData, GetDS(taskData, XP1), XmFileSelectionBoxGetChild(GetWidget(taskData, XP1),get_C_ulong(taskData, P2))); case XCALL_XmFileSelectionDoSearch: FileSelectionDoSearch(taskData, GetWidget(taskData, XP1),P2); break; case XCALL_XmIsSomething: return XmIsSomething(taskData, get_C_ulong(taskData, P1),GetWidget(taskData, XP2)); case XCALL_XmMainWindowSetAreas: XmMainWindowSetAreas(GetWidget(taskData, XP1), GetNWidget(taskData, XP2), GetNWidget(taskData, XP3), GetNWidget(taskData, XP4), GetNWidget(taskData, XP5), GetNWidget(taskData, XP6)); break; case XCALL_XmMainWindowSepX: switch(get_C_ulong(taskData, P2)) { case 1: return EmptyWidget(taskData, GetDS(taskData, XP1),XmMainWindowSep1(GetWidget(taskData, XP1))); case 2: return EmptyWidget(taskData, GetDS(taskData, XP1),XmMainWindowSep2(GetWidget(taskData, XP1))); default: return EmptyWidget(taskData, GetDS(taskData, XP1),XmMainWindowSep3(GetWidget(taskData, XP1))); } case XCALL_XmMessageBoxGetChild: return EmptyWidget(taskData, GetDS(taskData, XP1), XmMessageBoxGetChild(GetWidget(taskData, XP1),get_C_ulong(taskData, P2))); case XCALL_XmOptionButtonGadget: return EmptyWidget(taskData, GetDS(taskData, XP1),XmOptionButtonGadget(GetWidget(taskData, XP1))); case XCALL_XmOptionLabelGadget: return EmptyWidget(taskData, GetDS(taskData, XP1),XmOptionLabelGadget (GetWidget(taskData, XP1))); case XCALL_XmSelectionBoxGetChild: return EmptyWidget(taskData, GetDS(taskData, XP1), XmSelectionBoxGetChild(GetWidget(taskData, XP1),get_C_ulong(taskData, P2))); case XCALL_XmSetMenuCursor: XmSetMenuCursor(GetDisplay(taskData, XP1),GetCursor(taskData, XP2)); break; case XCALL_XmScrolledWindowSetAreas: XmScrolledWindowSetAreas(GetWidget(taskData, XP1), GetNWidget(taskData, XP2), GetNWidget(taskData, XP3), GetNWidget(taskData, XP4)); break; /******************************************************************************/ /* */ /* Operations on XmText widgets */ /* */ /******************************************************************************/ #define TextWidgetToLong(func) \ case XCALL_ ## func : \ return(WidgetToLong(taskData,(char *) #func,GetTextWidget,func,XP1)) #define TextWidgetToInt(func) \ case XCALL_ ## func : \ return(WidgetToInt(taskData,(char *) #func,GetTextWidget,func,XP1)) #define TextWidgetToBool(func) \ case XCALL_ ## func : \ return(WidgetToBool(taskData,(char *) #func,GetTextWidget,func,XP1)) #define TextWidgetToString(func) \ case XCALL_ ## func : \ return(WidgetToString(taskData,(char *) #func,GetTextWidget,func,XP1)) #define TextWidgetIntAction(func) \ case XCALL_ ## func : \ WidgetIntAction(taskData,(char *) #func,GetTextWidget,func,XP1,P2); \ break #define TextWidgetLongAction(func) \ case XCALL_ ## func : \ WidgetLongAction(taskData,(char *) #func,GetTextWidget,func,XP1,P2); \ break #define TextWidgetBoolAction(func) \ case XCALL_ ## func : \ WidgetBoolAction(taskData,(char *) #func,GetTextWidget,func,XP1,P2); \ break /* XmTextClearSelection not supported */ /* XmTextCopy not supported */ /* XmTextCut not supported */ #ifdef LESSTIF_VERSION /* This is not supported in LessTif, at least not 0.89. */ case XCALL_XmTextGetAddMode: RaiseXWindows(taskData, "XmTextGetAddMode: not implemented"); #else TextWidgetToBool(XmTextGetAddMode); #endif TextWidgetToLong(XmTextGetCursorPosition); TextWidgetToInt(XmTextGetBaseline); TextWidgetToBool(XmTextGetEditable); TextWidgetToLong(XmTextGetInsertionPosition); TextWidgetToLong(XmTextGetLastPosition); TextWidgetToInt(XmTextGetMaxLength); TextWidgetToString(XmTextGetSelection); /* XmTextGetSelectionPosition not supported */ TextWidgetToString(XmTextGetString); /* XmTextGetSource not supported */ TextWidgetToLong(XmTextGetTopCharacter); case XCALL_XmTextInsert: { Widget w = GetTextWidget(taskData, (char *) "XmTextInsert",XP1); { unsigned pos = get_C_ulong(taskData, P2); PolyStringObject *s = GetString(P3); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextInsert(w,pos,buffer); break; } } TextWidgetToBool(XmTextPaste); /* with side effect! */ /* XmTextPosToXY not supported */ TextWidgetToBool(XmTextRemove); /* with side effect! */ case XCALL_XmTextReplace: { Widget w = GetTextWidget(taskData, (char *) "XmTextReplace",XP1); { unsigned from_pos = get_C_ulong(taskData, P2); unsigned to_pos = get_C_ulong(taskData, P3); PolyStringObject *s = GetString(P4); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextReplace(w,from_pos,to_pos,buffer); break; } } TextWidgetIntAction(XmTextScroll); /* for side effect! */ TextWidgetBoolAction(XmTextSetAddMode); TextWidgetLongAction(XmTextSetCursorPosition); TextWidgetBoolAction(XmTextSetEditable); /* XmTextSetHighlight not supported */ TextWidgetLongAction(XmTextSetInsertionPosition); TextWidgetIntAction(XmTextSetMaxLength); /* XmTextSetSelection not supported */ /* XmTextSetSource not supported */ /* inlined SPF 15/2/94 */ case XCALL_XmTextSetString: { Widget w = GetTextWidget(taskData, (char *) "XmTextSetString",XP1); { PolyStringObject *s = GetString(P2); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextSetString(w,buffer); break; } } TextWidgetLongAction(XmTextSetTopCharacter); TextWidgetLongAction(XmTextShowPosition); case XCALL_XmTextXYToPos: { Widget w = GetTextWidget(taskData, (char *) "XmTextXYToPos",XP1); { int x = get_C_long(taskData, P2); int y = get_C_long(taskData, P3); return Make_int(XmTextXYToPos(w,x,y)); } } #undef TextWidgetToLong #undef TextWidgetToInt #undef TextWidgetToBool #undef TextWidgetToString #undef TextWidgetIntAction #undef TextWidgetBoolAction /******************************************************************************/ /* */ /* Operations on XmTextField widgets */ /* */ /******************************************************************************/ #define TextFieldWidgetToLong(func) \ case XCALL_ ## func : \ return(WidgetToLong(taskData, (char *) #func,GetTextFieldWidget,func,XP1)) #define TextFieldWidgetToInt(func) \ case XCALL_ ## func : \ return(WidgetToInt(taskData, (char *) #func,GetTextFieldWidget,func,XP1)) #define TextFieldWidgetToBool(func) \ case XCALL_ ## func : \ return(WidgetToBool(taskData, (char *) #func,GetTextFieldWidget,func,XP1)) #define TextFieldWidgetToString(func) \ case XCALL_ ## func : \ return(WidgetToString(taskData, (char *) #func,GetTextFieldWidget,func,XP1)) #define TextFieldWidgetIntAction(func) \ case XCALL_ ## func : \ WidgetIntAction(taskData, (char *) #func,GetTextFieldWidget,func,XP1,P2); \ break #define TextFieldWidgetLongAction(func) \ case XCALL_ ## func : \ WidgetLongAction(taskData, (char *) #func,GetTextFieldWidget,func,XP1,P2); \ break #define TextFieldWidgetBoolAction(func) \ case XCALL_ ## func : \ WidgetBoolAction(taskData, (char *) #func,GetTextFieldWidget,func,XP1,P2); \ break /* XmTextFieldClearSelection not supported */ /* XmTextFieldCopy not supported */ /* XmTextFieldCut not supported */ #ifdef LESSTIF_VERSION /* This is not supported in LessTif, at least not 0.89. */ case XCALL_XmTextFieldGetAddMode: RaiseXWindows(taskData, "XmTextFieldGetAddMode: not implemented"); #else TextFieldWidgetToBool(XmTextFieldGetAddMode); #endif TextFieldWidgetToInt(XmTextFieldGetBaseline); TextFieldWidgetToLong(XmTextFieldGetCursorPosition); TextFieldWidgetToBool(XmTextFieldGetEditable); TextFieldWidgetToLong(XmTextFieldGetInsertionPosition); TextFieldWidgetToLong(XmTextFieldGetLastPosition); TextFieldWidgetToInt(XmTextFieldGetMaxLength); TextFieldWidgetToString(XmTextFieldGetSelection); /* XmTextFieldGetSelectionPosition not supported */ TextFieldWidgetToString(XmTextFieldGetString); /* XmTextFieldGetSource not supported */ case XCALL_XmTextFieldInsert: { Widget w = GetTextFieldWidget(taskData, (char *) "XmTextFieldInsert",XP1); { unsigned pos = get_C_ulong(taskData, P2); PolyStringObject *s = GetString(P3); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextFieldInsert(w,pos,buffer); break; } } TextFieldWidgetToBool(XmTextFieldPaste); /* for side effect! */ /* XmTextFieldPosToXY not supported */ TextFieldWidgetToBool(XmTextFieldRemove); /* for side effect! */ case XCALL_XmTextFieldReplace: { Widget w = GetTextFieldWidget(taskData, (char *) "XmTextFieldReplace",XP1); { unsigned from_pos = get_C_ulong(taskData, P2); unsigned to_pos = get_C_ulong(taskData, P3); PolyStringObject *s = GetString(P4); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextFieldReplace(w,from_pos,to_pos,buffer); break; } } TextFieldWidgetBoolAction(XmTextFieldSetAddMode); TextFieldWidgetLongAction(XmTextFieldSetCursorPosition); TextFieldWidgetBoolAction(XmTextFieldSetEditable); /* XmTextFieldSetHighlight not supported */ TextFieldWidgetLongAction(XmTextFieldSetInsertionPosition); TextFieldWidgetIntAction(XmTextFieldSetMaxLength); /* XmTextFieldSetSelection not supported */ /* inlined SPF 15/2/94 */ case XCALL_XmTextFieldSetString: { Widget w = GetTextFieldWidget(taskData, (char *) "XmTextFieldSetString",XP1); { PolyStringObject *s = GetString(P2); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextFieldSetString(w,buffer); break; } } TextFieldWidgetLongAction(XmTextFieldShowPosition); /* for side effect! */ case XCALL_XmTextFieldXYToPos: { Widget w = GetTextFieldWidget(taskData, (char *) "XmTextFieldXYToPos",XP1); { int x = get_C_long(taskData, P2); int y = get_C_long(taskData, P3); return Make_int(XmTextFieldXYToPos(w,x,y)); } } case XCALL_XmTrackingLocate: return EmptyWidget(taskData, GetDS(taskData, XP1), XmTrackingLocate(GetWidget(taskData, XP1),GetCursor(taskData, XP2),get_C_ulong(taskData, P3))); case XCALL_XmUpdateDisplay: XmUpdateDisplay(GetWidget(taskData, XP1)); break; #undef TextFieldWidgetToLong #undef TextFieldWidgetToInt #undef TextFieldWidgetToBool #undef TextFieldWidgetToString #undef TextFieldWidgetIntAction #undef TextFieldWidgetLongAction #undef TextFieldWidgetBoolAction /******************************************************************************/ /* */ /* Operations on XmList widgets */ /* */ /******************************************************************************/ #define ListWidgetAction(func) \ case XCALL_ ## func : \ WidgetAction(taskData, (char *) #func,GetListWidget,func,XP1); \ break #define ListWidgetBoolAction(func) \ case XCALL_ ## func : \ WidgetBoolAction(taskData, (char *) #func,GetListWidget,func,XP1,P2); \ break #define ListWidgetXmstringAction(func) \ case XCALL_ ## func : \ WidgetXmstringAction(taskData, (char *) #func,GetListWidget,func,XP1,P2); \ break #define ListWidgetXmstringlistAction(func) \ case XCALL_ ## func : \ WidgetXmstringlistAction(taskData, (char *) #func,GetListWidget,func,XP1,(ML_Cons_Cell *)XP2); \ break #define ListWidgetIntAction(func) \ case XCALL_ ## func : \ WidgetIntAction(taskData, (char *) #func,GetListWidget,func,XP1,P2); \ break #define ListWidgetIntIntAction(func) \ case XCALL_ ## func : \ WidgetIntIntAction(taskData, (char *) #func,GetListWidget,func,XP1,P2,P3); \ break #define ListWidgetXmstringIntAction(func) \ case XCALL_ ## func : \ WidgetXmstringIntAction(taskData, (char *) #func,GetListWidget,func,XP1,P2,P3); \ break #define ListWidgetIntBoolAction(func) \ case XCALL_ ## func : \ WidgetIntBoolAction(taskData, (char *) #func,GetListWidget,func,XP1,P2,P3); \ break #define ListWidgetXmstringBoolAction(func) \ case XCALL_ ## func : \ WidgetXmstringBoolAction(taskData, (char *) #func,GetListWidget,func,XP1,P2,P3); \ break #define ListWidgetXmstringlistIntAction(func) \ case XCALL_ ## func : \ WidgetXmstringlistIntAction(taskData, (char *) #func,GetListWidget,func,XP1,(ML_Cons_Cell *)XP2,P3); \ break #define ListWidgetXmstringToIntlist(func) \ case XCALL_ ## func : \ return(WidgetXmstringToIntlist(taskData, (char *) #func,GetListWidget,func,XP1,P2)) #define ListWidgetToIntlist(func) \ case XCALL_ ## func : \ return(WidgetToIntlist(taskData, (char *) #func,GetListWidget,func,XP1)) #define ListWidgetXmstringToBool(func) \ case XCALL_ ## func : \ return(WidgetXmstringToBool(taskData, (char *) #func,GetListWidget,func,XP1,P2)) #define ListWidgetXmstringToInt(func) \ case XCALL_ ## func : \ return(WidgetXmstringToInt(taskData, (char *) #func,GetListWidget,func,XP1,P2)) /************************* Adding Items to List *******************************/ ListWidgetXmstringIntAction(XmListAddItem); ListWidgetXmstringIntAction(XmListAddItemUnselected); ListWidgetXmstringlistIntAction(XmListAddItems); /************************* Deleting Items from List ***************************/ ListWidgetAction(XmListDeleteAllItems); ListWidgetXmstringAction(XmListDeleteItem); ListWidgetXmstringlistAction(XmListDeleteItems); ListWidgetIntAction(XmListDeletePos); ListWidgetIntIntAction(XmListDeleteItemsPos); /************************* Deselecting Items **********************************/ ListWidgetAction(XmListDeselectAllItems); ListWidgetXmstringAction(XmListDeselectItem); ListWidgetIntAction(XmListDeselectPos); /************************* Query Functions ************************************/ ListWidgetXmstringToIntlist(XmListGetMatchPos); ListWidgetToIntlist(XmListGetSelectedPos); ListWidgetXmstringToBool(XmListItemExists); ListWidgetXmstringToInt(XmListItemPos); /************************* Replacing Items in the List ************************/ case XCALL_XmListReplaceItems: /* Unpairing the strings is done in the ML, because it's easier there. */ { Widget w = GetListWidget(taskData, (char *) "XmListReplaceItems",XP1); unsigned n = ListLength(P2); unsigned n2 = ListLength(P3); if (n != n2) { RaiseXWindows(taskData, "XmListReplaceItems: strings lists are different lengths"); } else { XmString *oldstrings = (XmString *)alloca(n * sizeof(XmString)); XmString *newstrings = (XmString *)alloca(n * sizeof(XmString)); GetList4(taskData, P2,oldstrings,sizeof(XmString),GetXmString); GetList4(taskData, P3,newstrings,sizeof(XmString),GetXmString); XmListReplaceItems(w,oldstrings,n,newstrings); for (unsigned i = 0; i < n; i ++) XmStringFree(oldstrings[i]); for (unsigned i = 0; i < n; i ++) XmStringFree(newstrings[i]); } break; } ListWidgetXmstringlistIntAction(XmListReplaceItemsPos); /************************* Selecting Items in the List ************************/ ListWidgetXmstringBoolAction(XmListSelectItem); ListWidgetIntBoolAction(XmListSelectPos); /************************* Set Add Mode ***************************************/ ListWidgetBoolAction(XmListSetAddMode); /************************* Set Appearance *************************************/ ListWidgetXmstringAction(XmListSetBottomItem); ListWidgetIntAction(XmListSetBottomPos); ListWidgetIntAction(XmListSetHorizPos); ListWidgetXmstringAction(XmListSetItem); ListWidgetIntAction(XmListSetPos); #undef ListWidgetAction #undef ListWidgetBoolAction #undef ListWidgetXmstringAction #undef ListWidgetXmstringlistAction #undef ListWidgetIntAction #undef ListWidgetIntIntAction #undef ListWidgetXmstringIntAction #undef ListWidgetXmstringBoolAction #undef ListWidgetXmstringlistIntAction #undef ListWidgetXmstringToIntlist #undef ListWidgetToIntlist #undef ListWidgetXmstringToBool #undef ListWidgetXmstringToInt /* Calls added by DCJM. */ case XCALL_XmMenuPosition: MenuPosition( GetWidget(taskData, XP1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3)); break; /******************************************************************************/ /* */ /* Default case */ /* */ /******************************************************************************/ default: Crash ("Unimplemented X Windows call %d", code); } return Make_bool(False); } typedef struct { int code; const char *name; } CodeName; static CodeName ProtocolNames[] = { { X_CreateWindow,"XCreateWindow"}, { X_ChangeWindowAttributes,"XChangeWindowAttributes"}, { X_GetWindowAttributes,"XGetWindowAttributes"}, { X_DestroyWindow,"XDestroyWindow"}, { X_DestroySubwindows,"XDestroySubwindows"}, { X_ChangeSaveSet,"XChangeSAVESet"}, { X_ReparentWindow,"XReparentWindow"}, { X_MapWindow,"XMapWindow"}, { X_MapSubwindows,"XMapSubwindows"}, { X_UnmapWindow,"XUnmapWindow"}, { X_UnmapSubwindows,"XUnmapSubwindows"}, { X_ConfigureWindow,"XConfigureWindow"}, { X_CirculateWindow,"XCirculateWindow"}, { X_GetGeometry,"XGetGeometry"}, { X_QueryTree,"XQueryTree"}, { X_InternAtom,"XInternAtom"}, { X_GetAtomName,"XGetAtomName"}, { X_ChangeProperty,"XChangeProperty"}, { X_DeleteProperty,"XDeleteProperty"}, { X_GetProperty,"XGetProperty"}, { X_ListProperties,"XListProperties"}, { X_SetSelectionOwner,"XSetSelectionOwner"}, { X_GetSelectionOwner,"XGetSelectionOwner"}, { X_ConvertSelection,"XConvertSelection"}, { X_SendEvent,"XSendEvent"}, { X_GrabPointer,"XGrabPointer"}, { X_UngrabPointer,"XUngrabPointer"}, { X_GrabButton,"XGrabButton"}, { X_UngrabButton,"XUngrabButton"}, { X_ChangeActivePointerGrab,"XChangeActivePointerGrab"}, { X_GrabKeyboard,"XGrabKeyboard"}, { X_UngrabKeyboard,"XUngrabKeyboard"}, { X_GrabKey,"XGrabKey"}, { X_UngrabKey,"XUngrabKey"}, { X_AllowEvents,"XAllowEvents"}, { X_GrabServer,"XGrabServer"}, { X_UngrabServer,"XUngrabServer"}, { X_QueryPointer,"XQueryPointer"}, { X_GetMotionEvents,"XGetMotionEvents"}, { X_TranslateCoords,"XTranslateCoords"}, { X_WarpPointer,"XWarpPointer"}, { X_SetInputFocus,"XSetInputFocus"}, { X_GetInputFocus,"XGetInputFocus"}, { X_QueryKeymap,"XQueryKeymap"}, { X_OpenFont,"XOpenFont"}, { X_CloseFont,"XCloseFont"}, { X_QueryFont,"XQueryFont"}, { X_QueryTextExtents,"XQueryTextExtents"}, { X_ListFonts,"XListFonts"}, { X_ListFontsWithInfo,"XListFontsWithInfo"}, { X_SetFontPath,"XSetFontPath"}, { X_GetFontPath,"XGetFontPath"}, { X_CreatePixmap,"XCreatePixmap"}, { X_FreePixmap,"XFreePixmap"}, { X_CreateGC,"XCreateGC"}, { X_ChangeGC,"XChangeGC"}, { X_CopyGC,"XCopyGC"}, { X_SetDashes,"XSetDashes"}, { X_SetClipRectangles,"XSetClipRectangles"}, { X_FreeGC,"XFreeGC"}, { X_ClearArea,"XClearArea"}, { X_CopyArea,"XCopyArea"}, { X_CopyPlane,"XCopyPlane"}, { X_PolyPoint,"XPolyPoint"}, { X_PolyLine,"XPolyLine"}, { X_PolySegment,"XPolySegment"}, { X_PolyRectangle,"XPolyRectangle"}, { X_PolyArc,"XPolyArc"}, { X_FillPoly,"XFillPoly"}, { X_PolyFillRectangle,"XPolyFillRectangle"}, { X_PolyFillArc,"XPolyFillArc"}, { X_PutImage,"XPutImage"}, { X_GetImage,"XGetImage"}, { X_PolyText8,"XPolyText8"}, { X_PolyText16,"XPolyText16"}, { X_ImageText8,"XImageText8"}, { X_ImageText16,"XImageText16"}, { X_CreateColormap,"XCreateColormap"}, { X_FreeColormap,"XFreeColormap"}, { X_CopyColormapAndFree,"XCopyColormapAndFree"}, { X_InstallColormap,"XInstallColormap"}, { X_UninstallColormap,"XUninstallColormap"}, { X_ListInstalledColormaps,"XListInstalledColormaps"}, { X_AllocColor,"XAllocColor"}, { X_AllocNamedColor,"XAllocNamedColor"}, { X_AllocColorCells,"XAllocColorCells"}, { X_AllocColorPlanes,"XAllocColorPlanes"}, { X_FreeColors,"XFreeColors"}, { X_StoreColors,"XStoreColors"}, { X_StoreNamedColor,"XStoreNamedColor"}, { X_QueryColors,"XQueryColors"}, { X_LookupColor,"XLookupColor"}, { X_CreateCursor,"XCreateCursor"}, { X_CreateGlyphCursor,"XCreateGlyphCursor"}, { X_FreeCursor,"XFreeCursor"}, { X_RecolorCursor,"XRecolorCursor"}, { X_QueryBestSize,"XQueryBestSize"}, { X_QueryExtension,"XQueryExtension"}, { X_ListExtensions,"XListExtensions"}, { X_ChangeKeyboardMapping,"XChangeKeyboardMapping"}, { X_GetKeyboardMapping,"XGetKeyboardMapping"}, { X_ChangeKeyboardControl,"XChangeKeyboardControl"}, { X_GetKeyboardControl,"XGetKeyboardControl"}, { X_Bell,"XBell"}, { X_ChangePointerControl,"XChangePointerControl"}, { X_GetPointerControl,"XGetPointerControl"}, { X_SetScreenSaver,"XSetScreenSaver"}, { X_GetScreenSaver,"XGetScreenSaver"}, { X_ChangeHosts,"XChangeHosts"}, { X_ListHosts,"XListHosts"}, { X_SetAccessControl,"XSetAccessControl"}, { X_SetCloseDownMode,"XSetCloseDownMode"}, { X_KillClient,"XKillClient"}, { X_RotateProperties,"XRotateProperties"}, { X_ForceScreenSaver,"XForceScreenSaver"}, { X_SetPointerMapping,"XSetPointerMapping"}, { X_GetPointerMapping,"XGetPointerMapping"}, { X_SetModifierMapping,"XSetModifierMapping"}, { X_GetModifierMapping,"XGetModifierMapping"}, { X_NoOperation,"XNoOperation"} }; static CodeName ProtocolErrors[] = { { Success,"Success"}, { BadRequest,"BadRequest"}, { BadValue,"BadValue"}, { BadWindow,"BadWindow"}, { BadPixmap,"BadPixmap"}, { BadAtom,"BadAtom"}, { BadCursor,"BadCursor"}, { BadFont,"BadFont"}, { BadMatch,"BadMatch"}, { BadDrawable,"BadDrawable"}, { BadAccess,"BadAccess"}, { BadAlloc,"BadAlloc"}, { BadColor,"BadColor"}, { BadGC,"BadGC"}, { BadIDChoice,"BadIDChoice"}, { BadName,"BadName"}, { BadLength,"BadLength"}, { BadImplementation,"BadImplementation"} }; static int XWindowsError(Display *display, XErrorEvent *error) { const char *errorName = "unknown"; const char *requestName = "unknown"; int i,n; char buffer[500]; n = sizeof(ProtocolErrors) / sizeof(ProtocolErrors[0]); for(i = 0; i < n; i++) { if (ProtocolErrors[i].code == error->error_code) { errorName = ProtocolErrors[i].name; } } n = sizeof(ProtocolNames) / sizeof(ProtocolNames[0]); for(i = 0; i < n; i++) { if (ProtocolNames[i].code == error->request_code) { requestName = ProtocolNames[i].name; } } sprintf(buffer,"%s in %s",errorName,requestName); printf("\nX Error %s\n\n", buffer); #if NEVER /* Raise exception if we are running in synchronous mode */ if (display->private15) RaiseXWindows(taskData, buffer); #endif return 0; /* DUMMY value - SPF 6/1/94 */ } struct _entrypts xwindowsEPT[] = { { "PolyXWindowsGeneral", (polyRTSFunction)&PolyXWindowsGeneral}, { NULL, NULL} // End of list. }; class XWinModule: public RtsModule { public: virtual void Init(void); void GarbageCollect(ScanAddress *process); }; // Declare this. It will be automatically added to the table. static XWinModule xwinModule; void XWinModule::GarbageCollect(ScanAddress *process) { /* Process all the objects in the list. If an object */ /* is not found from outside then it is removed. */ T_List **T = &TList; C_List **C = &CList; int i; /* process all XList headers */ for (i = 0; i < XLISTSIZE; i++) { X_List *L = XList[i]; while(L) { PolyObject *P = L->object; /* copy object pointer */ X_List *N = L->next; /* copy next pointer */ process->ScanRuntimeAddress(&P, ScanAddress::STRENGTH_WEAK); /* P may have been moved, or overwritten with a 0 if not accessible */ if (P == 0) DestroyXObject(L->object); else L->object = (X_Object*)P; L = N; } } /* Process the timeout/message list */ while (*T) { T_List *t = *T; process->ScanRuntimeAddress(&t->alpha, ScanAddress::STRENGTH_STRONG); process->ScanRuntimeAddress(&t->handler, ScanAddress::STRENGTH_STRONG); PolyObject *obj = t->window_object; process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_WEAK); t->window_object = (X_Window_Object*)obj; obj = t->widget_object; process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_STRONG); t->widget_object = (X_Widget_Object*)obj; // DCJM: I don't understand this. The widget entry will never go // to zero since it's strong not weak. if (t->window_object == 0 && t->widget_object == 0) { *T = t->next; free(t); } else T = &t->next; } /* Process the callback list */ while(*C) { C_List *c = *C; process->ScanRuntimeAddress(&c->function, ScanAddress::STRENGTH_STRONG); PolyObject *obj = c->widget_object; process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_STRONG); c->widget_object = (X_Widget_Object*)obj; /* DCJM: This doesn't make sense. The widget entry will only go to zero if the G.C. operation was weak, not strong as in the line above. */ if (c->widget_object == 0) { *C = c->next; free(c); } else C = &c->next; } /* Process the callback waiting list */ if (! FList.IsTagged()) { PolyObject *obj = FList.AsObjPtr(); process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_STRONG); FList = obj; } /* and the Xt event waiting list. */ if (! GList.IsTagged()) { PolyObject *obj = GList.AsObjPtr(); process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_STRONG) ; GList = obj; } } void XWinModule::Init(void) { initXList(); /* added 9/12/93 SPF */ XtToolkitThreadInitialize(); XtToolkitInitialize(); XSetErrorHandler(XWindowsError); } POLYUNSIGNED PolyXWindowsGeneral(FirstArgument threadId, PolyWord params) { TaskData *taskData = TaskData::FindTaskForId(threadId); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(params); Handle result = 0; try { result = XWindows_c(taskData, pushedArg); } catch (KillException &) { processes->ThreadExit(taskData); // May test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } #else // We haven't got X or we haven't got Motif #include "globals.h" #include "run_time.h" #include "sys.h" #include "save_vec.h" #include "machine_dep.h" #include "processes.h" #include "rtsentry.h" #include "xwindows.h" extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolyXWindowsGeneral(FirstArgument threadId, PolyWord params); } Handle XWindows_c(TaskData *taskData, Handle/*params*/) { raise_exception_string(taskData, EXC_XWindows, "Not implemented"); /*NOTREACHED*/ return taskData->saveVec.push(TAGGED(0)); /* just to keep lint happy */ } POLYUNSIGNED PolyXWindowsGeneral(FirstArgument threadId, PolyWord /*params*/) { TaskData *taskData = TaskData::FindTaskForId(threadId); taskData->PreRTSCall(); try { raise_exception_string(taskData, EXC_XWindows, "Not implemented"); } catch (...) { } // Handle the C++ exception taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); // Return unit since we're raising an exception } struct _entrypts xwindowsEPT[] = { { "PolyXWindowsGeneral", (polyRTSFunction)&PolyXWindowsGeneral}, { NULL, NULL} // End of list. }; #endif diff --git a/mlsource/MLCompiler/CodeTree/BackendIntermediateCode.sml b/mlsource/MLCompiler/CodeTree/BackendIntermediateCode.sml index e8e123d3..011a1896 100644 --- a/mlsource/MLCompiler/CodeTree/BackendIntermediateCode.sml +++ b/mlsource/MLCompiler/CodeTree/BackendIntermediateCode.sml @@ -1,735 +1,735 @@ (* 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} + {base: backendIC, index: backendIC option, offset: int} 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 "]" + PrettyString(Int.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/BackendIntermediateCodeSig.sml b/mlsource/MLCompiler/CodeTree/BackendIntermediateCodeSig.sml index 4bc209aa..dc293f7b 100644 --- a/mlsource/MLCompiler/CodeTree/BackendIntermediateCodeSig.sml +++ b/mlsource/MLCompiler/CodeTree/BackendIntermediateCodeSig.sml @@ -1,187 +1,189 @@ (* - 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. *) signature BackendIntermediateCodeSig = sig type machineWord = Address.machineWord datatype argumentType = GeneralType | DoubleFloatType | SingleFloatType structure BuiltIns: BUILTINS datatype backendIC = BICNewenv of bicCodeBinding list * backendIC (* Set of bindings with an expression. *) | BICConstnt of machineWord * Universal.universal list (* Load a constant *) | BICExtract of bicLoadForm (* Get a local variable, an argument or a closure value *) | BICField of {base: backendIC, offset: int } (* Load a field from a tuple or record *) | BICEval of (* Evaluate a function with an argument list. *) { function: backendIC, argList: (backendIC * argumentType) list, resultType: argumentType } (* Built-in functions. *) | BICNullary of {oper: BuiltIns.nullaryOps} | BICUnary of {oper: BuiltIns.unaryOps, arg1: backendIC} | BICBinary of {oper: BuiltIns.binaryOps, arg1: backendIC, arg2: backendIC} | BICArbitrary of {oper: BuiltIns.arithmeticOperations, shortCond: backendIC, arg1: backendIC, arg2: backendIC, longCall: backendIC} | BICLambda of bicLambdaForm (* Lambda expressions. *) | BICCond of backendIC * backendIC * backendIC (* If-then-else expression *) | BICCase of (* Case expressions *) { cases : backendIC option list, (* NONE means "jump to the default". *) test : backendIC, default : backendIC, isExhaustive: bool, firstIndex: word } | BICBeginLoop of (* Start of tail-recursive inline function. *) { loop: backendIC, arguments: (bicSimpleBinding * argumentType) list } | BICLoop of (backendIC * argumentType) list (* Jump back to start of tail-recursive function. *) | BICRaise of backendIC (* Raise an exception *) | BICHandle of (* Exception handler. *) { exp: backendIC, handler: backendIC, exPacketAddr: int } | BICTuple of backendIC list (* Tuple *) | BICSetContainer of (* Copy a tuple to a container. *) { container: backendIC, tuple: backendIC, filter: BoolVector.vector } | BICLoadContainer of {base: backendIC, offset: int } | BICTagTest of { test: backendIC, tag: word, maxTag: word } | BICLoadOperation of { kind: loadStoreKind, address: bicAddress } | BICStoreOperation of { kind: loadStoreKind, address: bicAddress, value: backendIC } | BICBlockOperation of { kind: blockOpKind, sourceLeft: bicAddress, destRight: bicAddress, length: backendIC } | 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} + being loaded/stored and the offset is always in bytes. + For ML memory accesses the index and offset are unsigned; for C values + they are signed. *) + {base: backendIC, index: backendIC option, offset: int} type pretty val pretty : backendIC -> pretty val loadStoreKindRepr: loadStoreKind -> string and blockOpKindRepr: blockOpKind -> string structure CodeTags: sig val tupleTag: Universal.universal list list Universal.tag val mergeTupleProps: Universal.universal list * Universal.universal list -> Universal.universal list end structure Sharing: sig type backendIC = backendIC and bicLoadForm = bicLoadForm and caseType = caseType and pretty = pretty and argumentType = argumentType and bicCodeBinding = bicCodeBinding and bicSimpleBinding = bicSimpleBinding and loadStoreKind = loadStoreKind and blockOpKind = blockOpKind and unaryOps = BuiltIns.unaryOps and binaryOps = BuiltIns.binaryOps and nullaryOps = BuiltIns.nullaryOps and testConditions = BuiltIns.testConditions and arithmeticOperations = BuiltIns.arithmeticOperations end end; diff --git a/mlsource/MLCompiler/CodeTree/BaseCodeTree.sml b/mlsource/MLCompiler/CodeTree/BaseCodeTree.sml index a66a7c9a..a9c52c31 100644 --- a/mlsource/MLCompiler/CodeTree/BaseCodeTree.sml +++ b/mlsource/MLCompiler/CodeTree/BaseCodeTree.sml @@ -1,777 +1,777 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited 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 = 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} + and codeAddress = {base: codetree, index: codetree option, offset: int} 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 "]" + PrettyString(Int.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 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 c984f413..ceab6a9b 100644 --- a/mlsource/MLCompiler/CodeTree/BaseCodeTreeSig.sml +++ b/mlsource/MLCompiler/CodeTree/BaseCodeTreeSig.sml @@ -1,220 +1,223 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited 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 = 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} + (* Code address. The base is either a Poly address or a SysWord value for C + loads and stores. For Poly addresses the index and offset are unsigned + values; for C operations they are signed. *) + and codeAddress = {base: codetree, index: codetree option, offset: int} 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/INTCODECONS.ML b/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONS.ML index 40277465..211ca29f 100644 --- a/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONS.ML +++ b/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONS.ML @@ -1,1444 +1,1666 @@ (* - Copyright (c) 2015-18 David C.J. Matthews + Copyright (c) 2015-18, 2020 David C.J. Matthews Copyright (c) 2000 Cambridge University Technical Services Limited This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor INTCODECONS ( structure DEBUG: DEBUGSIG structure PRETTY: PRETTYSIG ) : INTCODECONSSIG = struct open CODE_ARRAY open DEBUG open Address open Misc infix 5 << <<+ <<- >> >>+ >>- ~>> ~>>+ ~>>- (* Shift operators *) infix 3 andb orb xorb andbL orbL xorbL andb8 orb8 xorb8 val op << = Word.<< and op >> = Word.>> and op ~>> = Word.~>> val wordToWord8 = Word8.fromLargeWord o Word.toLargeWord and word8ToWord = Word.fromLargeWord o Word8.toLargeWord - + (* Typically the compiler is built on a little-endian machine but it could be run on a machine with either endian-ness. We have to find out the endian-ness when we run. There are separate versions of the compiler for 32-bit and 64-bit so that can be a constant. *) local val isBigEndian: unit -> bool = RunCall.rtsCallFast1 "PolyIsBigEndian" in - val littleEndian = not o isBigEndian + val isBigEndian = isBigEndian() end - val wordLength = RunCall.bytesPerWord - - val opcode_enterInt = 0wx00 - and opcode_jump = 0wx02 (* 8-bit unsigned jump forward. *) + val opcode_jump = 0wx02 (* 8-bit unsigned jump forward. *) and opcode_jumpFalse = 0wx03 (* Test top of stack. Take 8-bit unsigned jump if false. *) - and opcode_delHandler = 0wx05 + and opcode_loadMLWord = 0wx04 + and opcode_storeMLWord = 0wx05 and opcode_alloc_ref = 0wx06 + and opcode_blockMoveWord = 0wx07 + and opcode_loadUntagged = 0wx08 + and opcode_storeUntagged = 0wx09 and opcode_case16 = 0wx0a - and opcode_containerW = 0wx0b and opcode_callClosure = 0wx0c and opcode_returnW = 0wx0d - and opcode_pad = 0wx0e + and opcode_containerB = 0wx0e and opcode_raiseEx = 0wx10 - and opcode_getStoreW = 0wx11 + and opcode_callConstAddr16 = 0wx11 + and opcode_callConstAddr8 = 0wx12 and opcode_localW = 0wx13 - and opcode_indirectW = 0wx14 - and opcode_moveToVecW = 0wx15 - and opcode_setStackValW = 0wx17 - and opcode_resetW = 0wx18 - and opcode_resetR_w = 0wx19 + and opcode_callLocalB = 0wx16 and opcode_constAddr16 = 0wx1a and opcode_constIntW = 0wx1b - and opcode_callFastRTSRRtoR = 0wx1c - and opcode_callFastRTSRGtoR = 0wx1d and opcode_jumpBack8 = 0wx1e (* 8-bit unsigned jump backwards - relative to end of instr. *) and opcode_returnB = 0wx1f and opcode_jumpBack16 = 0wx20 (* 16-bit unsigned jump backwards - relative to end of instr. *) - and opcode_getStoreB = 0wx21 + and opcode_indirectLocalBB = 0wx21 and opcode_localB = 0wx22 and opcode_indirectB = 0wx23 and opcode_moveToVecB = 0wx24 and opcode_setStackValB = 0wx25 and opcode_resetB = 0wx26 and opcode_resetRB = 0wx27 and opcode_constIntB = 0wx28 and opcode_local_0 = 0wx29 and opcode_local_1 = 0wx2a and opcode_local_2 = 0wx2b and opcode_local_3 = 0wx2c and opcode_local_4 = 0wx2d and opcode_local_5 = 0wx2e and opcode_local_6 = 0wx2f and opcode_local_7 = 0wx30 and opcode_local_8 = 0wx31 and opcode_local_9 = 0wx32 and opcode_local_10 = 0wx33 and opcode_local_11 = 0wx34 and opcode_indirect_0 = 0wx35 and opcode_indirect_1 = 0wx36 and opcode_indirect_2 = 0wx37 and opcode_indirect_3 = 0wx38 and opcode_indirect_4 = 0wx39 and opcode_indirect_5 = 0wx3a and opcode_const_0 = 0wx3b and opcode_const_1 = 0wx3c and opcode_const_2 = 0wx3d and opcode_const_3 = 0wx3e and opcode_const_4 = 0wx3f and opcode_const_10 = 0wx40 - and opcode_return_0 = 0wx41 and opcode_return_1 = 0wx42 and opcode_return_2 = 0wx43 and opcode_return_3 = 0wx44 -(* and opcode_moveToVec_0 = 0wx45 - and opcode_moveToVec_1 = 0wx46 - and opcode_moveToVec_2 = 0wx47 - and opcode_moveToVec_3 = 0wx48 - and opcode_moveToVec_4 = 0wx49 - and opcode_moveToVec_5 = 0wx4a - and opcode_moveToVec_6 = 0wx4b - and opcode_moveToVec_7 = 0wx4c *) + and opcode_local_12 = 0wx45 + and opcode_jumpTrue = 0wx46 + and opcode_jump16True = 0wx47 and opcode_reset_1 = 0wx50 and opcode_reset_2 = 0wx51 - and opcode_getStore_2 = 0wx52 - and opcode_getStore_3 = 0wx53 - and opcode_getStore_4 = 0wx54 - and opcode_tuple_containerW = 0wx55 - and opcode_floatAbs = 0wx56 - and opcode_floatNeg = 0wx57 - and opcode_fixedIntToFloat = 0wx58 - and opcode_floatToReal = 0wx59 - and opcode_realToFloat = 0wx5a - and opcode_floatEqual = 0wx5b - and opcode_floatLess = 0wx5c - and opcode_floatLessEq = 0wx5d - and opcode_floatGreater = 0wx5e - and opcode_floatGreaterEq = 0wx5f - and opcode_floatAdd = 0wx60 - and opcode_floatSub = 0wx61 - and opcode_floatMult = 0wx62 - and opcode_floatDiv = 0wx63 and opcode_resetR_1 = 0wx64 and opcode_resetR_2 = 0wx65 and opcode_resetR_3 = 0wx66 - and opcode_tupleW = 0wx67 and opcode_tupleB = 0wx68 and opcode_tuple_2 = 0wx69 and opcode_tuple_3 = 0wx6a and opcode_tuple_4 = 0wx6b and opcode_lock = 0wx6c and opcode_ldexc = 0wx6d - and opcode_realToInt = 0wx6e - and opcode_floatToInt = 0wx6f - and opcode_callFastRTSFtoF = 0wx70 - and opcode_callFastRTSGtoF = 0wx71 - and opcode_callFastRTSFFtoF = 0wx72 - and opcode_callFastRTSFGtoF = 0wx73 and opcode_pushHandler = 0wx78 - and opcode_realUnordered = 0wx79 - and opcode_floatUnordered = 0wx7a and opcode_tailbb = 0wx7b - and opcode_tail = 0wx7c - and opcode_tail3b = 0wx7d - and opcode_tail4b = 0wx7e - and opcode_tail3_2 = 0wx7f - and opcode_tail3_3 = 0wx80 and opcode_setHandler = 0wx81 - and opcode_callFastRTS0 = 0wx83 and opcode_callFastRTS1 = 0wx84 and opcode_callFastRTS2 = 0wx85 and opcode_callFastRTS3 = 0wx86 and opcode_callFastRTS4 = 0wx87 and opcode_callFastRTS5 = 0wx88 - and opcode_callFullRTS0 = 0wx89 and opcode_callFullRTS1 = 0wx8a and opcode_callFullRTS2 = 0wx8b and opcode_callFullRTS3 = 0wx8c and opcode_callFullRTS4 = 0wx8d and opcode_callFullRTS5 = 0wx8e - - and opcode_callFastRTSRtoR = 0wx8f - and opcode_callFastRTSGtoR = 0wx90 - and opcode_notBoolean = 0wx91 and opcode_isTagged = 0wx92 and opcode_cellLength = 0wx93 and opcode_cellFlags = 0wx94 and opcode_clearMutable = 0wx95 and opcode_atomicIncr = 0wx97 and opcode_atomicDecr = 0wx98 - and opcode_atomicReset = 0wx99 - and opcode_longWToTagged = 0wx9a - and opcode_signedToLongW = 0wx9b - and opcode_unsignedToLongW = 0wx9c - and opcode_realAbs = 0wx9d - and opcode_realNeg = 0wx9e - and opcode_fixedIntToReal = 0wx9f - and opcode_equalWord = 0wxa0 and opcode_lessSigned = 0wxa2 and opcode_lessUnsigned = 0wxa3 and opcode_lessEqSigned = 0wxa4 and opcode_lessEqUnsigned = 0wxa5 and opcode_greaterSigned = 0wxa6 and opcode_greaterUnsigned = 0wxa7 and opcode_greaterEqSigned = 0wxa8 and opcode_greaterEqUnsigned = 0wxa9 - and opcode_fixedAdd = 0wxaa and opcode_fixedSub = 0wxab and opcode_fixedMult = 0wxac and opcode_fixedQuot = 0wxad and opcode_fixedRem = 0wxae - and opcode_fixedDiv = 0wxaf - and opcode_fixedMod = 0wxb0 and opcode_wordAdd = 0wxb1 and opcode_wordSub = 0wxb2 and opcode_wordMult = 0wxb3 and opcode_wordDiv = 0wxb4 and opcode_wordMod = 0wxb5 and opcode_wordAnd = 0wxb7 and opcode_wordOr = 0wxb8 and opcode_wordXor = 0wxb9 and opcode_wordShiftLeft = 0wxba and opcode_wordShiftRLog = 0wxbb - and opcode_wordShiftRArith = 0wxbc and opcode_allocByteMem = 0wxbd - and opcode_lgWordEqual = 0wxbe - and opcode_lgWordLess = 0wxc0 - and opcode_lgWordLessEq = 0wxc1 - and opcode_lgWordGreater = 0wxc2 - and opcode_lgWordGreaterEq = 0wxc3 - and opcode_lgWordAdd = 0wxc4 - and opcode_lgWordSub = 0wxc5 - and opcode_lgWordMult = 0wxc6 - and opcode_lgWordDiv = 0wxc7 - and opcode_lgWordMod = 0wxc8 - and opcode_lgWordAnd = 0wxc9 - and opcode_lgWordOr = 0wxca - and opcode_lgWordXor = 0wxcb - and opcode_lgWordShiftLeft = 0wxcc - and opcode_lgWordShiftRLog = 0wxcd - and opcode_lgWordShiftRArith = 0wxce - and opcode_realEqual = 0wxcf - and opcode_realLess = 0wxd1 - and opcode_realLessEq = 0wxd2 - and opcode_realGreater = 0wxd3 - and opcode_realGreaterEq = 0wxd4 - and opcode_realAdd = 0wxd5 - and opcode_realSub = 0wxd6 - and opcode_realMult = 0wxd7 - and opcode_realDiv = 0wxd8 + and opcode_indirectLocalB1 = 0wxc1 + and opcode_isTaggedLocalB = 0wxc2 + and opcode_jumpNEqLocalInd = 0wxc3 + and opcode_jumpTaggedLocal = 0wxc4 + and opcode_jumpNEqLocal = 0wxc5 + and opcode_indirect0Local0 = 0wxc6 + and opcode_indirectLocalB0 = 0wxc7 and opcode_getThreadId = 0wxd9 and opcode_allocWordMemory = 0wxda - and opcode_loadMLWord = 0wxdb and opcode_loadMLByte = 0wxdc - and opcode_loadC8 = 0wxdd - and opcode_loadC16 = 0wxde - and opcode_loadC32 = 0wxdf - and opcode_loadC64 = 0wxe0 - and opcode_loadCFloat = 0wxe1 - and opcode_loadCDouble = 0wxe2 - and opcode_storeMLWord = 0wxe3 and opcode_storeMLByte = 0wxe4 - and opcode_storeC8 = 0wxe5 - and opcode_storeC16 = 0wxe6 - and opcode_storeC32 = 0wxe7 - and opcode_storeC64 = 0wxe8 - and opcode_storeCFloat = 0wxe9 - and opcode_storeCDouble = 0wxea - and opcode_blockMoveWord = 0wxeb and opcode_blockMoveByte = 0wxec and opcode_blockEqualByte = 0wxed and opcode_blockCompareByte = 0wxee - and opcode_loadUntagged = 0wxef - and opcode_storeUntagged = 0wxf0 and opcode_deleteHandler = 0wxf1 (* Just deletes the handler - no jump. *) - and opcode_jump32 = 0wxf2 (* 32-bit signed jump, forwards or backwards. *) - and opcode_jump32False = 0wxf3 (* Test top item. Take 32-bit signed jump if false. *) - and opcode_constAddr32 = 0wxf4 (* Followed by a 32-bit offset. Load a constant at that address. *) - and opcode_setHandler32 = 0wxf5 (* Setup a handler whose address is given by the 32-bit signed offset. *) - and opcode_case32 = 0wxf6 (* Indexed case with 32-bit offsets *) and opcode_jump16 = 0wxf7 and opcode_jump16False = 0wxf8 and opcode_setHandler16 = 0wxf9 and opcode_constAddr8 = 0wxfa - and opcode_stackSize8 = 0wxfb + (*and opcode_stackSize8 = 0wxfb*) and opcode_stackSize16 = 0wxfc + and opcode_escape = 0wxfe (* For two-byte opcodes. *) + (*and opcode_enterIntX86 = 0wxff*) (* Reserved - this is the first byte of a call *) + + (* Extended opcodes - preceded by 0xfe escape *) + val ext_opcode_containerW = 0wx0b + and ext_opcode_indirectW = 0wx14 + and ext_opcode_moveToVecW = 0wx15 + and ext_opcode_setStackValW = 0wx17 + and ext_opcode_resetW = 0wx18 + and ext_opcode_resetR_w = 0wx19 + and ext_opcode_callFastRTSRRtoR = 0wx1c + and ext_opcode_callFastRTSRGtoR = 0wx1d + and ext_opcode_jump32True = 0wx48 + and ext_opcode_floatAbs = 0wx56 + and ext_opcode_floatNeg = 0wx57 + and ext_opcode_fixedIntToFloat = 0wx58 + and ext_opcode_floatToReal = 0wx59 + and ext_opcode_realToFloat = 0wx5a + and ext_opcode_floatEqual = 0wx5b + and ext_opcode_floatLess = 0wx5c + and ext_opcode_floatLessEq = 0wx5d + and ext_opcode_floatGreater = 0wx5e + and ext_opcode_floatGreaterEq = 0wx5f + and ext_opcode_floatAdd = 0wx60 + and ext_opcode_floatSub = 0wx61 + and ext_opcode_floatMult = 0wx62 + and ext_opcode_floatDiv = 0wx63 + and ext_opcode_tupleW = 0wx67 + and ext_opcode_realToInt = 0wx6e + and ext_opcode_floatToInt = 0wx6f + and ext_opcode_callFastRTSFtoF = 0wx70 + and ext_opcode_callFastRTSGtoF = 0wx71 + and ext_opcode_callFastRTSFFtoF = 0wx72 + and ext_opcode_callFastRTSFGtoF = 0wx73 + and ext_opcode_realUnordered = 0wx79 + and ext_opcode_floatUnordered = 0wx7a + and ext_opcode_tail = 0wx7c + and ext_opcode_callFastRTSRtoR = 0wx8f + and ext_opcode_callFastRTSGtoR = 0wx90 + and ext_opcode_atomicReset = 0wx99 + and ext_opcode_longWToTagged = 0wx9a + and ext_opcode_signedToLongW = 0wx9b + and ext_opcode_unsignedToLongW = 0wx9c + and ext_opcode_realAbs = 0wx9d + and ext_opcode_realNeg = 0wx9e + and ext_opcode_fixedIntToReal = 0wx9f + and ext_opcode_fixedDiv = 0wxaf + and ext_opcode_fixedMod = 0wxb0 + and ext_opcode_wordShiftRArith = 0wxbc + and ext_opcode_lgWordEqual = 0wxbe + and ext_opcode_lgWordLess = 0wxc0 + and ext_opcode_lgWordLessEq = 0wxc1 + and ext_opcode_lgWordGreater = 0wxc2 + and ext_opcode_lgWordGreaterEq = 0wxc3 + and ext_opcode_lgWordAdd = 0wxc4 + and ext_opcode_lgWordSub = 0wxc5 + and ext_opcode_lgWordMult = 0wxc6 + and ext_opcode_lgWordDiv = 0wxc7 + and ext_opcode_lgWordMod = 0wxc8 + and ext_opcode_lgWordAnd = 0wxc9 + and ext_opcode_lgWordOr = 0wxca + and ext_opcode_lgWordXor = 0wxcb + and ext_opcode_lgWordShiftLeft = 0wxcc + and ext_opcode_lgWordShiftRLog = 0wxcd + and ext_opcode_lgWordShiftRArith = 0wxce + and ext_opcode_realEqual = 0wxcf + and ext_opcode_realLess = 0wxd1 + and ext_opcode_realLessEq = 0wxd2 + and ext_opcode_realGreater = 0wxd3 + and ext_opcode_realGreaterEq = 0wxd4 + and ext_opcode_realAdd = 0wxd5 + and ext_opcode_realSub = 0wxd6 + and ext_opcode_realMult = 0wxd7 + and ext_opcode_realDiv = 0wxd8 + and ext_opcode_loadC8 = 0wxdd + and ext_opcode_loadC16 = 0wxde + and ext_opcode_loadC32 = 0wxdf + and ext_opcode_loadC64 = 0wxe0 + and ext_opcode_loadCFloat = 0wxe1 + and ext_opcode_loadCDouble = 0wxe2 + and ext_opcode_storeC8 = 0wxe5 + and ext_opcode_storeC16 = 0wxe6 + and ext_opcode_storeC32 = 0wxe7 + and ext_opcode_storeC64 = 0wxe8 + and ext_opcode_storeCFloat = 0wxe9 + and ext_opcode_storeCDouble = 0wxea + and ext_opcode_jump32 = 0wxf2 (* 32-bit signed jump, forwards or backwards. *) + and ext_opcode_jump32False = 0wxf3 (* Test top item. Take 32-bit signed jump if false. *) + and ext_opcode_constAddr32 = 0wxf4 (* Followed by a 32-bit offset. Load a constant at that address. *) + and ext_opcode_setHandler32 = 0wxf5 (* Setup a handler whose address is given by the 32-bit signed offset. *) + and ext_opcode_case32 = 0wxf6 (* Indexed case with 32-bit offsets *) + - - local - val repArray : string Array.array = - Array.tabulate (256, fn (i) => ""); - - fun repUpdate (n, s) = Array.update (repArray, Word8.toInt n, s); - - val () = repUpdate(opcode_enterInt, "enterInt"); - val () = repUpdate(opcode_jump, "jump"); - val () = repUpdate(opcode_jumpFalse, "jumpFalse"); - val () = repUpdate(opcode_delHandler, "delHandler"); - val () = repUpdate(opcode_alloc_ref, "alloc_ref"); - val () = repUpdate(opcode_case16, "case16"); - val () = repUpdate(opcode_callClosure, "callClosure"); - val () = repUpdate(opcode_returnW, "returnW"); - val () = repUpdate(opcode_pad, "pad"); - val () = repUpdate(opcode_raiseEx, "raiseEx"); - val () = repUpdate(opcode_getStoreW, "getStoreW"); - val () = repUpdate(opcode_localW, "localW"); - val () = repUpdate(opcode_indirectW, "indirectW"); - val () = repUpdate(opcode_moveToVecW, "moveToVecW"); - val () = repUpdate(opcode_setStackValW, "setStackValW"); - val () = repUpdate(opcode_resetW, "resetW"); - val () = repUpdate(opcode_resetR_w, "resetR_w"); - val () = repUpdate(opcode_constAddr16, "constAddr16"); - val () = repUpdate(opcode_constIntW, "constIntW"); - val () = repUpdate(opcode_callFastRTSRRtoR, "callFullRTSRRtoR") - val () = repUpdate(opcode_callFastRTSRGtoR, "callFullRTSRGtoR") - val () = repUpdate(opcode_jumpBack8, "jumpBack8"); - val () = repUpdate(opcode_returnB, "returnB"); - val () = repUpdate(opcode_jumpBack16, "jumpBack16"); - val () = repUpdate(opcode_getStoreB, "getStoreB"); - val () = repUpdate(opcode_localB, "localB"); - val () = repUpdate(opcode_indirectB, "indirectB"); - val () = repUpdate(opcode_moveToVecB, "moveToVecB"); - val () = repUpdate(opcode_setStackValB, "setStackValB"); - val () = repUpdate(opcode_resetB, "resetB"); - val () = repUpdate(opcode_resetRB, "resetRB"); - val () = repUpdate(opcode_constIntB, "constIntB"); - val () = repUpdate(opcode_local_0, "local_0"); - val () = repUpdate(opcode_local_1, "local_1"); - val () = repUpdate(opcode_local_2, "local_2"); - val () = repUpdate(opcode_local_3, "local_3"); - val () = repUpdate(opcode_local_4, "local_4"); - val () = repUpdate(opcode_local_5, "local_5"); - val () = repUpdate(opcode_local_6, "local_6"); - val () = repUpdate(opcode_local_7, "local_7"); - val () = repUpdate(opcode_local_8, "local_8"); - val () = repUpdate(opcode_local_9, "local_9"); - val () = repUpdate(opcode_local_10, "local_10"); - val () = repUpdate(opcode_local_11, "local_11"); - val () = repUpdate(opcode_indirect_0, "indirect_0"); - val () = repUpdate(opcode_indirect_1, "indirect_1"); - val () = repUpdate(opcode_indirect_2, "indirect_2"); - val () = repUpdate(opcode_indirect_3, "indirect_3"); - val () = repUpdate(opcode_indirect_4, "indirect_4"); - val () = repUpdate(opcode_indirect_5, "indirect_5"); - val () = repUpdate(opcode_const_0, "const_0"); - val () = repUpdate(opcode_const_1, "const_1"); - val () = repUpdate(opcode_const_2, "const_2"); - val () = repUpdate(opcode_const_3, "const_3"); - val () = repUpdate(opcode_const_4, "const_4"); - val () = repUpdate(opcode_const_10, "const_10"); - val () = repUpdate(opcode_return_0, "return_0"); - val () = repUpdate(opcode_return_1, "return_1"); - val () = repUpdate(opcode_return_2, "return_2"); - val () = repUpdate(opcode_return_3, "return_3"); - val () = repUpdate(opcode_reset_1, "reset_1"); - val () = repUpdate(opcode_reset_2, "reset_2"); - val () = repUpdate(opcode_getStore_2, "getStore_2"); - val () = repUpdate(opcode_getStore_3, "getStore_3"); - val () = repUpdate(opcode_getStore_4, "getStore_4"); - val () = repUpdate(opcode_tuple_containerW, "tuple_containerW"); - val () = repUpdate(opcode_floatAbs, "floatAbs"); - val () = repUpdate(opcode_floatNeg, "floatNeg"); - val () = repUpdate(opcode_fixedIntToFloat, "opcode_fixedIntToFloat"); - val () = repUpdate(opcode_floatToReal, "floatToReal"); - val () = repUpdate(opcode_realToFloat, "realToFloat"); - val () = repUpdate(opcode_floatEqual, "floatEqual"); - val () = repUpdate(opcode_floatLess, "floatLess"); - val () = repUpdate(opcode_floatLessEq, "floatLessEq"); - val () = repUpdate(opcode_floatGreater, "floatGreater"); - val () = repUpdate(opcode_floatGreaterEq,"floatGreaterEq"); - val () = repUpdate(opcode_floatAdd, "floatAdd"); - val () = repUpdate(opcode_floatSub, "floatSub"); - val () = repUpdate(opcode_floatMult, "floatMult"); - val () = repUpdate(opcode_floatDiv, "floatDiv"); - val () = repUpdate(opcode_resetR_1, "resetR_1"); - val () = repUpdate(opcode_resetR_2, "resetR_2"); - val () = repUpdate(opcode_resetR_3, "resetR_3"); - val () = repUpdate(opcode_tupleW, "tupleW"); - val () = repUpdate(opcode_tupleB, "tupleB"); - val () = repUpdate(opcode_tuple_2, "tuple_2"); - val () = repUpdate(opcode_tuple_3, "tuple_3"); - val () = repUpdate(opcode_tuple_4, "tuple_4"); - val () = repUpdate(opcode_lock, "lock"); - val () = repUpdate(opcode_ldexc, "ldexc"); - val () = repUpdate(opcode_realToInt, "realToInt"); - val () = repUpdate(opcode_floatToInt, "floatToInt"); - val () = repUpdate(opcode_callFastRTSFtoF, "callFastRTSFtoF"); - val () = repUpdate(opcode_callFastRTSGtoF, "callFastRTSGtoF"); - val () = repUpdate(opcode_callFastRTSFFtoF, "callFastRTSFFtoF"); - val () = repUpdate(opcode_callFastRTSFGtoF, "callFastRTSFGtoF"); - val () = repUpdate(opcode_setHandler, "setHandler"); - val () = repUpdate(opcode_pushHandler, "pushHandler"); - val () = repUpdate(opcode_realUnordered, "realUnordered"); - val () = repUpdate(opcode_floatUnordered, "floatUnordered"); - val () = repUpdate(opcode_tailbb, "tailbb"); - val () = repUpdate(opcode_tail, "tail"); - val () = repUpdate(opcode_tail3b, "tail3b"); - val () = repUpdate(opcode_tail4b, "tail4b"); - val () = repUpdate(opcode_tail3_2, "tail3_2"); - val () = repUpdate(opcode_tail3_3, "tail3_3"); - val () = repUpdate(opcode_callFastRTS0, "callFastRTS0") - val () = repUpdate(opcode_callFastRTS1, "callFastRTS1") - val () = repUpdate(opcode_callFastRTS2, "callFastRTS2") - val () = repUpdate(opcode_callFastRTS3, "callFastRTS3") - val () = repUpdate(opcode_callFastRTS4, "callFastRTS4") - val () = repUpdate(opcode_callFastRTS5, "callFastRTS5") - val () = repUpdate(opcode_callFullRTS0, "callFullRTS0") - val () = repUpdate(opcode_callFullRTS1, "callFullRTS1") - val () = repUpdate(opcode_callFullRTS2, "callFullRTS2") - val () = repUpdate(opcode_callFullRTS3, "callFullRTS3") - val () = repUpdate(opcode_callFullRTS4, "callFullRTS4") - val () = repUpdate(opcode_callFullRTS5, "callFullRTS5") - val () = repUpdate(opcode_callFastRTSRtoR, "callFullRTSRtoR") - val () = repUpdate(opcode_callFastRTSGtoR, "callFullRTSGtoR") - val () = repUpdate(opcode_notBoolean, "notBoolean") - val () = repUpdate(opcode_isTagged, "isTagged") - val () = repUpdate(opcode_cellLength, "cellLength") - val () = repUpdate(opcode_cellFlags, "cellFlags") - val () = repUpdate(opcode_clearMutable, "clearMutable") - val () = repUpdate(opcode_atomicIncr, "atomicIncr") - val () = repUpdate(opcode_atomicDecr, "atomicDecr") - val () = repUpdate(opcode_atomicReset, "atomicReset") - val () = repUpdate(opcode_longWToTagged, "longWToTagged") - val () = repUpdate(opcode_signedToLongW, "signedToLongW") - val () = repUpdate(opcode_unsignedToLongW, "unsignedToLongW") - val () = repUpdate(opcode_realAbs, "realAbs") - val () = repUpdate(opcode_realNeg, "realNeg") - val () = repUpdate(opcode_fixedIntToReal, "fixedIntToReal") - - val () = repUpdate(opcode_equalWord, "equalWord") - val () = repUpdate(opcode_lessSigned, "lessSigned") - val () = repUpdate(opcode_lessUnsigned, "lessUnsigned") - val () = repUpdate(opcode_lessEqSigned, "lessEqSigned") - val () = repUpdate(opcode_lessEqUnsigned, "lessEqUnsigned") - val () = repUpdate(opcode_greaterSigned, "greaterSigned") - val () = repUpdate(opcode_greaterUnsigned, "greaterUnsigned") - val () = repUpdate(opcode_greaterEqSigned, "greaterEqSigned") - val () = repUpdate(opcode_greaterEqUnsigned, "greaterEqUnsigned") - - val () = repUpdate(opcode_fixedAdd, "fixedAdd") - val () = repUpdate(opcode_fixedSub, "fixedSub") - val () = repUpdate(opcode_fixedMult, "fixedMult") - val () = repUpdate(opcode_fixedQuot, "fixedQuot") - val () = repUpdate(opcode_fixedRem, "fixedRem") - val () = repUpdate(opcode_fixedDiv, "fixedDiv") - val () = repUpdate(opcode_fixedMod, "fixedMod") - val () = repUpdate(opcode_wordAdd, "wordAdd") - val () = repUpdate(opcode_wordSub, "wordSub") - val () = repUpdate(opcode_wordMult, "wordMult") - val () = repUpdate(opcode_wordDiv, "wordDiv") - val () = repUpdate(opcode_wordMod, "wordMod") - val () = repUpdate(opcode_wordAnd, "wordAnd") - val () = repUpdate(opcode_wordOr, "wordOr") - val () = repUpdate(opcode_wordXor, "wordXor") - val () = repUpdate(opcode_wordShiftLeft, "wordShiftLeft") - val () = repUpdate(opcode_wordShiftRLog, "wordShiftRLog") - val () = repUpdate(opcode_wordShiftRArith, "wordShiftRArith") - val () = repUpdate(opcode_allocByteMem, "allocByteMem") - val () = repUpdate(opcode_lgWordEqual, "lgWordEqual") - val () = repUpdate(opcode_lgWordLess, "lgWordLess") - val () = repUpdate(opcode_lgWordLessEq, "lgWordLessEq") - val () = repUpdate(opcode_lgWordGreater, "lgWordGreater") - val () = repUpdate(opcode_lgWordGreaterEq, "lgWordGreaterEq") - val () = repUpdate(opcode_lgWordAdd, "lgWordAdd") - val () = repUpdate(opcode_lgWordSub, "lgWordSub") - val () = repUpdate(opcode_lgWordMult, "lgWordMult") - val () = repUpdate(opcode_lgWordDiv, "lgWordDiv") - val () = repUpdate(opcode_lgWordMod, "lgWordMod") - val () = repUpdate(opcode_lgWordAnd, "lgWordAnd") - val () = repUpdate(opcode_lgWordOr, "lgWordOr") - val () = repUpdate(opcode_lgWordXor, "lgWordXor") - val () = repUpdate(opcode_lgWordShiftLeft, "lgWordShiftLeft") - val () = repUpdate(opcode_lgWordShiftRLog, "lgWordShiftRLog") - val () = repUpdate(opcode_lgWordShiftRArith, "lgWordShiftRArith") - val () = repUpdate(opcode_realEqual, "realEqual") - val () = repUpdate(opcode_realLess, "realLess") - val () = repUpdate(opcode_realLessEq, "realLessEq") - val () = repUpdate(opcode_realGreater, "realGreater") - val () = repUpdate(opcode_realGreaterEq, "realGreaterEq") - val () = repUpdate(opcode_realAdd, "realAdd") - val () = repUpdate(opcode_realSub, "realSub") - val () = repUpdate(opcode_realMult, "realMult") - val () = repUpdate(opcode_realDiv, "realDiv") - val () = repUpdate(opcode_getThreadId, "getThreadId") - val () = repUpdate(opcode_allocWordMemory, "allocWordMemory") - val () = repUpdate(opcode_loadMLWord, "loadMLWord") - val () = repUpdate(opcode_loadMLByte, "loadMLByte") - val () = repUpdate(opcode_loadC8, "loadC8") - val () = repUpdate(opcode_loadC16, "loadC16") - val () = repUpdate(opcode_loadC32, "loadC32") - val () = repUpdate(opcode_loadC64, "loadC64") - val () = repUpdate(opcode_loadCFloat, "loadCFloat") - val () = repUpdate(opcode_loadCDouble, "loadCDouble") - val () = repUpdate(opcode_storeMLWord, "storeMLWord") - val () = repUpdate(opcode_storeMLByte, "storeMLByte") - val () = repUpdate(opcode_storeC8, "storeC8") - val () = repUpdate(opcode_storeC16, "storeC16") - val () = repUpdate(opcode_storeC32, "storeC32") - val () = repUpdate(opcode_storeC64, "storeC64") - val () = repUpdate(opcode_storeCFloat, "storeCFloat") - val () = repUpdate(opcode_storeCDouble, "storeCDouble") - val () = repUpdate(opcode_blockMoveWord, "blockMoveWord") - val () = repUpdate(opcode_blockMoveByte, "blockMoveByte") - val () = repUpdate(opcode_blockEqualByte, "blockEqualByte") - val () = repUpdate(opcode_blockCompareByte, "blockCompareByte") - val () = repUpdate(opcode_loadUntagged, "loadUntagged") - val () = repUpdate(opcode_deleteHandler, "deleteHandler") - val () = repUpdate(opcode_jump32, "jump32") - val () = repUpdate(opcode_jump32False, "jump32False") - val () = repUpdate(opcode_constAddr32, "constAddr32") - val () = repUpdate(opcode_setHandler32, "setHandler32") - val () = repUpdate(opcode_jump16, "jump16") - val () = repUpdate(opcode_case32, "case32") - val () = repUpdate(opcode_jump16False, "jump16false") - val () = repUpdate(opcode_setHandler16, "setHandler16") - val () = repUpdate(opcode_constAddr8, "constAddr8") - val () = repUpdate(opcode_stackSize8, "stackSize8") - val () = repUpdate(opcode_stackSize16, "stackSize16") - in - fun repr n : string = Array.sub (repArray, Word8.toInt n); - end; - - - local - val sizeArray : int Array.array = Array.array (256, 1); - - fun sizeUpdate (n, s) = Array.update (sizeArray, Word8.toInt n, s); - - val () = sizeUpdate(opcode_enterInt , 2); - val () = sizeUpdate(opcode_jump , 2); - val () = sizeUpdate(opcode_jumpFalse , 2); - val () = sizeUpdate(opcode_delHandler , 2); - val () = sizeUpdate(opcode_case16 , 3); - val () = sizeUpdate(opcode_returnW , 3); - val () = sizeUpdate(opcode_getStoreW , 3); - val () = sizeUpdate(opcode_localW , 3); - val () = sizeUpdate(opcode_indirectW , 3); - val () = sizeUpdate(opcode_moveToVecW , 3); - val () = sizeUpdate(opcode_setStackValW, 3); - val () = sizeUpdate(opcode_resetW , 3); - val () = sizeUpdate(opcode_resetR_w , 3); - val () = sizeUpdate(opcode_constAddr16 , 3); - val () = sizeUpdate(opcode_constIntW , 3); - val () = sizeUpdate(opcode_jumpBack8 , 2); - val () = sizeUpdate(opcode_returnB , 2); - val () = sizeUpdate(opcode_jumpBack16 , 3); - val () = sizeUpdate(opcode_getStoreB , 2); - val () = sizeUpdate(opcode_localB , 2); - val () = sizeUpdate(opcode_indirectB , 2); - val () = sizeUpdate(opcode_moveToVecB , 2); - val () = sizeUpdate(opcode_setStackValB, 2); - val () = sizeUpdate(opcode_resetB , 2); - val () = sizeUpdate(opcode_resetRB , 2); - val () = sizeUpdate(opcode_constIntB , 2); - val () = sizeUpdate(opcode_tupleW , 3); - val () = sizeUpdate(opcode_tupleB , 2); - val () = sizeUpdate(opcode_setHandler , 2); - val () = sizeUpdate(opcode_tailbb , 3); - val () = sizeUpdate(opcode_tail , 5); - val () = sizeUpdate(opcode_tail3b , 2); - val () = sizeUpdate(opcode_tail4b , 2); - val () = sizeUpdate(opcode_case32 , 3); - val () = sizeUpdate(opcode_jump32, 5) - val () = sizeUpdate(opcode_jump32False, 5) - val () = sizeUpdate(opcode_constAddr32, 5) - val () = sizeUpdate(opcode_setHandler32, 5) - val () = sizeUpdate(opcode_constAddr8 , 2); - val () = sizeUpdate(opcode_stackSize8 , 2); - val () = sizeUpdate(opcode_stackSize16 , 3); - val () = sizeUpdate(opcode_realToFloat , 2); - val () = sizeUpdate(opcode_realToInt, 2); - val () = sizeUpdate(opcode_floatToInt, 2); - in - fun size n = Array.sub (sizeArray, Word8.toInt n); - end - - (* A Label is a ref that is later set to the location. *) - type labels = {destination: Word.word ref } + (* A Label is a ref that is later set to the location. + Several labels can be linked together so that they are only set + at a single point. + Only forward jumps are linked so when we come to finally set the + label we will have the full list. *) + type labels = Word.word ref list ref (* Used for jump, jumpFalse, setHandler and delHandler. *) - datatype jumpTypes = Jump | JumpFalse | SetHandler + datatype jumpTypes = Jump | JumpBack | JumpFalse | JumpTrue | SetHandler datatype opcode = SimpleCode of Word8.word list (* Bytes that don't need any special treatment *) - | LabelCode of labels (* A label - forwards or backwards. *) - | JumpInstruction of { label: labels, jumpType: jumpTypes, size : jumpSize ref } (* Jumps or SetHandler. *) - | PushConstant of { constNum: int, size : jumpSize ref } + | LabelCode of labels (* A label - forwards or backwards. *) + | JumpInstruction of { label: labels, jumpType: jumpTypes, size: jumpSize ref } (* Jumps or SetHandler. *) + | PushConstant of { constNum: int, size : jumpSize ref, isCall: bool } + | PushShort of Word.word | IndexedCase of { labels: labels list, size : jumpSize ref } + | LoadLocal of Word8.word (* Locals - simplifies peephole optimisation. *) + | IndirectLocal of { localAddr: Word8.word, indirect: Word8.word } (* Ditto *) + | UncondTransfer of Word8.word list (* Raisex, return and tail. *) + | IsTaggedLocalB of Word8.word + | JumpOnIsTaggedLocalB of { label: labels, size: jumpSize ref, localAddr: Word8.word } + | JumpNotEqualLocalInd0BB of { label: labels, size: jumpSize ref, localAddr: Word8.word, const: Word8.word } + | JumpNotEqualLocalConstBB of { label: labels, size: jumpSize ref, localAddr: Word8.word, const: Word8.word } and jumpSize = Size8 | Size16 | Size32 and code = Code of { constVec: machineWord list ref, (* Vector of words to be put at end *) procName: string, (* Name of the procedure. *) printAssemblyCode:bool, (* Whether to print the code when we finish. *) printStream: string->unit, (* The stream to use *) stage1Code: opcode list ref } (* create and initialise a code segment *) fun codeCreate (name : string, parameters) = let val printStream = PRETTY.getSimplePrinter(parameters, []); in Code { constVec = ref [], procName = name, printAssemblyCode = DEBUG.getParameter DEBUG.assemblyCodeTag parameters, printStream = printStream, stage1Code = ref [] } end (* Find the offset in the constant area of a constant. *) (* The first has offset 0. *) fun addConstToVec (valu, Code{constVec, ...}) = let (* Search the list to see if the constant is already there. *) fun findConst valu [] num = (* Add to the list *) ( constVec := ! constVec @ [valu]; num ) | findConst valu (h :: t) num = if wordEq (valu, h) then num else findConst valu t (num + 1) (* Not equal *) in findConst valu (! constVec) 0 end fun printCode (seg: codeVec, procName: string, endcode, printStream) = let val () = printStream "\n"; val () = if procName = "" (* No name *) then printStream "?" else printStream procName; val () = printStream ":\n"; (* prints a string representation of a number *) fun printHex (v) = printStream(Word.fmt StringCvt.HEX v); val ptr = ref 0w0; - - (* To make sure we do not print branch extensions as though they - were instructions we keep a list of all indirect forward references - and print values at those addresses as addresses. - This list is sorted with the lowest address first. *) - - val indirections = ref []; - - local - fun addL (n, []) = [n] - | addL (n, l as (x :: xs)) = - if n < x then n :: l - else if n = x then l - else x :: addL (n, xs) - in - fun addInd (ind) = indirections := addL (ind, !indirections) - end - + (* Gets "length" bytes from locations "addr", "addr"+1... Returns an unsigned number. *) fun getB (0, _, _) = 0w0 | getB (length, addr, seg) = (getB (length - 1, addr + 0w1, seg) << 0w8) + word8ToWord (codeVecGet (seg, addr)) (* Prints a relative address. *) - fun printDisp (len, spacer: string, addToList: bool) = + fun printDisp (len, spacer: string) = let val ad = getB(len, !ptr, seg) + !ptr + Word.fromInt len - val () = if addToList then addInd ad else (); val () = printStream spacer; val () = printHex ad; in ptr := !ptr + Word.fromInt len end (* Prints an operand of an instruction *) fun printOp (len, spacer : string) = let val () = printStream spacer; val () = printHex (getB (len, !ptr, seg)) in ptr := !ptr + Word.fromInt len end; in while !ptr < endcode do let val addr = !ptr in printHex addr; (* The address. *) - if (case !indirections of v :: _ => v = addr | [] => false) - then - let (* It's an address. *) - val () = printDisp (2, "\t", false); - in - case !indirections of - _ :: vs => indirections := vs - | _ => raise InternalError "printCode: indirection list confused" - end - - else let (* It's an instruction. *) - val () = printStream "\t"; + val () = printStream "\t" val opc = codeVecGet (seg, !ptr) (* opcode *) - val () = ptr := !ptr + 0w1; - val () = printStream (repr opc); - - val sz = size opc; + val () = ptr := !ptr + 0w1 in - if sz = 1 then () - - else if opc = opcode_jump orelse - opc = opcode_jumpFalse orelse - opc = opcode_setHandler orelse - opc = opcode_delHandler orelse - opc = opcode_constAddr16 orelse - opc = opcode_jump32 orelse - opc = opcode_jump32False orelse - opc = opcode_setHandler32 orelse - opc = opcode_constAddr8 orelse - opc = opcode_constAddr32 - then printDisp (sz - 1, "\t", false) - - else if opc = opcode_jumpBack8 (* Should be negative *) - then - ( - printStream "\t"; - printHex((!ptr - 0w1) - getB(1, !ptr, seg)); - ptr := !ptr + 0w1 - ) - - else if opc = opcode_jumpBack16 (* Should be negative *) - then - ( - printStream "\t"; - printHex((!ptr - 0w1) - getB(2, !ptr, seg)); - ptr := !ptr + 0w2 - ) - - else if opc = opcode_case16 - then - let - (* Have to find out how many items there are. *) - val limit = getB (2, !ptr, seg); - val () = printOp (2, "\t"); - val base = !ptr; + case opc of + 0wx02 => (printStream "jump"; printDisp (1, "\t\t")) + | 0wx03 => (printStream "jumpFalse"; printDisp (1, "\t")) + | 0wx04 => printStream "loadMLWord" + | 0wx05 => printStream "storeMLWord" + | 0wx06 => printStream "alloc_ref" + | 0wx07 => printStream "blockMoveWord" + | 0wx08 => printStream "loadUntagged" + | 0wx09 => printStream "storeUntagged" + | 0wx0a => + let + (* Have to find out how many items there are. *) + val limit = getB (2, !ptr, seg); + val () = printOp (2, "case16\t"); + val base = !ptr; - fun printEntry _ = (printStream "\n\t"; printHex(base + getB(2, !ptr, seg)); ptr := !ptr + 0w2) + fun printEntry _ = (printStream "\n\t"; printHex(base + getB(2, !ptr, seg)); ptr := !ptr + 0w2) - fun forLoop f i n = if i > n then () else (f i; forLoop f (i + 0w1) n) - in - forLoop printEntry 0w0 limit - end - - else if opc = opcode_tail - then (printOp (2, "\t"); printOp (2, ",")) - - else if opc = opcode_tailbb - then (printOp (1, "\t"); printOp (1, ",")) + fun forLoop f i n = if i >= n then () else (f i; forLoop f (i + 0w1) n) + in + forLoop printEntry 0w0 limit + end + | 0wx0c => printStream "callClosure" + | 0wx0d => printOp(2, "returnW\t") + | 0wx0e => printStream "containerB" + | 0wx10 => printStream "raiseEx" + | 0wx11 => printDisp (2, "callConstAddr16\t") + | 0wx12 => printDisp (1, "callConstAddr8\t") + | 0wx13 => printOp(2, "localW\t") + | 0wx16 => printOp(1, "callLocalB\t") + | 0wx1a => (printStream "constAddr16"; printDisp (2, "\t")) + | 0wx1b => printOp(2, "constIntW\t") + | 0wx1e => + ((* Should be negative *) + printStream "jumpBack8\t"; + printHex((!ptr - 0w1) - getB(1, !ptr, seg)); + ptr := !ptr + 0w1 + ) + | 0wx1f => printOp(1, "returnB\t") + | 0wx20 => + ( + printStream "jumpBack16\t"; + printHex((!ptr - 0w1) - getB(2, !ptr, seg)); + ptr := !ptr + 0w2 + ) + | 0wx21 => (printOp(1, "indirectLocalBB\t"); printOp(1, ",")) + | 0wx22 => printOp(1, "localB\t") + | 0wx23 => printOp(1, "indirectB\t") + | 0wx24 => printOp(1, "moveToVecB\t") + | 0wx25 => printOp(1, "setStackValB\t") + | 0wx26 => printOp(1, "resetB\t") + | 0wx27 => printOp(1, "resetRB\t") + | 0wx28 => printOp(1, "constIntB\t") + | 0wx29 => printStream "local_0" + | 0wx2a => printStream "local_1" + | 0wx2b => printStream "local_2" + | 0wx2c => printStream "local_3" + | 0wx2d => printStream "local_4" + | 0wx2e => printStream "local_5" + | 0wx2f => printStream "local_6" + | 0wx30 => printStream "local_7" + | 0wx31 => printStream "local_8" + | 0wx32 => printStream "local_9" + | 0wx33 => printStream "local_10" + | 0wx34 => printStream "local_11" + | 0wx35 => printStream "indirect_0" + | 0wx36 => printStream "indirect_1" + | 0wx37 => printStream "indirect_2" + | 0wx38 => printStream "indirect_3" + | 0wx39 => printStream "indirect_4" + | 0wx3a => printStream "indirect_5" + | 0wx3b => printStream "const_0" + | 0wx3c => printStream "const_1" + | 0wx3d => printStream "const_2" + | 0wx3e => printStream "const_3" + | 0wx3f => printStream "const_4" + | 0wx40 => printStream "const_10" + | 0wx41 => printStream "return_0" + | 0wx42 => printStream "return_1" + | 0wx43 => printStream "return_2" + | 0wx44 => printStream "return_3" + | 0wx45 => printStream "local_12" + | 0wx46 => (printStream "jumpTrue"; printDisp (1, "\t")) + | 0wx47 => (printStream "jumpTrue"; printDisp (2, "\t")) + | 0wx50 => printStream "reset_1" + | 0wx51 => printStream "reset_2" + | 0wx52 => printStream "getStore_2" + | 0wx53 => printStream "getStore_3" + | 0wx54 => printStream "getStore_4" + | 0wx64 => printStream "resetR_1" + | 0wx65 => printStream "resetR_2" + | 0wx66 => printStream "resetR_3" + | 0wx68 => printOp(1, "tupleB\t") + | 0wx69 => printStream "tuple_2" + | 0wx6a => printStream "tuple_3" + | 0wx6b => printStream "tuple_4" + | 0wx6c => printStream "lock" + | 0wx6d => printStream "ldexc" + | 0wx78 => printStream "pushHandler" + | 0wx7b => (printOp (1, "tailbb\t"); printOp (1, ",")) + | 0wx7d => printOp(1, "tail3b\t") + | 0wx7e => printOp(1, "tail4b\t") + | 0wx7f => printStream "tail3_2" + | 0wx80 => printStream "tail3_3" + | 0wx81 => (printStream "setHandler"; printDisp (1, "\t")) + | 0wx83 => printStream "callFastRTS0" + | 0wx84 => printStream "callFastRTS1" + | 0wx85 => printStream "callFastRTS2" + | 0wx86 => printStream "callFastRTS3" + | 0wx87 => printStream "callFastRTS4" + | 0wx88 => printStream "callFastRTS5" + | 0wx89 => printStream "callFullRTS0" + | 0wx8a => printStream "callFullRTS1" + | 0wx8b => printStream "callFullRTS2" + | 0wx8c => printStream "callFullRTS3" + | 0wx8d => printStream "callFullRTS4" + | 0wx8e => printStream "callFullRTS5" + | 0wx91 => printStream "notBoolean" + | 0wx92 => printStream "isTagged" + | 0wx93 => printStream "cellLength" + | 0wx94 => printStream "cellFlags" + | 0wx95 => printStream "clearMutable" + | 0wx97 => printStream "atomicIncr" + | 0wx98 => printStream "atomicDecr" + | 0wxa0 => printStream "equalWord" + | 0wxa1 => printOp(1, "equalWordConstB\t") + | 0wxa2 => printStream "lessSigned" + | 0wxa3 => printStream "lessUnsigned" + | 0wxa4 => printStream "lessEqSigned" + | 0wxa5 => printStream "lessEqUnsigned" + | 0wxa6 => printStream "greaterSigned" + | 0wxa7 => printStream "greaterUnsigned" + | 0wxa8 => printStream "greaterEqSigned" + | 0wxa9 => printStream "greaterEqUnsigned" + | 0wxaa => printStream "fixedAdd" + | 0wxab => printStream "fixedSub" + | 0wxac => printStream "fixedMult" + | 0wxad => printStream "fixedQuot" + | 0wxae => printStream "fixedRem" + | 0wxb1 => printStream "wordAdd" + | 0wxb2 => printStream "wordSub" + | 0wxb3 => printStream "wordMult" + | 0wxb4 => printStream "wordDiv" + | 0wxb5 => printStream "wordMod" + | 0wxb7 => printStream "wordAnd" + | 0wxb8 => printStream "wordOr" + | 0wxb9 => printStream "wordXor" + | 0wxba => printStream "wordShiftLeft" + | 0wxbb => printStream "wordShiftRLog" + | 0wxbd => printStream "allocByteMem" + | 0wxc1 => printOp(1, "indirectLocalB1\t") + | 0wxc2 => printOp(1, "isTaggedLocalB\t") + | 0wxc3 => (printOp(1, "jumpNEqLocalInd\t"); printOp(1, ","); printOp(1, ","); printDisp(1, "\t")) + | 0wxc4 => (printOp(1, "jumpTaggedLocal\t"); printDisp(1, "\t")) + | 0wxc5 => (printOp(1, "jumpNEqLocal\t"); printOp(1, ","); printOp(1, ","); printDisp(1, "\t")) + | 0wxc6 => printStream "indirect0Local0" + | 0wxc7 => printOp(1, "indirectLocalB0\t") + | 0wxd9 => printStream "getThreadId" + | 0wxda => printStream "allocWordMemory" + | 0wxdc => printStream "loadMLByte" + | 0wxe4 => printStream "storeMLByte" + | 0wxec => printStream "blockMoveByte" + | 0wxed => printStream "blockEqualByte" + | 0wxee => printStream "blockCompareByte" + | 0wxf1 => printStream "deleteHandler" + | 0wxf7 => printStream "jump16" + | 0wxf8 => printStream "jump16False" + | 0wxf9 => printStream "setHandler16" + | 0wxfa => printDisp (1, "constAddr8\t") + | 0wxfb => printOp(1, "stackSize8\t") + | 0wxfc => printOp(2, "stackSize16\t") + | 0wxff => printStream "enterIntX86" - else printOp (sz - 1, "\t") + | 0wxfe => + ( + case codeVecGet (seg, !ptr) before ptr := !ptr + 0w1 of + 0wx0b => printStream "containerW" + | 0wx0f => printDisp (4, "callConstAddr32\t") + | 0wx14 => printOp(2, "indirectW\t") + | 0wx15 => printOp(2, "moveToVecW\t") + | 0wx17 => printOp(2, "setStackValW\t") + | 0wx18 => printOp(2, "resetW\t") + | 0wx19 => printOp(2, "resetR_w\t") + | 0wx1c => printStream "callFastRTSRRtoR" + | 0wx1d => printStream "callFastRTSRGtoR" + | 0wx48 => (printStream "jumpTrue"; printDisp (4, "\t")) + | 0wx56 => printStream "floatAbs" + | 0wx57 => printStream "floatNeg" + | 0wx58 => printStream "fixedIntToFloat" + | 0wx59 => printStream "floatToReal" + | 0wx5a => printOp(1, "realToFloat\t") + | 0wx5b => printStream "floatEqual" + | 0wx5c => printStream "floatLess" + | 0wx5d => printStream "floatLessEq" + | 0wx5e => printStream "floatGreater" + | 0wx5f => printStream "floatGreaterEq" + | 0wx60 => printStream "floatAdd" + | 0wx61 => printStream "floatSub" + | 0wx62 => printStream "floatMult" + | 0wx63 => printStream "floatDiv" + | 0wx67 => printOp(2, "tupleW\t") + | 0wx6e => printOp(1, "realToInt\t") + | 0wx6f => printOp(1, "floatToInt\t") + | 0wx70 => printStream "callFastRTSFtoF" + | 0wx71 => printStream "callFastRTSGtoF" + | 0wx72 => printStream "callFastRTSFFtoF" + | 0wx73 => printStream "callFastRTSFGtoF" + | 0wx79 => printStream "realUnordered" + | 0wx7a => printStream "floatUnordered" + | 0wx7c => (printOp (2, "tail\t"); printOp (2, ",")) + | 0wx8f => printStream "callFastRTSRtoR" + | 0wx90 => printStream "callFastRTSGtoR" + | 0wx99 => printStream "atomicReset" + | 0wx9a => printStream "longWToTagged" + | 0wx9b => printStream "signedToLongW" + | 0wx9c => printStream "unsignedToLongW" + | 0wx9d => printStream "realAbs" + | 0wx9e => printStream "realNeg" + | 0wx9f => printStream "fixedIntToReal" + | 0wxaf => printStream "fixedDiv" + | 0wxb0 => printStream "fixedMod" + | 0wxbc => printStream "wordShiftRArith" + | 0wxbe => printStream "lgWordEqual" + | 0wxc0 => printStream "lgWordLess" + | 0wxc1 => printStream "lgWordLessEq" + | 0wxc2 => printStream "lgWordGreater" + | 0wxc3 => printStream "lgWordGreaterEq" + | 0wxc4 => printStream "lgWordAdd" + | 0wxc5 => printStream "lgWordSub" + | 0wxc6 => printStream "lgWordMult" + | 0wxc7 => printStream "lgWordDiv" + | 0wxc8 => printStream "lgWordMod" + | 0wxc9 => printStream "lgWordAnd" + | 0wxca => printStream "lgWordOr" + | 0wxcb => printStream "lgWordXor" + | 0wxcc => printStream "lgWordShiftLeft" + | 0wxcd => printStream "lgWordShiftRLog" + | 0wxce => printStream "lgWordShiftRArith" + | 0wxcf => printStream "realEqual" + | 0wxd1 => printStream "realLess" + | 0wxd2 => printStream "realLessEq" + | 0wxd3 => printStream "realGreater" + | 0wxd4 => printStream "realGreaterEq" + | 0wxd5 => printStream "realAdd" + | 0wxd6 => printStream "realSub" + | 0wxd7 => printStream "realMult" + | 0wxd8 => printStream "realDiv" + | 0wxdd => printStream "loadC8" + | 0wxde => printStream "loadC16" + | 0wxdf => printStream "loadC32" + | 0wxe0 => printStream "loadC64" + | 0wxe1 => printStream "loadCFloat" + | 0wxe2 => printStream "loadCDouble" + | 0wxe5 => printStream "storeC8" + | 0wxe6 => printStream "storeC16" + | 0wxe7 => printStream "storeC32" + | 0wxe8 => printStream "storeC64" + | 0wxe9 => printStream "storeCFloat" + | 0wxea => printStream "storeCDouble" + | 0wxf2 => printDisp (4, "jump32\t") + | 0wxf3 => printDisp (4, "jump32False\t") + | 0wxf4 => printDisp (4, "constAddr32\t") + | 0wxf5 => printDisp (4, "setHandler32\t") + | 0wxf6 => + let + (* Have to find out how many items there are. *) + val limit = getB (2, !ptr, seg); + val () = printOp (2, "case32\t"); + val base = !ptr; + + fun printEntry _ = (printStream "\n\t"; printHex(base + getB(4, !ptr, seg)); ptr := !ptr + 0w4) + + fun forLoop f i n = if i >= n then () else (f i; forLoop f (i + 0w1) n) + in + forLoop printEntry 0w0 limit + end + | _ => printStream ("unknown:0xfe 0x" ^ Word8.toString opc) + ) + + | opc => printStream("unknown:0x" ^ Word8.toString opc) + end; (* an instruction. *) printStream "\n" end (* main loop *) end (* printCode *) - + fun codeSize (SimpleCode l) = List.length l | codeSize (LabelCode _) = 0 | codeSize (JumpInstruction{size=ref Size8, ...}) = 2 | codeSize (JumpInstruction{size=ref Size16, ...}) = 3 - | codeSize (JumpInstruction{size=ref Size32, ...}) = 5 + | codeSize (JumpInstruction{size=ref Size32, ...}) = 6 | codeSize (PushConstant{size=ref Size8, ...}) = 2 | codeSize (PushConstant{size=ref Size16, ...}) = 3 - | codeSize (PushConstant{size=ref Size32, ...}) = 5 - | codeSize (IndexedCase{labels, size=ref Size32, ...}) = 3 + List.length labels * 4 + | codeSize (PushConstant{size=ref Size32, isCall=false, ...}) = 6 + | codeSize (PushConstant{size=ref Size32, isCall=true, ...}) = 7 + | codeSize (PushShort value) = + if value <= 0w4 orelse value = 0w10 then 1 + else if value < 0w256 then 2 else 3 + | codeSize (IndexedCase{labels, size=ref Size32, ...}) = 4 + List.length labels * 4 | codeSize (IndexedCase{labels, size=ref Size16, ...}) = 3 + List.length labels * 2 | codeSize (IndexedCase{labels=_, size=ref Size8, ...}) = raise InternalError "codeSize" - + | codeSize (LoadLocal w) = if w <= 0w12 then 1 else 2 + | codeSize (IndirectLocal{indirect=0w0, localAddr=0w0}) = 1 + | codeSize (IndirectLocal{indirect=0w0, ...}) = 2 + | codeSize (IndirectLocal{indirect=0w1, ...}) = 2 + | codeSize (IndirectLocal _) = 3 + | codeSize (UncondTransfer l) = List.length l + | codeSize (IsTaggedLocalB _) = 2 + | codeSize (JumpOnIsTaggedLocalB{size=ref Size8, ...}) = 3 + | codeSize (JumpOnIsTaggedLocalB{size=ref Size16, ...}) = 5 + | codeSize (JumpOnIsTaggedLocalB{size=ref Size32, ...}) = 8 + + | codeSize (JumpNotEqualLocalInd0BB{size=ref Size8, ...}) = 4 + | codeSize (JumpNotEqualLocalInd0BB{label, size, localAddr, const}) = + codeSize(IndirectLocal{localAddr=localAddr, indirect=0w0}) + + codeSize(PushShort(word8ToWord const)) + 1 + + codeSize(JumpInstruction{jumpType=JumpFalse, label=label, size=size}) + + | codeSize (JumpNotEqualLocalConstBB{size=ref Size8, ...}) = 4 + | codeSize (JumpNotEqualLocalConstBB {label, size, localAddr, const}) = + codeSize(LoadLocal localAddr) + codeSize(PushShort(word8ToWord const)) + 1 + + codeSize(JumpInstruction{jumpType=JumpFalse, label=label, size=size}) + (* General function to process the code. ic is the byte counter within the original code. *) - fun foldCode foldFn n ops = + fun foldCode startIc foldFn ops = let - fun doFold(oper :: operList, ic, acc) = - doFold(operList, ic + Word.fromInt(codeSize oper), - foldFn(oper, ic, acc)) - | doFold(_, _, n) = n + fun doFold(oper :: operList, ic) = + doFold(operList, + (* Get the size BEFORE any possible change. *) + ic + Word.fromInt(codeSize oper) before foldFn(oper, ic)) + | doFold(_, ic) = ic in - doFold(ops, 0w0, n) + doFold(ops, startIc) end - (* Process the code, setting the destination of any labels. Return the length of the code. *) - fun setLabels(LabelCode{destination, ...} :: ops, ic) = (destination := ic; setLabels(ops, ic)) + (* Process the code, setting the destination of any labels. Return the length of the code. *) + fun setLabels(LabelCode(ref labs) :: ops, ic) = (List.app(fn d => d := ic) labs; setLabels(ops, ic)) | setLabels(oper :: ops, ic) = setLabels(ops, ic + Word.fromInt(codeSize oper)) | setLabels([], ic) = ic - + (* Set the sizes of branches depending on the distance to the destination. *) fun setLabelsAndSizes ops = let + val wordLength = wordSize + (* Set the labels and adjust the sizes, repeating until it never gets smaller*) fun setLabAndSize(ops, lastSize) = let (* Calculate offsets for constants. *) val endIC = Word.andb(lastSize + wordLength - 0w1, ~ wordLength) val firstConstant = endIC + wordLength * 0w3 (* Because the constant area is word aligned we have to allow for the possibility that the distance between a "load constant" instruction and the target could actually increase. *) val alignment = wordLength - 0w1 - fun adjust(JumpInstruction{size as ref Size32, label={destination=ref dest}, ...}, ic, _) = + fun adjust(JumpInstruction{size as ref Size32, label=ref lab, ...}, ic) = let + val dest = !(hd lab) val diff = if dest <= ic (* N.B. Include infinite loops as backwards. *) then ic - dest (* Backwards - Counts from start of instruction. *) - else dest - (ic + 0w5) (* Forwards - Relative to the current end. *) + else dest - (ic + 0w6) (* Forwards - Relative to the current end. *) in if diff < 0wx100 then size := Size8 else if diff < 0wx10000 then size := Size16 else () end - | adjust(JumpInstruction{size as ref Size16, label={destination=ref dest}, ...}, ic, _) = - if dest <= ic - then if ic - dest < 0wx100 then size := Size8 else () - else if dest - (ic + 0w3) < 0wx100 then size := Size8 else () - - | adjust(IndexedCase{size as ref Size32, labels}, ic, _) = + | adjust(JumpInstruction{size as ref Size16, label=ref lab, ...}, ic) = + let + val dest = !(hd lab) + in + if dest <= ic + then if ic - dest < 0wx100 then size := Size8 else () + else if dest - (ic + 0w3) < 0wx100 then size := Size8 else () + end + + | adjust(IndexedCase{size as ref Size32, labels}, ic) = let - val startAddr = ic+0w3 + val startAddr = ic+0w4 (* Use 16-bit case if all the offsets are 16-bits. *) - fun is16bit{destination=ref dest} = + fun is16bit(ref lab) = + let + val dest = !(hd lab) + in dest > startAddr andalso dest < startAddr+0wx10000 + end in if List.all is16bit labels then size := Size16 else () end - | adjust(PushConstant{size as ref Size32, constNum, ...}, ic, _) = + | adjust(PushConstant{size as ref Size32, constNum, ...}, ic) = let val constAddr = firstConstant + Word.fromInt constNum * wordLength - val offset = constAddr - (ic + 0w5) + val offset = constAddr - (ic + 0w6) in if offset < 0wx100-alignment then size := Size8 else if offset < 0wx10000-alignment then size := Size16 else () end - | adjust(PushConstant{size as ref Size16, constNum, ...}, ic, _) = + | adjust(PushConstant{size as ref Size16, constNum, ...}, ic) = let val constAddr = firstConstant + Word.fromInt constNum * wordLength val offset = constAddr - (ic + 0w3) in if offset < 0wx100-alignment then size := Size8 else () end + | adjust(JumpOnIsTaggedLocalB{size as ref Size32, label=ref lab, ...}, ic) = + let + val dest = !(hd lab) + val diff = dest - (ic + 0w8) + in + if diff < 0wx100 + then size := Size8 + else if diff < 0wx10000 + then size := Size16 + else () + end + + | adjust(JumpOnIsTaggedLocalB{size as ref Size16, label=ref lab, ...}, ic) = + let + val dest = !(hd lab) + in + if dest - (ic + 0w5) < 0wx100 then size := Size8 else () + end + + | adjust(j as JumpNotEqualLocalInd0BB{size as ref Size32, label=ref lab, ...}, ic) = + let + val dest = !(hd lab) + val diff = dest - (ic + Word.fromInt(codeSize j)) + in + if diff < 0wx100 + then size := Size8 + else if diff < 0wx10000 + then size := Size16 + else () + end + + | adjust(j as JumpNotEqualLocalInd0BB{size as ref Size16, label=ref lab, ...}, ic) = + let + val dest = !(hd lab) + in + if dest - (ic + Word.fromInt(codeSize j)) < 0wx100 then size := Size8 else () + end + + | adjust(j as JumpNotEqualLocalConstBB{size as ref Size32, label=ref lab, ...}, ic) = + let + val dest = !(hd lab) + val diff = dest - (ic + Word.fromInt(codeSize j)) + in + if diff < 0wx100 + then size := Size8 + else if diff < 0wx10000 + then size := Size16 + else () + end + + | adjust(j as JumpNotEqualLocalConstBB{size as ref Size16, label=ref lab, ...}, ic) = + let + val dest = !(hd lab) + in + if dest - (ic + Word.fromInt(codeSize j)) < 0wx100 then size := Size8 else () + end + | adjust _ = () - val () = foldCode adjust () ops + val _ = foldCode 0w0 adjust ops val nextSize = setLabels(ops, 0w0) in if nextSize < lastSize then setLabAndSize(ops, nextSize) else if nextSize = lastSize then lastSize else raise InternalError "setLabAndSize - size increased" end in setLabAndSize(ops, setLabels(ops, 0w0)) end fun genCode(ops, Code {constVec, ...}) = let (* First pass - set the labels. *) val codeSize = setLabelsAndSizes ops + val wordSize = wordSize (* Align to wordLength. *) - val endIC = Word.andb(codeSize + wordLength - 0w1, ~ wordLength) - val endOfCode = endIC div wordLength - val firstConstant = endIC + wordLength * 0w3 (* Add 3 for fn name, unused and profile count. *) + val endIC = Word.andb(codeSize + wordSize - 0w1, ~ wordSize) + val paddingBytes = List.tabulate(Word.toInt(endIC - codeSize), fn _ => SimpleCode[opcode_const_0]) + val endOfCode = endIC div wordSize + val firstConstant = endIC + wordSize * 0w3 (* Add 3 for fn name, unused and profile count. *) val segSize = endOfCode + Word.fromInt(List.length(! constVec)) + 0w4 val codeVec = byteVecMake segSize val ic = ref 0w0 fun genByte b = byteVecSet(codeVec, !ic, b) before ic := !ic + 0w1 - fun genByteCode(SimpleCode bytes, _, _) = + fun genByteCode(SimpleCode bytes, _) = (* Simple code - just generate the bytes. *) List.app genByte bytes - | genByteCode(LabelCode _, _, _) = () + | genByteCode(UncondTransfer bytes, _) = List.app genByte bytes + + | genByteCode(LabelCode _, _) = () - | genByteCode(JumpInstruction{label={destination=ref dest}, jumpType, size=ref Size32, ...}, ic, _) = + | genByteCode(JumpInstruction{label=ref labs, jumpType, size=ref Size32, ...}, ic) = let - val opc = + val dest = !(hd labs) + val extOpc = case jumpType of - SetHandler => opcode_setHandler32 - | JumpFalse => opcode_jump32False - | Jump => opcode_jump32 - val diff = dest - (ic + 0w5) + SetHandler => ext_opcode_setHandler32 + | JumpFalse => ext_opcode_jump32False + | JumpTrue => ext_opcode_jump32True + | Jump => ext_opcode_jump32 + | JumpBack => ext_opcode_jump32 + val diff = dest - (ic + 0w6) in - genByte opc; + genByte opcode_escape; + genByte extOpc; genByte(wordToWord8 diff); (* This may be negative so we must use an arithmetic shift. *) genByte(wordToWord8(diff ~>> 0w8)); genByte(wordToWord8(diff ~>> 0w16)); genByte(wordToWord8(diff ~>> 0w24)) end - | genByteCode(JumpInstruction{label={destination=ref dest}, jumpType, size=ref Size16, ...}, ic, _) = - if dest <= ic - then (* Jump back. *) - let - val _ = jumpType = Jump orelse raise InternalError "genByteCode - back jump" - val diff = ic - dest - val _ = diff < 0wx10000 orelse raise InternalError "genByteCode - jump range" - in - genByte opcode_jumpBack16; - genByte(wordToWord8 diff); - genByte(wordToWord8(diff >> 0w8)) - end - else + | genByteCode(JumpInstruction{label=ref labs, jumpType, size=ref Size16, ...}, ic) = let - val opc = - case jumpType of - SetHandler => opcode_setHandler16 - | JumpFalse => opcode_jump16False - | Jump => opcode_jump16 - val diff = dest - (ic + 0w3) - val _ = diff < 0wx10000 orelse raise InternalError "genByteCode - jump range" + val dest = !(hd labs) in - genByte opc; - genByte(wordToWord8 diff); - genByte(wordToWord8(diff >> 0w8)) + if dest <= ic + then (* Jump back. *) + let + val _ = jumpType = JumpBack orelse raise InternalError "genByteCode - back jump" + val diff = ic - dest + val _ = diff < 0wx10000 orelse raise InternalError "genByteCode - jump range" + in + genByte opcode_jumpBack16; + genByte(wordToWord8 diff); + genByte(wordToWord8(diff >> 0w8)) + end + else + let + val opc = + case jumpType of + SetHandler => opcode_setHandler16 + | JumpFalse => opcode_jump16False + | JumpTrue => opcode_jump16True + | Jump => opcode_jump16 + | JumpBack => raise InternalError "genByteCode: JumpBack goes forward" + val diff = dest - (ic + 0w3) + val _ = diff < 0wx10000 orelse raise InternalError "genByteCode - jump range" + in + genByte opc; + genByte(wordToWord8 diff); + genByte(wordToWord8(diff >> 0w8)) + end end - | genByteCode(JumpInstruction{label={destination=ref dest}, jumpType, size=ref Size8, ...}, ic, _) = - if dest <= ic - then (* Jump back. *) - let - val _ = jumpType = Jump orelse raise InternalError "genByteCode - back jump" - val diff = ic - dest - val _ = diff < 0wx100 orelse raise InternalError "genByteCode - jump range" - in - genByte opcode_jumpBack8; - genByte(wordToWord8 diff) - end - else + | genByteCode(JumpInstruction{label=ref labs, jumpType, size=ref Size8, ...}, ic) = let - val opc = - case jumpType of - SetHandler => opcode_setHandler - | JumpFalse => opcode_jumpFalse - | Jump => opcode_jump - val diff = dest - (ic + 0w2) - val _ = diff < 0wx100 orelse raise InternalError "genByteCode - jump range" + val dest = !(hd labs) in - genByte opc; - genByte(wordToWord8 diff) + if dest <= ic + then (* Jump back. *) + let + val _ = jumpType = JumpBack orelse raise InternalError "genByteCode - back jump" + val diff = ic - dest + val _ = diff < 0wx100 orelse raise InternalError "genByteCode - jump range" + in + genByte opcode_jumpBack8; + genByte(wordToWord8 diff) + end + else + let + val opc = + case jumpType of + SetHandler => opcode_setHandler + | JumpFalse => opcode_jumpFalse + | JumpTrue => opcode_jumpTrue + | Jump => opcode_jump + | JumpBack => raise InternalError "genByteCode: JumpBack goes forward" + val diff = dest - (ic + 0w2) + val _ = diff < 0wx100 orelse raise InternalError "genByteCode - jump range" + in + genByte opc; + genByte(wordToWord8 diff) + end end - | genByteCode(PushConstant{ constNum, size=ref Size32, ... }, ic, _) = + | genByteCode(PushConstant{ constNum, size=ref Size32, isCall=false, ... }, ic) = let - val constAddr = firstConstant + Word.fromInt constNum * wordLength + val constAddr = firstConstant + Word.fromInt constNum * wordSize (* Offsets are calculated from the END of the instruction *) - val offset = constAddr - (ic + 0w5) + val offset = constAddr - (ic + 0w6) in - genByte(opcode_constAddr32); + genByte opcode_escape; + genByte ext_opcode_constAddr32; genByte(wordToWord8 offset); genByte(wordToWord8(offset >> 0w8)); genByte(wordToWord8(offset >> 0w16)); genByte(wordToWord8(offset >> 0w24)) end - | genByteCode(PushConstant{ constNum, size=ref Size16, ... }, ic, _) = + | genByteCode(PushConstant{ constNum, size=ref Size32, isCall=true, ... }, ic) = + ( + (* Turn this back into a push of a constant and call-closure. *) + genByteCode(PushConstant{ constNum=constNum, size=ref Size32, isCall=false }, ic); + genByte opcode_callClosure + ) + + | genByteCode(PushConstant{ constNum, size=ref Size16, isCall, ... }, ic) = let - val constAddr = firstConstant + Word.fromInt constNum * wordLength + val constAddr = firstConstant + Word.fromInt constNum * wordSize val offset = constAddr - (ic + 0w3) val _ = offset < 0wx10000 orelse raise InternalError "genByteCode - constant range" in - genByte(opcode_constAddr16); + genByte(if isCall then opcode_callConstAddr16 else opcode_constAddr16); genByte(wordToWord8 offset); genByte(wordToWord8(offset >> 0w8)) end - | genByteCode(PushConstant{ constNum, size=ref Size8, ... }, ic, _) = + | genByteCode(PushConstant{ constNum, size=ref Size8, isCall, ... }, ic) = let - val constAddr = firstConstant + Word.fromInt constNum * wordLength + val constAddr = firstConstant + Word.fromInt constNum * wordSize val offset = constAddr - (ic + 0w2) val _ = offset < 0wx100 orelse raise InternalError "genByteCode - constant range" in - genByte(opcode_constAddr8); + genByte(if isCall then opcode_callConstAddr8 else opcode_constAddr8); genByte(wordToWord8 offset) end - - | genByteCode(IndexedCase{labels, size=ref Size32, ...}, ic, _) = + + | genByteCode(PushShort 0w0, _) = genByte opcode_const_0 + | genByteCode(PushShort 0w1, _) = genByte opcode_const_1 + | genByteCode(PushShort 0w2, _) = genByte opcode_const_2 + | genByteCode(PushShort 0w3, _) = genByte opcode_const_3 + | genByteCode(PushShort 0w4, _) = genByte opcode_const_4 + | genByteCode(PushShort 0w10, _) = genByte opcode_const_10 + | genByteCode(PushShort value, _) = + if value < 0w256 then (genByte opcode_constIntB; genByte(wordToWord8 value)) + else (genByte opcode_constIntW; genByte(wordToWord8 value); genByte(wordToWord8(value >> 0w8))) + + | genByteCode(IndexedCase{labels, size=ref Size32, ...}, ic) = let val nCases = List.length labels - val () = genByte(opcode_case32) + val () = genByte opcode_escape + val () = genByte ext_opcode_case32 val () = genByte(Word8.fromInt nCases) val () = genByte(Word8.fromInt (nCases div 256)) - val startOffset = ic+0w3 (* Offsets are relative to here. *) + val startOffset = ic+0w4 (* Offsets are relative to here. *) - fun putLabel{destination=ref dest} = + fun putLabel(ref labs) = let + val dest = !(hd labs) val diff = dest - startOffset val _ = dest > startOffset orelse raise InternalError "genByteCode - indexed case" in genByte(wordToWord8 diff); genByte(wordToWord8(diff >> 0w8)); genByte(wordToWord8(diff >> 0w16)); genByte(wordToWord8(diff >> 0w24)) end in List.app putLabel labels end - | genByteCode(IndexedCase{labels, size=ref Size16, ...}, ic, _) = + | genByteCode(IndexedCase{labels, size=ref Size16, ...}, ic) = let val nCases = List.length labels val () = genByte(opcode_case16) val () = genByte(Word8.fromInt nCases) val () = genByte(Word8.fromInt (nCases div 256)) val startOffset = ic+0w3 (* Offsets are relative to here. *) - fun putLabel{destination=ref dest} = + fun putLabel(ref labs) = let + val dest = !(hd labs) val diff = dest - startOffset val _ = dest > startOffset orelse raise InternalError "genByteCode - indexed case" val _ = diff < 0wx10000 orelse raise InternalError "genByteCode - indexed case" in genByte(wordToWord8 diff); genByte(wordToWord8(diff >> 0w8)) end in List.app putLabel labels end - | genByteCode(IndexedCase{size=ref Size8, ...}, _, _) = raise InternalError "genByteCode - IndexedCase byte" + | genByteCode(IndexedCase{size=ref Size8, ...}, _) = raise InternalError "genByteCode - IndexedCase byte" + + | genByteCode(LoadLocal 0w0, _) = genByte opcode_local_0 + | genByteCode(LoadLocal 0w1, _) = genByte opcode_local_1 + | genByteCode(LoadLocal 0w2, _) = genByte opcode_local_2 + | genByteCode(LoadLocal 0w3, _) = genByte opcode_local_3 + | genByteCode(LoadLocal 0w4, _) = genByte opcode_local_4 + | genByteCode(LoadLocal 0w5, _) = genByte opcode_local_5 + | genByteCode(LoadLocal 0w6, _) = genByte opcode_local_6 + | genByteCode(LoadLocal 0w7, _) = genByte opcode_local_7 + | genByteCode(LoadLocal 0w8, _) = genByte opcode_local_8 + | genByteCode(LoadLocal 0w9, _) = genByte opcode_local_9 + | genByteCode(LoadLocal 0w10, _) = genByte opcode_local_10 + | genByteCode(LoadLocal 0w11, _) = genByte opcode_local_11 + | genByteCode(LoadLocal 0w12, _) = genByte opcode_local_12 + | genByteCode(LoadLocal w, _) = (genByte opcode_localB; genByte w) + + | genByteCode(IndirectLocal{localAddr=0w0, indirect=0w0}, _) = genByte opcode_indirect0Local0 + | genByteCode(IndirectLocal{localAddr, indirect=0w0}, _) = + (genByte opcode_indirectLocalB0; genByte localAddr) + | genByteCode(IndirectLocal{localAddr, indirect=0w1}, _) = + (genByte opcode_indirectLocalB1; genByte localAddr) + | genByteCode(IndirectLocal{localAddr, indirect}, _) = + (genByte opcode_indirectLocalBB; genByte localAddr; genByte indirect) + + | genByteCode(IsTaggedLocalB addr, _) = + (genByte opcode_isTaggedLocalB; genByte addr) + + | genByteCode(JumpOnIsTaggedLocalB {label=ref labs, size=ref Size8, localAddr}, ic) = + let + val dest = !(hd labs) + val diff = dest - (ic + 0w3) + in + genByte opcode_jumpTaggedLocal; + genByte localAddr; + genByte(wordToWord8 diff) + end + + | genByteCode(JumpOnIsTaggedLocalB {label, size, localAddr}, ic) = + ( + (* Turn this back into the original sequence. *) + genByteCode(IsTaggedLocalB localAddr, ic); + genByteCode(JumpInstruction{jumpType=JumpTrue, label=label, size=size}, ic+0w2) + ) + + | genByteCode(JumpNotEqualLocalInd0BB {label=ref labs, size=ref Size8, localAddr, const}, ic) = + let + val dest = !(hd labs) + val diff = dest - (ic + 0w4) + in + genByte opcode_jumpNEqLocalInd; + genByte localAddr; genByte const; + genByte(wordToWord8 diff) + end + + | genByteCode(JumpNotEqualLocalInd0BB {label, size, localAddr, const}, ic) = + (* Turn this back into the original sequence. *) + (foldCode ic genByteCode + [IndirectLocal{localAddr=localAddr, indirect=0w0}, PushShort(word8ToWord const), + SimpleCode[opcode_equalWord], + JumpInstruction{jumpType=JumpFalse, label=label, size=size}]; ()) + + | genByteCode(JumpNotEqualLocalConstBB {label=ref labs, size=ref Size8, localAddr, const}, ic) = + let + val dest = !(hd labs) + val diff = dest - (ic + 0w4) + in + genByte opcode_jumpNEqLocal; + genByte localAddr; genByte const; + genByte(wordToWord8 diff) + end + + | genByteCode(JumpNotEqualLocalConstBB {label, size, localAddr, const}, ic) = + (* Turn this back into the original sequence. *) + (foldCode ic genByteCode + [LoadLocal localAddr, PushShort(word8ToWord const), + SimpleCode[opcode_equalWord], + JumpInstruction{jumpType=JumpFalse, label=label, size=size}]; ()) in - foldCode genByteCode () ops; + foldCode 0w0 genByteCode (ops @ paddingBytes); (codeVec (* Return the completed code. *), endIC (* And the size. *)) end fun setLong (value, addrs, seg) = let + val wordLength = wordSize + fun putBytes(value, a, seg, i) = if i = wordLength then () else ( byteVecSet(seg, - if littleEndian() then a+i else a+wordLength-i-0w1, + if not isBigEndian then a+i else a+wordLength-i-0w1, Word8.fromInt(value mod 256)); putBytes(value div 256, a, seg, i+0w1) ) in putBytes(value, addrs, seg, 0w0) end + (* Peephole optimisation. *) + local + fun peepHole([], _, output) = List.rev output + + | peepHole(LabelCode lab1 :: (instrs as LabelCode lab2 :: _), exited, output) = + ( + (* Consecutive labels. Merge these, discarding the first. *) + lab2 := !lab1 @ !lab2; + peepHole(instrs, exited, output) + ) + + (* A label followed by an unconditional branch. Forward the original label. + Although JumpBack is also unconditional we don't forward those because + we don't have a conditional backwards jump. *) + | peepHole((LabelCode lab1) :: + (jump as JumpInstruction{jumpType=Jump, label=lab2, ...}) :: tl, + exited, output) = + ( + lab2 := !lab1 @ !lab2; + (* Leave the jump in the stream and leave "exited" unchanged. + This will now be unreachable if we had previously exited but + we need to take the jump if we hadn't. *) + peepHole(jump :: tl, exited, output) + ) + + (* Discard everything after an unconditional transfer until the next label. *) + | peepHole((label as LabelCode _) :: tl, _, output) = + peepHole(tl, false, label::output) + + | peepHole(_ :: tl, true, output) = peepHole(tl, true, output) + + | peepHole((jump as JumpInstruction{jumpType=Jump, ...}) :: tl, _, output) = + peepHole(tl, true, jump :: output) + + (* Return, raise-exception and tail-call. *) + | peepHole((uncond as UncondTransfer _) :: tl, _, output) = + peepHole(tl, true, uncond :: output) + + (* A conditional branch round an unconditional branch. Replace by a + conditional branch with the sense reversed. *) + | peepHole((cond as JumpInstruction{jumpType=JumpFalse, label=lab1, ...}) :: + (uncond as JumpInstruction{jumpType=Jump, label=lab2, size}) :: + (tail as LabelCode lab3 :: _), _, output) = + if lab1 = lab3 + then peepHole(tail, false, JumpInstruction{jumpType=JumpTrue, label=lab2, size=size} :: output) + else peepHole(uncond :: tail, false, cond :: output) + + | peepHole((cond as JumpInstruction{jumpType=JumpTrue, label=lab1, ...}) :: + (uncond as JumpInstruction{jumpType=Jump, label=lab2, size}) :: + (tail as LabelCode lab3 :: _), _, output) = + if lab1 = lab3 + then peepHole(tail, false, JumpInstruction{jumpType=JumpFalse, label=lab2, size=size} :: output) + else peepHole(uncond :: tail, false, cond :: output) + + | peepHole(IsTaggedLocalB addr :: JumpInstruction{jumpType=JumpTrue, label, size} :: tail, _, output) = + peepHole(tail, false, JumpOnIsTaggedLocalB {label=label, size=size, localAddr=addr} :: output) + + | peepHole((indLocal as IndirectLocal{localAddr, indirect=0w0}) :: + (instrs as PushShort const :: SimpleCode[0wxa0(*opcode_equalWord*)] :: + JumpInstruction{jumpType=JumpFalse, label, size} :: tail), _, output) = + if const < 0w256 + then peepHole(tail, false, + JumpNotEqualLocalInd0BB {label=label, size=size, localAddr=localAddr, const=wordToWord8 const} :: output) + else peepHole(instrs, false, indLocal :: output) + + | peepHole((load as LoadLocal localAddr) :: + (instrs as PushShort const :: SimpleCode[0wxa0(*opcode_equalWord*)] :: + JumpInstruction{jumpType=JumpFalse, label, size} :: tail), _, output) = + if const < 0w256 + then peepHole(tail, false, + JumpNotEqualLocalConstBB {label=label, size=size, localAddr=localAddr, const=wordToWord8 const} :: output) + else peepHole(instrs, false, load :: output) + + | peepHole(hd::tl, exited, output) = peepHole(tl, exited, hd::output) + in + fun optimise code = peepHole(code, false, []) + end + (* Adds the constants onto the code, and copies the code into a new segment *) fun copyCode (cvec as Code{ printAssemblyCode, printStream, procName, constVec, stage1Code, ...}, maxStack, resultClosure) = let local - val revCode = List.rev(!stage1Code) - (* Add a stack check. *) - val stackCheck = - if maxStack < 256 - then SimpleCode[opcode_stackSize8, Word8.fromInt maxStack] - else SimpleCode[opcode_stackSize16, Word8.fromInt maxStack, Word8.fromInt(maxStack div 256)] + val revCode = optimise(List.rev(!stage1Code)) + (* Add a stack check. This is only needed if the + function needs more than 128 words since the call and tail functions + check for this much. *) in - val codeList = stackCheck :: revCode + val codeList = + if maxStack < 128 + then revCode + else SimpleCode[opcode_stackSize16, Word8.fromInt maxStack, Word8.fromInt(maxStack div 256)] :: revCode end val (byteVec, endIC) = genCode(codeList, cvec) + val wordLength = wordSize (* +3 for profile count, function name and constants count *) val numOfConst = List.length(! constVec) val endOfCode = endIC div wordLength val segSize = endOfCode + Word.fromInt numOfConst + 0w4 val firstConstant = endIC + wordLength * 0w3 (* Add 3 for fn name, unused and profile count. *) (* Put in the number of constants. This must go in before we actually put in any constants. *) local val addr = ((segSize - 0w1) * wordLength) in val () = setLong (numOfConst + 3, addr, byteVec) end (* Now we've filled in all the size info we need to convert the segment into a proper code segment before it's safe to put in any ML values. *) val codeVec = byteVecToCodeVec(byteVec, resultClosure) local val name : string = procName val nameWord : machineWord = toMachineWord name in val () = codeVecPutWord (codeVec, endOfCode, nameWord) end (* This used to be used on X86 for the register mask. *) val () = codeVecPutWord (codeVec, endOfCode+0w1, toMachineWord 1) (* Profile ref. A byte ref used by the profiler in the RTS. *) local val v = RunCall.allocateByteMemory(0w1, Word.fromLargeWord(Word8.toLargeWord(Word8.orb(F_mutable, F_bytes)))) fun clear 0w0 = () | clear i = (assignByte(v, i-0w1, 0w0); clear (i-0w1)) - val () = clear wordSize + val () = clear(wordSize) in val () = codeVecPutWord (codeVec, endOfCode+0w2, toMachineWord v) end (* and then copy the constants from the constant list. *) local fun setConstant(value, num) = let val constAddr = (firstConstant div wordLength) + num in codeVecPutWord (codeVec, constAddr, value); num+0w1 end in val _ = List.foldl setConstant 0w0 (!constVec) end in if printAssemblyCode then (* print out the code *) (printCode (codeVec, procName, endIC, printStream); printStream"\n") else (); codeVecLock(codeVec, resultClosure) end (* copyCode *) fun addItemToList(item, Code{stage1Code, ...}) = stage1Code := item :: !stage1Code val genOpcode = addItemToList fun putBranchInstruction(brOp, label, cvec) = addItemToList(JumpInstruction{label=label, jumpType=brOp, size = ref Size32}, cvec) fun setLabel(label, cvec) = addItemToList(LabelCode label, cvec) - fun createLabel () = { destination=ref 0w0 } + fun createLabel () = ref [ref 0w0] local fun genOpc(opc, cvec) = addItemToList(SimpleCode [opc], cvec) - and genOpcByte(opc, arg1, cvec) = addItemToList(SimpleCode [opc, Word8.fromInt arg1], cvec) - and genOpcWord(opc, arg1, cvec) = - addItemToList(SimpleCode[opc, Word8.fromInt arg1, Word8.fromInt (arg1 div 256)], cvec) + and genExtOpc(opc, cvec) = addItemToList(SimpleCode [opcode_escape, opc], cvec) + and genOpcByte(opc, arg1, cvec) = + if 0 <= arg1 andalso arg1 < 256 + then addItemToList(SimpleCode [opc, Word8.fromInt arg1], cvec) + else raise InternalError "genOpcByte" + and genExtOpcByte(opc, arg1, cvec) = + if 0 <= arg1 andalso arg1 < 256 + then addItemToList(SimpleCode [opcode_escape, opc, Word8.fromInt arg1], cvec) + else raise InternalError "genExtOpcByte" + and genExtOpcWord(opc, arg1, cvec) = + if 0 <= arg1 andalso arg1 < 65536 + then addItemToList(SimpleCode[opcode_escape, opc, Word8.fromInt arg1, Word8.fromInt (arg1 div 256)], cvec) + else raise InternalError "genExtOpcWord" open IEEEReal fun encodeRound TO_NEAREST = 0 | encodeRound TO_NEGINF = 1 | encodeRound TO_POSINF = 2 | encodeRound TO_ZERO = 3 in - fun genRaiseEx cvec = genOpc (opcode_raiseEx, cvec) + fun genRaiseEx cvec = addItemToList(UncondTransfer [opcode_raiseEx], cvec) fun genLock cvec = genOpc (opcode_lock, cvec) fun genLdexc cvec = genOpc (opcode_ldexc, cvec) fun genPushHandler cvec = genOpc (opcode_pushHandler, cvec) fun genRTSCallFast(0, cvec) = genOpc (opcode_callFastRTS0, cvec) | genRTSCallFast(1, cvec) = genOpc (opcode_callFastRTS1, cvec) | genRTSCallFast(2, cvec) = genOpc (opcode_callFastRTS2, cvec) | genRTSCallFast(3, cvec) = genOpc (opcode_callFastRTS3, cvec) | genRTSCallFast(4, cvec) = genOpc (opcode_callFastRTS4, cvec) | genRTSCallFast(5, cvec) = genOpc (opcode_callFastRTS5, cvec) | genRTSCallFast(_, _) = raise InternalError "genRTSFastCall" fun genRTSCallFull(0, cvec) = genOpc (opcode_callFullRTS0, cvec) | genRTSCallFull(1, cvec) = genOpc (opcode_callFullRTS1, cvec) | genRTSCallFull(2, cvec) = genOpc (opcode_callFullRTS2, cvec) | genRTSCallFull(3, cvec) = genOpc (opcode_callFullRTS3, cvec) | genRTSCallFull(4, cvec) = genOpc (opcode_callFullRTS4, cvec) | genRTSCallFull(5, cvec) = genOpc (opcode_callFullRTS5, cvec) | genRTSCallFull(_, _) = raise InternalError "genRTSCallFull" - fun genContainer (size, cvec) = genOpcWord(opcode_containerW, size, cvec) - and genTupleFromContainer (size, cvec) = genOpcWord(opcode_tuple_containerW, size, cvec) + fun genContainer (size, cvec) = + if size < 256 + then genOpcByte(opcode_containerB, size, cvec) + else genExtOpcWord(ext_opcode_containerW, size, cvec) fun genCase (nCases, cvec) = let val labels = List.tabulate(nCases, fn _ => createLabel()) in addItemToList(IndexedCase{labels=labels, size=ref Size32}, cvec); labels end (* For the moment don't try to merge stack resets. *) fun resetStack(0, _, _) = () + | resetStack(1, true, cvec) = + addItemToList(SimpleCode[opcode_resetR_1], cvec) + | resetStack(2, true, cvec) = + addItemToList(SimpleCode[opcode_resetR_2], cvec) + | resetStack(3, true, cvec) = + addItemToList(SimpleCode[opcode_resetR_3], cvec) + | resetStack(offset, true, cvec) = if offset < 0 then raise InternalError "resetStack" else if offset > 255 - then genOpcWord(opcode_resetR_w, offset, cvec) - else if offset > 3 then genOpcByte(opcode_resetRB, offset, cvec) - else addItemToList(SimpleCode[opcode_resetR_1 + Word8.fromInt(offset - 1)], cvec) + then genExtOpcWord(ext_opcode_resetR_w, offset, cvec) + else genOpcByte(opcode_resetRB, offset, cvec) + | resetStack(1, false, cvec) = + addItemToList(SimpleCode[opcode_reset_1], cvec) + | resetStack(2, false, cvec) = + addItemToList(SimpleCode[opcode_reset_2], cvec) + | resetStack(offset, false, cvec) = if offset < 0 then raise InternalError "resetStack" else if offset > 255 - then genOpcWord(opcode_resetW, offset, cvec) - else if offset > 2 then genOpcByte(opcode_resetB, offset, cvec) - else addItemToList(SimpleCode[opcode_reset_1 + Word8.fromInt(offset - 1)], cvec) + then genExtOpcWord(ext_opcode_resetW, offset, cvec) + else genOpcByte(opcode_resetB, offset, cvec) + + fun genCallClosure(Code{stage1Code as ref(PushConstant{constNum, size, isCall=false} :: tail), ...}) = + stage1Code := PushConstant{constNum=constNum, size=size, isCall=true} :: tail + + | genCallClosure(Code{stage1Code as ref(LoadLocal w :: tail), ...}) = + stage1Code := SimpleCode [opcode_callLocalB, w] :: tail + + | genCallClosure(Code{stage1Code, ...}) = + stage1Code := SimpleCode [opcode_callClosure] :: !stage1Code - fun genCallClosure cvec = genOpc (opcode_callClosure, cvec) - fun genTailCall (toslide, slideby, cvec) = if toslide < 256 andalso slideby < 256 - then case (toslide, slideby) of - (3, 2) => genOpc (opcode_tail3_2, cvec) - | (3, 3) => genOpc (opcode_tail3_3, cvec) - | (3, _) => genOpcByte(opcode_tail3b, slideby, cvec) - | (4, _) => genOpcByte(opcode_tail4b, slideby, cvec) - | (_, _) => (* General byte case *) - addItemToList(SimpleCode[opcode_tailbb, Word8.fromInt toslide, Word8.fromInt slideby], cvec) + then (* General byte case *) + addItemToList(UncondTransfer[opcode_tailbb, Word8.fromInt toslide, Word8.fromInt slideby], cvec) else (* General case. *) addItemToList( - SimpleCode[opcode_tail, Word8.fromInt toslide, Word8.fromInt(toslide div 256), + UncondTransfer[opcode_escape, ext_opcode_tail, Word8.fromInt toslide, Word8.fromInt(toslide div 256), Word8.fromInt slideby, Word8.fromInt (slideby div 256)], cvec) fun pushConst (value : machineWord, cvec) = if isShort value andalso toShort value < 0w32768 - then - let - val iVal = Word.toInt (toShort value); - in - if iVal = 10 - then genOpc (opcode_const_10, cvec) - - else if iVal <= 4 - then genOpc (opcode_const_0 + Word8.fromInt iVal, cvec) - - else if iVal < 256 - then genOpcByte (opcode_constIntB, iVal, cvec) - - else genOpcWord (opcode_constIntW, iVal, cvec) - end - + then addItemToList(PushShort(toShort value), cvec) else (* address or large short *) - addItemToList(PushConstant{constNum = addConstToVec(value, cvec), size=ref Size32}, cvec) + addItemToList(PushConstant{constNum = addConstToVec(value, cvec), size=ref Size32, isCall=false}, cvec) - fun genRTSCallFastRealtoReal cvec = genOpc (opcode_callFastRTSRtoR, cvec) - and genRTSCallFastRealRealtoReal cvec = genOpc (opcode_callFastRTSRRtoR, cvec) - and genRTSCallFastGeneraltoReal cvec = genOpc (opcode_callFastRTSGtoR, cvec) - and genRTSCallFastRealGeneraltoReal cvec = genOpc (opcode_callFastRTSRGtoR, cvec) + fun genRTSCallFastRealtoReal cvec = genExtOpc (ext_opcode_callFastRTSRtoR, cvec) + and genRTSCallFastRealRealtoReal cvec = genExtOpc (ext_opcode_callFastRTSRRtoR, cvec) + and genRTSCallFastGeneraltoReal cvec = genExtOpc (ext_opcode_callFastRTSGtoR, cvec) + and genRTSCallFastRealGeneraltoReal cvec = genExtOpc (ext_opcode_callFastRTSRGtoR, cvec) - and genRTSCallFastFloattoFloat cvec = genOpc (opcode_callFastRTSFtoF, cvec) - and genRTSCallFastFloatFloattoFloat cvec = genOpc (opcode_callFastRTSFFtoF, cvec) - and genRTSCallFastGeneraltoFloat cvec = genOpc (opcode_callFastRTSGtoF, cvec) - and genRTSCallFastFloatGeneraltoFloat cvec = genOpc (opcode_callFastRTSFGtoF, cvec) + and genRTSCallFastFloattoFloat cvec = genExtOpc (ext_opcode_callFastRTSFtoF, cvec) + and genRTSCallFastFloatFloattoFloat cvec = genExtOpc (ext_opcode_callFastRTSFFtoF, cvec) + and genRTSCallFastGeneraltoFloat cvec = genOpc (ext_opcode_callFastRTSGtoF, cvec) + and genRTSCallFastFloatGeneraltoFloat cvec = genExtOpc (ext_opcode_callFastRTSFGtoF, cvec) - fun genDoubleToFloat(SOME rnding, cvec) = genOpcByte(opcode_realToFloat, encodeRound rnding, cvec) - | genDoubleToFloat(NONE, cvec) = genOpcByte(opcode_realToFloat, 5, cvec) + fun genDoubleToFloat(SOME rnding, cvec) = genExtOpcByte(ext_opcode_realToFloat, encodeRound rnding, cvec) + | genDoubleToFloat(NONE, cvec) = genExtOpcByte(ext_opcode_realToFloat, 5, cvec) - and genRealToInt(rnding, cvec) = genOpcByte(opcode_realToInt, encodeRound rnding, cvec) - and genFloatToInt(rnding, cvec) = genOpcByte(opcode_floatToInt, encodeRound rnding, cvec) - end - - local - fun gen1 (opW, opB, opF, first, arg1, cvec) = - if first <= arg1 andalso arg1 < first+List.length opF - then addItemToList(SimpleCode[List.nth(opF, arg1 - first)], cvec) - - else if 0 <= arg1 andalso arg1 <= 255 - then addItemToList(SimpleCode [opB, Word8.fromInt arg1], cvec) - - else addItemToList( - SimpleCode [opW, Word8.fromInt arg1, Word8.fromInt(arg1 div 256)], cvec) - in - fun genReturn (arg1, cvec) = - let - val ops = [opcode_return_0, opcode_return_1, opcode_return_2, opcode_return_3] - in - gen1 (opcode_returnW, opcode_returnB, ops, 0, arg1, cvec) - end - - fun genLocal (arg1, cvec) = - let - val ops = [opcode_local_0, opcode_local_1, opcode_local_2, opcode_local_3, opcode_local_4, - opcode_local_5, opcode_local_6, opcode_local_7, opcode_local_8, opcode_local_9, - opcode_local_10, opcode_local_11] - in - gen1 (opcode_localW, opcode_localB, ops, 0, arg1, cvec) - end - - fun genIndirect (arg1, cvec) = - let - val ops = [opcode_indirect_0, opcode_indirect_1, opcode_indirect_2, opcode_indirect_3, - opcode_indirect_4, opcode_indirect_5] - in - gen1 (opcode_indirectW, opcode_indirectB, ops, 0, arg1, cvec) - end + and genRealToInt(rnding, cvec) = genExtOpcByte(ext_opcode_realToInt, encodeRound rnding, cvec) + and genFloatToInt(rnding, cvec) = genExtOpcByte(ext_opcode_floatToInt, encodeRound rnding, cvec) + + fun genEqualWordConst(w, cvec) = + (pushConst(toMachineWord w, cvec); genOpc(opcode_equalWord, cvec)) + + fun genIsTagged(Code{stage1Code as ref(LoadLocal addr :: tail), ...}) = + stage1Code := IsTaggedLocalB addr :: tail + | genIsTagged cvec = genOpc(opcode_isTagged, cvec) + + fun genIndirectSimple(0, cvec) = genOpc(opcode_indirect_0, cvec) + | genIndirectSimple(1, cvec) = genOpc(opcode_indirect_1, cvec) + | genIndirectSimple(2, cvec) = genOpc(opcode_indirect_2, cvec) + | genIndirectSimple(3, cvec) = genOpc(opcode_indirect_3, cvec) + | genIndirectSimple(4, cvec) = genOpc(opcode_indirect_4, cvec) + | genIndirectSimple(5, cvec) = genOpc(opcode_indirect_5, cvec) + | genIndirectSimple(arg1, cvec) = + if arg1 < 256 + then genOpcByte(opcode_indirectB, arg1, cvec) + else genExtOpcWord(ext_opcode_indirectW, arg1, cvec) (* genMoveToVec is now only used for mutually recursive closures. *) fun genMoveToVec (arg1, cvec) = - gen1 (opcode_moveToVecW, opcode_moveToVecB, [], 0, arg1, cvec) - + if arg1 < 256 + then genOpcByte(opcode_moveToVecB, arg1, cvec) + else genExtOpcWord(ext_opcode_moveToVecW, arg1, cvec) + fun genSetStackVal (arg1, cvec) = - gen1 (opcode_setStackValW, opcode_setStackValB, [], 0, arg1, cvec) - - fun genTuple (arg1, cvec) = - let - val ops = [opcode_tuple_2, opcode_tuple_3, opcode_tuple_4] - in - gen1 (opcode_tupleW, opcode_tupleB, ops, 2, arg1, cvec) - end + if arg1 < 256 + then genOpcByte(opcode_setStackValB, arg1, cvec) + else genExtOpcWord(ext_opcode_setStackValW, arg1, cvec) + + fun genTuple (2, cvec) = genOpc(opcode_tuple_2, cvec) + | genTuple (3, cvec) = genOpc(opcode_tuple_3, cvec) + | genTuple (4, cvec) = genOpc(opcode_tuple_4, cvec) + | genTuple (arg1, cvec) = + if arg1 < 256 + then genOpcByte(opcode_tupleB, arg1, cvec) + else genExtOpcWord(ext_opcode_tupleW, arg1, cvec) end + fun genReturn(1, cvec) = addItemToList(UncondTransfer[opcode_return_1], cvec) + | genReturn(2, cvec) = addItemToList(UncondTransfer[opcode_return_2], cvec) + | genReturn(3, cvec) = addItemToList(UncondTransfer[opcode_return_3], cvec) + | genReturn(arg1, cvec) = + addItemToList(UncondTransfer( + if 0 <= arg1 andalso arg1 <= 255 + then [opcode_returnB, Word8.fromInt arg1] + else [opcode_returnW, Word8.fromInt arg1, Word8.fromInt(arg1 div 256)]), + cvec) + + fun genLocal (arg1, cvec) = + if 0 <= arg1 andalso arg1 < 256 then addItemToList(LoadLocal(Word8.fromInt arg1), cvec) + else addItemToList(SimpleCode[opcode_localW, Word8.fromInt arg1, Word8.fromInt(arg1 div 256)], cvec) + + fun genIndirect (arg1, cvec as Code{stage1Code as ref(LoadLocal w :: tail), ...}) = + if 0 <= arg1 andalso arg1 <= 255 + then stage1Code := IndirectLocal{localAddr=w, indirect=Word8.fromInt arg1} :: tail + else genIndirectSimple(arg1, cvec) + + | genIndirect (arg1, cvec) = genIndirectSimple(arg1, cvec) + + fun genEnterIntCatch _ = () and genEnterIntCall _ = () val opcode_notBoolean = SimpleCode [opcode_notBoolean] - val opcode_isTagged = SimpleCode [opcode_isTagged] - and opcode_cellLength = SimpleCode [opcode_cellLength] + val opcode_cellLength = SimpleCode [opcode_cellLength] and opcode_cellFlags = SimpleCode [opcode_cellFlags] and opcode_clearMutable = SimpleCode [opcode_clearMutable] and opcode_atomicIncr = SimpleCode [opcode_atomicIncr] and opcode_atomicDecr = SimpleCode [opcode_atomicDecr] - and opcode_atomicReset = SimpleCode [opcode_atomicReset] - and opcode_longWToTagged = SimpleCode [opcode_longWToTagged] - and opcode_signedToLongW = SimpleCode [opcode_signedToLongW] - and opcode_unsignedToLongW = SimpleCode [opcode_unsignedToLongW] - and opcode_realAbs = SimpleCode [opcode_realAbs] - and opcode_realNeg = SimpleCode [opcode_realNeg] - and opcode_fixedIntToReal = SimpleCode [opcode_fixedIntToReal] - and opcode_fixedIntToFloat = SimpleCode [opcode_fixedIntToFloat] - and opcode_floatToReal = SimpleCode [opcode_floatToReal] + and opcode_atomicReset = SimpleCode [opcode_escape, ext_opcode_atomicReset] + and opcode_longWToTagged = SimpleCode [opcode_escape, ext_opcode_longWToTagged] + and opcode_signedToLongW = SimpleCode [opcode_escape, ext_opcode_signedToLongW] + and opcode_unsignedToLongW = SimpleCode [opcode_escape, ext_opcode_unsignedToLongW] + and opcode_realAbs = SimpleCode [opcode_escape, ext_opcode_realAbs] + and opcode_realNeg = SimpleCode [opcode_escape, ext_opcode_realNeg] + and opcode_fixedIntToReal = SimpleCode [opcode_escape, ext_opcode_fixedIntToReal] + and opcode_fixedIntToFloat = SimpleCode [opcode_escape, ext_opcode_fixedIntToFloat] + and opcode_floatToReal = SimpleCode [opcode_escape, ext_opcode_floatToReal] val opcode_equalWord = SimpleCode [opcode_equalWord] and opcode_lessSigned = SimpleCode [opcode_lessSigned] and opcode_lessUnsigned = SimpleCode [opcode_lessUnsigned] and opcode_lessEqSigned = SimpleCode [opcode_lessEqSigned] and opcode_lessEqUnsigned = SimpleCode [opcode_lessEqUnsigned] and opcode_greaterSigned = SimpleCode [opcode_greaterSigned] and opcode_greaterUnsigned = SimpleCode [opcode_greaterUnsigned] and opcode_greaterEqSigned = SimpleCode [opcode_greaterEqSigned] and opcode_greaterEqUnsigned = SimpleCode [opcode_greaterEqUnsigned] val opcode_fixedAdd = SimpleCode [opcode_fixedAdd] val opcode_fixedSub = SimpleCode [opcode_fixedSub] val opcode_fixedMult = SimpleCode [opcode_fixedMult] val opcode_fixedQuot = SimpleCode [opcode_fixedQuot] val opcode_fixedRem = SimpleCode [opcode_fixedRem] - val opcode_fixedDiv = SimpleCode [opcode_fixedDiv] - val opcode_fixedMod = SimpleCode [opcode_fixedMod] + val opcode_fixedDiv = SimpleCode [opcode_escape, ext_opcode_fixedDiv] + val opcode_fixedMod = SimpleCode [opcode_escape, ext_opcode_fixedMod] val opcode_wordAdd = SimpleCode [opcode_wordAdd] val opcode_wordSub = SimpleCode [opcode_wordSub] val opcode_wordMult = SimpleCode [opcode_wordMult] val opcode_wordDiv = SimpleCode [opcode_wordDiv] val opcode_wordMod = SimpleCode [opcode_wordMod] val opcode_wordAnd = SimpleCode [opcode_wordAnd] val opcode_wordOr = SimpleCode [opcode_wordOr] val opcode_wordXor = SimpleCode [opcode_wordXor] val opcode_wordShiftLeft = SimpleCode [opcode_wordShiftLeft] val opcode_wordShiftRLog = SimpleCode [opcode_wordShiftRLog] - val opcode_wordShiftRArith = SimpleCode [opcode_wordShiftRArith] + val opcode_wordShiftRArith = SimpleCode [opcode_escape, ext_opcode_wordShiftRArith] val opcode_allocByteMem = SimpleCode [opcode_allocByteMem] - val opcode_lgWordEqual = SimpleCode [opcode_lgWordEqual] - val opcode_lgWordLess = SimpleCode [opcode_lgWordLess] - val opcode_lgWordLessEq = SimpleCode [opcode_lgWordLessEq] - val opcode_lgWordGreater = SimpleCode [opcode_lgWordGreater] - val opcode_lgWordGreaterEq = SimpleCode [opcode_lgWordGreaterEq] - val opcode_lgWordAdd = SimpleCode [opcode_lgWordAdd] - val opcode_lgWordSub = SimpleCode [opcode_lgWordSub] - val opcode_lgWordMult = SimpleCode [opcode_lgWordMult] - val opcode_lgWordDiv = SimpleCode [opcode_lgWordDiv] - val opcode_lgWordMod = SimpleCode [opcode_lgWordMod] - val opcode_lgWordAnd = SimpleCode [opcode_lgWordAnd] - val opcode_lgWordOr = SimpleCode [opcode_lgWordOr] - val opcode_lgWordXor = SimpleCode [opcode_lgWordXor] - val opcode_lgWordShiftLeft = SimpleCode [opcode_lgWordShiftLeft] - val opcode_lgWordShiftRLog = SimpleCode [opcode_lgWordShiftRLog] - val opcode_lgWordShiftRArith = SimpleCode [opcode_lgWordShiftRArith] - val opcode_realEqual = SimpleCode [opcode_realEqual] - val opcode_realLess = SimpleCode [opcode_realLess] - val opcode_realLessEq = SimpleCode [opcode_realLessEq] - val opcode_realGreater = SimpleCode [opcode_realGreater] - val opcode_realGreaterEq = SimpleCode [opcode_realGreaterEq] - val opcode_realUnordered = SimpleCode [opcode_realUnordered] - val opcode_realAdd = SimpleCode [opcode_realAdd] - val opcode_realSub = SimpleCode [opcode_realSub] - val opcode_realMult = SimpleCode [opcode_realMult] - val opcode_realDiv = SimpleCode [opcode_realDiv] - and opcode_floatAbs = SimpleCode [opcode_floatAbs] - and opcode_floatNeg = SimpleCode [opcode_floatNeg] - val opcode_floatEqual = SimpleCode [opcode_floatEqual] - val opcode_floatLess = SimpleCode [opcode_floatLess] - val opcode_floatLessEq = SimpleCode [opcode_floatLessEq] - val opcode_floatGreater = SimpleCode [opcode_floatGreater] - val opcode_floatGreaterEq = SimpleCode [opcode_floatGreaterEq] - val opcode_floatUnordered = SimpleCode [opcode_floatUnordered] - val opcode_floatAdd = SimpleCode [opcode_floatAdd] - val opcode_floatSub = SimpleCode [opcode_floatSub] - val opcode_floatMult = SimpleCode [opcode_floatMult] - val opcode_floatDiv = SimpleCode [opcode_floatDiv] + val opcode_lgWordEqual = SimpleCode [opcode_escape, ext_opcode_lgWordEqual] + val opcode_lgWordLess = SimpleCode [opcode_escape, ext_opcode_lgWordLess] + val opcode_lgWordLessEq = SimpleCode [opcode_escape, ext_opcode_lgWordLessEq] + val opcode_lgWordGreater = SimpleCode [opcode_escape, ext_opcode_lgWordGreater] + val opcode_lgWordGreaterEq = SimpleCode [opcode_escape, ext_opcode_lgWordGreaterEq] + val opcode_lgWordAdd = SimpleCode [opcode_escape, ext_opcode_lgWordAdd] + val opcode_lgWordSub = SimpleCode [opcode_escape, ext_opcode_lgWordSub] + val opcode_lgWordMult = SimpleCode [opcode_escape, ext_opcode_lgWordMult] + val opcode_lgWordDiv = SimpleCode [opcode_escape, ext_opcode_lgWordDiv] + val opcode_lgWordMod = SimpleCode [opcode_escape, ext_opcode_lgWordMod] + val opcode_lgWordAnd = SimpleCode [opcode_escape, ext_opcode_lgWordAnd] + val opcode_lgWordOr = SimpleCode [opcode_escape, ext_opcode_lgWordOr] + val opcode_lgWordXor = SimpleCode [opcode_escape, ext_opcode_lgWordXor] + val opcode_lgWordShiftLeft = SimpleCode [opcode_escape, ext_opcode_lgWordShiftLeft] + val opcode_lgWordShiftRLog = SimpleCode [opcode_escape, ext_opcode_lgWordShiftRLog] + val opcode_lgWordShiftRArith = SimpleCode [opcode_escape, ext_opcode_lgWordShiftRArith] + val opcode_realEqual = SimpleCode [opcode_escape, ext_opcode_realEqual] + val opcode_realLess = SimpleCode [opcode_escape, ext_opcode_realLess] + val opcode_realLessEq = SimpleCode [opcode_escape, ext_opcode_realLessEq] + val opcode_realGreater = SimpleCode [opcode_escape, ext_opcode_realGreater] + val opcode_realGreaterEq = SimpleCode [opcode_escape, ext_opcode_realGreaterEq] + val opcode_realUnordered = SimpleCode [opcode_escape, ext_opcode_realUnordered] + val opcode_realAdd = SimpleCode [opcode_escape, ext_opcode_realAdd] + val opcode_realSub = SimpleCode [opcode_escape, ext_opcode_realSub] + val opcode_realMult = SimpleCode [opcode_escape, ext_opcode_realMult] + val opcode_realDiv = SimpleCode [opcode_escape, ext_opcode_realDiv] + and opcode_floatAbs = SimpleCode [opcode_escape, ext_opcode_floatAbs] + and opcode_floatNeg = SimpleCode [opcode_escape, ext_opcode_floatNeg] + val opcode_floatEqual = SimpleCode [opcode_escape, ext_opcode_floatEqual] + val opcode_floatLess = SimpleCode [opcode_escape, ext_opcode_floatLess] + val opcode_floatLessEq = SimpleCode [opcode_escape, ext_opcode_floatLessEq] + val opcode_floatGreater = SimpleCode [opcode_escape, ext_opcode_floatGreater] + val opcode_floatGreaterEq = SimpleCode [opcode_escape, ext_opcode_floatGreaterEq] + val opcode_floatUnordered = SimpleCode [opcode_escape, ext_opcode_floatUnordered] + val opcode_floatAdd = SimpleCode [opcode_escape, ext_opcode_floatAdd] + val opcode_floatSub = SimpleCode [opcode_escape, ext_opcode_floatSub] + val opcode_floatMult = SimpleCode [opcode_escape, ext_opcode_floatMult] + val opcode_floatDiv = SimpleCode [opcode_escape, ext_opcode_floatDiv] val opcode_getThreadId = SimpleCode [opcode_getThreadId] val opcode_allocWordMemory = SimpleCode [opcode_allocWordMemory] val opcode_alloc_ref = SimpleCode [opcode_alloc_ref] val opcode_loadMLWord = SimpleCode [opcode_loadMLWord] val opcode_loadMLByte = SimpleCode [opcode_loadMLByte] - val opcode_loadC8 = SimpleCode [opcode_loadC8] - val opcode_loadC16 = SimpleCode [opcode_loadC16] - val opcode_loadC32 = SimpleCode [opcode_loadC32] - val opcode_loadC64 = SimpleCode [opcode_loadC64] - val opcode_loadCFloat = SimpleCode [opcode_loadCFloat] - val opcode_loadCDouble = SimpleCode [opcode_loadCDouble] + val opcode_loadC8 = SimpleCode [opcode_escape, ext_opcode_loadC8] + val opcode_loadC16 = SimpleCode [opcode_escape, ext_opcode_loadC16] + val opcode_loadC32 = SimpleCode [opcode_escape, ext_opcode_loadC32] + val opcode_loadC64 = SimpleCode [opcode_escape, ext_opcode_loadC64] + val opcode_loadCFloat = SimpleCode [opcode_escape, ext_opcode_loadCFloat] + val opcode_loadCDouble = SimpleCode [opcode_escape, ext_opcode_loadCDouble] val opcode_loadUntagged = SimpleCode [opcode_loadUntagged] val opcode_storeMLWord = SimpleCode [opcode_storeMLWord] val opcode_storeMLByte = SimpleCode [opcode_storeMLByte] - val opcode_storeC8 = SimpleCode [opcode_storeC8] - val opcode_storeC16 = SimpleCode [opcode_storeC16] - val opcode_storeC32 = SimpleCode [opcode_storeC32] - val opcode_storeC64 = SimpleCode [opcode_storeC64] - val opcode_storeCFloat = SimpleCode [opcode_storeCFloat] - val opcode_storeCDouble = SimpleCode [opcode_storeCDouble] + val opcode_storeC8 = SimpleCode [opcode_escape, ext_opcode_storeC8] + val opcode_storeC16 = SimpleCode [opcode_escape, ext_opcode_storeC16] + val opcode_storeC32 = SimpleCode [opcode_escape, ext_opcode_storeC32] + val opcode_storeC64 = SimpleCode [opcode_escape, ext_opcode_storeC64] + val opcode_storeCFloat = SimpleCode [opcode_escape, ext_opcode_storeCFloat] + val opcode_storeCDouble = SimpleCode [opcode_escape, ext_opcode_storeCDouble] val opcode_storeUntagged = SimpleCode [opcode_storeUntagged] val opcode_blockMoveWord = SimpleCode [opcode_blockMoveWord] val opcode_blockMoveByte = SimpleCode [opcode_blockMoveByte] val opcode_blockEqualByte = SimpleCode [opcode_blockEqualByte] val opcode_blockCompareByte = SimpleCode [opcode_blockCompareByte] val opcode_deleteHandler = SimpleCode [opcode_deleteHandler] structure Sharing = struct type code = code type opcode = opcode type labels = labels type closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONSSIG.sml b/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONSSIG.sml index 6c905f9d..8ad5980a 100644 --- a/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONSSIG.sml +++ b/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONSSIG.sml @@ -1,215 +1,214 @@ (* - Copyright (c) 2016-18 David C.J. Matthews + Copyright (c) 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 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 INTCODECONSSIG = sig type machineWord = Address.machineWord type address = Address.address type code type opcode type labels type closureRef val opcode_notBoolean: opcode - val opcode_isTagged: opcode - and opcode_cellLength: opcode + val opcode_cellLength: opcode and opcode_cellFlags: opcode and opcode_clearMutable: opcode and opcode_atomicIncr: opcode and opcode_atomicDecr: opcode and opcode_atomicReset: opcode and opcode_longWToTagged: opcode and opcode_signedToLongW: opcode and opcode_unsignedToLongW: opcode and opcode_realAbs: opcode and opcode_realNeg: opcode and opcode_fixedIntToReal: opcode and opcode_fixedIntToFloat: opcode and opcode_floatToReal: opcode and opcode_floatAbs: opcode and opcode_floatNeg: opcode val opcode_equalWord: opcode and opcode_lessSigned: opcode and opcode_lessUnsigned: opcode and opcode_lessEqSigned: opcode and opcode_lessEqUnsigned: opcode and opcode_greaterSigned: opcode and opcode_greaterUnsigned: opcode and opcode_greaterEqSigned: opcode and opcode_greaterEqUnsigned: opcode val opcode_fixedAdd: opcode val opcode_fixedSub: opcode val opcode_fixedMult: opcode val opcode_fixedQuot: opcode val opcode_fixedRem: opcode val opcode_fixedDiv: opcode val opcode_fixedMod: opcode val opcode_wordAdd: opcode val opcode_wordSub: opcode val opcode_wordMult: opcode val opcode_wordDiv: opcode val opcode_wordMod: opcode val opcode_wordAnd: opcode val opcode_wordOr: opcode val opcode_wordXor: opcode val opcode_wordShiftLeft: opcode val opcode_wordShiftRLog: opcode val opcode_wordShiftRArith: opcode val opcode_allocByteMem: opcode val opcode_lgWordEqual: opcode val opcode_lgWordLess: opcode val opcode_lgWordLessEq: opcode val opcode_lgWordGreater: opcode val opcode_lgWordGreaterEq: opcode val opcode_lgWordAdd: opcode val opcode_lgWordSub: opcode val opcode_lgWordMult: opcode val opcode_lgWordDiv: opcode val opcode_lgWordMod: opcode val opcode_lgWordAnd: opcode val opcode_lgWordOr: opcode val opcode_lgWordXor: opcode val opcode_lgWordShiftLeft: opcode val opcode_lgWordShiftRLog: opcode val opcode_lgWordShiftRArith: opcode val opcode_realEqual: opcode val opcode_realLess: opcode val opcode_realLessEq: opcode val opcode_realGreater: opcode val opcode_realGreaterEq: opcode val opcode_realUnordered: opcode val opcode_realAdd: opcode val opcode_realSub: opcode val opcode_realMult: opcode val opcode_realDiv: opcode val opcode_floatEqual: opcode val opcode_floatLess: opcode val opcode_floatLessEq: opcode val opcode_floatGreater: opcode val opcode_floatGreaterEq: opcode val opcode_floatUnordered: opcode val opcode_floatAdd: opcode val opcode_floatSub: opcode val opcode_floatMult: opcode val opcode_floatDiv: opcode val opcode_getThreadId: opcode val opcode_allocWordMemory: opcode val opcode_alloc_ref: opcode val opcode_loadMLWord: opcode val opcode_loadMLByte: opcode val opcode_loadC8: opcode val opcode_loadC16: opcode val opcode_loadC32: opcode val opcode_loadC64: opcode val opcode_loadCFloat: opcode val opcode_loadCDouble: opcode val opcode_loadUntagged: opcode val opcode_storeMLWord: opcode val opcode_storeMLByte: opcode val opcode_storeC8: opcode val opcode_storeC16: opcode val opcode_storeC32: opcode val opcode_storeC64: opcode val opcode_storeCFloat: opcode val opcode_storeCDouble: opcode val opcode_storeUntagged: opcode val opcode_blockMoveWord: opcode val opcode_blockMoveByte: opcode val opcode_blockEqualByte: opcode val opcode_blockCompareByte: opcode val opcode_deleteHandler: opcode val codeCreate: string * Universal.universal list -> code (* makes the initial segment. *) (* GEN- routines all put a value at the instruction counter and add an appropriate amount to it. *) (* gen... - put instructions and their operands. *) val genCallClosure : code -> unit val genRaiseEx : code -> unit val genLock : code -> unit val genLdexc : code -> unit val genPushHandler : code -> unit val genReturn : int * code -> unit val genLocal : int * code -> unit val genIndirect : int * code -> unit val genMoveToVec : int * code -> unit val genSetStackVal : int * code -> unit val genCase : int * code -> labels list val genTuple : int * code -> unit val genTailCall : int * int * code -> unit val genDoubleToFloat: IEEEReal.rounding_mode option * code -> unit and genRealToInt: IEEEReal.rounding_mode * code -> unit and genFloatToInt: IEEEReal.rounding_mode * code -> unit val genRTSCallFast: int * code -> unit val genRTSCallFull: int * code -> unit val genRTSCallFastRealtoReal: code -> unit val genRTSCallFastRealRealtoReal: code -> unit val genRTSCallFastGeneraltoReal: code -> unit val genRTSCallFastRealGeneraltoReal: code -> unit val genRTSCallFastFloattoFloat: code -> unit val genRTSCallFastFloatFloattoFloat: code -> unit val genRTSCallFastGeneraltoFloat: code -> unit val genRTSCallFastFloatGeneraltoFloat: code -> unit val genOpcode: opcode * code -> unit (* genEnter instructions are only needed when machine-code routines can call interpreted routines or vice-versa. The enterInt instruction causes the interpreter to be entered and the argument indicates the reason. *) val genEnterIntCatch : code -> unit val genEnterIntCall : code * int -> unit (* pushConst - Generates code to push a constant. *) val pushConst : machineWord * code -> unit (* Create a container on the stack *) val genContainer : int * code -> unit - (* Create a tuple from a container. *) - val genTupleFromContainer : int * code -> unit - (* copyCode - Finish up after compiling a function. *) val copyCode : code * int * closureRef -> unit (* putBranchInstruction puts in an instruction which involves a forward reference. *) - datatype jumpTypes = Jump | JumpFalse | SetHandler + datatype jumpTypes = Jump | JumpBack | JumpFalse | JumpTrue | SetHandler val putBranchInstruction: jumpTypes * labels * code -> unit val createLabel: unit -> labels (* Define the position of a label. *) val setLabel: labels * code -> unit val resetStack: int * bool * code -> unit (* Set a pending reset *) + val genEqualWordConst: word * code -> unit + val genIsTagged: code -> unit + structure Sharing: sig type code = code type opcode = opcode type labels = labels type closureRef = closureRef end end ; diff --git a/mlsource/MLCompiler/CodeTree/ByteCode/INTGCODE.ML b/mlsource/MLCompiler/CodeTree/ByteCode/INTGCODE.ML index fe5da4e9..b999b3ae 100644 --- a/mlsource/MLCompiler/CodeTree/ByteCode/INTGCODE.ML +++ b/mlsource/MLCompiler/CodeTree/ByteCode/INTGCODE.ML @@ -1,1159 +1,1163 @@ (* 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} = + (* Operations on ML memory always have the base as an ML address. + Word operations are always word aligned. The higher level will + have extracted any constant offset and scaled it if necessary. + That's helpful for the X86 but not for the interpreter. We + have to turn them back into indexes. *) + fun genMLAddress({base, index, offset}, scale) = ( 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) => + offset mod scale = 0 orelse raise InternalError "genMLAddress"; + case (index, offset div scale) of + (NONE, soffset) => (pushConst (toMachineWord soffset, cvec); incsp()) + | (SOME indexVal, 0) => gencde (indexVal, ToStack, NotEnd, loopAddr) + | (SOME indexVal, soffset) => ( gencde (indexVal, ToStack, NotEnd, loopAddr); - pushConst (toMachineWord offset, cvec); + pushConst (toMachineWord soffset, 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} = + fun genCAddress{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) + putBranchInstruction(JumpBack, startLoop, cvec) end | BICRaise exp => - let - val () = gencde (exp, ToStack, NotEnd, loopAddr) - val () = genRaiseEx cvec; - in - exited := true - end + ( + gencde (exp, ToStack, NotEnd, loopAddr); + genRaiseEx cvec + ) | 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); + 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) + genEqualWordConst(tag, 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) + | IsTaggedValue => genIsTagged 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=BuiltIns.WordComparison{test=BuiltIns.TestEqual, ...}, arg1, arg2=BICConstnt(w, _) } => + let + val () = gencde (arg1, ToStack, NotEnd, loopAddr) + in + genEqualWordConst(toShort w, cvec) + end + + | BICBinary { oper=BuiltIns.WordComparison{test=BuiltIns.TestEqual, ...}, arg1=BICConstnt(w, _), arg2 } => + let + val () = gencde (arg2, ToStack, NotEnd, loopAddr) + in + genEqualWordConst(toShort w, cvec) + 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) + offset mod Word.toInt wordSize = 0 orelse raise InternalError "gencde: BICLoadOperation - not word multiple"; + genIndirect (offset div Word.toInt 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 + | BICLoadOperation { kind=LoadStoreMLWord _, address} => + ( + genMLAddress(address, Word.toInt wordSize); genOpcode(opcode_loadMLWord, cvec); - decsp(); decsp() - end + decsp() + ) | BICLoadOperation { kind=LoadStoreMLByte _, address} => ( - genByteAddress address; + genMLAddress(address, 1); genOpcode(opcode_loadMLByte, cvec); decsp() ) | BICLoadOperation { kind=LoadStoreC8, address} => ( - genByteAddress address; + genCAddress address; genOpcode(opcode_loadC8, cvec); decsp() ) | BICLoadOperation { kind=LoadStoreC16, address} => ( - genNonByteAddress address; + genCAddress address; genOpcode(opcode_loadC16, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreC32, address} => ( - genNonByteAddress address; + genCAddress address; genOpcode(opcode_loadC32, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreC64, address} => ( wordSize = 0w8 orelse raise InternalError "LoadStoreC64 but not 64-bit mode"; - genNonByteAddress address; + genCAddress address; genOpcode(opcode_loadC64, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreCFloat, address} => ( - genNonByteAddress address; + genCAddress address; genOpcode(opcode_loadCFloat, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreCDouble, address} => ( - genNonByteAddress address; + genCAddress address; genOpcode(opcode_loadCDouble, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreUntaggedUnsigned, address} => ( - genNonByteAddress address; + genMLAddress(address, Word.toInt wordSize); genOpcode(opcode_loadUntagged, cvec); - decsp(); 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 + | BICStoreOperation { kind=LoadStoreMLWord _, address, value } => + ( + genMLAddress(address, Word.toInt wordSize); + gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeMLWord, cvec); - decsp(); decsp(); decsp() - end + decsp(); decsp() + ) | BICStoreOperation { kind=LoadStoreMLByte _, address, value } => ( - genByteAddress address; + genMLAddress(address, 1); gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeMLByte, cvec); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreC8, address, value} => ( - genByteAddress address; + genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeC8, cvec); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreC16, address, value} => ( - genNonByteAddress address; + genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeC16, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreC32, address, value} => ( - genNonByteAddress address; + genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeC32, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreC64, address, value} => ( - genNonByteAddress address; + genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeC64, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreCFloat, address, value} => ( - genNonByteAddress address; + genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeCFloat, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreCDouble, address, value} => ( - genNonByteAddress address; + genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeCDouble, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreUntaggedUnsigned, address, value} => ( - genNonByteAddress address; + genMLAddress(address, Word.toInt wordSize); gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeUntagged, cvec); - decsp(); decsp(); decsp() + decsp(); decsp() ) | BICBlockOperation { kind=BlockOpMove{isByteMove=true}, sourceLeft, destRight, length } => ( - genByteAddress sourceLeft; - genByteAddress destRight; + genMLAddress(sourceLeft, 1); + genMLAddress(destRight, 1); 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; + genMLAddress(sourceLeft, Word.toInt wordSize); + genMLAddress(destRight, Word.toInt wordSize); gencde (length, ToStack, NotEnd, loopAddr); genOpcode(opcode_blockMoveWord, cvec); - decsp(); decsp(); decsp(); decsp(); decsp(); decsp() + decsp(); decsp(); decsp(); decsp() ) | BICBlockOperation { kind=BlockOpEqualByte, sourceLeft, destRight, length } => ( - genByteAddress sourceLeft; - genByteAddress destRight; + genMLAddress(sourceLeft, 1); + genMLAddress(destRight, 1); gencde (length, ToStack, NotEnd, loopAddr); genOpcode(opcode_blockEqualByte, cvec); decsp(); decsp(); decsp(); decsp() ) | BICBlockOperation { kind=BlockOpCompareByte, sourceLeft, destRight, length } => ( - genByteAddress sourceLeft; - genByteAddress destRight; + genMLAddress(sourceLeft, 1); + genMLAddress(destRight, 1); 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 + if 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 + if 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) + (* andalso and orelse are turned into conditionals with constants. + Convert this into a series of tests. *) + fun genTest(BICConstnt(w, _), jumpOn, targetLabel) = + let + val cVal = case toShort w of 0w0 => false | 0w1 => true | _ => raise InternalError "genTest" + in + if cVal = jumpOn + then putBranchInstruction (Jump, targetLabel, cvec) + else () + end + + | genTest(BICUnary { oper=BuiltIns.NotBoolean, arg1 }, jumpOn, targetLabel) = + genTest(arg1, not jumpOn, targetLabel) + + | genTest(BICCond (testPart, thenPart, elsePart), jumpOn, targetLabel) = + let + val toElse = createLabel() and exitJump = createLabel() + in + genTest(testPart, false, toElse); + genTest(thenPart, jumpOn, targetLabel); + putBranchInstruction (Jump, exitJump, cvec); + setLabel (toElse, cvec); + genTest(elsePart, jumpOn, targetLabel); + setLabel (exitJump, cvec) + end + + | genTest(testCode, jumpOn, targetLabel) = + ( + gencde (testCode, ToStack, NotEnd, loopAddr); + putBranchInstruction(if jumpOn then JumpTrue else JumpFalse, targetLabel, cvec); + decsp() (* conditional branch pops a value. *) + ) + val toElse = createLabel() and exitJump = createLabel() - val () = putBranchInstruction(JumpFalse, toElse, cvec) - val () = decsp() + val () = genTest(testCode, false, toElse) 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) + val () = 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); + val () = 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 6d0bb1f9..f5da39d7 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE.ML +++ b/mlsource/MLCompiler/CodeTree/CODETREE.ML @@ -1,606 +1,606 @@ (* 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 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 InlineAlways args, fn _ => raise InternalError "mkMacroProc: closure")) []) | 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 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 mkEqualTaggedWord (arg1, arg2) = Binary{oper=eqWord, arg1=arg1, arg2=arg2} 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 fun mkLoadOperation(oper, base, index) = - LoadOperation{kind=oper, address={base=base, index=SOME index, offset=0w0}} + LoadOperation{kind=oper, address={base=base, index=SOME index, offset=0}} 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} + StoreOperation{kind=oper, address={base=base, index=SOME index, offset=0}, 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} + sourceLeft={base=leftBase, index=SOME leftIndex, offset=0}, + destRight={base=rightBase, index=SOME rightIndex, offset=0}, 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)) (* 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. *) 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_SIMPLIFIER.sml b/mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml index abbbe4d2..2ea3c308 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml +++ b/mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml @@ -1,1752 +1,1774 @@ (* 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: { 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, 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" + val ffiSizeFloat: unit -> int = RunCall.rtsCallFast1 "PolySizeFloat" + and ffiSizeDouble: unit -> int = 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 + we have separate pre-built compilers for 32 and 64-bit. + Loads from C memory use signed offsets. Loads from ML memory never + have a negative offset and are limited by the maximum size of a cell + so can always be unsigned. *) + fun getMultiplier (LoadStoreMLWord _) = (Word.toInt RunCall.bytesPerWord, false (* unsigned *)) + | getMultiplier (LoadStoreMLByte _) = (1, false) + | getMultiplier LoadStoreC8 = (1, true (* signed *) ) + | getMultiplier LoadStoreC16 = (2, true (* signed *) ) + | getMultiplier LoadStoreC32 = (4, true (* signed *) ) + | getMultiplier LoadStoreC64 = (8, true (* signed *) ) + | getMultiplier LoadStoreCFloat = (ffiSizeFloat(), true (* signed *) ) + | getMultiplier LoadStoreCDouble = (ffiSizeDouble(), true (* signed *) ) + | getMultiplier LoadStoreUntaggedUnsigned = (Word.toInt RunCall.bytesPerWord, false (* unsigned *)) 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 + val wordOffset = Word.fromInt 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 + val wordOffset = Word.fromInt 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)), []) + else Constnt(toMachineWord(loadByte(addr, Word.fromInt 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 + if isMutable addr orelse not(isBytes addr) orelse offset <> 0 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) + BlockOpMove{isByteMove=false} => Word.toInt RunCall.bytesPerWord + | BlockOpMove{isByteMove=true} => 1 + | BlockOpEqualByte => 1 + | BlockOpCompareByte => 1 + val (genSrcAddress, RevList decSrcAddress) = simpAddress(sourceLeft, (multiplier, false), context) + val (genDstAddress, RevList decDstAddress) = simpAddress(destRight, (multiplier, false), 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 + if offset = Word.toInt 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) + makeMoves(offset+1) in - mkEnv(combinedDecs @ makeMoves 0w0, CodeZero (* unit result *)) + mkEnv(combinedDecs @ makeMoves 0, 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 + if offset = Word.toInt 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), + makeComparison(offset+1), CodeFalse) in - mkEnv(combinedDecs, makeComparison 0w0) + mkEnv(combinedDecs, makeComparison 0) 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=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, 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, 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 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 = if isNowInline = DontInline then newCode else REMOVE_REDUNDANT.cleanProc(newCode, [UseExport], LoadClosure, localCount) + (* 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. + The limit is set to 10 times the optimiser's limit because it seems that + otherwise significant functions are not inlined. *) + val stillInline = + case isNowInline of + SmallInline => + if evaluateInlining(cleanBody, List.length argTypes, maxInlineSize*10) <> TooBig + then SmallInline + else DontInline + | inl => inl + 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 = - if isInline = InlineAlways orelse - (isNowInline = SmallInline andalso - evaluateInlining(cleanBody, List.length argTypes, maxInlineSize) <> TooBig) + if stillInline <> DontInline 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, 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, 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 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, _) => 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, _, _, _, _, _, _) = (* 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. *) (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) = + | simpAddress({base, index=SOME index, offset: int}, (multiplier: int, isSigned), 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) + if isShort indexOffset + then + let + val indexOffsetW = toShort indexOffset + in + if indexOffsetW < 0w1000 orelse isSigned andalso indexOffsetW > ~ 0w1000 + then (NONE, offset + (if isSigned then Word.toIntX else Word.toInt)indexOffsetW * multiplier) + else (SOME genIndex, offset) + end 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{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(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/X86Code/X86CodetreeToICode.ML b/mlsource/MLCompiler/CodeTree/X86Code/X86CodetreeToICode.ML index 53ab1f6c..ca0b7eb3 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86CodetreeToICode.ML +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86CodetreeToICode.ML @@ -1,3995 +1,4017 @@ (* 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. 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 leng = Word.toInt(toShort l) val moveKind = if toShort l = nativeWordSize then moveNativeWord else Move32Bit val isLeftAligned = case sourceLeft of - {index=NONE, offset, ...} => offset mod leng = 0w0 + {index=NONE, offset:int, ...} => offset mod leng = 0 | _ => false val isRightAligned = case destRight of - {index=NONE, offset, ...} => offset mod leng = 0w0 + {index=NONE, offset: int, ...} => offset mod leng = 0 | _ => 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} + val memResult = {base=realBase, offset=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} + then {base=realBase, offset=offset-4, index=MemIndex4 indexReg, cache=NONE} + else {base=realBase, offset=offset-2, index=MemIndex2 indexReg, cache=NONE} in (codeLoadAddr @ codeIndex, [], memResult) end | codeAddressRev({base, index=NONE, offset}, _, context, tailCode) = let val (codeBase, baseReg) = codeToPRegRev(base, context, tailCode) - (* 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} + val memResult = {offset=offset, base=baseReg, index=memIndexOrObject, cache=NONE} in (codeBase, [], memResult) end and codeAddress(addr, isByte, context) = let val (code, untag, res) = codeAddressRev(addr, isByte, context, []) in (List.rev code, untag, res) end (* C-memory operations are slightly different. The base address is a LargeWord.word value. The index is a byte index so may have to be untagged. *) and codeCAddress({base, index=SOME index, offset}, 0w1, context) = let (* Byte address with index. The index needs to be untagged. *) - val untaggedBaseReg = newUReg() and indexReg1 = newUReg() + val 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}), - 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} + (* The index needs to untagged and, if necessary, sign-extended to the native word size. *) + val (untagCode, sxReg) = + if targetArch = ObjectId32Bit + then + let + val sReg1 = newUReg() and sReg2 = newUReg() + in + ([BlockSimple(SignExtend32To64{dest=sReg1, source=RegisterArgument indexReg}), + BlockSimple(UntagValue{dest=sReg2, source=sReg1, isSigned=true, cache=NONE, opSize=nativeWordOpSize})], sReg2) + end + else + let + val sReg = newUReg() + in + ([BlockSimple(UntagValue{dest=sReg, source=indexReg, isSigned=true, cache=NONE, opSize=nativeWordOpSize})], sReg) + end + val loadCode = [BlockSimple(LoadArgument{source=wordAt baseReg, dest=untaggedBaseReg, kind=moveNativeWord})] + val memResult = {base=untaggedBaseReg, offset=offset, index=MemIndex1 sxReg, cache=NONE} in - (codeBase @ codeIndex, untagCode, memResult) + (codeBase @ codeIndex, loadCode @ 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})] + (* The index is signed i.e. negative index values are legal. We don't have + to do anything special on the native code versions but on 32-in-64 we need + to sign extend. *) + val (untagCode, sxReg) = + if targetArch = ObjectId32Bit + then + let + val sReg = newUReg() + in + ([BlockSimple(SignExtend32To64{source=RegisterArgument indexReg, dest=sReg})], sReg) + end + else ([], indexReg) + val loadCode = [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} + 0w2 => {base=untaggedBaseReg, offset=offset-1, index=MemIndex1 sxReg, cache=NONE} + | 0w4 => {base=untaggedBaseReg, offset=offset-2, index=MemIndex2 sxReg, cache=NONE} + | 0w8 => {base=untaggedBaseReg, offset=offset-4, index=MemIndex4 sxReg, cache=NONE} | _ => raise InternalError "codeCAddress: unknown size" in - (codeBase @ codeIndex, untagCode, memResult) + (codeBase @ codeIndex, loadCode @ 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} + val memResult = {offset=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/DEBUGGERSIG.sml b/mlsource/MLCompiler/DEBUGGER.sig similarity index 98% rename from mlsource/MLCompiler/DEBUGGERSIG.sml rename to mlsource/MLCompiler/DEBUGGER.sig index eff36efd..d413b8c7 100644 --- a/mlsource/MLCompiler/DEBUGGERSIG.sml +++ b/mlsource/MLCompiler/DEBUGGER.sig @@ -1,105 +1,105 @@ (* Title: Source level debugger for Poly/ML Author: David Matthews - Copyright (c) David Matthews 2000, 2009, 2014-15 + Copyright (c) David Matthews 2000, 2009, 2014-15, 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 DEBUGGERSIG = +signature DEBUGGER = sig type types type values type machineWord type fixStatus type structVals type typeConstrSet type signatures type functors type locationProp type typeId type level type lexan type codeBinding type codetree type typeVarMap type environEntry type location = { file: string, startLine: FixedInt.int, startPosition: FixedInt.int, endLine: FixedInt.int, endPosition: FixedInt.int } val envTypeId: typeId -> environEntry type breakPoint = bool ref (* Functions to make debug entries for various values, types etc. *) type debuggerStatus val initialDebuggerStatus: debuggerStatus val makeValDebugEntries: values list * debuggerStatus * level * lexan * (int -> int) * typeVarMap -> codeBinding list * debuggerStatus val makeTypeConstrDebugEntries: typeConstrSet list * debuggerStatus * level * lexan * (int -> int) -> codeBinding list * debuggerStatus val makeStructDebugEntries: structVals list * debuggerStatus * level * lexan * (int->int) -> codeBinding list * debuggerStatus val makeTypeIdDebugEntries: typeId list * debuggerStatus * level * lexan * (int->int) -> codeBinding list * debuggerStatus val updateDebugLocation: debuggerStatus * location * lexan -> codeBinding list * debuggerStatus (* Create a local break point and check the global and local break points. *) val breakPointCode: breakPoint option ref * location * level * lexan * (int->int) -> codeBinding list (* Add debugging calls on entry and exit to a function. *) val wrapFunctionInDebug: (debuggerStatus -> codetree) * string * codetree * types * types * location * debuggerStatus * level * lexan * (int -> int) -> codetree (* Exported functions that appear in PolyML.DebuggerInterface. *) type debugState (* The run-time state. *) val makeValue: debugState -> string * types * locationProp list * machineWord -> values and makeException: debugState -> string * types * locationProp list * machineWord -> values and makeConstructor: debugState -> string * types * bool * int * locationProp list * machineWord -> values and makeAnonymousValue: debugState -> types * machineWord -> values val makeStructure: debugState -> string * signatures * locationProp list * machineWord -> structVals and makeTypeConstr: debugState -> typeConstrSet -> typeConstrSet val setOnEntry: (string * PolyML.location -> unit) option -> unit and setOnExit: (string * PolyML.location -> unit) option -> unit and setOnExitException: (string * PolyML.location -> exn -> unit) option -> unit and setOnBreakPoint: (PolyML.location * bool ref -> unit) option -> unit structure Sharing: sig type types = types type values = values type machineWord = machineWord type fixStatus = fixStatus type structVals = structVals type typeConstrSet = typeConstrSet type signatures = signatures type functors = functors type locationProp = locationProp type environEntry = environEntry type typeId = typeId type level = level type lexan = lexan type codeBinding = codeBinding type codetree = codetree type typeVarMap = typeVarMap type debuggerStatus = debuggerStatus end end; diff --git a/mlsource/MLCompiler/DEBUGGER_.sml b/mlsource/MLCompiler/DEBUGGER_.sml index 45e1c1f2..56ac83ca 100644 --- a/mlsource/MLCompiler/DEBUGGER_.sml +++ b/mlsource/MLCompiler/DEBUGGER_.sml @@ -1,589 +1,589 @@ (* Title: Source level debugger for Poly/ML Author: David Matthews - Copyright (c) David Matthews 2000, 2014, 2015 + Copyright (c) David Matthews 2000, 2014, 2015, 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 *) functor DEBUGGER_ ( structure STRUCTVALS : STRUCTVALSIG structure VALUEOPS : VALUEOPSSIG structure CODETREE : CODETREESIG structure TYPETREE: TYPETREESIG structure ADDRESS : AddressSig structure COPIER: COPIERSIG structure TYPEIDCODE: TYPEIDCODESIG structure LEX : LEXSIG structure DEBUG: DEBUGSIG structure UTILITIES : sig val splitString: string -> { first:string,second:string } end sharing STRUCTVALS.Sharing = VALUEOPS.Sharing = TYPETREE.Sharing = COPIER.Sharing = TYPEIDCODE.Sharing = CODETREE.Sharing = ADDRESS = LEX.Sharing ) -: DEBUGGERSIG +: DEBUGGER = struct open STRUCTVALS VALUEOPS CODETREE COPIER TYPETREE DEBUG (* The static environment contains these kinds of entries. *) datatype environEntry = EnvValue of string * types * locationProp list | EnvException of string * types * locationProp list | EnvVConstr of string * types * bool * int * locationProp list | EnvTypeid of { original: typeId, freeId: typeId } | EnvStructure of string * signatures * locationProp list | EnvTConstr of string * typeConstrSet | EnvStartFunction of string * location * types | EnvEndFunction of string * location * types local open ADDRESS in (* Entries in the thread data. The RTS allocates enough space for this. The first entry is 5 because earlier entries are used by Thread.Thread. *) val threadIdStack = mkConst(toMachineWord 0w5) (* The static/dynamic/location entries for calling fns *) and threadIdCurrentStatic = mkConst(toMachineWord 0w6) (* The static info for bindings i.e. name/type. *) and threadIdCurrentDynamic = mkConst(toMachineWord 0w7) (* Dynamic infor for bindings i.e. actual run-time value. *) and threadIdCurrentLocation = mkConst(toMachineWord 0w8) (* Location in code: line number/offset etc. *) (* Global function entries. These could be in storage allocated by the RTS. *) (* Specialised option type here. Because a function is always boxed this avoids the need for an extra level of indirection. *) datatype ('a, 'b) functionOpt = NoFunction | AFunction of 'a -> 'b val globalOnEntry = ref NoFunction and globalOnExit = ref NoFunction and globalOnExitExc = ref NoFunction and globalOnBreakPoint = ref NoFunction val onEntryCode = mkLoadOperation(LoadStoreMLWord{isImmutable=false}, mkConst(toMachineWord globalOnEntry), CodeZero) and onExitCode = mkLoadOperation(LoadStoreMLWord{isImmutable=false}, mkConst(toMachineWord globalOnExit), CodeZero) and onExitExcCode = mkLoadOperation(LoadStoreMLWord{isImmutable=false}, mkConst(toMachineWord globalOnExitExc), CodeZero) and onBreakPointCode = mkLoadOperation(LoadStoreMLWord{isImmutable=false}, mkConst(toMachineWord globalOnBreakPoint), CodeZero) (* We need to ensure that any break-point code preserves the state. It could be modified if we hit a break-point and run the interactive debugger with PolyML.Compiler.debug true. *) fun wrap (f:'a -> unit) (x: 'a) : unit = let val threadId: address = RunCall.unsafeCast(Thread.Thread.self()) val stack = loadWord(threadId, 0w5) and static = loadWord(threadId, 0w6) and dynamic = loadWord(threadId, 0w7) and location = loadWord(threadId, 0w8) fun restore () = ( assignWord(threadId, 0w5, stack); assignWord(threadId, 0w6, static); assignWord(threadId, 0w7, dynamic); assignWord(threadId, 0w8, location) ) in f x handle exn => (restore(); PolyML.Exception.reraise exn); restore() end fun setOnEntry NONE = globalOnEntry := NoFunction | setOnEntry (SOME(f: string * PolyML.location -> unit)) = globalOnEntry := AFunction (wrap f) and setOnExit NONE = globalOnExit := NoFunction | setOnExit (SOME(f: string * PolyML.location -> unit)) = globalOnExit := AFunction (wrap f) and setOnExitException NONE = globalOnExitExc := NoFunction | setOnExitException (SOME(f: string * PolyML.location -> exn -> unit)) = globalOnExitExc := AFunction (fn x => wrap (f x)) and setOnBreakPoint NONE = globalOnBreakPoint := NoFunction | setOnBreakPoint (SOME(f: PolyML.location * bool ref -> unit)) = globalOnBreakPoint := AFunction (wrap f) end (* When stopped at a break-point any Bound ids must be replaced by Free ids. We make new Free ids at this point. *) fun envTypeId (id as TypeId{ description, idKind = Bound{arity, ...}, ...}) = EnvTypeid { original = id, freeId = makeFreeId(arity, Global CodeZero, isEquality id, description) } | envTypeId id = EnvTypeid { original = id, freeId = id } fun searchEnvs match (staticEntry :: statics, dlist as dynamicEntry :: dynamics) = ( case (match (staticEntry, dynamicEntry), staticEntry) of (SOME result, _) => SOME result | (NONE, EnvTypeid _) => searchEnvs match (statics, dynamics) | (NONE, EnvVConstr _) => searchEnvs match (statics, dynamics) | (NONE, EnvValue _) => searchEnvs match (statics, dynamics) | (NONE, EnvException _) => searchEnvs match (statics, dynamics) | (NONE, EnvStructure _) => searchEnvs match (statics, dynamics) | (NONE, EnvStartFunction _) => searchEnvs match (statics, dynamics) | (NONE, EnvEndFunction _) => searchEnvs match (statics, dynamics) (* EnvTConstr doesn't have an entry in the dynamic list *) | (NONE, EnvTConstr _) => searchEnvs match (statics, dlist) ) | searchEnvs _ _ = NONE (* N.B. It is possible to have ([EnvTConstr ...], []) in the arguments so we can't treat that if either the static or dynamic list is nil and the other non-nil as an error. *) (* Exported functions that appear in PolyML.DebuggerInterface. *) type debugState = environEntry list * machineWord list * location fun searchType ((clist, rlist, _): debugState) typeid = let fun match (EnvTypeid{original, freeId }, valu) = if sameTypeId(original, typeid) then case freeId of TypeId{description, idKind as Free _, ...} => (* This can occur for datatypes inside functions. *) SOME(TypeId { access= Global(mkConst valu), idKind=idKind, description=description}) | _ => raise Misc.InternalError "searchType: TypeFunction" else NONE | match _ = NONE in case (searchEnvs match (clist, rlist), typeid) of (SOME t, _) => t | (NONE, TypeId{description, idKind = TypeFn typeFn, ...}) => makeTypeFunction(description, typeFn) | (NONE, typeid as TypeId{description, idKind = Bound{arity, ...}, ...}) => (* The type ID is missing. Make a new temporary ID. *) makeFreeId(arity, Global(TYPEIDCODE.codeForUniqueId()), isEquality typeid, description) | (NONE, typeid as TypeId{description, idKind = Free{arity, ...}, ...}) => (* The type ID is missing. Make a new temporary ID. *) makeFreeId(arity, Global(TYPEIDCODE.codeForUniqueId()), isEquality typeid, description) end (* Values must be copied so that compile-time type IDs are replaced by their run-time values. *) fun makeTypeConstr (state: debugState) (TypeConstrSet(tcons, (*tcConstructors*) _)) = let val typeID = searchType state (tcIdentifier tcons) val newTypeCons = makeTypeConstructor(tcName tcons, tcTypeVars tcons, typeID, tcLocations tcons) val newValConstrs = (*map copyAConstructor tcConstructors*) [] in TypeConstrSet(newTypeCons, newValConstrs) end (* When creating a structure we have to add a type map that will look up the bound Ids. *) fun makeStructure state (name, rSig, locations, valu) = let local val Signatures{ name = sigName, tab, typeIdMap, firstBoundIndex, locations=sigLocs, ... } = rSig fun getFreeId n = searchType state (makeBoundId(0 (* ??? *), Global CodeZero, n, false, false, basisDescription "")) in val newSig = makeSignature(sigName, tab, firstBoundIndex, sigLocs, composeMaps(typeIdMap, getFreeId), []) end in makeGlobalStruct (name, newSig, mkConst valu, locations) end local fun runTimeType (state: debugState) ty = let fun copyId(TypeId{idKind=Free _, access=Global _ , ...}) = NONE (* Use original *) | copyId id = SOME(searchType state id) in copyType (ty, fn x => x, fn tcon => copyTypeConstr (tcon, copyId, fn x => x, fn s => s)) end (* Return the value as a constant. In almost all cases we just return the value. The exception is when we have an equality type variable. In that case we must return a function because we will use applyToInstanceType to apply it to the instance type(s). N.B. This is probably because of the way that allowGeneralisation side-effects the type variables resulting in local type variables becoming generic. *) fun getValue(valu, ty) = let val filterTypeVars = List.filter (fn tv => not TYPEIDCODE.justForEqualityTypes orelse tvEquality tv) val polyVars = filterTypeVars (getPolyTypeVars(ty, fn _ => NONE)) val nPolyVars = List.length polyVars in if nPolyVars = 0 then mkConst valu else mkInlproc(mkConst valu, nPolyVars, "poly", [], 0) end in fun makeValue state (name, ty, location, valu) = mkGvar(name, runTimeType state ty, getValue(valu, ty), location) and makeException state (name, ty, location, valu) = mkGex(name, runTimeType state ty, getValue(valu, ty), location) and makeConstructor state (name, ty, nullary, count, location, valu) = makeValueConstr(name, runTimeType state ty, nullary, count, Global(getValue(valu, ty)), location) and makeAnonymousValue state (ty, valu) = makeValue state ("", ty, [], valu) end (* Functions to make the debug entries. These are needed both in CODEGEN_PARSETREE for the core language and STRUCTURES for the module language. *) (* Debugger status within the compiler. During compilation the environment is built up as a pair consisting of the static data and code to compute the run-time data. The static data, a constant at run-time, holds the variable names and types. The run-time code, when executed at run-time, returns the address of a list holding the actual values of the variables. "dynEnv" is always a "load" from a (codetree) variable. It has type level->codetree rather than codetree because the next reference could be inside an inner function. "lastLoc" is the last location that was *) type debuggerStatus = {staticEnv: environEntry list, dynEnv: level->codetree, lastLoc: location} val initialDebuggerStatus: debuggerStatus = {staticEnv = [], dynEnv = fn _ => CodeZero, lastLoc = LEX.nullLocation } (* Set the current state in the thread data. *) fun updateState (level, mkAddr) (decs, debugEnv: debuggerStatus as {staticEnv, dynEnv, ...}) = let open ADDRESS val threadId = multipleUses(getCurrentThreadId, fn () => mkAddr 1, level) fun assignItem(offset, value) = mkNullDec(mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, offset, value)) val newDecs = decs @ #dec threadId @ [assignItem(threadIdCurrentStatic, mkConst(toMachineWord staticEnv)), assignItem(threadIdCurrentDynamic, dynEnv level)] in (newDecs, debugEnv) end fun makeValDebugEntries (vars: values list, debugEnv: debuggerStatus, level, lex, mkAddr, typeVarMap) = if getParameter debugTag (LEX.debugParams lex) then let fun loadVar (var, (decs, {staticEnv, dynEnv, lastLoc, ...})) = let val loadVal = codeVal (var, level, typeVarMap, [], lex, LEX.nullLocation) val newEnv = (* Create a new entry in the environment. *) mkDatatype [ loadVal (* Value. *), dynEnv level ] val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) val ctEntry = case var of Value{class=Exception, name, typeOf, locations, ...} => EnvException(name, typeOf, locations) | Value{class=Constructor{nullary, ofConstrs, ...}, name, typeOf, locations, ...} => EnvVConstr(name, typeOf, nullary, ofConstrs, locations) | Value{name, typeOf, locations, ...} => EnvValue(name, typeOf, locations) in (decs @ dec, {staticEnv = ctEntry :: staticEnv, dynEnv = load, lastLoc = lastLoc}) end in updateState (level, mkAddr) (List.foldl loadVar ([], debugEnv) vars) end else ([], debugEnv) fun makeTypeConstrDebugEntries(typeCons, debugEnv, level, lex, mkAddr) = if not (getParameter debugTag (LEX.debugParams lex)) then ([], debugEnv) else let fun foldIds(tc :: tcs, {staticEnv, dynEnv, lastLoc, ...}) = let val cons = tsConstr tc val id = tcIdentifier cons val {second = typeName, ...} = UTILITIES.splitString(tcName cons) in if tcIsAbbreviation (tsConstr tc) then foldIds(tcs, {staticEnv=EnvTConstr(typeName, tc) :: staticEnv, dynEnv=dynEnv, lastLoc = lastLoc}) else let (* This code will build a cons cell containing the run-time value associated with the type Id as the hd and the rest of the run-time environment as the tl. *) val loadTypeId = TYPEIDCODE.codeId(id, level) val newEnv = mkDatatype [ loadTypeId, dynEnv level ] val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) (* Make an entry for the type constructor itself as well as the new type id. The type Id is used both for the type constructor and also for any values of the type. *) val (decs, newEnv) = foldIds(tcs, {staticEnv=EnvTConstr(typeName, tc) :: envTypeId id :: staticEnv, dynEnv=load, lastLoc = lastLoc}) in (dec @ decs, newEnv) end end | foldIds([], debugEnv) = ([], debugEnv) in updateState (level, mkAddr) (foldIds(typeCons, debugEnv)) end fun makeStructDebugEntries (strs: structVals list, debugEnv, level, lex, mkAddr) = if getParameter debugTag (LEX.debugParams lex) then let fun loadStruct (str as Struct { name, signat, locations, ...}, (decs, {staticEnv, dynEnv, lastLoc, ...})) = let val loadStruct = codeStruct (str, level) val newEnv = mkDatatype [ loadStruct (* Structure. *), dynEnv level ] val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) val ctEntry = EnvStructure(name, signat, locations) in (decs @ dec, {staticEnv=ctEntry :: staticEnv, dynEnv=load, lastLoc = lastLoc}) end in updateState (level, mkAddr) (List.foldl loadStruct ([], debugEnv) strs) end else ([], debugEnv) (* Create debug entries for typeIDs. The idea is that if we stop in the debugger we can access the type ID, particularly for printing values of the type. "envTypeId" creates a free id for each bound id but the print and equality functions are extracted when we are stopped in the debugger. *) fun makeTypeIdDebugEntries(typeIds, debugEnv, level, lex, mkAddr) = if not (getParameter debugTag (LEX.debugParams lex)) then ([], debugEnv) else let fun foldIds(id :: ids, {staticEnv, dynEnv, lastLoc, ...}) = let (* This code will build a cons cell containing the run-time value associated with the type Id as the hd and the rest of the run-time environment as the tl. *) val loadTypeId = case id of TypeId { access = Formal addr, ... } => (* If we are processing functor arguments we will have a Formal here. *) mkInd(addr, mkLoadArgument 0) | _ => TYPEIDCODE.codeId(id, level) val newEnv = mkDatatype [ loadTypeId, dynEnv level ] val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) val (decs, newEnv) = foldIds(ids, {staticEnv=envTypeId id :: staticEnv, dynEnv=load, lastLoc = lastLoc}) in (dec @ decs, newEnv) end | foldIds([], debugEnv) = ([], debugEnv) in updateState (level, mkAddr) (foldIds(typeIds, debugEnv)) end (* Update the location info in the thread data if we want debugging info. If the location has not changed don't do anything. Whether it has changed could depend on whether we're only counting line numbers or whether we have more precise location info with the IDE. *) fun updateDebugLocation(debuggerStatus as {staticEnv, dynEnv, lastLoc, ...}, location, lex) = if not (getParameter debugTag (LEX.debugParams lex)) orelse lastLoc = location then ([], debuggerStatus) else let open ADDRESS val setLocation = mkStoreOperation(LoadStoreMLWord{isImmutable=false}, getCurrentThreadId, threadIdCurrentLocation, mkConst(toMachineWord location)) in ([mkNullDec setLocation], {staticEnv=staticEnv, dynEnv=dynEnv, lastLoc=location}) end (* Add debugging calls on entry and exit to a function. *) fun wrapFunctionInDebug(codeBody: debuggerStatus -> codetree, name: string, argCode, argType, resType: types, location, entryEnv: debuggerStatus, level, lex, mkAddr) = if not (getParameter debugTag (LEX.debugParams lex)) then codeBody entryEnv (* Code-generate the body without any wrapping. *) else let open ADDRESS val functionName = name (* TODO: munge this to get the root. *) fun addStartExitEntry({staticEnv, dynEnv, lastLoc, ...}, code, ty, startExit) = let val newEnv = mkDatatype [ code, dynEnv level ] val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) val ctEntry = startExit(functionName, location, ty) in (dec, {staticEnv=ctEntry :: staticEnv, dynEnv=load, lastLoc = lastLoc}) end (* All the "on" functions take this as an argument. *) val onArgs = [mkConst(toMachineWord(functionName, location))] val threadId = multipleUses(getCurrentThreadId, fn () => mkAddr 1, level) fun loadIdEntry offset = multipleUses(mkLoadOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, offset), fn () => mkAddr 1, level) val currStatic = loadIdEntry threadIdCurrentStatic and currDynamic = loadIdEntry threadIdCurrentDynamic and currLocation = loadIdEntry threadIdCurrentLocation and currStack = loadIdEntry threadIdStack (* At the start of the function: 1. Push the previous state to the stack. 2. Create a debugging entry for the arguments 3. Update the state to the state on entry, including the args 4. Call the global onEntry function if it's set 5. Call the local onEntry function if it's set *) (* Save the previous state. *) val assignStack = mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, threadIdStack, mkDatatype[ #load currStatic level, #load currDynamic level, #load currLocation level, #load currStack level]) val prefixCode = #dec threadId @ #dec currStatic @ #dec currDynamic @ #dec currLocation @ #dec currStack @ [mkNullDec assignStack] (* Make a debugging entry for the arguments. This needs to be set before we call onEntry so we can produce tracing info. It also needs to be passed to the body of the function so that it is included in the debug status of the rest of the body. *) local val {staticEnv, dynEnv, lastLoc, ...} = entryEnv val newEnv = mkDatatype [ argCode, dynEnv level ] val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) val ctEntry = EnvStartFunction(functionName, location, argType) in val debuggerDecs = dec val bodyDebugEnv = {staticEnv = ctEntry :: staticEnv, dynEnv = load, lastLoc = lastLoc} end local val {staticEnv, dynEnv, ...} = bodyDebugEnv val assignStatic = mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, threadIdCurrentStatic, mkConst(toMachineWord staticEnv)) val assignDynamic = mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, threadIdCurrentDynamic, dynEnv level) val assignLocation = mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, threadIdCurrentLocation, mkConst(toMachineWord location)) val onEntryFn = multipleUses(onEntryCode, fn () => mkAddr 1, level) val optCallOnEntry = mkIf(mkTagTest(#load onEntryFn level, 0w0, 0w0), CodeZero, mkEval(#load onEntryFn level, onArgs)) in val entryCode = debuggerDecs @ [mkNullDec assignStatic, mkNullDec assignDynamic, mkNullDec assignLocation] @ #dec onEntryFn @ [mkNullDec optCallOnEntry] end (* Restore the state. Used both if the function returns normally or if it raises an exception. We use the old state rather than popping the stack because that is more reliable if we have an asynchronous exception. *) local (* Set the entry in the thread vector to an entry from the top-of-stack. *) fun restoreEntry(offset, value) = mkNullDec( mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, offset, value)) in val restoreState = [restoreEntry(threadIdCurrentStatic, #load currStatic level), restoreEntry(threadIdCurrentDynamic, #load currDynamic level), restoreEntry(threadIdCurrentLocation, #load currLocation level), restoreEntry(threadIdStack, #load currStack level)] end local (* If an exception is raised we need to call the onExitException entry, restore the state and reraise the exception. *) (* There are potential race conditions here if we have asynchronous exceptions. *) val exPacketAddr = mkAddr 1 val onExitExcFn = multipleUses(onExitExcCode, fn () => mkAddr 1, level) (* OnExitException has an extra curried argument - the exception packet. *) val optCallOnExitExc = mkIf(mkTagTest(#load onExitExcFn level, 0w0, 0w0), CodeZero, mkEval(mkEval(#load onExitExcFn level, onArgs), [mkLoadLocal exPacketAddr])) in val exPacketAddr = exPacketAddr val exceptionCase = mkEnv(#dec onExitExcFn @ [mkNullDec optCallOnExitExc] @ restoreState, mkRaise(mkLoadLocal exPacketAddr)) end (* Code for the body and the exception. *) val bodyCode = multipleUses(mkHandle(codeBody bodyDebugEnv, exceptionCase, exPacketAddr), fn () => mkAddr 1, level) (* Code for normal exit. *) local val endFn = addStartExitEntry(entryEnv, #load bodyCode level, resType, EnvEndFunction) val (rtEnvDec, _) = updateState (level, mkAddr) endFn val onExitFn = multipleUses(onExitCode, fn () => mkAddr 1, level) val optCallOnExit = mkIf(mkTagTest(#load onExitFn level, 0w0, 0w0), CodeZero, mkEval(#load onExitFn level, onArgs)) in val exitCode = rtEnvDec @ #dec onExitFn @ [mkNullDec optCallOnExit] end in mkEnv(prefixCode @ entryCode @ #dec bodyCode @ exitCode @ restoreState, #load bodyCode level) end type breakPoint = bool ref (* Create a local break point and check the global and local break points. *) fun breakPointCode(breakPoint, location, level, lex, mkAddr) = if not (getParameter debugTag (LEX.debugParams lex)) then [] else let open ADDRESS (* Create a new local breakpoint and assign it to the ref. It is possible for the ref to be already assigned a local breakpoint value if we are compiling a match. In that case the same expression may be code-generated more than once but we only want one local break-point. *) val localBreakPoint = case breakPoint of ref (SOME bpt) => bpt | r as ref NONE => let val b = ref false in r := SOME b; b end; (* Call the breakpoint function if it's defined. *) val globalBpt = multipleUses(onBreakPointCode, fn () => mkAddr 1, level) val testCode = mkIf( mkNot(mkTagTest(#load globalBpt level, 0w0, 0w0)), mkEval(#load globalBpt level, [mkTuple[mkConst(toMachineWord location), mkConst(toMachineWord localBreakPoint)]]), CodeZero ) in #dec globalBpt @ [mkNullDec testCode] end structure Sharing = struct type types = types type values = values type machineWord = machineWord type fixStatus = fixStatus type structVals = structVals type typeConstrSet = typeConstrSet type signatures = signatures type functors = functors type locationProp = locationProp type environEntry = environEntry type typeId = typeId type level = level type lexan = lexan type codeBinding = codeBinding type codetree = codetree type typeVarMap = typeVarMap type debuggerStatus = debuggerStatus end end; diff --git a/mlsource/MLCompiler/INITIALISE_.ML b/mlsource/MLCompiler/INITIALISE_.ML index 8c8baa33..84275b57 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-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 DEBUGGER : DEBUGGER 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 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=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? *) 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. *) 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. *) 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/ParseTree/BASE_PARSE_TREE.sml b/mlsource/MLCompiler/ParseTree/BASE_PARSE_TREE.sml index 037fd109..1558ee69 100644 --- a/mlsource/MLCompiler/ParseTree/BASE_PARSE_TREE.sml +++ b/mlsource/MLCompiler/ParseTree/BASE_PARSE_TREE.sml @@ -1,333 +1,333 @@ (* Copyright (c) 2013-2016 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Derived from the original parse-tree Copyright (c) 2000 Cambridge University Technical Services Limited Further development: Copyright (c) 2000-13 David C.J. Matthews Title: Parse Tree Structure and Operations. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) functor BASE_PARSE_TREE ( structure STRUCTVALS : STRUCTVALSIG structure TYPETREE : TYPETREESIG - structure DEBUGGER : DEBUGGERSIG + structure DEBUGGER : DEBUGGER sharing STRUCTVALS.Sharing = TYPETREE.Sharing = DEBUGGER.Sharing ): BaseParseTreeSig = struct open STRUCTVALS open TYPETREE type breakPoint = DEBUGGER.breakPoint datatype parsetree = Ident of (* An identifier is just a name. In the second pass it is associated with a particular declaration and the type is assigned into the type field. The type of this identifier is needed to deal with overloaded operators. If we have an occurence of ``='', say, the type of the value will be 'a * 'a -> bool but the type of a particular occurence, i.e. the type of the identifier must be int * int -> bool, say, after all the unification has been done. *) { name: string, expType: types ref, value: values ref, location: location, possible: (unit -> string list) ref (* Used with the IDE. *) } | Literal of (* Literal constants may be overloaded on more than one type. The types are specified by installing appropriate conversion functions: convInt, convReal, convChar, convString and convWord. *) { converter: values, expType: types ref, literal: string, location: location } | Applic of (* Function application *) { f: parsetree, arg: parsetree, location: location, isInfix: bool, expType: types ref } | Cond of (* Conditional *) { test: parsetree, thenpt: parsetree, elsept: parsetree, location: location, thenBreak: breakPoint option ref, elseBreak: breakPoint option ref } | TupleTree of { fields: parsetree list, location: location, expType: types ref } | ValDeclaration of { dec: valbind list, explicit: {lookup: string -> typeVarForm option, apply: (string * typeVarForm -> unit) -> unit }, implicit: {lookup: string -> typeVarForm option, apply: (string * typeVarForm -> unit) -> unit }, location: location } | FunDeclaration of { dec: fvalbind list, explicit: {lookup: string -> typeVarForm option, apply: (string * typeVarForm -> unit) -> unit }, implicit: {lookup: string -> typeVarForm option, apply: (string * typeVarForm -> unit) -> unit }, location: location } | OpenDec of (* Open a structure. The variables, structures and types are just needed if debugging information is being generated. *) { decs: structureIdentForm list, variables: values list ref, structures: structVals list ref, typeconstrs: typeConstrSet list ref, location: location } | Constraint of (* Constraint (explicit type given) *) (* A constraint has a value and a type. The actual type, will, however be the unification of these two and not necessarily the given type. *) { value: parsetree, given: typeParsetree, location: location } | Layered of (* Layered pattern. Equivalent to an ordinary pattern except that the variable is given the name of the object which is to be matched. *) { var: parsetree, pattern: parsetree, location: location } | Fn of { matches: matchtree list, location: location, expType: types ref } | Localdec of (* Local dec in dec and let dec in exp. *) { decs: (parsetree * breakPoint option ref) list, body: (parsetree * breakPoint option ref) list, isLocal: bool, varsInBody: values list ref, (* Variables in the in..dec part of a local declaration. *) location: location } | TypeDeclaration of typebind list * location | AbsDatatypeDeclaration of (* Datatype and Abstract Type declarations *) { isAbsType: bool, typelist: datatypebind list, withtypes: typebind list, declist: (parsetree * breakPoint option ref) list, location: location, equalityStatus: bool list ref } | DatatypeReplication of { newType: string, oldType: string, oldLoc: location, newLoc: location, location: location } | ExpSeq of (parsetree * breakPoint option ref) list * location | Directive of (* Directives are infix, infixr and nonfix. They are processed by the parser itself and only appear in the parse tree for completeness. *) { tlist: string list, fix: infixity, location: location } | ExDeclaration of exbind list * location | Raise of parsetree * location | HandleTree of (* Execute an expression and catch any exceptions. *) { exp: parsetree, hrules: matchtree list, location: location, listLocation: location } | While of (* Ordinary while-loop *) { test: parsetree, body: parsetree, location: location, breakPoint: breakPoint option ref } | Case of (* Case-statement *) { test: parsetree, match: matchtree list, location: location, listLocation: location, expType: types ref } | Andalso of { first: parsetree, second: parsetree, location: location } | Orelse of { first: parsetree, second: parsetree, location: location } | Labelled of (* Labelled record & the entry in the list. "frozen" is false if it's a pattern with "...". *) { recList: labelRecEntry list, frozen: bool, expType: types ref, location: location } | Selector of { name: string, labType: types, typeof: types, location: location } | List of { elements: parsetree list, location: location, expType: types ref } | EmptyTree | WildCard of location | Unit of location | Parenthesised of parsetree * location and valbind = (* Value bindings.*) ValBind of (* Consists of a declaration part (pattern) and an expression. *) { dec: parsetree, exp: parsetree, line: location, isRecursive: bool, variables: values list ref (* list of variables declared and their poly vars *) } and fvalbind = (* Function binding *) (* `Fun' bindings *) (* A function binding is a list of clauses, each of which uses a valBinding to hold the list of patterns and the corresponding function body. The second pass extracts the function variable and the number of patterns in each clause. It checks that they are the same in each clause. *) FValBind of { clauses: fvalclause list, numOfPatts: int ref, functVar: values ref, argType: types ref, resultType: types ref, location: location } and fvalclause = (* Clause within a function binding. *) FValClause of { dec: funpattern, exp: parsetree, line: location, breakPoint: breakPoint option ref } and typebind = (* Non-generative type binding *) TypeBind of { name: string, typeVars: typeVarForm list, decType: typeParsetree option, isEqtype: bool, (* True if this was an eqtype in a signature. *) tcon: typeConstrSet ref, nameLoc: location, fullLoc: location } and datatypebind = (* Generative type binding *) DatatypeBind of { name: string, typeVars: typeVarForm list, constrs: valueConstr list, tcon: typeConstrSet ref, nameLoc: location, fullLoc: location } and exbind = (* An exception declaration. It has a name and optionally a previous exception and a type. *) ExBind of { name: string, previous: parsetree, ofType: typeParsetree option, value: values ref, nameLoc: location, fullLoc: location } and matchtree = (* A match is a pattern and an expression. If the pattern matches then the expression is evaluated in the environment of the pattern. *) MatchTree of { vars: parsetree, exp: parsetree, location: location, argType: types ref, resType: types ref, breakPoint: breakPoint option ref } (* Name of a structure. Used only in an ``open'' declaration. *) withtype structureIdentForm = { name: string, value: structVals option ref, location: location } (* An entry in a label record in an expression or a pattern. *) and labelRecEntry = { name: string, nameLoc: location, valOrPat: parsetree, fullLocation: location, expType: types ref } and funpattern = (* The declaration part of a fun binding. *) { ident: { name: string, expType: types ref, location: location }, isInfix: bool, args: parsetree list, constraint: typeParsetree option } and valueConstr = {constrName: string, constrArg: typeParsetree option, idLocn: location, constrVal: values ref} structure Sharing = struct type types = types and typeVarForm = typeVarForm and typeConstrSet = typeConstrSet and values = values and infixity = infixity and structVals = structVals and typeParsetree = typeParsetree and parsetree = parsetree and valbind = valbind and fvalbind = fvalbind and fvalclause = fvalclause and typebind = typebind and datatypebind = datatypebind and exbind = exbind and matchtree = matchtree end end; diff --git a/mlsource/MLCompiler/ParseTree/CODEGEN_PARSETREE.sml b/mlsource/MLCompiler/ParseTree/CODEGEN_PARSETREE.sml index b81924f9..f0d527be 100644 --- a/mlsource/MLCompiler/ParseTree/CODEGEN_PARSETREE.sml +++ b/mlsource/MLCompiler/ParseTree/CODEGEN_PARSETREE.sml @@ -1,1740 +1,1740 @@ (* Copyright (c) 2013-2015 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Derived from the original parse-tree Copyright (c) 2000 Cambridge University Technical Services Limited Further development: Copyright (c) 2000-13 David C.J. Matthews Title: Parse Tree Structure and Operations. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) functor CODEGEN_PARSETREE ( structure BASEPARSETREE : BaseParseTreeSig structure PRINTTREE: PrintParsetreeSig structure EXPORTTREE: ExportParsetreeSig structure MATCHCOMPILER: MatchCompilerSig structure LEX : LEXSIG structure CODETREE : CODETREESIG - structure DEBUGGER : DEBUGGERSIG + structure DEBUGGER : DEBUGGER structure TYPETREE : TYPETREESIG structure TYPEIDCODE: TYPEIDCODESIG structure STRUCTVALS : STRUCTVALSIG structure VALUEOPS : VALUEOPSSIG structure DATATYPEREP: DATATYPEREPSIG structure DEBUG: DEBUGSIG structure MISC : sig (* These are handled in the compiler *) exception Conversion of string (* string to int conversion failure *) (* This isn't handled at all (except generically) *) exception InternalError of string (* compiler error *) end structure ADDRESS : AddressSig sharing BASEPARSETREE.Sharing = PRINTTREE.Sharing = EXPORTTREE.Sharing = MATCHCOMPILER.Sharing = LEX.Sharing = CODETREE.Sharing = DEBUGGER.Sharing = TYPETREE.Sharing = TYPEIDCODE.Sharing = STRUCTVALS.Sharing = VALUEOPS.Sharing = DATATYPEREP.Sharing = ADDRESS ): CodegenParsetreeSig = struct open BASEPARSETREE open PRINTTREE open EXPORTTREE open MATCHCOMPILER open CODETREE open TYPEIDCODE open LEX open TYPETREE open DEBUG open STRUCTVALS open VALUEOPS open MISC open DATATYPEREP open TypeVarMap open DEBUGGER datatype environEntry = datatype DEBUGGER.environEntry (* To simplify passing the context it is wrapped up in this type. *) type cgContext = { decName: string, debugEnv: debuggerStatus, mkAddr: int->int, level: level, typeVarMap: typeVarMap, lex: lexan, lastDebugLine: int ref, isOuterLevel: bool (* Used only to decide if we need to report non-exhaustive matches. *) } fun repDecName decName ({debugEnv, mkAddr, level, typeVarMap, lex, lastDebugLine, isOuterLevel, ...}: cgContext) = { debugEnv=debugEnv, mkAddr=mkAddr, level=level, typeVarMap=typeVarMap, decName=decName, lex=lex, lastDebugLine=lastDebugLine, isOuterLevel = isOuterLevel}: cgContext and repDebugEnv debugEnv ({decName, mkAddr, level, typeVarMap, lex, lastDebugLine, isOuterLevel, ...}: cgContext) = { debugEnv=debugEnv, mkAddr=mkAddr, level=level, typeVarMap=typeVarMap, decName=decName, lex=lex, lastDebugLine=lastDebugLine, isOuterLevel = isOuterLevel}: cgContext and repTypeVarMap typeVarMap ({decName, debugEnv, mkAddr, level, lex, lastDebugLine, isOuterLevel, ...}: cgContext) = { debugEnv=debugEnv, mkAddr=mkAddr, level=level, typeVarMap=typeVarMap, decName=decName, lex=lex, lastDebugLine=lastDebugLine, isOuterLevel = isOuterLevel}: cgContext (* Create a new level. Sets isOuterLevel to false. *) and repNewLevel(decName, mkAddr, level) ({debugEnv, lex, lastDebugLine, typeVarMap, ...}: cgContext) = { debugEnv=debugEnv, mkAddr=mkAddr, level=level, typeVarMap=typeVarMap, decName=decName, lex=lex, lastDebugLine=lastDebugLine, isOuterLevel = false}: cgContext (* Try this pipeline function *) infix |> fun a |> f = f a val singleArg = mkLoadArgument 0 (* Make a tuple out of a set of arguments or return the single argument if there is just one. *) fun mkArgTuple(from, nTuple) = if nTuple = 1 (* "tuple" is a singleton *) then mkLoadArgument from else if nTuple <= 0 then raise InternalError "mkArgTuple" else mkTuple(List.tabulate(nTuple, fn n => mkLoadArgument(n+from))) (* Load args by selecting from a tuple. *) fun loadArgsFromTuple([t], arg) = [(arg, t)](* "tuple" is a singleton *) | loadArgsFromTuple(types, arg) = ListPair.zip(List.tabulate(List.length types, fn num => mkInd (num, arg)), types) (* Return the argument/result type which is currently just floating point or everything else. *) fun getCodeArgType t = case isFloatingPt t of NONE => GeneralType | SOME FloatDouble => DoubleFloatType | SOME FloatSingle => SingleFloatType (* tupleWidth returns the width of a tuple or record or 1 if it isn't one. It is used to detect both argument tuples and results. When used for arguments the idea is that frequently a tuple is used as a way of passing multiple arguments and these can be passed on the stack. When used for results the idea is to create the result tuple on the stack and avoid garbage collector and allocator time. If we could tell that the caller was simply going to explode it we would gain but if the caller needed a tuple on the heap we wouldn't. We wouldn't actually lose if we were going to create a tuple and return it but we would lose if we exploded a tuple here and then created a new one in the caller. This version of the code assumes that if we create a tuple on one branch we're going to create one on others which may not be correct. *) (* This now returns the argument type for each entry so returns a list rather than a number. *) fun tupleWidth(TupleTree{expType=ref expType, ...}) = recordFieldMap getCodeArgType expType | tupleWidth(Labelled{expType=ref expType, ...}) = if recordNotFrozen expType (* An error, but reported elsewhere. *) then [GeneralType] (* Safe enough *) else recordFieldMap getCodeArgType expType | tupleWidth(Cond{thenpt, elsept, ...}) = ( case tupleWidth thenpt of [_] => tupleWidth elsept | w => w ) | tupleWidth(Constraint{value, ...}) = tupleWidth value | tupleWidth(HandleTree{exp, ...}) = (* Look only at the expression and ignore the handlers on the, possibly erroneous, assumption that they won't normally be executed. *) tupleWidth exp | tupleWidth(Localdec{body=[], ...}) = raise InternalError "tupleWidth: empty localdec" | tupleWidth(Localdec{body, ...}) = (* We are only interested in the last expression. *) tupleWidth(#1 (List.last body)) | tupleWidth(Case{match, ...}) = let fun getWidth(MatchTree{exp, ...}) = tupleWidth exp in List.foldl(fn(v, [_]) => getWidth v | (_, s) => s) [GeneralType] match end | tupleWidth(Parenthesised(p, _)) = tupleWidth p | tupleWidth(ExpSeq(p, _)) = tupleWidth(#1 (List.last p)) | tupleWidth(Ident{ expType=ref expType, ...}) = [getCodeArgType expType] | tupleWidth(Literal{ expType=ref expType, ...}) = [getCodeArgType expType] | tupleWidth(Applic{ expType=ref expType, ...}) = [getCodeArgType expType] | tupleWidth _ = [GeneralType] (* Start of the code-generator itself. *) (* Report unreferenced identifiers. *) fun reportUnreferencedValue lex (Value{name, references=SOME{exportedRef=ref false, localRef=ref nil, ...}, locations, ...}) = let fun getDeclLoc (DeclaredAt loc :: _) = loc | getDeclLoc (_ :: locs) = getDeclLoc locs | getDeclLoc [] = nullLocation (* Shouldn't happen. *) in warningMessage(lex, getDeclLoc locations, "Value identifier ("^name^") has not been referenced.") end | reportUnreferencedValue _ _ = () (* Process a list of possibly mutually recursive functions and identify those that are really referenced. *) fun reportUnreferencedValues(valList, lex) = let fun checkRefs valList = let fun unReferenced(Value{references=SOME{exportedRef=ref false, localRef=ref nil, ...}, ...}) = true | unReferenced _ = false val (unrefed, refed) = List.partition unReferenced valList fun update(Value{references=SOME{localRef, recursiveRef, ...}, ...}, changed) = let (* If it is referred to by a referenced function it is referenced. *) fun inReferenced(_, refName) = List.exists (fn Value{name, ...} => name=refName) refed val (present, absent) = List.partition inReferenced (!recursiveRef) in if null present then changed else ( localRef := List.map #1 present @ ! localRef; recursiveRef := absent; true ) end | update(_, changed) = changed in (* Repeat until there's no change. *) if List.foldl update false unrefed then checkRefs unrefed else () end in checkRefs valList; List.app (reportUnreferencedValue lex) valList end fun makeDebugEntries (vars: values list, {debugEnv, level, typeVarMap, lex, mkAddr, ...}: cgContext) = let val (code, newDebug) = DEBUGGER.makeValDebugEntries(vars, debugEnv, level, lex, mkAddr, typeVarMap) in (code, newDebug) end (* Add a breakpoint if debugging is enabled. The bpt argument is set in the parsetree so that it can be found by the IDE. *) fun addBreakPointCall(bpt, location, {mkAddr, level, lex, debugEnv, ...}) = let open DEBUGGER val (lineCode, newStatus) = updateDebugLocation(debugEnv, location, lex) val code = breakPointCode(bpt, location, level, lex, mkAddr) in (lineCode @ code, newStatus) end (* In order to build a call stack in the debugger we need to know about function entry and exit. *) fun wrapFunctionInDebug(codeBody, name, argCode, argType, restype, location, {debugEnv, mkAddr, level, lex, ...}) = DEBUGGER.wrapFunctionInDebug(codeBody, name, argCode, argType, restype, location, debugEnv, level, lex, mkAddr) (* Create an entry in the static environment for the function. *) (* fun debugFunctionEntryCode(name, argCode, argType, location, {debugEnv, mkAddr, level, lex, ...}) = DEBUGGER.debugFunctionEntryCode(name, argCode, argType, location, debugEnv, level, lex, mkAddr)*) (* Find all the variables declared by each pattern. *) fun getVariablesInPatt (Ident {value = ref ident, ...}, varl) = (* Ignore constructors *) if isConstructor ident then varl else ident :: varl | getVariablesInPatt(TupleTree{fields, ...}, varl) = List.foldl getVariablesInPatt varl fields | getVariablesInPatt(Labelled {recList, ...}, varl) = List.foldl (fn ({valOrPat, ...}, vl) => getVariablesInPatt(valOrPat, vl)) varl recList (* Application of a constructor: only the argument can contain vars. *) | getVariablesInPatt(Applic {arg, ...}, varl) = getVariablesInPatt (arg, varl) | getVariablesInPatt(List{elements, ...}, varl) = List.foldl getVariablesInPatt varl elements | getVariablesInPatt(Constraint {value, ...}, varl) = getVariablesInPatt(value, varl) | getVariablesInPatt(Layered {var, pattern, ...}, varl) = (* There may be a constraint on the variable so it is easiest to recurse. *) getVariablesInPatt(pattern, getVariablesInPatt(var, varl)) | getVariablesInPatt(Parenthesised(p, _), varl) = getVariablesInPatt(p, varl) | getVariablesInPatt(_, varl) = varl (* constants and error cases. *); (* If we are only passing equality types filter out the others. *) val filterTypeVars = List.filter (fn tv => not justForEqualityTypes orelse tvEquality tv) fun codeMatch(near, alt : matchtree list, arg, isHandlerMatch, matchContext as { level, mkAddr, lex, typeVarMap, ...}): codetree = let val noOfPats = length alt (* Check for unreferenced variables. *) val () = if getParameter reportUnreferencedIdsTag (debugParams lex) then let fun getVars(MatchTree{vars, ...}, l) = getVariablesInPatt(vars, l) val allVars = List.foldl getVars [] alt in List.app (reportUnreferencedValue lex) allVars end else () val lineNo = case alt of MatchTree {location, ... } :: _ => location | _ => raise Match (* Save the argument in a variable. *) val decCode = multipleUses (arg, fn () => mkAddr 1, level); (* Generate code to load it. *) val loadExpCode = #load decCode level; (* Generate a range of addresses for any functions that have to be generated for the expressions. *) val baseAddr = mkAddr noOfPats (* We want to avoid the code blowing up if we have a large expression which occurs multiple times in the resulting code. e.g. case x of [1,2,3,4] => exp1 | _ => exp2 Here exp2 will be called at several points in the code. Most patterns occur only once, sometimes a few more times. The first three times the pattern occurs the code is inserted directly. Further cases are dealt with as function calls. *) val insertDirectCount = 3 (* First three cases are inserted directly. *) (* Make an array to count the number of references to a pattern. This is used to decide whether to use a function for certain expressions or to make it inline. *) val uses = IntArray.array (noOfPats, 0); (* Called when a selection has been made to code-generate the expression. *) fun codePatternExpression pattChosenIndex = let val context = matchContext (* Increment the count for this pattern. *) val useCount = IntArray.sub(uses, pattChosenIndex) + 1 val () = IntArray.update (uses, pattChosenIndex, useCount) val MatchTree {vars, exp, breakPoint, ... } = List.nth(alt, pattChosenIndex) in if useCount <= insertDirectCount then (* Use the expression directly *) let (* If debugging add debug entries for the variables then put in a break-point. *) val vl = getVariablesInPatt(vars, []) val (envDec, varDebugEnv) = makeDebugEntries(vl, context) val (bptCode, bptEnv) = addBreakPointCall(breakPoint, getLocation exp, context |> repDebugEnv varDebugEnv) in mkEnv(envDec @ bptCode, codegen (exp, context |> repDebugEnv bptEnv)) end else let (* Put in a call to the expression as a function. *) val thisVars = getVariablesInPatt(vars, []) (* Make an argument list from the variables bound in the pattern. *) fun makeArg(Value{access=Local{addr=ref lvAddr, ...}, ...}) = mkLoadLocal lvAddr | makeArg _ = raise InternalError "makeArg" val argsForCall = List.map makeArg thisVars in mkEval(mkLoadLocal (baseAddr + pattChosenIndex), argsForCall) end end (* Generate the code and also check for redundancy and exhaustiveness. *) local val cmContext = { mkAddr = mkAddr, level = level, typeVarMap = typeVarMap, lex = lex } in val (matchCode, exhaustive) = codeMatchPatterns(alt, loadExpCode, isHandlerMatch, lineNo, codePatternExpression, cmContext) end (* Report inexhaustiveness if necessary. TODO: It would be nice to have some example of a pattern that isn't matched for. *) (* If this is a handler we may have set the option to report exhaustiveness. This helps in tracking down handlers that don't treat Interrupt specially. *) val () = if exhaustive then if isHandlerMatch andalso getParameter reportExhaustiveHandlersTag (debugParams lex) then errorNear (lex, false, near, lineNo, "Handler catches all exceptions.") else () else if isHandlerMatch then () else errorNear (lex, false, near, lineNo, "Matches are not exhaustive.") (* Report redundant patterns. *) local fun reportRedundant(patNo, 0) = let val MatchTree {location, ... } = List.nth(alt, patNo) in errorNear (lex, false, near, location, "Pattern " ^ Int.toString (patNo+1) ^ " is redundant.") end | reportRedundant _ = () in val () = IntArray.appi reportRedundant uses end (* Generate functions for expressions that have been used more than 3 times. *) fun cgExps([], _, _, _, _, _, _) = [] | cgExps (MatchTree {vars, exp, breakPoint, ...} ::al, base, patNo, uses, lex, near, cgContext as { decName, level, ...}) = if IntArray.sub(uses, patNo - 1) <= insertDirectCount then (* Skip if it has been inserted directly and we don't need a fn. *) cgExps(al, base, patNo + 1, uses, lex, near, cgContext) else let val functionLevel = newLevel level (* For the function. *) local val addresses = ref 1 in fun fnMkAddrs n = ! addresses before (addresses := !addresses + n) end val fnContext = cgContext |> repNewLevel(decName, fnMkAddrs, functionLevel) (* We have to pass the variables as arguments. Bind a local variable to the argument so we can set the variable address as a local address. *) val pattVars = getVariablesInPatt(vars, []) val noOfArgs = length pattVars val argumentList = List.tabulate(noOfArgs, mkLoadArgument) val localAddresses = List.map(fn _ => fnMkAddrs 1) pattVars (* One address for each argument. *) val localDecs = ListPair.mapEq mkDec (localAddresses, argumentList) local (* Set the addresses to be suitable for arguments. At the same time create a debugging environment if required. *) fun setAddr (Value{access=Local{addr=lvAddr, level=lvLevel}, ...}, localAddr) = (lvAddr := localAddr; lvLevel := functionLevel) | setAddr _ = raise InternalError "setAddr" in val _ = ListPair.appEq setAddr (pattVars, localAddresses) end (* If debugging add the debug entries for the variables then a break-point. *) val (envDec, varDebugEnv) = makeDebugEntries(pattVars, fnContext) val (bptCode, bptEnv) = addBreakPointCall(breakPoint, getLocation exp, fnContext |> repDebugEnv varDebugEnv) val functionBody = mkEnv(localDecs @ envDec @ bptCode, codegen (exp, fnContext |> repDebugEnv bptEnv)) val patNoIndex = patNo - 1 in mkDec(base + patNoIndex, mkProc (functionBody, noOfArgs, decName ^ "/" ^ Int.toString patNo, getClosure functionLevel, fnMkAddrs 0)) :: cgExps(al, base, patNo + 1, uses, lex, near, cgContext) end val expressionFuns = cgExps(alt, baseAddr, 1, uses, lex, near, matchContext) in (* Return the code in a block. *) mkEnv (#dec decCode @ expressionFuns, matchCode) end (* codeMatch *) (* Code-generates a piece of tree. Returns the code and also the, possibly updated, debug context. This is needed to record the last location that was set in the thread data. *) and codeGenerate(Ident {value = ref (v as Value{class = Exception, ...}), location, ...}, { level, typeVarMap, lex, debugEnv, ...}) = (* Exception identifier *) (codeExFunction (v, level, typeVarMap, [], lex, location), debugEnv) | codeGenerate(Ident {value = ref (v as Value{class = Constructor _, ...}), expType=ref expType, location, ...}, { level, typeVarMap, lex, debugEnv, ...}) = (* Constructor identifier *) let (* The instance type is not necessarily the same as the type of the value of the identifier. e.g. in the expression 1 :: nil, "::" has an instance type of int * list int -> list int but the type of "::" is 'a * 'a list -> 'a list. *) (* When using the constructor as a value we just want the second word. Must pass [] as the polyVars otherwise this will be applied BEFORE extracting the construction function not afterwards. *) fun getConstr level = ValueConstructor.extractInjection(codeVal (v, level, typeVarMap, [], lex, location)) val polyVars = getPolymorphism (v, expType, typeVarMap) val code = applyToInstance(if justForEqualityTypes then [] else polyVars, level, typeVarMap, getConstr) in (code, debugEnv) end | codeGenerate(Ident {value = ref v, expType=ref expType, location, ...}, { level, typeVarMap, lex, debugEnv, ...}) = (* Value identifier *) let val polyVars = getPolymorphism (v, expType, typeVarMap) val code = codeVal (v, level, typeVarMap, polyVars, lex, location) in (code, debugEnv) end | codeGenerate(c as Literal{converter, literal, expType=ref expType, location}, { lex, debugEnv, ...}) = ( case getLiteralValue(converter, literal, expType, fn s => errorNear(lex, true, c, location, s)) of SOME w => (mkConst w, debugEnv) | NONE => (CodeZero, debugEnv) ) | codeGenerate(Applic {f = Ident {value = ref function, expType=ref expType, ...}, arg, location, ...}, context as { level, typeVarMap, lex, ...}) = (* Some functions are special e.g. overloaded and type-specific functions. These need to picked out and processed by applyFunction. *) let val polyVars = getPolymorphism (function, expType, typeVarMap) val (argCode, argEnv) = codeGenerate (arg, context) val code = applyFunction (function, argCode, level, typeVarMap, polyVars, lex, location) in (code, argEnv) end | codeGenerate(Applic {f, arg, ...}, context) = let val (fnCode, fnEnv) = codeGenerate(f, context) val (argCode, argEnv) = codeGenerate(arg, context |> repDebugEnv fnEnv) in (mkEval (fnCode, [argCode]), argEnv) end | codeGenerate(Cond {test, thenpt, elsept, thenBreak, elseBreak, ...}, context) = let val (testCode, testEnv) = codeGenerate(test, context) val (thenBptCode, thenDebug) = addBreakPointCall(thenBreak, getLocation thenpt, context |> repDebugEnv testEnv) val (thenCode, _) = codeGenerate(thenpt, context |> repDebugEnv thenDebug) val (elseBptCode, elseDebug) = addBreakPointCall(elseBreak, getLocation elsept, context |> repDebugEnv testEnv) val (elseCode, _) = codeGenerate(elsept, context |> repDebugEnv elseDebug) in (mkIf (testCode, mkEnv(thenBptCode, thenCode), mkEnv(elseBptCode, elseCode)), testEnv) end | codeGenerate(TupleTree{fields=[(*pt*)_], ...}, _) = (* There was previously a special case to optimise unary tuples but I can't understand how they can occur. Check this and remove the special case if it really doesn't. *) raise InternalError "codegen: Unary tuple" (*codegen (pt, context)*) | codeGenerate(TupleTree{fields, ...}, context as { debugEnv, ...}) = (* Construct a vector of objects. *) (mkTuple(map (fn x => codegen (x, context)) fields), debugEnv) | codeGenerate(Labelled {recList = [{valOrPat, ...}], ...}, context) = codeGenerate (valOrPat, context) (* optimise unary records *) | codeGenerate(Labelled {recList, expType=ref expType, ...}, context as { level, mkAddr, debugEnv, ...}) = let (* We must evaluate the expressions in the order they are written. This is not necessarily the order they appear in the record. *) val recordSize = length recList; (* The size of the record. *) (* First declare the values as local variables. *) (* We work down the list evaluating the expressions and putting the results away in temporaries. When we reach the end we construct the tuple by asking for each entry in turn. *) fun declist [] look = ([], mkTuple (List.tabulate (recordSize, look))) | declist ({name, valOrPat, ...} :: t) look = let val thisDec = multipleUses (codegen (valOrPat, context), fn () => mkAddr 1, level); val myPosition = entryNumber (name, expType); fun lookFn i = if i = myPosition then #load thisDec (level) else look i val (otherDecs, tuple) = declist t lookFn in (#dec thisDec @ otherDecs, tuple) end in (* Create the record and package it up as a block. *) (mkEnv (declist recList (fn _ => raise InternalError "missing in record")), debugEnv) end | codeGenerate(c as Selector {name, labType, location, typeof, ...}, { decName, typeVarMap, lex, debugEnv, ...}) = let (* Check that the type is frozen. *) val () = if recordNotFrozen labType then errorNear (lex, true, c, location, "Can't find a fixed record type.") else (); val selectorBody : codetree = if recordWidth labType = 1 then singleArg (* optimise unary tuples - no indirection! *) else let val offset : int = entryNumber (name, labType); in mkInd (offset, singleArg) end val code =(* Make an inline function. *) case filterTypeVars (getPolyTypeVars(typeof, mapTypeVars typeVarMap)) of [] => mkInlproc (selectorBody, 1, decName ^ "#" ^ name, [], 0) | polyVars => (* This may be polymorphic. *) mkInlproc( mkInlproc (selectorBody, 1, decName ^ "#" ^ name, [], 0), List.length polyVars, decName ^ "#" ^ name ^ "(P)", [], 0) in (code, debugEnv) end | codeGenerate(Unit _, { debugEnv, ...}) = (* Use zero. It is possible to have () = (). *) (CodeZero, debugEnv) | codeGenerate(List{elements, expType = ref listType, location, ...}, context as { level, typeVarMap, lex, debugEnv, ...}) = let (* Construct a list. We need to apply the constructors appropriate to the type. *) val baseType = case listType of TypeConstruction{args=[baseType], ...} => baseType | _ => raise InternalError "List: bad element type" val consType = mkFunctionType(mkProductType[baseType, listType], listType) fun consList [] = let (* "nil" *) val polyVars = getPolymorphism (nilConstructor, listType, typeVarMap) fun getConstr level = ValueConstructor.extractInjection( codeVal (nilConstructor, level, typeVarMap, [], lex, location)) in applyToInstance(polyVars, level, typeVarMap, getConstr) end | consList (h::t) = let (* :: *) val H = codegen (h, context) and T = consList t val polyVars = getPolymorphism (consConstructor, consType, typeVarMap) in applyFunction (consConstructor, mkTuple [H,T], level, typeVarMap, polyVars, lex, location) end in (consList elements, debugEnv) end | codeGenerate(Constraint {value, ...}, context) = codeGenerate (value, context) (* code gen. the value *) | codeGenerate(c as Fn { location, expType=ref expType, ... }, context as { typeVarMap, debugEnv, ...}) = (* Function *) (codeLambda(c, location, filterTypeVars(getPolyTypeVars(expType, mapTypeVars typeVarMap)), context), debugEnv) | codeGenerate(Localdec {decs, body, ...}, context) = (* Local expressions only. Local declarations will be handled by codeSequence.*) let (* This is the continuation called when the declarations have been processed. We need to ensure that if there are local datatypes we make new entries in the type value cache after them. *) (* TODO: This is a bit of a mess. We want to return the result of the last expression as an expression rather than a codeBinding. *) fun processBody (previousDecs: codeBinding list, nextContext as {debugEnv, ...}) = let fun codeList ([], d) = ([], d) | codeList ((p, bpt) :: tl, d) = (* Generate any break point code first, then this entry, then the rest. *) let val (lineChange, newEnv) = addBreakPointCall(bpt, getLocation p, nextContext |> repDebugEnv d) (* addBreakPointCall also updates the location info in case of a break-point or a function call. We want to pass that along. *) val code = mkNullDec(codegen (p, nextContext |> repDebugEnv newEnv)) val (codeRest, finalEnv) = codeList (tl, newEnv) in (lineChange @ [code] @ codeRest, finalEnv) end val (exps, finalDebugEnv) = codeList (body, debugEnv) in (previousDecs @ exps, finalDebugEnv) end val (decs, lastEnv) = codeSequence (decs, [], context, processBody) in (decSequenceWithFinalExp decs, lastEnv) end | codeGenerate(ExpSeq(ptl, _), context as { debugEnv, ...}) = (* Sequence of expressions. Discard results of all except the last.*) let fun codeList ([], _) = raise InternalError "ExpSeq: empty sequence" | codeList ((p, bpt)::tl, d) = let val (bptCode, newEnv) = addBreakPointCall(bpt, getLocation p, context |> repDebugEnv d) (* Because addBreakPointCall updates the location info in the debug env we need to pass this along in the same way as when making bindings. *) val (thisCode, postCodeEnv) = codeGenerate (p, context |> repDebugEnv newEnv) in case tl of [] => (bptCode, thisCode, postCodeEnv) | tl => let val (otherDecs, expCode, postListEnv) = codeList(tl, postCodeEnv) in (bptCode @ (mkNullDec thisCode :: otherDecs), expCode, postListEnv) end end val (codeDecs, codeExp, finalEnv) = codeList(ptl, debugEnv) in (mkEnv (codeDecs, codeExp), finalEnv) end | codeGenerate(Raise (pt, location), context as { level, mkAddr, ...}) = let val (raiseCode, raiseEnv) = codeGenerate(pt, context) val {dec, load} = multipleUses (raiseCode, fn () => mkAddr 1, level) val load = load level (* Copy the identifier, name and argument from the packet and add this location. *) val excPacket = mkEnv(dec, mkTuple[mkInd(0, load), mkInd(1, load), mkInd(2, load), codeLocation location]) in (mkRaise excPacket, raiseEnv) end | codeGenerate(c as HandleTree {exp, hrules, ...}, context as { debugEnv, mkAddr, ...}) = (* Execute an expression in the scope of a handler *) let val exPacketAddr = mkAddr 1 val handleExp = codegen (exp, context) val handlerCode = codeMatch (c, hrules, mkLoadLocal exPacketAddr, true, context) in (mkHandle (handleExp, handlerCode, exPacketAddr), debugEnv) end | codeGenerate(While {test, body, breakPoint, ...}, context as { debugEnv, ...}) = let val (testCode, testEnv) = codeGenerate(test, context) val (bptCode, testDebug) = addBreakPointCall(breakPoint, getLocation body, context |> repDebugEnv testEnv) val (bodyCode, _) = codeGenerate(body, context |> repDebugEnv testDebug) in (mkWhile (testCode, mkEnv(bptCode, bodyCode)), debugEnv) end | codeGenerate(c as Case {test, match, ...}, context as { debugEnv, ...}) = (* The matches are made into a series of tests and applied to the test expression. *) let val testCode = codegen (test, context) in (codeMatch (c, match, testCode, false, context), debugEnv) end | codeGenerate(Andalso {first, second, ...}, context) = let val (firstCode, firstEnv) = codeGenerate(first, context) (* Any updates to the debug context in the first part will carry over but we can't be sure whether any of the second part will be executed. *) val (secondCode, _) = codeGenerate(second, context |> repDebugEnv firstEnv) in (* Equivalent to if first then second else false *) (mkCand (firstCode, secondCode), firstEnv) end | codeGenerate(Orelse {first, second, ...}, context) = let val (firstCode, firstEnv) = codeGenerate(first, context) (* Any updates to the debug context in the first part will carry over but we can't be sure whether any of the second part will be executed. *) val (secondCode, _) = codeGenerate(second, context |> repDebugEnv firstEnv) in (* Equivalent to if first then true else second *) (mkCor (firstCode, secondCode), firstEnv) end | codeGenerate(Parenthesised(p, _), context) = codeGenerate (p, context) | codeGenerate(_, {debugEnv, ...}) = (CodeZero, debugEnv) (* empty and any others *) (* Old codegen function which discards the debug context. *) and codegen (c: parsetree, context) = #1 (codeGenerate(c, context)) (* Code-generate a lambda (fn expression). *) and codeLambda(c, location, polyVars, cpContext as {mkAddr=originalmkAddr, level=originalLevel, decName, ...}) = let fun getFnBody (Constraint {value, ...}) = getFnBody value | getFnBody (Fn{matches, ...}) = matches | getFnBody (Parenthesised(p, _)) = getFnBody p | getFnBody _ = raise InternalError "getFnBody: not a constrained fn-expression"; val f = getFnBody c; (* This function comprises a new declaration level *) val nLevel = if null polyVars then originalLevel else newLevel originalLevel local val addresses = ref 1 in fun fnMkAddr n = (! addresses) before (addresses := ! addresses + n) end val (firstPat, resType, argType) = case f of MatchTree {vars, resType = ref rtype, argType = ref atype, ...} :: _ => (vars, rtype, atype) | _ => raise InternalError "codeLambda: body of fn is not a clause list"; val tupleSize = List.length(tupleWidth firstPat) in if tupleSize <> 1 andalso null polyVars then let (* If the first pattern is a tuple we make a tuple from the arguments and pass that in. Could possibly treat labelled records in the same way but we have the problem of finding the size of the record. Currently, we don't apply this optimisation if the function is polymorphic. *) val newDecName : string = decName ^ "(" ^ Int.toString tupleSize ^ ")"; val fnLevel = newLevel nLevel val argumentCode = mkArgTuple(0, tupleSize) val newContext = cpContext |> repNewLevel(newDecName, fnMkAddr, fnLevel) fun codeAlts newDebugEnv = let val bodyContext = newContext |> repDebugEnv newDebugEnv in codeMatch (c, f, argumentCode, false, bodyContext) end val wrap = wrapFunctionInDebug(codeAlts, newDecName, argumentCode, argType, resType, location, newContext) val mainProc = mkProc(wrap, tupleSize, newDecName, getClosure fnLevel, fnMkAddr 0) (* Now make a block containing the procedure which expects multiple arguments and an inline procedure which expects a single tuple argument and calls the main procedure after taking the tuple apart. *) val thisDec = multipleUses (mainProc, fn () => originalmkAddr 1, originalLevel); val resProc = (* Result procedure. *) let val nLevel = newLevel originalLevel in mkInlproc (mkEval(#load thisDec nLevel, List.map #1 (loadArgsFromTuple(List.tabulate(tupleSize, fn _ => GeneralType), singleArg))), 1, decName ^ "(1)", getClosure nLevel, 0) end in mkEnv(#dec thisDec, resProc) end else let (* No tuple or polymorphic. *) val newDecName : string = decName ^ "(1)"; val fnLevel = newLevel nLevel val newContext = cpContext |> repNewLevel(newDecName, fnMkAddr, fnLevel) fun codeAlts newDebugEnv = let val bodyContext = newContext |> repDebugEnv newDebugEnv in codeMatch (c, f, mkLoadArgument 0, false, bodyContext) end (* If we're debugging add the debug info before resetting the level. *) val wrapped = wrapFunctionInDebug(codeAlts, newDecName, mkLoadArgument 0, argType, resType, location, newContext) val pr = mkProc (wrapped, 1, newDecName, getClosure fnLevel, fnMkAddr 0) in if null polyVars then pr else mkProc(pr, List.length polyVars, newDecName^"(P)", getClosure nLevel, 0) end end (* codeLambda *) (* Code-generates a sequence of declarations. *) and codeSequence ([], leading, codeSeqContext, processBody): codeBinding list * debuggerStatus = processBody(leading, codeSeqContext) (* Do the continuation. *) | codeSequence ((firstEntry as FunDeclaration {dec, ...}, _) :: pTail, leading, codeSeqContext, processBody) = let val (firstDec, firstEnv) = codeFunBindings(dec, firstEntry, codeSeqContext) in codeSequence (pTail, leading @ firstDec, codeSeqContext |> repDebugEnv firstEnv, processBody) end | codeSequence ((firstEntry as ValDeclaration {dec, location, ...}, bpt) :: pTail, leading, codeSeqContext as {lex, ...}, processBody) = let (* Check the types for escaped datatypes. *) local fun checkVars(ValBind{variables=ref vars, line, ...}) = List.app(fn var => checkForEscapingDatatypes(valTypeOf var, fn message => errorNear (lex, true, firstEntry, line, message))) vars in val () = List.app checkVars dec end (* Put in a break point *) val (bptCode, bptDbEnv) = addBreakPointCall(bpt, location, codeSeqContext) val postBptContext = codeSeqContext |> repDebugEnv bptDbEnv (* Split the bindings into recursive and non-recursive. These have to be processed differently. *) val (recBindings, nonrecBindings) = List.partition(fn ValBind{isRecursive, ...} => isRecursive) dec val nonRecCode = codeNonRecValBindings(nonrecBindings, firstEntry, postBptContext) val recCode = case recBindings of [] => [] | _ => #1 (codeRecValBindings(recBindings, firstEntry, postBptContext)) (* Construct the debugging environment by loading all variables. *) val vars = List.foldl(fn (ValBind{variables=ref v, ...}, vars) => v @ vars) [] dec val (decEnv, env) = makeDebugEntries (vars, postBptContext) in codeSequence (pTail, leading @ bptCode @ nonRecCode @ recCode @ decEnv, codeSeqContext |> repDebugEnv env, processBody) end | codeSequence ((Localdec {decs, body, varsInBody=ref vars, ...}, _) :: pTail, leading, codeSeqContext, processBody) = let (* Local declarations only *) (* The debug environment needs to reflect the local...in...end structure but if there are local datatypes we need to process all subsequent declarations in the scope of the "stopper" we've put onto the typeVarMap. *) fun processTail(previous, newContext) = let (* The debug env for the tail is the original environment together with the variables in the body, excluding variables in the local...in part. *) val (decEnv, resEnv) = makeDebugEntries (vars, codeSeqContext) (* Original context. *) in codeSequence (pTail, previous @ decEnv, newContext |> repDebugEnv resEnv, processBody) end in (* Process the declarations then the tail. *) codeSequence (decs @ body, leading, codeSeqContext, processTail) end | codeSequence ((ExDeclaration(tlist, _), _) :: pTail, leading, codeSeqContext as {mkAddr, level, typeVarMap, lex, ...}, processBody) = let fun codeEx (ExBind{value=ref exval, previous, ... }) = let val ex = exval; (* This exception is treated in the same way as a local variable except that the value it contains is created by generating a word on the heap. The address of this word constitutes a unique identifier. Non-generative exception bindings i.e. exception ex=ex' merely copy the word from the previous exception. *) val (lvAddr, lvLevel, exType) = case ex of Value{access=Local{addr, level}, typeOf, ...} => (addr, level, typeOf) | _ => raise InternalError "lvAddr" in lvAddr := mkAddr 1; lvLevel := level; mkDec (! lvAddr, case previous of EmptyTree => (* Generate a new exception. This is a single mutable word which acts as a token. It is a mutable to ensure that there is precisely one copy of it. It contains a function to print values of the type so when we raise the exception we can print the exception packet without knowing the type. *) mkExIden (exType, level, typeVarMap) | Ident{value=ref prevVal, location, ...} => (* Copy the previous value. N.B. We want the exception identifier here so we can't call codegen. *) codeVal (prevVal, level, typeVarMap, [], lex, location) | _ => raise InternalError "codeEx" ) end (* codeEx *); val exdecs = map codeEx tlist fun getValue(ExBind{value=ref exval, ...}) = exval val (debugDecs, newDebugEnv) = makeDebugEntries(map getValue tlist, codeSeqContext) in codeSequence (pTail, leading @ exdecs @ debugDecs, codeSeqContext |> repDebugEnv newDebugEnv, processBody) end (* ExDeclaration *) | codeSequence ( (AbsDatatypeDeclaration {typelist, declist, equalityStatus = ref absEq, isAbsType, withtypes, ...}, _) :: pTail, leading, codeSeqContext as {mkAddr, level, typeVarMap, debugEnv, lex, ...}, processBody) = let (* Code-generate the eq and print functions for the abstype first then the declarations, which may use these. *) (* The debugging environment for the declarations should include the constructors but the result shouldn't. For the moment ignore the constructors. *) val typeCons = List.map(fn (DatatypeBind {tcon = ref tc, ...}) => tc) typelist val eqStatus = if isAbsType then absEq else List.map (tcEquality o tsConstr) typeCons local fun getConstrCode(DatatypeBind {tcon = ref (tc as TypeConstrSet(_, constrs)), typeVars, ...}, eqStatus) = let (* Get the argument types or EmptyType if this is nullary. *) fun getConstrType(Value{typeOf=FunctionType{arg, ...}, name, ...}) = (name, arg) | getConstrType(Value{name, ...}) = (name, EmptyType) val constrTypesAndNames = List.map getConstrType constrs val {constrs, boxed, size} = chooseConstrRepr(constrTypesAndNames, List.map TypeVar typeVars) in ({typeConstr=tc, eqStatus=eqStatus, boxedCode=boxed, sizeCode=size}, constrs) end in val constrAndBoxSizeCode = ListPair.mapEq getConstrCode (typelist, eqStatus) val (tcEqBoxSize, constrsCode) = ListPair.unzip constrAndBoxSizeCode end local fun decConstrs(DatatypeBind {tcon = ref (TypeConstrSet(_, constrs)), ...}, reprs, (decs, debugEnv)) = let (* Declare the constructors as local variables. *) fun decCons(Value{access=Local{addr, level=lev}, ...}, repr) = let val newAddr = mkAddr 1 in addr := newAddr; lev := level; mkDec(newAddr, repr) end | decCons _ = raise InternalError "decCons: Not local" val constrDecs = ListPair.map decCons (constrs, reprs) val (newDecs, newDebug) = makeDebugEntries(constrs, codeSeqContext |> repDebugEnv debugEnv) in (constrDecs @ decs @ newDecs, newDebug) end in val (valConstrDecs: codeBinding list, constrDebugenv: debuggerStatus) = ListPair.foldl decConstrs ([], debugEnv) (typelist, constrsCode) end val typeFunctions = createDatatypeFunctions(tcEqBoxSize, mkAddr, level, typeVarMap, getParameter createPrintFunctionsTag (debugParams lex)) local (* Create debug entries for the type constructors and the new type ids. *) val (dataTypeDebugDecs, dataTypeDebugEnv) = makeTypeConstrDebugEntries(typeCons, constrDebugenv, level, lex, mkAddr) val withTypeTypes = List.map(fn (TypeBind {tcon = ref tc, ...}) => tc) withtypes val (withTypeDebugDecs, withTypeDebugEnv) = makeTypeConstrDebugEntries(withTypeTypes, dataTypeDebugEnv, level, lex, mkAddr) in val typeDebugDecs = dataTypeDebugDecs @ withTypeDebugDecs val typeDebugEnv = withTypeDebugEnv end (* Mark these in the type value cache. If they are used in subsequent polymorphic IDs we must create them after this. *) val newTypeVarMap = markTypeConstructors(List.map tsConstr typeCons, mkAddr, level, typeVarMap) (* Process the with..end part. We have to restore the equality attribute for abstypes here in case getPolymorphism requires it. *) val () = if isAbsType then ListPair.appEq(fn(TypeConstrSet(tc, _), eqt) => tcSetEquality (tc, eqt)) (typeCons, absEq) else () val (localDecs, newDebug) = codeSequence (declist, [], codeSeqContext |> repDebugEnv typeDebugEnv |> repTypeVarMap newTypeVarMap, fn (code, {debugEnv, ...}) => (code, debugEnv)) val () = if isAbsType then List.app(fn TypeConstrSet(tc, _) => tcSetEquality (tc, false)) typeCons else () (* Then the subsequent declarations. *) val (tailDecs, finalEnv) = codeSequence (pTail, [], codeSeqContext |> repDebugEnv newDebug |> repTypeVarMap newTypeVarMap, processBody) in (* The code consists of previous declarations, the value constructors, the type IDs, debug declarations for the types and value constructors, any type values created for subsequent polymorphic calls, declarations in with...end and finally code after this declaration within the same "let..in..end" block. *) (leading @ valConstrDecs @ typeFunctions @ typeDebugDecs @ getCachedTypeValues newTypeVarMap @ localDecs @ tailDecs, finalEnv) end | codeSequence ((OpenDec {variables=ref vars, structures = ref structs, typeconstrs = ref types, ...}, _) :: pTail, leading, codeSeqContext as { level, lex, mkAddr, ...}, processBody) = let (* All we need to do here is make debugging entries. *) val (firstDec, firstEnv) = makeDebugEntries(vars, codeSeqContext) val (secondDec, secondEnv) = makeTypeConstrDebugEntries(types, firstEnv, level, lex, mkAddr) val (thirdDec, thirdEnv) = makeStructDebugEntries(structs, secondEnv, level, lex, mkAddr) in codeSequence (pTail, leading @ firstDec @ secondDec @ thirdDec, codeSeqContext |> repDebugEnv thirdEnv, processBody) end | codeSequence ((TypeDeclaration (typebinds, _), _) :: pTail, leading, codeSeqContext as { debugEnv, level, lex, mkAddr, ...}, processBody) = let (* Just create debug entries for the type constructors. *) val typeCons = List.map(fn (TypeBind {tcon = ref tc, ...}) => tc) typebinds val (typeDebugDecs, typeDebugEnv) = makeTypeConstrDebugEntries(typeCons, debugEnv, level, lex, mkAddr) in codeSequence (pTail, leading @ typeDebugDecs, codeSeqContext |> repDebugEnv typeDebugEnv, processBody) end | codeSequence (_ :: pTail, leading, (* Directive *) codeSeqContext, processBody) = codeSequence (pTail, leading, codeSeqContext, processBody) (* Code generate a set of fun bindings. This is used for other function creation as well since it handles the most general case. *) and codeFunBindings(tlist: fvalbind list, near, context as {decName, mkAddr, level, typeVarMap, lex, ...}) = let (* Get the function variables. *) val functionVars = map (fn(FValBind{functVar = ref var, ...}) => var) tlist (* Check the types for escaped datatypes. *) local fun checkVars(FValBind{functVar=ref var, location, ...}) = checkForEscapingDatatypes(valTypeOf var, fn message => errorNear (lex, true, near, location, message)) in val () = List.app checkVars tlist end (* Each function may result in either one or two functions actually being generated. If a function is not curried it will generate a single function of one argument, but if it is curried (e.g. fun f a b = ...) it will generate two mutually recursive functions. A function fun f a b = X will be translated into val rec f' = fn(a,b) => X and f = fn a => b => f'(a,b) with the second function (f) being inline. This allows the optimiser to replace references to f with all its arguments by f' which avoids building unneccessary closures. *) fun setValueAddress( FValBind{functVar = ref(Value{access=Local{addr, level}, ...}), ...}, ad, lev) = (addr := ad; level := lev) | setValueAddress _ = raise InternalError "setValueAddress" (* Create a list of addresses for the functions. This is the address used for the most general case. Also set the variable addresses. These may be changed for polymorphic functions but will eventually be reset. *) val addressList = List.map (fn _ => mkAddr 2 (* We need two addresses. *)) tlist val () = ListPair.appEq (fn (t, a) => setValueAddress(t, a, level)) (tlist, addressList) (* Get the polymorphic variables for each function. *) local fun getPoly(FValBind{functVar = ref (Value{typeOf, ...}), ...}) = filterTypeVars(getPolyTypeVars(typeOf, mapTypeVars typeVarMap)) in val polyVarList = List.map getPoly tlist end (* Now we can process the function bindings. *) fun loadFunDecs ((fb as FValBind{numOfPatts = ref numOfPats, functVar = ref(Value{name, ...}), clauses, argType = ref aType, resultType = ref resType, location, ...})::otherDecs, polyVars :: otherPolyVars, addr :: otherAddresses) = let (* Make up the function, and if there are several mutually recursive functions, put it in the vector. *) val procName = decName ^ name; val nPolyVars = List.length polyVars (*val _ = print(concat[name, " is ", Int.toString nPolyVars, "-ary\n"])*) (* Check that all the type-vars are in the list. *) (*local fun checkVars tv = case List.find(fn t => sameTv(t, tv)) fdTypeVars of SOME _ => () | NONE => raise InternalError "Type var not found" in val _ = List.app checkVars polyVars end*) (* Produce a list of the size of any tuples or labelled records in the first clause. Tuples in the first clause are passed as separate arguments. We could look at the other clauses and only pass them as separate arguments if each clause contains a tuple. We can treat labelled records exactly like tuples here - we only need to worry about the mapping from labels to tuple offsets when we create the record (getting the order of evaluation right) and in the pattern-matching code (extracting the right fields). We don't have to worry about that here, because all we're doing is untupling and retupling, taking care always to put the values back at exactly the same offset we got them from. *) val tupleSeq : argumentType list list = case clauses of (FValClause{dec= { args, ...}, ...} :: _) => List.map tupleWidth args | _ => raise InternalError "badly formed parse tree"; local fun getResultTuple(FValClause{exp, ...}) = tupleWidth exp val resultTuples = List.foldl(fn(t, [_]) => getResultTuple t | (_, s) => s) [GeneralType] clauses (* If we're debugging we want the result of the function so we don't do this optimisation. *) (* The optimiser also detects functions returning tuples and turns them into containers. That works for local functions but doesn't work if the function is exported e.g. IntInf.divMod. *) val resultTuple = if (getParameter debugTag (debugParams lex)) then [GeneralType] else resultTuples in val resTupleLength = List.length resultTuple (*val _ = resTupleLength = 1 orelse raise InternalError "resTupleLength <> 1"*) (* If there's a single argument return the type of that otherwise if we're tupling the result is general. *) val (resultType, extraArg) = case resultTuple of [one] => (one, 0) | _ => (GeneralType, 1) end (* Count the total number of arguments needed. *) val totalArgs = List.foldl (op +) (extraArg+nPolyVars) (List.map List.length tupleSeq) (* The old test was "totalArgs = 1", but that's not really right, because we could have one genuine arg plus a lot of "()" patterns. We now use the normal inlining mechanism to optimise this (unusual) case too. *) val noInlineFunction = numOfPats = 1 andalso totalArgs = 1 andalso tupleSeq = [[GeneralType]] andalso resultType = GeneralType (* Turn the list of clauses into a match. *) fun clauseToTree(FValClause {dec={ args, ...}, exp, line, breakPoint, ...}) = MatchTree { vars = if numOfPats = 1 then hd args else TupleTree{fields=args, location=line, expType=ref EmptyType}, exp = exp, location = line, argType = ref badType, resType = ref badType, breakPoint = breakPoint } val matches = map clauseToTree clauses (* We arrange for the inner function to be called with the curried arguments in reverse order, but the tupled arguments in the normal order. For example, the ML declaration: fun g a b c = ... gives the order fun g (a, b, c) = ... gives the order fun g (a, b) c (d, e, f) = ... gives the order We want reverse the order of curried arguments to produce better code. (The last curried argument often gets put into the first argument register by the normal calling mechanism, so we try to ensure that it stays there.) We don't reverse the order of tupled arguments because I'm still a bit confused about when a tuple is an argument tuple (reversed?) and when it isn't (not reversed). Just to add to this, if the function is polymorphic we have to add the polymorphic arguments on at the end. *) local (* Create the argument type list. I'm sure this can be combined with the next version of makeArgs but it's all too complicated. *) fun makeArgs(parms, []) = let val polyParms = List.tabulate(nPolyVars, fn _ => GeneralType) val resTupleSize = resTupleLength in if resTupleSize = 1 then parms @ polyParms else parms @ polyParms @ [GeneralType] end | makeArgs(parms, t::ts) = makeArgs (t @ parms, ts) in val argTypes = makeArgs ([], tupleSeq) end local (* This function comprises a new declaration level *) val nArgTypes = List.length argTypes val fnLevel = newLevel level val argList : codetree = if numOfPats = 1 then mkArgTuple(nArgTypes-totalArgs, totalArgs-extraArg-nPolyVars) else let fun makeArgs([], _) = [] | makeArgs(h::t, n) = mkArgTuple(nArgTypes-n-List.length h, List.length h) :: makeArgs(t, n + List.length h) in mkTuple (makeArgs(tupleSeq, extraArg+nPolyVars)) end local val addresses = ref 1 in fun fnMkAddr n = (! addresses) before (addresses := ! addresses + n) end val innerProcName : string = concat ([procName, "(" , Int.toString totalArgs, ")"]); local (* The poly args come after any result tuple. *) val tupleOffset = if resTupleLength = 1 then 0 else 1 val argAddrs = List.tabulate(nPolyVars, fn n => fn l => mkLoadParam(n+nArgTypes-nPolyVars-tupleOffset, l, fnLevel)) val mainTypeVars = ListPair.zipEq(polyVars, argAddrs) (* Also need to add any variables used by other polymorphic functions but not in the existing list. This is only for very unusual cases. *) fun addExtras (fPolyVars, pVarList) = let fun checkPolymorphism(fpVar, pVars) = if isSome(List.find (fn(t, _) => sameTv(t, fpVar)) mainTypeVars) orelse isSome(List.find (fn (t, _) => sameTv(t, fpVar)) pVars) then pVars else (fpVar, fn _ => defaultTypeCode) :: pVars in List.foldl checkPolymorphism pVarList fPolyVars end val extraEntries = List.foldl addExtras [] polyVarList in val typevarArgMap = mainTypeVars @ extraEntries val newTypeVarMap = extendTypeVarMap(typevarArgMap, fnMkAddr, fnLevel, typeVarMap) end val fnContext = context |> repNewLevel(innerProcName, fnMkAddr, fnLevel) |> repTypeVarMap newTypeVarMap (* If we have (mutually) recursive references to polymorphic functions we need to create local versions applied to the polymorphic variables. We only need to consider functions that use the polymorphic variables for this function. If another function uses different variables it can't be called from this one. If it had been called from this any type variables would have been fixed as monotypes or the type variables of this function. Except this is wrong in one case. If one of the recursive calls involves an exception (e.g. f (fn _ => raise Fail "") (or perhaps some other case involving "don't care" polymorphic variables) it is possible to call a function with more polymorphism. *) local fun createApplications(fVal::fVals, addr::addrList, [] :: polyVarList, otherDecs) = ( (* Monomorphic functions. *) setValueAddress(fVal, addr, level); createApplications(fVals, addrList, polyVarList, otherDecs) ) | createApplications( fVal::fVals, addr::addrList, fPolyVars ::polyVarList, otherDecs) = let fun createMatches fpVar = case List.find (fn(t, _) => sameTv(t, fpVar)) typevarArgMap of SOME (_, codeFn) => codeFn fnLevel | NONE => raise InternalError "createMatches: Missing type var" val polyArgs = List.map createMatches fPolyVars val newAddr = fnMkAddr 1 val polyFn = mkLoad(addr, fnLevel, level) (* Set the address to this so if we use this function we pick up this declaration. *) val () = setValueAddress(fVal, newAddr, fnLevel); val newDecs = mkDec(newAddr, mkEval(polyFn, polyArgs)) :: otherDecs in createApplications(fVals, addrList, polyVarList, newDecs) end | createApplications(_, _, _, decs) = decs in val appDecs = if noInlineFunction then [] (* This may be directly recursive. *) else createApplications (tlist, addressList, polyVarList, []) end local (* Function body. The debug state has a "start of function" entry that is used when tracing and points to the arguments. There are then entries for the recursive functions so they can be used if we break within the function. *) fun codeBody fnEntryEnv = let val startContext = fnContext |> repDebugEnv fnEntryEnv (* Create debug entries for recursive references. *) val (recDecs, recDebugEnv) = makeDebugEntries(functionVars, startContext) val bodyContext = fnContext |> repDebugEnv recDebugEnv val codeMatches = mkEnv(recDecs, codeMatch (near, matches, argList, false, bodyContext)) in (* If the result is a tuple we try to avoid creating it by adding an extra argument to the inline function and setting this to the result. *) if resTupleLength = 1 then codeMatches else (* The function sets the extra argument to the result of the body of the function. We use the last argument for the container so that other arguments will be passed in registers in preference. Since the container is used for the result this argument is more likely to have to be pushed onto the stack within the function than an argument which may have its last use early on. *) mkSetContainer(mkLoadParam(nArgTypes-1, fnLevel, fnLevel), codeMatches, resTupleLength) end in (* If we're debugging add the debug info before resetting the level. *) val codeForBody = wrapFunctionInDebug(codeBody, procName, argList, aType, resType, location, fnContext) end val () = if List.length argTypes = totalArgs then () else raise InternalError "Argument length problem" in val innerFun = mkFunction{ body=mkEnv(getCachedTypeValues newTypeVarMap @ appDecs, codeForBody), argTypes=argTypes, resultType=resultType, name=innerProcName, closure=getClosure fnLevel, numLocals=fnMkAddr 0} end; (* We now have a function which can be applied to the arguments once we have them. If the function is curried we must make a set of nested inline procedures which will take one of the parameters at a time. If all the parameters are provided at once they will be optimised away. *) val polyLevel = if null polyVars then level else newLevel level (* Make into curried functions *) fun makeFuns(innerLevel, _, mkParms, []) = let (* Load a reference to the inner function. *) val loadInnerFun = mkLoad (addr + 1, innerLevel, level) val polyParms = List.tabulate(nPolyVars, fn n => (mkLoadParam(n, innerLevel, polyLevel), GeneralType)) val resTupleSize = resTupleLength val parms = mkParms innerLevel in (* Got to the bottom. - put in a call to the procedure. *) if resTupleSize = 1 then (mkCall (loadInnerFun, parms @ polyParms, resultType), 0) else (* Create a container for the result, side-effect it in the function, then create a tuple from it. Most of the time this will be optimised away. *) let val containerAddr = 0 (* In a new space *) val loadContainer = mkLoadLocal containerAddr in (mkEnv( [mkContainer(containerAddr, resTupleSize, mkCall(loadInnerFun, parms @ polyParms @ [(loadContainer, GeneralType)], GeneralType))], mkTupleFromContainer(containerAddr, resTupleSize)), containerAddr+1 (* One local *)) end end | makeFuns(innerLevel, decName, mkParms, t::ts) = let (* Make a function. *) val nLevel = newLevel innerLevel val newDecName : string = decName ^ "(1)" (* Arguments from this tuple precede older arguments, but order of arguments within the tuple is preserved. *) fun nextParms l = loadArgsFromTuple(t, mkLoadParam (0, l, nLevel)) @ mkParms l val (body, lCount) = makeFuns (nLevel, newDecName, nextParms, ts) in (mkInlproc (body, 1, newDecName, getClosure nLevel, lCount), 0) end (* end makeFuns *); (* Reset the address of the variable. *) val () = setValueAddress(fb, addr, level) in if noInlineFunction then (addr, innerFun) :: loadFunDecs(otherDecs, otherPolyVars, otherAddresses) else let val (baseFun, _) = makeFuns (polyLevel, procName, fn _ => [], tupleSeq) val polyFun = if null polyVars then baseFun else mkInlproc(baseFun, List.length polyVars, procName ^ "(P)", getClosure polyLevel, 0) in (* Return the `inner' procedure and the inline functions as a mutually recursive pair. Try putting the inner function first to see if the optimiser does better this way. *) (addr + 1, innerFun) :: (addr, polyFun) :: loadFunDecs(otherDecs, otherPolyVars, otherAddresses) end end (* loadFunDecs *) | loadFunDecs _ = [] val loaded = loadFunDecs(tlist, polyVarList, addressList) (* Set the final addresses in case they have changed. N.B. Do this before loading any debug references. *) val () = ListPair.appEq (fn (t, a) => setValueAddress(t, a, level)) (tlist, addressList) (* Construct the debugging environment for the rest of the scope. *) val (decEnv, newDebugEnv) = makeDebugEntries(functionVars, context) (* Check whether any of the functions were unreferenced. *) val _ = if getParameter reportUnreferencedIdsTag (debugParams lex) then reportUnreferencedValues(functionVars, lex) else () in (* Put the declarations into a package of mutual decs. *) (mkMutualDecs loaded :: decEnv, newDebugEnv) end (* codeFunBindings *) (* Recursive val declarations. Turn them into fun-bindings. This avoids duplicating a lot of code and codeFunBindings does a lot of optimisation. *) and codeRecValBindings(valDecs, near, context) = let (* Turn this into a fun binding. *) fun valBindToFvalBind(ValBind{ exp, line, variables=ref vars, ...}, fVals) = let fun getMatches (Fn { matches: matchtree list, ... }) = matches | getMatches (Constraint {value, ...}) = getMatches value | getMatches (Parenthesised(p, _)) = getMatches p | getMatches _ = raise InternalError "getMatches" fun matchTreeToClause(MatchTree{vars, exp, location, breakPoint, ...}) = let val dec = { ident = { name="", expType=ref EmptyType, location=location}, isInfix = false, args=[vars], constraint=NONE} in FValClause{dec = dec, exp=exp, line=location, breakPoint = breakPoint } end val clauses = List.map matchTreeToClause (getMatches exp) fun mkFValBind(var as Value{typeOf, ...}) = let val argType = mkTypeVar(generalisable, false, false, false) and resultType = mkTypeVar(generalisable, false, false, false) val () = if isSome(unifyTypes(typeOf, mkFunctionType(argType, resultType))) then raise InternalError "mkFValBind" else () in FValBind { clauses=clauses, numOfPatts=ref 1, functVar=ref var, argType=ref argType, resultType=ref resultType, location=line } end in fVals @ List.map mkFValBind vars end val converted = List.foldl valBindToFvalBind [] valDecs in codeFunBindings(converted, near, context) end (* codeRecValBindings *) (* Non-recursive val bindings. *) and codeNonRecValBindings(valBindings, near, originalContext: cgContext as { decName, typeVarMap, lex, isOuterLevel, ...}) = let (* Non-recursive val bindings. *) fun codeBinding (ValBind{dec=vbDec, exp=vbExp, line, variables=ref vars, ...}, otherDecs) = let (* A binding. *) (* Get a name for any functions. This is used for profiling and exception trace. *) val fName = case vars of [] => "_" | _ => String.concatWith "|" (List.map valName vars) (* Does this contain polymorphism? *) val polyVarsForVals = List.map(fn Value{typeOf, ...} => filterTypeVars (getPolyTypeVars(typeOf, mapTypeVars typeVarMap))) vars val polyVars = List.foldl(op @) [] polyVarsForVals val nPolyVars = List.length polyVars (* In almost all cases polymorphic declarations are of the form val a = b or val a = fn ... . They can, though, arise in pathological cases with arbitrary patterns and complex expressions. If any of the variables are polymorphic the expression must have been non-expansive. That means that we can safely evaluate it repeatedly. There's one exception: it may raise Bind. (e.g. val SOME x = NONE). For that reason we make sure it is evaluated at least once. We build the code as a function and then apply it one or more times. This is really to deal with pathological cases and pretty well all of this will be optimised away. *) val localContext as {level, mkAddr, typeVarMap, ...} = if nPolyVars = 0 then originalContext else let val addresses = ref 1 fun fnMkAddr n = (! addresses) before (addresses := ! addresses + n) val fnLevel = newLevel (#level originalContext) val argAddrs = List.tabulate(nPolyVars, fn n => fn l => mkLoadParam(n, l, fnLevel)) val argMap = ListPair.zipEq(polyVars, argAddrs) val newTypeVarMap = extendTypeVarMap(argMap, fnMkAddr, fnLevel, #typeVarMap originalContext) in originalContext |> repNewLevel(decName, fnMkAddr, fnLevel) |> repTypeVarMap newTypeVarMap end val exp = codegen (vbExp, localContext |> repDecName (decName ^ fName ^ "-")) (* Save the argument in a variable. *) val decCode = multipleUses (exp, fn () => mkAddr 1, level) (* Generate the code and also check for redundancy and exhaustiveness. *) local val cmContext = { mkAddr = mkAddr, level = level, typeVarMap = typeVarMap, lex = lex } in val (bindCode, exhaustive) = codeBindingPattern(vbDec, #load decCode level, line, cmContext) end (* Report inexhaustiveness if necessary. *) val () = if not exhaustive andalso not isOuterLevel then errorNear (lex, false, near, line, "Pattern is not exhaustive.") else () (* Check for unreferenced variables. *) val () = if getParameter reportUnreferencedIdsTag (debugParams lex) then List.app (reportUnreferencedValue lex) (getVariablesInPatt(vbDec, [])) else () val resultCode = if nPolyVars = 0 then #dec decCode @ bindCode else let fun loadVal(Value{access=Local{addr=ref add, ...}, ...}) = mkLoadLocal add | loadVal _ = raise InternalError "loadVal" val outerAddrs = #mkAddr originalContext and outerLevel = #level originalContext (* Construct a function that, when applied, returns all the variables. *) val fnAddr = outerAddrs 1 val resFunction = mkDec(fnAddr, mkInlproc( mkEnv(getCachedTypeValues typeVarMap @ #dec decCode @ bindCode, mkTuple(List.map loadVal vars)), nPolyVars, "(P)", getClosure level, mkAddr 0)) (* Apply the general function to the set of type variables using either the actual type variables if they are in this particular variable or defaults if they're not. *) fun application(pVars, level) = let val nPVars = List.length pVars val varNos = ListPair.zipEq(pVars, List.tabulate(nPVars, fn x=>x)) fun getArg argV = case List.find (fn (v, _) => sameTv(v, argV)) varNos of SOME (_, n) => mkLoadParam(n, level, level) | NONE => defaultTypeCode in mkEval(mkLoad(fnAddr, level, outerLevel), List.map getArg polyVars) end (* For each variable construct either a new function if it is polymorphic or a simple value if it is not (e.g. val (a, b) = (fn x=>x, 1)). Set the local addresses at the same time. *) fun loadFunctions(var::vars, polyV::polyVs, n) = let val vAddr = outerAddrs 1 val () = case var of Value{access=Local{addr, level}, ...} => (addr := vAddr; level := outerLevel) | _ => raise InternalError "loadFunctions" in mkDec(vAddr, case polyV of [] => (* monomorphic *) mkInd(n, application([], outerLevel)) | _ => (* polymorphic *) let val nPolyVars = List.length polyV val nLevel = newLevel outerLevel in mkInlproc( mkInd(n, application(polyV, nLevel)), nPolyVars, "(P)", getClosure nLevel, 0) end ) :: loadFunctions(vars, polyVs, n+1) end | loadFunctions _ = [] val loadCode = loadFunctions(vars, polyVarsForVals, 0) in (* Return the declaration of the function, a dummy application that will force any pattern checking and raise a Match if necessary and the declarations of the variables. *) resFunction :: mkNullDec(application([], outerLevel)) :: loadCode end in otherDecs @ resultCode end in List.foldl codeBinding [] valBindings end (* codeNonRecValBindings *) (* Code generates the parse tree. *) fun gencode (pt : parsetree, lex: lexan, debugEnv: debuggerStatus, outerLevel, mkOuterAddresses, outerTypeVarMap, structName: string, continuation) : codeBinding list * debuggerStatus = codeSequence ([(pt, ref NONE)], [], {decName=structName, mkAddr=mkOuterAddresses, level=outerLevel, typeVarMap=outerTypeVarMap, debugEnv=debugEnv, lex=lex, lastDebugLine=ref 0, isOuterLevel = true}, fn (code: codeBinding list, {debugEnv, typeVarMap, ...}) => continuation(code, debugEnv, typeVarMap)) (* Types that can be shared. *) structure Sharing = struct type parsetree = parsetree and lexan = lexan and codetree = codetree and environEntry = environEntry and level = level and typeVarMap = typeVarMap and codeBinding = codeBinding and debuggerStatus = debuggerStatus end end; diff --git a/mlsource/MLCompiler/ParseTree/EXPORT_PARSETREE.sml b/mlsource/MLCompiler/ParseTree/EXPORT_PARSETREE.sml index 34cde6ff..14c0f4e8 100644 --- a/mlsource/MLCompiler/ParseTree/EXPORT_PARSETREE.sml +++ b/mlsource/MLCompiler/ParseTree/EXPORT_PARSETREE.sml @@ -1,533 +1,533 @@ (* Copyright (c) 2013, 2016 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Derived from the original parse-tree Copyright (c) 2000 Cambridge University Technical Services Limited Further development: Copyright (c) 2000-13 David C.J. Matthews Title: Parse Tree Structure and Operations. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) functor EXPORT_PARSETREE ( structure BASEPARSETREE : BaseParseTreeSig structure PRINTTREE: PrintParsetreeSig structure LEX : LEXSIG structure STRUCTVALS : STRUCTVALSIG structure EXPORTTREE: EXPORTTREESIG structure TYPETREE : TYPETREESIG - structure DEBUGGER : DEBUGGERSIG + structure DEBUGGER : DEBUGGER sharing LEX.Sharing = TYPETREE.Sharing = STRUCTVALS.Sharing = EXPORTTREE.Sharing = BASEPARSETREE.Sharing = PRINTTREE.Sharing = DEBUGGER.Sharing ): ExportParsetreeSig = struct open LEX open STRUCTVALS open EXPORTTREE open TYPETREE open BASEPARSETREE open PRINTTREE fun getExportTree(navigation, p: parsetree) = let (* Common properties for navigation and printing. *) val commonProps = exportNavigationProps navigation @ [PTprint(fn d => displayParsetree(p, d))] fun asParent () = getExportTree(navigation, p) (* Put all these into a common list. That simplifies navigation between the various groups in abstypes and datatypes. *) datatype lType = DataT of datatypebind | TypeB of typebind | Decl of parsetree * breakPoint option ref (* Common code for datatypes, abstypes and type bindings. *) fun exportTypeBinding(navigation, this as DataT(DatatypeBind{name, nameLoc, fullLoc, constrs, tcon=ref(TypeConstrSet(tcon, _)), ...})) = let fun asParent () = exportTypeBinding(navigation, this) (* Ignore any type variables before the type name. *) fun getName () = getStringAsTree({parent=SOME asParent, previous=NONE, next=SOME getConstrs}, name, nameLoc, definingLocationProps(tcLocations tcon)) and getConstrs () = let fun exportConstrs(navigation, {constrName, idLocn, constrVal=ref(Value{locations, ...}), ... }) = (* TODO: the constructor type. *) getStringAsTree(navigation, constrName, idLocn, definingLocationProps locations) in (fullLoc, (* TODO: We need a separate location for the constrs. *) exportList(exportConstrs, SOME asParent) constrs @ exportNavigationProps {parent=SOME asParent, previous=SOME getName, next=NONE}) end in (fullLoc, PTfirstChild getName :: exportNavigationProps navigation) end | exportTypeBinding(navigation, this as TypeB(TypeBind{name, nameLoc, decType = SOME decType, fullLoc, tcon=ref(TypeConstrSet(tcon, _)), ...})) = let fun asParent () = exportTypeBinding(navigation, this) (* Ignore any type variables before the type name. *) fun getName () = getStringAsTree({parent=SOME asParent, previous=NONE, next=SOME getType}, name, nameLoc, definingLocationProps(tcLocations tcon)) and getType () = typeExportTree({parent=SOME asParent, previous=SOME getName, next=NONE}, decType) in (fullLoc, PTfirstChild getName :: exportNavigationProps navigation) end (* TypeBind is also used in a signature in which case decType could be NONE. *) | exportTypeBinding(navigation, this as TypeB(TypeBind{name, nameLoc, decType = NONE, fullLoc, tcon=ref(TypeConstrSet(tcon, _)), ...})) = let fun asParent () = exportTypeBinding(navigation, this) (* Ignore any type variables before the type name. *) (* Retain this as a child entry in case we decide to add the type vars later. *) fun getName () = getStringAsTree({parent=SOME asParent, previous=NONE, next=NONE}, name, nameLoc, definingLocationProps(tcLocations tcon)) in (fullLoc, PTfirstChild getName :: exportNavigationProps navigation) end | exportTypeBinding(navigation, Decl dec) = (* Value declarations in an abstype. *) exportTreeWithBpt(navigation, dec) (* In a couple of cases we can have a breakpoint associated with an entry. *) and exportTreeWithBpt(nav, (p, ref NONE)) = getExportTree (nav, p) | exportTreeWithBpt(nav, (p, ref (SOME bpt))) = let val (loc, props) = getExportTree (nav, p) in (loc, PTbreakPoint bpt :: props) end fun exportMatch(navigation, p as MatchTree{location, vars, exp, resType = ref rtype, argType = ref atype, breakPoint = ref bpt, ...}) = let fun asParent () = exportMatch(navigation, p) val debugProp = case bpt of NONE => [] | SOME bpt => [PTbreakPoint bpt] in (location, [PTprint(fn d => displayMatch(p, d)), PTtype (mkFunctionType (atype, rtype))] @ exportList(getExportTree, SOME asParent) [vars, exp] @ exportNavigationProps navigation @ debugProp ) end in case p of Ident{location, expType=ref expType, value, possible, name, ...} => let (* Include the type and declaration properties if these have been set. *) val (decProp, references, possProp) = case value of ref (Value{name = "", ...}) => let (* Generate possible completions. For the moment just consider simple prefixes. *) val completions = List.filter (String.isPrefix name) (! possible ()) in ([], NONE, [PTcompletions completions]) end | ref (Value{locations, references, ...}) => let (* If this is in a pattern it could be the defining location of the id. It's complicated trying to find out exactly which is the defining location so we check to see if this is the DeclaredAt location. *) val locProps = case List.find (fn DeclaredAt l => l = location | _ => false) locations of SOME _ => definingLocationProps locations | NONE => mapLocationProps locations in (locProps, references, []) end val refProp = case references of NONE => [] | SOME {exportedRef=ref exp, localRef=ref locals, recursiveRef=ref recs} => [PTreferences(exp, List.map #1 recs @ locals)] in (location, PTtype expType :: decProp @ commonProps @ refProp @ possProp) end | Literal {location, expType=ref expType, ...} => (location, PTtype expType :: commonProps) (* Infixed application. For the purposes of navigation we treat this as three entries in order. *) | Applic{location, f, arg = TupleTree{fields=[left, right], ...}, isInfix = true, expType=ref expType, ...} => (location, PTtype expType :: exportList(getExportTree, SOME asParent) [left, f, right] @ commonProps) (* Non-infixed application. *) | Applic{location, f, arg, expType=ref expType, ...} => (location, PTtype expType :: exportList(getExportTree, SOME asParent) [f, arg] @ commonProps) | Cond{location, test, thenpt, elsept, thenBreak, elseBreak, ...} => (location, exportList(exportTreeWithBpt, SOME asParent) [(test, ref NONE), (thenpt, thenBreak), (elsept, elseBreak)] @ commonProps) | TupleTree{fields, location, expType=ref expType, ...}=> (location, PTtype expType :: exportList(getExportTree, SOME asParent) fields @ commonProps) | ValDeclaration{location, dec, ...} => let fun exportVB(navigation, vb as ValBind{dec, exp, line, ...}) = let val vbProps = exportNavigationProps navigation (* First child should give the pattern *) (* Second child should give the expression *) fun exportThis () = exportVB(navigation, vb) val asChild = exportList(getExportTree, SOME exportThis) [dec, exp] in (line, asChild @ vbProps) end val expChild = exportList(exportVB, SOME asParent) dec in (* We need a special case for a top-level expression. This has been converted by the parser into val it = exp but the "val it = " takes up no space. We need to go directly to the expression in that case. *) case dec of [ValBind{dec=Ident{name="it", location=itLoc, ...}, exp, ...}] => if #startPosition itLoc = #endPosition itLoc andalso #startLine itLoc = #endLine itLoc then getExportTree(navigation, exp) else (location, expChild @ commonProps) | _ => (location, expChild @ commonProps) end | FunDeclaration{location, dec, ...} => let (* It's easiest to put these all together into a single list. *) datatype funEntry = FunIdent of { name: string, expType: types ref, location: location } * values | FunPtree of parsetree | FunConstraint of typeParsetree | FunInfixed of funEntry list * location fun exportFunEntry(navigation, FunIdent({expType=ref expType, location, ...}, Value{references, locations, ...})) = let val refProp = case references of NONE => [] | SOME {exportedRef=ref exp, localRef=ref locals, recursiveRef=ref recs} => [PTreferences(exp, List.map #1 recs @ locals)] in (location, refProp @ definingLocationProps locations @ (PTtype expType :: exportNavigationProps navigation)) end | exportFunEntry(navigation, FunPtree pt) = getExportTree(navigation, pt) | exportFunEntry(navigation, FunConstraint typ) = typeExportTree(navigation, typ) | exportFunEntry(navigation, this as FunInfixed(inf, location)) = let fun asParent () = exportFunEntry(navigation, this) val expChild = exportList(exportFunEntry, SOME asParent) inf in (location, expChild @ exportNavigationProps navigation) end fun exportAClause( FValClause{dec = {ident, isInfix, args, constraint}, exp, breakPoint = ref bpt, ...}, idVal, exportThis) = let (* The effect of this is to have all the elements of the clause as a single level except that if we have an infixed application of the function (e.g. fun f o g = ...) then this is a subnode. *) val funAndArgs = case (isInfix, args) of (true, TupleTree{fields=[left, right], location, ...} :: otherArgs) => (* Infixed. *) FunInfixed([FunPtree left, FunIdent(ident, idVal), FunPtree right], location) :: map FunPtree otherArgs | (_, args) => (* Normal prefixed form. *) FunIdent(ident, idVal) :: map FunPtree args val constraint = case constraint of NONE => [] |SOME typ => [FunConstraint typ] val debugProp = case bpt of NONE => [] | SOME bpt => [PTbreakPoint bpt] in exportList(exportFunEntry, SOME exportThis) (funAndArgs @ constraint @ [FunPtree exp]) @ debugProp end fun exportFB(navigation, fb as FValBind{clauses=[clause], location, functVar = ref idVal, ...}) = (* If there's just one clause go straight to it. Otherwise we have an unnecessary level of navigation. *) let val fbProps = exportNavigationProps navigation val asChild = exportAClause(clause, idVal, fn () => exportFB(navigation, fb)) in (location, asChild @ fbProps) end | exportFB(navigation, fb as FValBind{clauses, location, functVar = ref idVal, ...}) = let val fbProps = exportNavigationProps navigation (* Each child gives a clause. *) (* First child should give the pattern *) (* Second child should give the expression *) fun exportThis () = exportFB(navigation, fb) fun exportClause(navigation, clause as FValClause{ line, ...}) = let val clProps = exportNavigationProps navigation val asChild = exportAClause(clause, idVal, fn () => exportClause(navigation, clause)) in (line, asChild @ clProps) end val asChild = exportList(exportClause, SOME exportThis) clauses in (location, asChild @ fbProps) end val expChild = exportList(exportFB, SOME asParent) dec in (location, expChild @ commonProps) end | OpenDec{location, decs, ...} => let fun exportStructIdent(navigation, { value, location, ...} ) = let (* Include the declaration properties if it has been set. *) val locProps = case !value of SOME(Struct{locations, ...}) => mapLocationProps locations | NONE => [] val siProps = exportNavigationProps navigation @ locProps in (location, siProps) end val expChild = exportList(exportStructIdent, SOME asParent) decs in (location, expChild @ commonProps) end | Constraint{location, value, given, ...} => let (* The first position is the expression, the second the type *) fun getExpr () = getExportTree({parent=SOME asParent, previous=NONE, next=SOME getType}, value) and getType () = typeExportTree({parent=SOME asParent, previous=SOME getExpr, next=NONE}, given) in (location, PTfirstChild getExpr :: commonProps) end | Layered{location, var, pattern, ...} => (location, exportList(getExportTree, SOME asParent) [var, pattern] @ commonProps) | Fn {matches, location, expType = ref expType, ...} => (location, PTtype expType :: exportList(exportMatch, SOME asParent) matches @ commonProps) | Localdec{location, decs, body, ...} => (location, exportList(exportTreeWithBpt, SOME asParent) (decs @ body) @ commonProps) | TypeDeclaration(tbl, location) => let val allItems = List.map TypeB tbl in (location, exportList(exportTypeBinding, SOME asParent) allItems @ commonProps) end | AbsDatatypeDeclaration { location, typelist, withtypes, declist, ... } => let val allItems = List.map DataT typelist @ List.map TypeB withtypes @ List.map Decl declist in (location, exportList(exportTypeBinding, SOME asParent) allItems @ commonProps) end | DatatypeReplication{location, ...} => (* TODO *) (location, commonProps) | ExpSeq(ptl, location) => (location, exportList(exportTreeWithBpt, SOME asParent) ptl @ commonProps) | Directive{location, ...} => (* No need to process the individual identifiers. *) (location, commonProps) | ExDeclaration(exbinds, location) => let (* There are three possibilities here. exception exc; exception exc of ty; exception exc = exc' *) fun exportExdec(navigation, ExBind{name, previous=EmptyTree, ofType=NONE, nameLoc, value=ref(Value{locations, ...}), ...}) = (* Simple, generative exception with no type. *) getStringAsTree(navigation, name, nameLoc, PTtype exnType :: definingLocationProps locations) | exportExdec(navigation, eb as ExBind{name, previous=EmptyTree, ofType=SOME ofType, nameLoc, fullLoc, value=ref(Value{locations, ...}), ...}) = (* exception exc of type. *) let fun asParent () = exportExdec (navigation, eb) fun getName () = getStringAsTree({parent=SOME asParent, next=SOME getOfType, previous=NONE}, name, nameLoc, (* Type could be in here? *)definingLocationProps locations) and getOfType () = typeExportTree({parent=SOME asParent, previous=SOME getName, next=NONE}, ofType) in (fullLoc, PTfirstChild getName :: exportNavigationProps navigation) end | exportExdec(navigation, eb as ExBind{name, previous, (* ofType=NONE, *) nameLoc, fullLoc, value=ref(Value{locations, ...}), ...}) = let fun asParent () = exportExdec (navigation, eb) fun getName () = getStringAsTree({parent=SOME asParent, next=SOME getPreviousExc, previous=NONE}, name, nameLoc, (* Type could be in here? *)definingLocationProps locations) and getPreviousExc () = getExportTree({parent=SOME asParent, previous=SOME getName, next=NONE}, previous) in (fullLoc, PTfirstChild getName :: exportNavigationProps navigation) end val expChild = exportList(exportExdec, SOME asParent) exbinds in (location, expChild @ commonProps) end | Raise(raiseExp, location) => let fun getExp () = getExportTree({parent=SOME asParent, next=NONE, previous=NONE}, raiseExp) in (location, [PTfirstChild getExp] @ commonProps) end | HandleTree{location, exp, hrules, listLocation, ...} => let (* The first position is the expression, the second the matches *) fun getExpr () = getExportTree({parent=SOME asParent, previous=NONE, next=SOME getMatches}, exp) and getMatches () = (listLocation, exportList(exportMatch, SOME getMatches) hrules @ exportNavigationProps{parent=SOME asParent, previous=SOME getExpr, next=NONE}) in (location, [PTfirstChild getExpr] @ commonProps) end | While{location, test, body, breakPoint, ...} => (location, exportList(exportTreeWithBpt, SOME asParent) [(test, ref NONE), (body, breakPoint)] @ commonProps) | Case{location, test, match, listLocation, expType=ref expType, ...} => let (* The first position is the expression, the second the matches *) fun getExpr () = getExportTree({parent=SOME asParent, previous=NONE, next=SOME getMatches}, test) and getMatches () = (listLocation, exportList(exportMatch, SOME getMatches) match @ exportNavigationProps{parent=SOME asParent, previous=SOME getExpr, next=NONE}) in (location, [PTfirstChild getExpr, PTtype expType] @ commonProps) end | Andalso {location, first, second, ...} => (location, exportList(getExportTree, SOME asParent) [first, second] @ commonProps) | Orelse{location, first, second, ...} => (location, exportList(getExportTree, SOME asParent) [first, second] @ commonProps) | Labelled{location, expType=ref expType, recList, ...} => let (* It's convenient to be able to click on the label part and get the type of the expression or pattern on the right of the '='. *) fun exportField(navigation, label as {name, nameLoc, valOrPat, expType=ref expType, fullLocation, ...}) = let val patTree as (patLocation, _) = getExportTree(navigation, valOrPat) in if patLocation = fullLocation then (* The parser rewrites { name, ...} as { name=name, ... } (more generally { name: ty as pat, ...} as { name = name: ty as pat). To avoid having nodes that overlap we return only the pattern part here. *) patTree else let (* The first position is the label, the second the type *) fun asParent () = exportField (navigation, label) fun getLab () = getStringAsTree({parent=SOME asParent, next=SOME getExp, previous=NONE}, name, nameLoc, [PTtype expType]) and getExp () = getExportTree({parent=SOME asParent, previous=SOME getLab, next=NONE}, valOrPat) in (fullLocation, PTfirstChild getLab :: exportNavigationProps navigation) end end val expChild = exportList(exportField, SOME asParent) recList in (location, PTtype expType :: (expChild @ commonProps)) end | Selector{location, typeof, ...} => (location, PTtype typeof :: commonProps) | List{elements, location, expType = ref expType, ...} => (location, PTtype expType :: exportList(getExportTree, SOME asParent) elements @ commonProps) | EmptyTree => (nullLocation, commonProps) | WildCard location => (location, commonProps) | Unit location => (location, PTtype unitType :: commonProps) | Parenthesised(p, _) => getExportTree(navigation, p) end fun getLocation c = #1 (getExportTree({parent=NONE, next=NONE, previous=NONE}, c)) (* Extract the declaration location from the location list. *) fun declaredAt [] = LEX.nullLocation | declaredAt (DeclaredAt loc :: _) = loc | declaredAt (_::l) = declaredAt l (* Types that can be shared. *) structure Sharing = struct type lexan = lexan and parsetree = parsetree and matchtree = matchtree and locationProp = locationProp and pretty = pretty and ptProperties = ptProperties end end; diff --git a/mlsource/MLCompiler/ParseTree/MATCH_COMPILER.sml b/mlsource/MLCompiler/ParseTree/MATCH_COMPILER.sml index 9aac1280..7d0b685d 100644 --- a/mlsource/MLCompiler/ParseTree/MATCH_COMPILER.sml +++ b/mlsource/MLCompiler/ParseTree/MATCH_COMPILER.sml @@ -1,1202 +1,1202 @@ (* Copyright (c) 2013, 2015 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Derived from the original parse-tree Copyright (c) 2000 Cambridge University Technical Services Limited Further development: Copyright (c) 2000-13 David C.J. Matthews Title: Parse Tree Structure and Operations. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) functor MATCH_COMPILER ( structure BASEPARSETREE : BaseParseTreeSig structure PRINTTREE: PrintParsetreeSig structure LEX : LEXSIG structure CODETREE : CODETREESIG - structure DEBUGGER : DEBUGGERSIG + structure DEBUGGER : DEBUGGER structure TYPETREE : TYPETREESIG structure TYPEIDCODE: TYPEIDCODESIG structure STRUCTVALS : STRUCTVALSIG structure VALUEOPS : VALUEOPSSIG structure DATATYPEREP: DATATYPEREPSIG structure DEBUG: DEBUGSIG structure MISC : sig (* These are handled in the compiler *) exception Conversion of string (* string to int conversion failure *) (* This isn't handled at all (except generically) *) exception InternalError of string (* compiler error *) end structure ADDRESS : AddressSig sharing BASEPARSETREE.Sharing = PRINTTREE.Sharing = LEX.Sharing = CODETREE.Sharing = DEBUGGER.Sharing = TYPETREE.Sharing = TYPEIDCODE.Sharing = STRUCTVALS.Sharing = VALUEOPS.Sharing = DATATYPEREP.Sharing = ADDRESS ): MatchCompilerSig = struct open BASEPARSETREE open PRINTTREE open CODETREE open TYPEIDCODE open LEX open TYPETREE open DEBUG open STRUCTVALS open VALUEOPS open MISC open DATATYPEREP open TypeVarMap datatype environEntry = datatype DEBUGGER.environEntry type debuggerStatus = DEBUGGER.debuggerStatus (* To simplify passing the context it is wrapped up in this type. This is a subset of the context used in CODEGEN_PARSETREE. *) type matchContext = { mkAddr: int->int, level: level, typeVarMap: typeVarMap, lex: lexan } (* Devised by Mike Fourman, Nick Rothwell and me (DCJM). First coded up by Nick Rothwell for the Kit Compiler. First phase of the match compiler. The purpose of this phase is to take a match (a set of patterns) and bring together the elements that will be discriminated by testing any particular part of the value. Where a pattern is a tuple, for example, it is possible to discriminate on each of the fields independently, but it may be more efficient to discriminate on one of the fields first, and then on the others. The aim is to produce a set of tests that discriminate between the patterns quickly. *) abstype patSet = PatSet of int list with (* Each leaf in the tree contains a number which identifies the pattern it came from. As well as linking back to the patterns, these numbers represent an ordering, because earlier patterns mask out later ones. *) (* A set of pattern identifiers. *) val empty = PatSet []; fun singleton i = PatSet [i]; fun list (PatSet p) = p; infix 3 :::; fun a ::: b = PatSet (a :: list b); fun isEmptySet (PatSet []) = true | isEmptySet _ = false fun first (PatSet p) = hd p; fun next (PatSet p) = PatSet (tl p); fun cardinality(PatSet p) = List.length p (* Set from i to j inclusive. *) fun from i j = if i > j then empty else i ::: from (i + 1) j; infix 3 plus; infix 4 inside; infix 5 intersect; infix 6 diff; infix 7 eq; infix 8 eqSc infix 9 neq; (* Union of sets. *) fun a plus b = if isEmptySet a then b else if isEmptySet b then a else if first a = first b then first a ::: (next a plus next b) else if first a < first b then first a ::: (next a plus b) else first b ::: (a plus next b); (* Set membership. *) fun i inside a = if isEmptySet a then false else if i = first a then true else if i < first a then false else i inside next a (* Intersection of sets. *) fun a intersect b = if isEmptySet a orelse isEmptySet b then empty else if first a = first b then first a ::: ((next a) intersect (next b)) else if first a < first b then (next a) intersect b else a intersect next b; (* Set difference. *) fun a diff b = if isEmptySet a then empty else if isEmptySet b then a else if first a = first b then (next a) diff (next b) else if first a < first b then first a ::: ((next a) diff b) else a diff next b; (* Set equality. *) fun (PatSet a) eq (PatSet b) = a = b end (* patSet *); datatype aot = Aot of { patts: aots, (* Choices made at this point. *) defaults: patSet, (* Patterns that do not discriminate on this node. *) vars: values list (* The variables bound at this point. *) } and aots = TupleField of aot list (* Each element of the list is a field of the tuple. *) | Cons of consrec list * int (* List of constructors and the number of different constructors. *) | Excons of exconsrec list (* Exception constructors. *) | Scons of sconsrec list (* Int, char, string, real. *) | Wild (* Patterns that do not discriminate at all. *) (* Datatype constructors and exception constructors. *) withtype consrec = { constructor: values, (* The constructor itself. *) patts: patSet, (* Patterns that use this constructor *) appliedTo: aot, (* Patterns this constructor was applied to. *) polyVars: types list (* If this was polymorphic, the matched types. *) } and exconsrec = { constructor: values, patts: patSet, appliedTo: aot, exValue: machineWord option } and sconsrec = { eqFun: codetree, (* Equality functions for this type*) specVal: machineWord option, (* The constant value. NONE here means we had a conversion error. *) patts: patSet (* Patterns containing this value. *) } fun makeAot(patts, defaults, vars) = Aot { patts = patts, defaults = defaults, vars = vars } fun makeConsrec(constructor, patts, appliedTo, polyVars): consrec = { constructor = constructor, patts = patts, appliedTo = appliedTo, polyVars = polyVars } fun makeExconsrec(constructor, patts, appliedTo, exValue): exconsrec = { constructor = constructor, patts = patts, appliedTo = appliedTo, exValue = exValue } fun makeSconsrec(eqFun, specVal, patts) : sconsrec = { eqFun = eqFun, specVal = specVal, patts = patts } (* An empty wild card - can be expanded as required. *) val aotEmpty = makeAot(Wild, empty, []) (* A new wild card entry with the same defaults as a previous entry. *) fun wild (Aot {defaults, ...}) = makeAot(Wild, defaults, []) local (* Add a default (wild card or variable) to every node in the tree. *) fun addDefault (Aot {patts, defaults, vars}) patNo = let val newPatts = case patts of TupleField pl => TupleField (map (fn a => addDefault a patNo) pl) | Cons(cl, width) => let fun addDefaultToConsrec {constructor, patts, appliedTo, polyVars} = makeConsrec(constructor, patts, addDefault appliedTo patNo, polyVars) in Cons (map addDefaultToConsrec cl, width) end | Excons cl => let fun addDefaultToExconsrec {constructor, patts, appliedTo, exValue} = makeExconsrec(constructor, patts, addDefault appliedTo patNo, exValue) in Excons (map addDefaultToExconsrec cl) end | otherPattern => (* Wild, Scons *) otherPattern in makeAot(newPatts, defaults plus singleton patNo, vars) end (* addDefault *) fun addVar (Aot {patts, defaults, vars}) var = makeAot(patts, defaults, var :: vars) (* Add a constructor to the tree. It can only be added to a cons node or a wild card. *) fun addConstr(cons, noOfConstrs, doArg, tree as Aot {patts = Wild, defaults, vars, ...}, patNo, polyVars) = let (* Expand out the wildCard into a constructor node. *) val cr = makeConsrec(cons, singleton patNo, (* Expand the argument *) doArg (wild tree), polyVars); in makeAot(Cons([cr], noOfConstrs), defaults, vars) end | addConstr(cons, _, doArg, tree as Aot {patts = Cons(pl, width), defaults, vars}, patNo, polyVars) = let (* Merge this constructor with other occurences. *) fun addClist [] = (* Not there - add this on the end. *) [makeConsrec(cons, singleton patNo, doArg (wild tree), polyVars)] | addClist ((ccl as {constructor, patts, appliedTo, ... })::ccls) = if valName constructor = valName cons then (* Merge in. *) makeConsrec(cons, singleton patNo plus patts, doArg appliedTo, polyVars) :: ccls else (* Carry on looking. *) ccl :: addClist ccls; in makeAot (Cons (addClist pl, width), defaults, vars) end | addConstr _ = raise InternalError "addConstr: badly-formed and-or tree" (* Add a special constructor to the tree. Very similar to preceding. *) fun addSconstr(eqFun, cval, Aot {patts = Wild, defaults, vars, ...}, patNo, _) = (* Expand out the wildCard into a constructor node. *) makeAot (Scons [makeSconsrec(eqFun, cval, singleton patNo)], defaults, vars) | addSconstr(eqFun, cval, Aot {patts = Scons pl, defaults, vars, ...}, patNo, lex) = let (* Must be scons *) (* Merge this constructor with other occurrences. *) (* Special constants may be overloaded so we don't have a fixed set of types here. We need to use the type-specific equality function to test. Since only the basis library overloads constants we can assume that eqFun is a constant. *) fun equalSpecials(SOME a, SOME b) = let val eqCode = mkEval(eqFun, [mkTuple[mkConst a, mkConst b]]) in RunCall.unsafeCast(valOf(evalue(genCode(eqCode, debugParams lex, 0)()))) end | equalSpecials _ = false fun addClist [] = (* Not there - add this on the end. *) [makeSconsrec(eqFun, cval, singleton patNo)] | addClist ((ccl as { specVal, patts, ...}) :: ccls) = if equalSpecials(cval, specVal) then (* Merge in. *) makeSconsrec(eqFun, cval, singleton patNo plus patts) :: ccls else (* Carry on looking. *) ccl :: addClist ccls in makeAot (Scons (addClist pl), defaults, vars) end | addSconstr _ = raise InternalError "addSconstr: badly-formed and-or tree" (* Return the exception id if it is a constant. It may be a top-level exception or it could be in a top-level structure. *) local fun testAccess(Global code) = evalue code | testAccess(Selected{addr, base}) = ( case testAccess base of NONE => NONE | SOME c => evalue(mkInd(addr, mkConst c)) ) | testAccess _ = NONE in fun exceptionId(Value{access, ...}) = testAccess access end (* Add an exception constructor to the tree. Similar to the above now that non-constant exceptions are excluded from codePatt. *) fun addExconstr(cons, doArg, tree as Aot {patts = Wild, defaults, vars, ...}, patNo) = (* Expand out the wildCard into a constructor node. *) let val cr = makeExconsrec (cons, singleton patNo, doArg(wild tree), exceptionId cons) in makeAot (Excons [cr], defaults, vars) end | addExconstr(cons, doArg, tree as Aot {patts = Excons cl, defaults, vars, ...}, patNo) = let (* See if this is a constant. *) val newExval = exceptionId cons (* Two exceptions can only be considered the same if they are both constants and the same value. *) fun sameException(SOME a, SOME b) = PolyML.pointerEq(a, b) | sameException _ = false (* It would not be safe to merge exceptions if we were *) fun addClist [] = (* Not there - add this on the end. *) [makeExconsrec(cons, singleton patNo, doArg(wild tree), newExval)] | addClist ((ccl as {constructor, patts, appliedTo, exValue, ... })::ccls) = if sameException(newExval, exValue) then (* Merge in. *) makeExconsrec(constructor, singleton patNo plus patts, doArg appliedTo, exValue) :: ccls else (* Carry on looking. *) ccl :: addClist ccls in makeAot (Excons (addClist cl), defaults, vars) end | addExconstr _ = raise InternalError "addExconstr: badly-formed and-or tree" in (* Take a pattern and merge it into an andOrTree. *) fun buildAot (Ident {value=ref ident, expType=ref expType, ... }, tree, patNo, line, context as { typeVarMap, ...} ) = let val polyVars = List.map #value (getPolymorphism (ident, expType, typeVarMap)) fun doArg a = buildAot(WildCard nullLocation, a, patNo, line, context) in case ident of Value{class=Constructor {ofConstrs, ...}, ...} => (* Only nullary constructors. Constructors with arguments will be dealt with by ``isApplic'. *) addConstr(ident, ofConstrs, doArg, tree, patNo, polyVars) | Value{class=Exception, ...} => addExconstr(ident, doArg, tree, patNo) | _ => (* variable - matches everything. Defaults here and pushes a var. *) addVar (addDefault tree patNo) ident end | buildAot (TupleTree{fields, location, ...}, tree as Aot {patts = Wild, defaults = treeDefaults, vars = treeVars, ...}, patNo, _, context) = (* Adding tuple to existing wild-card *) let val tlist = map (fn el => buildAot(el, wild tree, patNo, location, context)) fields in makeAot (TupleField tlist, treeDefaults, treeVars) end | buildAot (TupleTree{fields, ...}, Aot {patts = TupleField pl, defaults = treeDefaults, vars = treeVars, ...}, patNo, line, context) = let (* Adding tuple to existing tuple. *) (* Merge each field of the tuple in with the corresponding field of the existing tree. *) val tlist = ListPair.mapEq (fn(t, a) => buildAot(t, a, patNo, line, context)) (fields, pl) in makeAot (TupleField tlist, treeDefaults, treeVars) end | buildAot (TupleTree _, _, _, _, _) = raise InternalError "pattern is not a tuple in a-o-t" | buildAot (vars as Labelled {recList, expType=ref expType, location, ...}, tree, patNo, _, context as { lex, ...}) = let (* Treat as a tuple, but in the order of the record entries. Missing entries are replaced by wild-cards. The order of the patterns given may bear no relation to the order in the record which will be matched. e.g. case X of (a = 1, ...) => ___ | (b = 2, a = 3) => ___ *) (* Check that the type is frozen. *) val () = if recordNotFrozen expType then errorNear (lex, true, vars, location, "Can't find a fixed record type.") else () (* Get the maximum number of patterns. *) val wilds = List.tabulate(recordWidth expType, fn _ => WildCard nullLocation) (* Now REPLACE entries from the actual pattern, leaving the defaulting ones behind. *) (* Take a pattern and add it into the list. *) fun mergen (_ :: t) 0 pat = pat :: t | mergen (h :: t) n pat = h :: mergen t (n - 1) pat | mergen [] _ _ = raise InternalError "mergen"; fun enterLabel ({name, valOrPat, ...}, l) = (* Put this label in the appropriate place in the tree. *) mergen l (entryNumber (name, expType)) valOrPat val tupleList = List.foldl enterLabel wilds recList in (* And process it as a tuple. *) buildAot(TupleTree{fields=tupleList, location=location, expType=ref expType}, tree, patNo, location, context) end | buildAot (Applic{f = Ident{value = ref applVal, expType = ref expType, ...}, arg, location, ...}, tree, patNo, _, context as { typeVarMap, ...}) = let val polyVars = List.map #value (getPolymorphism (applVal, expType, typeVarMap)) fun doArg atree = buildAot(arg, atree, patNo, location, context) in case applVal of Value{class=Constructor{ofConstrs, ...}, ...} => addConstr(applVal, ofConstrs, doArg, tree, patNo, polyVars) | Value{class=Exception, ...} => addExconstr(applVal, doArg, tree, patNo) | _ => tree (* Only if error *) end | buildAot (Applic _ , tree, _, _, _) = tree (* Only if error *) | buildAot (Unit _, tree, patNo, _, _) = (* There is only one value so it matches everything. *) addDefault tree patNo | buildAot (WildCard _, tree, patNo, _, _) = addDefault tree patNo (* matches everything *) | buildAot (List{elements, location, expType=ref expType, ...}, tree, patNo, _, context) = let (* Generate suitable combinations of cons and nil. e.g [1,2,3] becomes ::(1, ::(2, ::(3, nil))). *) (* Get the base type. *) val elementType = mkTypeVar (generalisable, false, false, false) val listType = mkTypeConstruction ("list", tsConstr listConstr, [elementType], [DeclaredAt inBasis]) val _ = unifyTypes(listType, expType) val polyVars = [elementType] fun processList [] tree = (* At the end put in a nil constructor. *) addConstr(nilConstructor, 2, fn a => buildAot (WildCard nullLocation, a, patNo, location, context), tree, patNo, polyVars) | processList (h :: t) tree = (* Cons node. *) let fun mkConsPat (Aot {patts = TupleField [hPat, tPat], defaults, vars, ...}) = let (* The argument is a pair consisting of the list element and the rest of the list. *) val tlist = [buildAot(h, hPat, patNo, location, context), processList t tPat]; in makeAot (TupleField tlist, defaults, vars) end | mkConsPat (tree as Aot {patts = Wild, defaults, vars, ...}) = let val hPat = wild tree; val tPat = wild tree; val tlist = [buildAot(h, hPat, patNo, location, context), processList t tPat]; in makeAot (TupleField tlist, defaults, vars) end | mkConsPat _ = raise InternalError "mkConsPat: badly-formed parse-tree" in addConstr(consConstructor, 2, mkConsPat, tree, patNo, polyVars) end (* end processList *); in processList elements tree end | buildAot (vars as Literal{converter, literal, expType=ref expType, location}, tree, patNo, _, {lex, level, ...}) = let (* At the same time we have to get the equality function for this type to plug into the code. Literals are overloaded so this may require first resolving the overload to the preferred type. *) val constr = typeConstrFromOverload(expType, true) val equality = equalityForType( mkTypeConstruction(tcName constr, constr, [], []), level, defaultTypeVarMap(fn _ => raise InternalError "equalityForType", baseLevel) (* Should never be used. *)) val litValue: machineWord option = getLiteralValue(converter, literal, expType, fn s => errorNear(lex, true, vars, location, s)) in addSconstr(equality, litValue, tree, patNo, lex) end | buildAot (Constraint {value, location, ...}, tree, patNo, _, context) = (* process the pattern *) buildAot(value, tree, patNo, location, context) | buildAot (Layered {var, pattern, location}, tree, patNo, _, context) =(* process the pattern *) let (* A layered pattern may involve a constraint which has to be removed. *) fun getVar (Ident {value, ...}) = !value | getVar (Constraint {value, ...}) = getVar value | getVar _ = undefinedValue (* error *) in addVar (buildAot(pattern, tree, patNo, location, context)) (getVar var) end | buildAot (Parenthesised(p, location), tree, patNo, _, context) = buildAot(p, tree, patNo, location, context) | buildAot (_, tree, _, _, _) = tree (* error cases *) end fun buildTree (patts: matchtree list, context) = let (* Merge together all the patterns into a single tree. *) fun maket [] _ tree = tree | maket ((MatchTree{vars, location, ...})::t) patNo tree = maket t (patNo + 1) (buildAot(vars, tree, patNo, location, context)) in maket patts 1 aotEmpty end fun bindPattVars(arg, vars, { mkAddr, level, ...}) = let val addressOfVar = mkAddr 1 val dec = mkDec (addressOfVar, arg) and load = mkLoadLocal addressOfVar (* Set the addresses of the variables and create debug entries. *) fun setAddr (Value{access=Local{addr=lvAddr, level=lvLevel}, ...}) = ( (* Set the address of the variable. *) lvAddr := addressOfVar; lvLevel := level ) | setAddr _ = raise InternalError "setAddr" val () = List.app setAddr vars in (load, dec) end local (* Find the "depth" of pattern i.e. the position of any defaults. If one of the fields is itself a tuple find the maximum depth of its fields, since if we decide to discriminate on this field we will come back and choose the deepest in that tuple. *) fun pattDepth (Aot {patts=TupleField pl, ...}, active) = List.foldl (fn (t, d) => Int.max(pattDepth(t, active), d)) 0 pl | pattDepth (Aot {patts, defaults,...}, active) = let (* Wild cards, constructors etc. *) val activeDefaults = defaults intersect active in if not (isEmptySet activeDefaults) then first activeDefaults else (* No default - the depth is the number of patterns that will be discriminated. Apart from Cons which could be a complete match, all the other cases will only occur if the match is not exhaustive. *) case patts of Cons (cl, _) => length cl + 1 | Excons cl => length cl + 1 | Scons sl => length sl + 1 | _ => 0 (* Error? *) end in fun bestColumn(colsToDo, noOfCols, asTuples, active) = let fun findDeepest(column, bestcol, depth) = if column = noOfCols (* Finished. *) then bestcol else if column inside colsToDo then let val thisDepth = pattDepth (List.nth(asTuples, column), active) in if thisDepth > depth then findDeepest (column + 1, column, thisDepth) else findDeepest (column + 1, bestcol, depth) end else findDeepest (column + 1, bestcol, depth) in findDeepest(0, 0, 0) end end (* The result of compiling the pattern match code. *) datatype pattCodeOption = PattCodeLeaf (* All the discrimination is done. *) | PattCodeBindTuple of (* The value is a tuple - take it apart. *) { tupleNo: int, next: pattCode } | PattCodeTupleSelect of (* Select a field of a tuple. *) { tupleNo: int, fieldOffset: int, next: pattCode } | PattCodeConstructors of (* Test a set of constructors *) { nConstrs: int, (* Number of constrs in datatype. 0 = infinite *) patterns: (pattCodeConstructor * pattCode) list, (* Constructor and pattern to follow. *) default: pattCode (* Pattern if none match *) } | PattCodeNaive of (* Do all the discrimination for each pattern separately. *) { pattNo: int, tests: (naiveTest * values list) list } list and pattCodeConstructor = PattCodeDatatype of values * types list | PattCodeException of values | PattCodeSpecial of codetree * machineWord option and naiveTest = NaiveWild | NaiveBindTuple of int | NaiveTupleSelect of { tupleNo: int, fieldOffset: int } | NaivePattTest of pattCodeConstructor withtype pattCode = { leafSet: patSet, (* Set of different patterns fired by the discrimination. *) leafCount: int, (* Count of number of leaves - >= cardinality of leafSet *) vars: values list, (* Variables bound to this node. May be layered i.e. id as pat *) code: pattCodeOption (* Code to apply at this node. *) } local fun pattCode(Aot {patts, defaults, vars, ...}, active: patSet, nextMatch: patSet * int -> pattCode, tupleNo) = let (* Get the set of defaults which are active. *) val activeDefaults = defaults intersect active fun makePattTest(patts, default, nConstrs) = let (* If we have included all the constructors the default may be redundant. *) val nPatts = length patts val (initSet, initCount) = if nPatts = nConstrs then (empty, 0) else (#leafSet default, #leafCount default) val defaultSet = #leafSet default (* If we have a default above a constructor then we may not need to discriminate on the constructor. This can occur in tuples where we have already discriminated on a different constructor. e.g (1, _) => ...| (_, SOME _) => ... | (_, NONE) => ... The values (1, NONE) and (1, SOME _) will both match the first pattern. *) val allSame = List.all (fn (_, { leafSet, ...}) => leafSet eq defaultSet) patts in if allSame then default else let val unionSet = foldl (fn ((_, {leafSet, ...}), s) => s plus leafSet) initSet patts val leafCount = foldl (fn ((_, {leafCount, ...}), n) => n + leafCount) initCount patts val constrs = { leafSet = unionSet, vars = [], code = PattCodeConstructors{nConstrs = nConstrs, patterns=patts, default=default}, leafCount = leafCount } in (* If the patterns are blowing up we are better off using naive matching. leafCount indicates the number of different times a pattern is fired. The cardinality of the unionSet is the number of different patterns. In particular we can have pathological cases that really blow up. See Tests/Succeed/Test133.ML. *) if leafCount > 1 andalso leafCount >= cardinality unionSet * 2 - 1 then makeNaive constrs else constrs end end val codePatt = (* If the active set is empty (match is not exhaustive) or everything will default we can skip further checks. *) if isEmptySet active orelse active eq activeDefaults then nextMatch(active, tupleNo) else case patts of TupleField [single] => (* Singleton tuple - this is just the same as the field. *) pattCode(single, active, nextMatch, tupleNo) | TupleField asTuples => let val thisTuple = tupleNo (* The address is used to refer to this tuple. *) val nextTupleNo = tupleNo+1 (* A simple-minded scheme would despatch the first column and then do the others. The scheme used here tries to do better by choosing the column that has any wild card furthest down the column. *) val noOfCols = length asTuples fun despatch colsToDo (active, tupleNo) = (* If we have done all the columns we can stop. (Or if the active set is empty). *) if isEmptySet colsToDo orelse isEmptySet active then nextMatch(active, tupleNo) else let (* Choose the best column. *) val bestcol = bestColumn(colsToDo, noOfCols, asTuples, active) (* Discriminate on the constructors in it. *) val code as { leafSet, leafCount, ...} = pattCode(List.nth(asTuples, bestcol), active, despatch (colsToDo diff (singleton bestcol)), tupleNo) (* Code to do the selection. *) val select = PattCodeTupleSelect{tupleNo = thisTuple, fieldOffset = bestcol, next = code } in { leafSet = leafSet, leafCount = leafCount, vars = [], code = select } end val takeApartTuple as { leafSet, leafCount, ...} = despatch (from 0 (noOfCols-1)) (active, nextTupleNo) val code = PattCodeBindTuple { tupleNo=tupleNo, next = takeApartTuple } in { leafSet = leafSet, leafCount = leafCount, vars=[], code=code } end | Cons(cl, width) => let fun doConstr({ patts, constructor, appliedTo, polyVars, ...}, rest) = let (* If this pattern is in the active set we discriminate on it. *) val newActive = patts intersect active in if isEmptySet newActive then (* No point *) rest else let val thenCode = pattCode(appliedTo, newActive plus activeDefaults, nextMatch, tupleNo) in (PattCodeDatatype(constructor, polyVars), thenCode) :: rest end end val pattList = foldl doConstr [] cl in makePattTest(pattList, nextMatch(activeDefaults, tupleNo), width) end | Excons cl => let (* We now process exception constructors in the same way as datatype constructors. This is only valid because all the exception constructors are constants. *) fun doConstr({ patts, constructor, appliedTo, ...}, rest) = let (* If this pattern is in the active set we discriminate on it. *) val newActive = patts intersect active in if isEmptySet newActive then (* No point *) rest else let val thenCode = pattCode(appliedTo, newActive plus activeDefaults, nextMatch, tupleNo) in (PattCodeException constructor, thenCode) :: rest end end val pattList = foldl doConstr [] cl in makePattTest(pattList, nextMatch(activeDefaults, tupleNo), 0) end | Scons sl => let (* Int, char, string *) (* Generate if..then..else for each of the choices. *) fun doConstr({ patts, eqFun, specVal, ...}, rest) = let val newActive = patts intersect active in if isEmptySet newActive then (* No point *) rest else (PattCodeSpecial(eqFun, specVal), nextMatch(newActive plus activeDefaults, tupleNo)) :: rest end val pattList = foldl doConstr [] sl in makePattTest(pattList, nextMatch(activeDefaults, tupleNo), 0) end | Wild => nextMatch(activeDefaults, tupleNo) in { leafSet = #leafSet codePatt, leafCount = #leafCount codePatt, vars=vars @ #vars codePatt, code = #code codePatt } end (* Turn a decision tree into a series of tests for each pattern. *) and makeNaive(pattern as { leafSet, vars, ... }) = let fun createTests(_, { code = PattCodeLeaf, vars, ...}) = [(NaiveWild, vars)] | createTests(pat, { code = PattCodeBindTuple{ tupleNo, next }, vars, ... }) = (NaiveBindTuple tupleNo, vars) :: createTests(pat, next) | createTests(pat, { code = PattCodeTupleSelect { tupleNo, fieldOffset, next }, vars, ...}) = (NaiveTupleSelect { tupleNo = tupleNo, fieldOffset = fieldOffset }, vars) :: createTests(pat, next) | createTests(pat, { code = PattCodeConstructors { patterns, default, ... }, vars, ...}) = if pat inside #leafSet default (* If it's in the default set we don't discriminate here. *) then (NaiveWild, vars) :: createTests(pat, default) else let (* If it's not in the default it must be in one of the constructors. *) val (constr, code) = valOf(List.find(fn (_, {leafSet, ...}) => pat inside leafSet) patterns) in (NaivePattTest constr, vars) :: createTests(pat, code) end | createTests(pat, { code = PattCodeNaive l, vars, ...}) = let val { tests, ...} = valOf(List.find(fn{pattNo, ...} => pat = pattNo) l) in (NaiveWild, vars) :: tests end fun createPatts setToDo = if isEmptySet setToDo then [] else let val pat = first setToDo val entry = { pattNo = pat, tests = createTests(pat, pattern) } val otherPatts = createPatts(setToDo diff singleton pat) in (* Normally we want the patterns in order since earlier ones will generally be more specific. If 0 is in the set it represents "non-exhaustive" and must go last. *) if pat = 0 then otherPatts @ [entry] else entry :: otherPatts end in { leafSet=leafSet, vars=vars, code=PattCodeNaive(createPatts leafSet), leafCount = cardinality leafSet } end in fun buildPatternCode(tree, noOfPats, alwaysNaive) = let fun firePatt(pattsLeft, _) = let val pattern = if isEmptySet pattsLeft then 0 (* This represents non-exhaustive. *) else first pattsLeft in { vars = [], code = PattCodeLeaf, leafSet = singleton pattern, leafCount = 1 } end val patts = pattCode(tree, from 1 noOfPats, firePatt, 0) in if alwaysNaive then makeNaive patts else patts end end local val EXC_Bind = 100 val EXC_Match = 101 (* Raises an exception. *) fun raiseException(exName, exIden, line) = mkRaise (mkTuple [exIden, mkStr exName, CodeZero, codeLocation line]); (* Create exception values - Small integer values are used for run-time system exceptions. *) val bindExceptionVal = mkConst (ADDRESS.toMachineWord EXC_Bind); val matchExceptionVal = mkConst (ADDRESS.toMachineWord EXC_Match); in (* Raise match and bind exceptions. *) fun raiseBindException line = raiseException("Bind", bindExceptionVal, line) and raiseMatchException line = raiseException("Match", matchExceptionVal, line) end (* Turn the decision tree into real code. *) local (* Guard and inversion code for constructors *) fun constructorCode(PattCodeDatatype(cons, polyVars), arg, {level, typeVarMap, ...}) = ( makeGuard (cons, polyVars, arg, level, typeVarMap), makeInverse (cons, polyVars, arg, level, typeVarMap) ) | constructorCode(PattCodeException cons, arg, {level, typeVarMap, ...}) = ( makeGuard (cons, [], arg, level, typeVarMap), makeInverse (cons, [], arg, level, typeVarMap) ) | constructorCode(PattCodeSpecial(eqFun, cval), arg, _) = let val constVal = case cval of SOME cv => mkConst cv | NONE => CodeZero in (mkEval(eqFun, [mkTuple[arg, constVal]]), CodeZero (* Unused *)) end (* Sequence of tests for naive match. *) fun makeNaiveTests([], _, _, _) = CodeTrue | makeNaiveTests ((NaiveWild, _) :: rest, arg, tupleMap, context) = makeNaiveTests(rest, arg, tupleMap, context) | makeNaiveTests ((NaiveBindTuple tupleNo, _) :: rest, arg, tupleMap, context) = let (* Bind it to a variable. We don't set the addresses of the vars at this point. *) val (declLoad, declDec) = bindPattVars(arg, [], context) in mkEnv([declDec], makeNaiveTests(rest, arg, (tupleNo, declLoad) :: tupleMap, context)) end | makeNaiveTests ((NaiveTupleSelect { tupleNo, fieldOffset}, _) :: rest, _, tupleMap, context) = let val findTuple = List.find(fn(a, _) => tupleNo = a) tupleMap in makeNaiveTests(rest, mkInd(fieldOffset, #2 (valOf findTuple)), tupleMap, context) end | makeNaiveTests ((NaivePattTest constr, _) :: rest, arg, tupleMap, context) = let (* Bind it to a variable. This avoids making multiple copies of code. *) val (declLoad, declDec) = bindPattVars(arg, [], context) val (thisTest, inverse) = constructorCode(constr, declLoad, context) in mkEnv([declDec], mkCand(thisTest, makeNaiveTests(rest, inverse, tupleMap, context))) end (* Load all the variables. *) fun makeLoads([], _, _, _, _) = [] | makeLoads((pattern, vars) :: rest, patNo, arg, tupleMap, context) = let val (declLoad, declDec) = bindPattVars(arg, vars, context) val pattLoad = case pattern of NaiveWild => makeLoads(rest, patNo, declLoad, tupleMap, context) | NaiveBindTuple tupleNo => makeLoads(rest, patNo, declLoad, (tupleNo, declLoad) :: tupleMap, context) | NaiveTupleSelect { tupleNo, fieldOffset} => let val findTuple = List.find(fn(a, _) => tupleNo = a) tupleMap in makeLoads(rest, patNo, mkInd(fieldOffset, #2 (valOf findTuple)), tupleMap, context) end | NaivePattTest constr => let val (_, inverse) = constructorCode(constr, declLoad, context) in makeLoads(rest, patNo, inverse, tupleMap, context) end in declDec :: pattLoad end in fun codeGenerateMatch(patCode, arg, firePatt, context: matchContext as {level, typeVarMap, ...}) = let fun codeMatch({ leafSet, vars, code, ...}, arg, tupleMap) = let (* Bind the current value to a codetree variable and set the addresses of any ML variables to this. *) val (declLoad, declDec) = bindPattVars(arg, vars, context) val pattCode = case code of PattCodeLeaf => (* Finished - fire the pattern. *) firePatt(first leafSet) | PattCodeBindTuple { tupleNo, next }=> (* Bind the tuple number to this address. *) codeMatch(next, arg, (tupleNo, declLoad) :: tupleMap) | PattCodeTupleSelect { tupleNo, fieldOffset, next } => let (* The tuple number should be in the map. Find the address and select the field. *) val findTuple = List.find(fn(a, _) => tupleNo = a) tupleMap in codeMatch(next, mkInd(fieldOffset, #2 (valOf findTuple)), tupleMap) end | PattCodeConstructors { nConstrs, patterns, default } => let fun doPattern((PattCodeDatatype(cons, polyVars), code) :: rest, 1) = (* This is the last pattern and we have done all the others. We don't need to test this one and we don't use the default. *) let val _ = null rest orelse raise InternalError "doPattern: not at end" val invertCode = makeInverse (cons, polyVars, declLoad, level, typeVarMap) in codeMatch(code, invertCode, tupleMap) end | doPattern([], _) = (* We've done all of them - do the default *) codeMatch(default, arg, tupleMap) | doPattern((constructor, matchCode) :: next, constrsLeft) = let val (testCode, invertCode) = constructorCode(constructor, declLoad, context) val thenCode = codeMatch(matchCode, invertCode, tupleMap) in mkIf(testCode, thenCode, doPattern(next, constrsLeft-1)) end in doPattern(patterns, nConstrs) end | PattCodeNaive patterns => let fun makePatterns [] = raise InternalError "makeTests: empty" | makePatterns ({ tests, pattNo} :: rest) = let val pattDecs = makeLoads(tests, pattNo, arg, tupleMap, context) val pattCode = mkEnv(pattDecs, firePatt pattNo) in (* If this is the last one there's no need for a test. *) if null rest then pattCode else mkIf(makeNaiveTests(tests, arg, tupleMap, context), pattCode, makePatterns rest) end in makePatterns patterns end in mkEnv([declDec], pattCode) end in codeMatch(patCode, arg, []) end (* Binding. This should be a single naive match. Generally it will be exhaustive so we will only have to load the variables. *) fun codeBinding( { leafSet, vars, code = PattCodeNaive({ tests, ...} :: _ (* Normally nil but could be PattCodeWild if non-exhaustive *)), ...}, arg, line, context) = let (* Bind this to a variable and set any top-level variable(s). *) val (declLoad, declDec) = bindPattVars(arg, vars, context) (* Create any test code to raise the bind exception *) val testCode = if not (0 inside leafSet) then [] (* Exhaustive - no test needed. *) else [mkNullDec(mkIf(makeNaiveTests(tests, declLoad, [], context), CodeZero, raiseBindException line))] (* Load the variables. *) val pattDecs = makeLoads(tests, 1, declLoad, [], context) in declDec :: testCode @ pattDecs end | codeBinding _ = raise InternalError "codeBinding: should be naive pattern match" end fun containsNonConstException(Aot{patts = TupleField fields, ...}) = List.foldl(fn (aot, t) => t orelse containsNonConstException aot) false fields | containsNonConstException(Aot{patts = Cons(cl, _), ...}) = List.foldl(fn ({appliedTo, ...}, t) => t orelse containsNonConstException appliedTo) false cl | containsNonConstException(Aot{patts = Excons cl, ...}) = List.foldl(fn ({appliedTo, exValue, ...}, t) => t orelse not (isSome exValue) orelse containsNonConstException appliedTo) false cl | containsNonConstException _ = false (* Scons or Wild *) (* Process a pattern in a binding. *) (* This previously used codePatt with special options to generate the correct structure for a binding. This does the test separately from loading the variables. If the pattern is not exhaustive this may do more work since the pattern is taken apart both in the test and for loading. *) fun codeBindingPattern(vbDec, arg, line, context) = let (* Build the tree. *) val andortree = buildAot(vbDec, aotEmpty, 1, line, context) (* Build the pattern code *) val patternCode as { leafSet, ... } = buildPatternCode(andortree, 1, true (* Always *)) (* It's not exhaustive if pattern zero is in the set. *) val exhaustive = not (0 inside leafSet) val codeDecs = codeBinding(patternCode, arg, line, context) in (codeDecs, exhaustive) end (* Process a set of patterns in a match. *) (* Naive match code. Doesn't check for exhaustiveness or redundancy. *) fun codeMatchPatterns(alt, arg, isHandlerMatch, lineNo, codePatternExpression, context as { lex, ...}) = let val noOfPats = length alt val andortree = buildTree(alt, context) (* If the match is sparse or there are any non-constant exceptions we need to use pattern-by-pattern matching. Non-constant exceptions could involve exception aliasing and this complicates pattern matching. It could break the rule that says that if a value matches one constructor it cannot then match any other. If we are compiling with debugging we also use the naive match. *) val alwaysNaive = containsNonConstException andortree orelse getParameter debugTag (debugParams lex) val patternCode as { leafSet, ... } = buildPatternCode(andortree, noOfPats, alwaysNaive) (* It's not exhaustive if pattern zero is in the set. *) val exhaustive = not (0 inside leafSet) fun firePatt 0 = ( exhaustive andalso raise InternalError "codeDefault called but exhaustive"; if isHandlerMatch then mkRaise arg else raiseMatchException lineNo ) | firePatt pattChosen = codePatternExpression(pattChosen - 1) in (codeGenerateMatch(patternCode, arg, firePatt, context), exhaustive) end (* Types that can be shared. *) structure Sharing = struct type parsetree = parsetree type typeVarMap = typeVarMap type level = level type codetree = codetree type matchtree = matchtree type codeBinding = codeBinding type lexan = lexan end end; diff --git a/mlsource/MLCompiler/STRUCTURES_.ML b/mlsource/MLCompiler/STRUCTURES_.ML index 207d3bde..8a9704d3 100644 --- a/mlsource/MLCompiler/STRUCTURES_.ML +++ b/mlsource/MLCompiler/STRUCTURES_.ML @@ -1,3310 +1,3310 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited Modified D.C.J. Matthews 2001-2016 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Title: Module Structure and Operations. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) functor STRUCTURES_ ( structure LEX : LEXSIG structure CODETREE : CODETREESIG structure STRUCTVALS : STRUCTVALSIG; structure VALUEOPS : VALUEOPSSIG; structure EXPORTTREE: EXPORTTREESIG structure TYPETREE : TYPETREESIG structure PARSETREE : PARSETREESIG structure PRETTY : PRETTYSIG structure COPIER: COPIERSIG structure TYPEIDCODE: TYPEIDCODESIG structure SIGNATURES: SIGNATURESSIG -structure DEBUGGER : DEBUGGERSIG +structure DEBUGGER : DEBUGGER structure UTILITIES : sig val noDuplicates: (string * 'a * 'a -> unit) -> { apply: (string * 'a -> unit) -> unit, enter: string * 'a -> unit, lookup: string -> 'a option }; val searchList: unit -> { apply: (string * 'a -> unit) -> unit, enter: string * 'a -> unit, lookup: string -> 'a option }; val splitString: string -> { first:string,second:string } end; structure UNIVERSALTABLE: sig type universal = Universal.universal type univTable type 'a tag = 'a Universal.tag val univEnter: univTable * 'a tag * string * 'a -> unit; val univLookup: univTable * 'a tag * string -> 'a option; val univFold: univTable * (string * universal * 'a -> 'a) * 'a -> 'a; end; structure DEBUG: DEBUGSIG sharing LEX.Sharing = VALUEOPS.Sharing = TYPETREE.Sharing = PARSETREE.Sharing = PRETTY.Sharing = EXPORTTREE.Sharing = STRUCTVALS.Sharing = COPIER.Sharing = CODETREE = UNIVERSALTABLE = TYPEIDCODE.Sharing = SIGNATURES.Sharing = DEBUGGER.Sharing ) : STRUCTURESSIG = (*****************************************************************************) (* STRUCTURES functor body *) (*****************************************************************************) struct open Misc; open PRETTY; open COPIER; open LEX; open CODETREE; open STRUCTVALS; open VALUEOPS; open TYPETREE; open PARSETREE; open UTILITIES; open DEBUG; open UNIVERSALTABLE; open Universal; (* for tag record selectors *) open EXPORTTREE; open TYPEIDCODE open SIGNATURES open DEBUGGER (* Transitional bindings. Calls to these should be replaced by pattern matching. *) fun sigTab (Signatures {tab,...}) = tab and sigMinTypes (Signatures {firstBoundIndex,...}) = firstBoundIndex and sigMaxTypes (Signatures {firstBoundIndex, boundIds,...}) = firstBoundIndex + List.length boundIds and sigTypeIdMap (Signatures {typeIdMap, ...}) = typeIdMap and sigBoundIds (Signatures {boundIds, ...}) = boundIds fun structName (Struct {name,...}) = name and structAccess (Struct {access,...}) = access and structLocations (Struct {locations,...}) = locations and structSignat (Struct {signat,...}) = signat (* Union of the various kinds of core language declaration. Structures are included because they can be declared by opening a structure with substructures. *) datatype coreDeclaration = CoreValue of values | CoreType of typeConstrSet | CoreFix of string*fixStatus (* Include the name because it isn't part of fixStatus. *) | CoreStruct of structVals (* Description of the actions to perform when a structure matches a signature. *) datatype valueMatching = ValueMatch of { sourceValue: values, targetType: types, coercion: valueCoercions } | StructureMatch of { sourceStructure: structVals, contentsMatch: structureMatch} | TypeIdMatch of { sourceIdNo: int, isEquality: bool } and valueCoercions = (* The coercions that may apply to a value. *) NoCoercion | ExceptionToValue | ConstructorToValue withtype structureMatch = (int * valueMatching) list (* "structs" is the abstract syntax for the module language. *) datatype structValue = StructureIdent of (* A structure name *) { name: string, (* The name *) valRef: structVals option ref, (* The variable found. *) location: location } | StructDec of (* struct ... end *) { alist: structDec list, (* List of items in it. *) location: location, matchToResult: structureMatch ref } | FunctorAppl of (* Application of a functor. *) { name: string, arg: structValue, valRef: functors option ref, (* The functor looked up. *) nameLoc: location, (* The location of the name itself. *) fullLoc: location, (* The location of the full application. *) argIds: { source: typeId, dest: typeId } list ref, (* The IDs that are required in the arguments. *) resIds: { source: typeId, dest: typeId } list ref, (* Generative IDs in the result. *) matchToArgument: structureMatch ref } | LetDec of (* let strdec in strexp. *) { decs: structDec list, body: structValue, line: location } | SigConstraint of (* Constraint of str to match sig. *) { str: structValue, (* Structure to constrain *) csig: sigs, (* Constraining signature *) opaque: bool, (* True if opaque, false if transparent. *) sigLoc: location, opaqueIds: { source : typeId, dest: typeId } list ref, matchToConstraint: structureMatch ref } and structDec = StructureDec of (* List of structure decs *) { bindings: structBind list, typeIdsForDebug: typeId list ref, line: location } | CoreLang of (* Any other decln. *) { dec: parsetree, (* The value *) vars: coreDeclaration list ref, (* The declarations *) location: location } | Localdec of (* Local strdec in strdec. *) { decs: structDec list, body: structDec list, line: location } withtype structBind = { name: string, (* The name of the structure *) nameLoc: location, haveSig: bool, (* Whether we moved an explicit signature to the value. *) value: structValue, (* And its value *) valRef: structVals option ref, (* The structure variable declared. *) line: location } fun mkStructIdent (name, location) = StructureIdent { name = name, valRef = ref NONE, location = location } (* For struct...end, make a signature to accept the values. *) fun mkStruct(alist, location) = StructDec { alist = alist, location = location, matchToResult = ref [] }; fun mkCoreLang (dec, location) = CoreLang { dec = dec, vars = ref [], location = location }; fun mkFunctorAppl (name, arg, nameLoc, fullLoc) = FunctorAppl { name = name, arg = arg, valRef = ref NONE, nameLoc = nameLoc, fullLoc = fullLoc, argIds = ref nil, resIds = ref nil, matchToArgument = ref [] }; fun mkFormalArg (name, signat) = { name = name, sigStruct = signat, valRef = ref NONE } fun mkLocaldec (decs, body, line) = Localdec { decs = decs, body = body, line = line }; fun mkLetdec (decs, body, line) = LetDec { decs = decs, body = body, line = line }; fun mkSigConstraint(str, csig, opaque, sigLoc) = SigConstraint { str=str, csig=csig, opaque=opaque, sigLoc=sigLoc, opaqueIds=ref nil, matchToConstraint = ref [] } fun mkStructureDec(bindings, line) = StructureDec { bindings = bindings, typeIdsForDebug = ref [], line = line } fun mkStructureBinding ((name, nameLoc), signat, value, fullLoc): structBind = let (* If there's an explicit signature move that to a constraint. *) val value = case signat of NONE => value | SOME (csig, opaque, sigLoc) => mkSigConstraint(value, csig, opaque, sigLoc) in { name = name, nameLoc = nameLoc, haveSig = isSome signat, value = value, valRef = ref NONE, line = fullLoc } end; type formalArgStruct = { name: string, sigStruct: sigs, valRef: structVals option ref } (* The structure variable. *) (* Top level declarations and program. *) datatype topdec = StrDec of structDec * typeId list ref (* Structure decs and core lang. *) | FunctorDec of functorBind list * location (* List of functor decs. *) | SignatureDec of sigBind list * location (* List of signature decs *) withtype (* Functor binding. *) functorBind = { name: string, nameLoc: location, haveSig: bool, (* Whether we moved an explicit signature to the value. *) body: structValue, arg: formalArgStruct, valRef: functors option ref, (* The functor variable declared. *) resIds: { source: typeId, dest: typeId } list ref, line: location, matchToResult: structureMatch ref, (* If we are debugging we need these at code-gen time. *) debugArgVals: values list ref, debugArgStructs: structVals list ref, debugArgTypeConstrs: typeConstrSet list ref } and sigBind = { name: string, (* The name of the signature *) nameLoc: location, sigStruct: sigs,(* Its value *) sigRef: signatures ref, (* The "value" of the signature. *) line: location } fun mkTopDec t = StrDec(t, ref nil) and mkFunctorDec s = FunctorDec s and mkSignatureDec s = SignatureDec s; fun mkFunctorBinding (name, nameLoc, signat, body, arg, line): functorBind = let (* If there's an explicit signature move that to a constraint. *) val body = case signat of NONE => body | SOME (csig, opaque, sigLoc) => mkSigConstraint(body, csig, opaque, sigLoc) in { name = name, nameLoc = nameLoc, haveSig = isSome signat, body = body, arg = arg, valRef = ref NONE, resIds = ref nil, line = line, matchToResult = ref [], debugArgVals = ref [], debugArgStructs = ref [], debugArgTypeConstrs = ref [] } end and mkSignatureBinding ((name, nameLoc), sg, ln) = { name = name, nameLoc = nameLoc, sigStruct = sg, line = ln, sigRef = ref undefinedSignature } type program = topdec list * location fun mkProgram tl = tl (* Pretty printing *) fun displayList ([], _, _) _ = [] | displayList ([v], _, depth) dodisplay = if depth <= 0 then [PrettyString "..."] else [dodisplay (v, depth)] | displayList (v::vs, separator, depth) dodisplay = if depth <= 0 then [PrettyString "..."] else let val brk = if separator = "," orelse separator = ";" then 0 else 1 in PrettyBlock (0, false, [], [ dodisplay (v, depth), PrettyBreak (brk, 0), PrettyString separator ] ) :: PrettyBreak (1, 0) :: displayList (vs, separator, depth - 1) dodisplay end (* displayList *) fun displayStruct (str, depth: FixedInt.int) = if depth <= 0 (* elide further text. *) then PrettyString "..." else case str of StructureDec { bindings = structList, ...} => let fun displayStructBind ( {name, haveSig, value, ...}: structBind, depth) = let (* If we desugared this before, return it to its original form. *) val (sigStruct, value) = case (haveSig, value) of (true, SigConstraint{str, csig, opaque, sigLoc, ...}) => (SOME(csig, opaque, sigLoc), str) | _ => (NONE, value) in PrettyBlock (3, false, [], PrettyString name :: ( case sigStruct of (* Signature is optional *) NONE => [] | SOME (sigStruct, opaque, _) => [ PrettyString (if opaque then " :>" else " :"), PrettyBreak (1, 0), displaySigs (sigStruct, depth - 1) ] ) @ [ PrettyString " =", PrettyBreak (1, 0), displayStructValue (value, depth - 1) ] ) end in PrettyBlock (3, false, [], PrettyString "structure" :: PrettyBreak (1, 0) :: displayList (structList, "and", depth) displayStructBind ) end | Localdec {decs, body, ...} => PrettyBlock (3, false, [], PrettyString "local" :: PrettyBreak (1, 0) :: displayList (decs, ";", depth - 1) displayStruct @ [ PrettyBreak (1, 0), PrettyString "in", PrettyBreak (1, 0)] @ displayList (body, ";", depth - 1) displayStruct @ [ PrettyBreak (1, 0), PrettyString "end" ] ) | CoreLang {dec, ...} => displayParsetree (dec, depth - 1) and displayStructValue (str, depth) = if depth <= 0 (* elide further text. *) then PrettyString "..." else case str of StructureIdent {name, ...} => PrettyString name | StructDec {alist, ...} => PrettyBlock (1, true, [], PrettyString "struct" :: PrettyBreak (1, 0) :: displayList (alist, "", depth) displayStruct @ [ PrettyBreak (1, 0), PrettyString "end"] ) | FunctorAppl {name, arg, ...} => PrettyBlock (1, false, [], [ PrettyString (name ^ "("), PrettyBreak (0, 0), displayStructValue (arg, depth), PrettyBreak (0, 0), PrettyString ")" ] ) | LetDec {decs, body, ...} => PrettyBlock (3, false, [], PrettyString "let" :: PrettyBreak (1, 0) :: displayList (decs, ";", depth - 1) displayStruct @ [ PrettyBreak (1, 0), PrettyString "in", PrettyBreak (1, 0), displayStructValue (body, depth - 1) ] @ [ PrettyBreak (1, 0), PrettyString "end" ] ) | SigConstraint{str, csig, opaque, ...} => PrettyBlock (0, false, [], [ displayStructValue (str, depth - 1), PrettyString (if opaque then " :>" else " :"), PrettyBreak (1, 0), displaySigs (csig, depth - 1) ] ) fun displayTopDec(top, depth) = if depth <= 0 (* elide further text. *) then PrettyString "..." else case top of StrDec(s, _) => displayStruct(s, depth) | SignatureDec (structList : sigBind list, _) => let fun displaySigBind ({name, sigStruct, ...}: sigBind, depth) = PrettyBlock (3, false, [], [ PrettyString (name ^ " ="), PrettyBreak (1, 0), displaySigs (sigStruct, depth - 1) ] ) in PrettyBlock (3, false, [], PrettyString "signature" :: PrettyBreak (1, 0) :: displayList (structList, "and", depth) displaySigBind ) end | FunctorDec (structList : functorBind list, _) => let fun displayFunctBind ( {name, arg={name=argName, sigStruct=argStruct, ...}, haveSig, body, ...}, depth) = let val (sigStruct, body) = case (haveSig, body) of (true, SigConstraint{str, csig, opaque, sigLoc, ...}) => (SOME(csig, opaque, sigLoc), str) | _ => (NONE, body) in PrettyBlock (3, false, [], PrettyString (name ^ "(") :: PrettyBreak (1, 0) :: PrettyBlock (1, false, [], ( if argName = "" then [] else [ PrettyString (argName ^ " :"), PrettyBreak (1, 2)] ) @ [displaySigs (argStruct, depth - 1)] ) :: PrettyString ")" :: ( case sigStruct of NONE => [] (* Signature is optional *) | SOME (sigStruct, opaque, _) => [ PrettyString(if opaque then " :>" else " :"), PrettyBreak (1, 0), displaySigs (sigStruct, depth - 1) ] ) @ [ PrettyBreak (1, 0), PrettyString "=", PrettyBreak (1, 0), displayStructValue (body, depth - 1) ] ) end in PrettyBlock (3, false, [], PrettyString "functor" :: PrettyBreak (1, 0) :: displayList (structList, "and", depth) displayFunctBind ) end (* End displayTopDec *) fun displayProgram ((sl, _), d) = PrettyBlock(0, true, [], displayList (sl, "", d) displayTopDec ) fun structExportTree(navigation, s: structDec) = let (* Common properties for navigation and printing. *) val commonProps = PTprint(fn d => displayStruct(s, d)) :: exportNavigationProps navigation fun asParent () = structExportTree(navigation, s) in case s of StructureDec{ bindings = sbl, line = location, ...} => let fun exportSB(navigation, sb as {name, nameLoc, haveSig, value, line, valRef=ref structOpt, ...}) = let (* If we desugared this before, return it to its original form. *) val (sigStruct, value) = case (haveSig, value) of (true, SigConstraint{str, csig, opaque, sigLoc, ...}) => (SOME(csig, opaque, sigLoc), str) | _ => (NONE, value) fun exportThis () = exportSB(navigation, sb) (* Three groups: name, signature and structures. It's all complicated because the signature may not be present. *) val locProps = case structOpt of SOME(Struct{locations, ...}) => definingLocationProps locations | _ => [] fun getName () = let val next = case sigStruct of SOME _ => getSigStruct | NONE => getValue in getStringAsTree({parent=SOME exportThis, previous=NONE, next=SOME next}, name, nameLoc, locProps) end and getSigStruct () = let val next = SOME getValue val (theSig, _, _) = valOf sigStruct in sigExportTree({parent=SOME exportThis, previous=SOME getName, next=next}, theSig) end and getValue () = let val previous = case sigStruct of NONE => getName | SOME _ => getSigStruct in structValueExportTree({parent=SOME exportThis, previous=SOME previous, next=NONE}, value) end in (line, PTfirstChild getName :: exportNavigationProps navigation) end val expChild = exportList(exportSB, SOME asParent) sbl in (location, expChild @ commonProps) end | CoreLang {dec, ...} => (* A value parse-tree entry. *) getExportTree(navigation, dec) | Localdec {decs, body, line, ...} => (line, exportList(structExportTree, SOME asParent) (decs @ body) @ commonProps) end and structValueExportTree(navigation, s: structValue) = let (* Common properties for navigation and printing. *) val commonProps = PTprint(fn d => displayStructValue(s, d)) :: exportNavigationProps navigation fun asParent () = structValueExportTree(navigation, s) in case s of StructureIdent { valRef = ref var, location, ... } => let val locs = case var of SOME(Struct{locations, ...}) => locations | NONE => [] in (* Get the location properties for the identifier. *) (location, mapLocationProps locs @ commonProps) end | StructDec{ location, alist, ...} => (location, exportList(structExportTree, SOME asParent) alist @ commonProps) | FunctorAppl { valRef, name, nameLoc, fullLoc, arg, ... } => let val locs = case ! valRef of SOME(Functor { locations, ...}) => locations | NONE => [] (* Navigate between the functor name and the argument. *) (* The first position is the expression, the second the type *) fun getFunctorName () = getStringAsTree({parent=SOME asParent, previous=NONE, next=SOME getFunctorArg}, name, nameLoc, mapLocationProps locs) and getFunctorArg () = structValueExportTree({parent=SOME asParent, previous=SOME getFunctorName, next=NONE}, arg) in (fullLoc, PTfirstChild getFunctorName :: commonProps) end | LetDec {decs, body, line, ...} => let (* For simplicity just merge these as a single list. *) datatype allEntries = Value of structValue | Dec of structDec fun exportEntries(navigation, Value strval) = structValueExportTree(navigation, strval) | exportEntries(navigation, Dec strdec) = structExportTree(navigation, strdec) in (line, exportList(exportEntries, SOME asParent) (List.map Dec decs @ [Value body]) @ commonProps) end | SigConstraint { str, csig, sigLoc, ... } => let (* Navigate between the functor name and the argument. *) (* The first position is the expression, the second the type *) fun getStructure () = structValueExportTree({parent=SOME asParent, previous=NONE, next=SOME getSignature}, str) and getSignature () = sigExportTree({parent=SOME asParent, previous=SOME getStructure, next=NONE}, csig) in (sigLoc, PTfirstChild getStructure :: commonProps) end end fun topDecExportTree(navigation, top: topdec) = let (* Common properties for navigation and printing. *) val commonProps = PTprint(fn d => displayTopDec(top, d)) :: exportNavigationProps navigation fun asParent () = topDecExportTree(navigation, top) in case top of StrDec(s, _) => structExportTree(navigation, s) | SignatureDec(sigs, location) => let fun exportSB(navigation, sb as {name, nameLoc, sigStruct, line, sigRef=ref(Signatures{locations, ...}), ...}) = let fun exportThis () = exportSB(navigation, sb) fun getName () = getStringAsTree({parent=SOME exportThis, previous=NONE, next=SOME getSig}, name, nameLoc, definingLocationProps locations) and getSig () = sigExportTree({parent=SOME exportThis, previous=SOME getName, next=NONE}, sigStruct) in (line, PTfirstChild getName :: exportNavigationProps navigation) end in (location, exportList(exportSB, SOME asParent) sigs @ commonProps) end | FunctorDec(fbl, location) => let fun exportFB(navigation, fb as {name, nameLoc, haveSig, arg={sigStruct=argStruct, ...}, body, line, valRef=ref optFunc, ...}) = let val locations = case optFunc of SOME(Functor{locations, ...}) => locations | _ => [] val (sigStruct, body) = case (haveSig, body) of (true, SigConstraint{str, csig, opaque, sigLoc, ...}) => (SOME(csig, opaque, sigLoc), str) | _ => (NONE, body) val fbProps = exportNavigationProps navigation fun exportThis () = exportFB(navigation, fb) (* Because the signature is optional navigation on the arg and body depends on whether there's a signature. *) fun getName() = getStringAsTree({parent=SOME exportThis, previous=NONE, next=SOME getArg}, name, nameLoc, definingLocationProps locations) and getArg() = let val next = if isSome sigStruct then getSig else getBody in sigExportTree({parent=SOME exportThis, previous=SOME getName, next=SOME next}, argStruct) end and getSig() = sigExportTree({parent=SOME exportThis, previous=SOME getArg, next=SOME getBody}, #1(valOf sigStruct)) and getBody() = let val previous = if isSome sigStruct then getSig else getArg in structValueExportTree({parent=SOME exportThis, previous=SOME previous, next=NONE}, body) end in (line, PTfirstChild getName :: fbProps) end val expChild = exportList(exportFB, SOME asParent) fbl in (location, expChild @ commonProps) end end (* Convert a "program" into a navigable tree. *) fun structsExportTree (parentTree, trees: program) = let val parentTreeNav = exportNavigationProps parentTree (* The top level is actually a list. *) fun exportTree(([], location)) = (location, parentTreeNav) | exportTree(topdec as (sl, location)) = let fun getEntry(this as (s :: sl), getPrevious) (): exportTree = topDecExportTree( { parent = SOME(fn () => exportTree topdec), (* Parent is this. *) previous = getPrevious, (* If we have a successor then that is the entry and its predecessor returns here. *) next = case sl of [] => NONE | t => SOME(getEntry(t, SOME(getEntry(this, getPrevious)))) }, s ) | getEntry _ () = raise Empty in (location, parentTreeNav @ [PTfirstChild(getEntry(sl, NONE))]) end in exportTree trees end (* Puts out an error message and then prints the piece of tree. *) fun errorMsgNear (lex, hard, near, lno, message) : unit = let val parameters = debugParams lex val errorDepth = getParameter errorDepthTag parameters in reportError lex { hard = hard, location = lno, message = message, context = SOME(near errorDepth) } end; (* TODO: If the item being errored is in a substructure it currently doesn't report the name of the substructure. *) (* Report an error about signature-structure matching. *) fun sigStructMatchMsg (lex, near, lno, structName) (doDisplay: 'a -> pretty) (structValue: 'a, sigValue: 'a, reason) = let val message = PrettyBlock(3, true, [], [ PrettyString ("Structure does not match signature" ^ (if structName = "" then "." else " in sub-structure " ^ structName)), PrettyBreak(1, 0), PrettyBlock(3, false, [], [ PrettyString "Signature:", PrettyBreak(1, 0), doDisplay sigValue ]), PrettyBreak(1, 0), PrettyBlock(3, false, [], [ PrettyString "Structure:", PrettyBreak(1, 0), doDisplay structValue ]), PrettyBreak(1, 0), PrettyBlock(3, false, [], [ PrettyString "Reason:", PrettyBreak(1, 0), reason ]) ]) in errorMsgNear(lex, true, near, lno, message) end fun sigStructMissingMsg (lex, near, lno, structName) (doDisplay: 'a -> pretty) (sigValue: 'a) = let val message = PrettyBlock(3, true, [], [ PrettyString ("Structure does not match signature" ^ (if structName = "" then "." else " in sub-structure " ^ structName)), PrettyBreak(1, 0), PrettyBlock(3, false, [], [ PrettyString "Signature:", PrettyBreak(1, 0), doDisplay sigValue ]), PrettyBreak(1, 0), PrettyBlock(3, false, [], [ PrettyString "Structure:", PrettyBreak(1, 0), PrettyString "Not present" ]) ]) in errorMsgNear(lex, true, near, lno, message) end (* Older version: prints just a string message. *) fun errorNear(lex, hard, near, lno, message: string) = errorMsgNear (lex, hard, near, lno, PrettyBlock (0, false, [], [PrettyString message])) fun errorDepth lex = let open DEBUG val parameters = LEX.debugParams lex in getParameter errorDepthTag parameters end (* Error message routine for lookupType and lookupStructure. *) fun giveError (sVal : structValue, lno : LEX.location, lex : lexan) : string -> unit = fn (message : string) => errorNear (lex, true, fn n => displayStructValue(sVal, n), lno, message); (* Turn a result from matchTypes into a pretty structure so that it can be included in a message. *) (* TODO: When reporting type messages from inside the structure we should use the environment from within the structure and for type within the signature the signature env. *) fun matchErrorReport(lex, structTypeEnv, sigTypeEnv) = unifyTypesErrorReport(lex, structTypeEnv, sigTypeEnv, "match") datatype matchTypeResult = MatchError of matchResult | MatchSuccess of types (* Check that two types match. Returns either an error result or the set of polymorphic variables for the source and the target. *) fun matchTypes (candidate, target, targMap: int -> typeId option, _) = let fun copyId(TypeId{idKind=Bound{ offset, ...}, ...}) = targMap offset | copyId _ = NONE fun copyATypeConstr tcon = copyTypeConstr(tcon, copyId, fn x => x, fn s => s) fun copyTarget t = (* Leave type variables. *) copyType (t, fn x => x, copyATypeConstr); val copiedTarget = copyTarget target (* Do the match to a version of the candidate with copies of the type variables so that we can instantiate them. We could do this by passing in a mapping function but the problem is that if we have a type variable that gets unified to another variable we will not map it properly if it occurs again (we call "eventual" and get the second tv before calling the map function so we get a second copy and not the first copy). *) val (copiedCandidate : types, _) = generalise candidate; in case unifyTypes (copiedCandidate, copiedTarget) of NONE => (* Succeeded. Return the unified type. Either will do. *) MatchSuccess copiedTarget | SOME error => MatchError error end; (* Check that a matching has succeeded, and check the value constructors if they are datatypes. *) fun checkTypeConstrs (candidSet as TypeConstrSet(candid, candidConstrs), targetSet as TypeConstrSet(target, targetConstrs), targTypeMap: int -> typeId option, lex, near, lno, typeEnv, structPath) = let val candidName : string = tcName candid; val targetName : string = tcName target; val tvars = List.map TypeVar (tcTypeVars target); (* either will do *) (* If we get an error in the datatype itself print the full datatype. *) val printTypeEnv = { lookupType = fn _ => NONE, lookupStruct = fn _ => NONE } val errorInDatatype = sigStructMatchMsg(lex, near, lno, structPath)(fn t => displayTypeConstrs(t, errorDepth lex, printTypeEnv)) in if tcArity candid <> tcArity target then () (* Have already given the error message. *) else (* Check the type constructors themselves first. This checks that the sharing constraints have been satisfied. *) case matchTypes (mkTypeConstruction (candidName, candid, tvars, []), mkTypeConstruction (targetName, target, tvars, []), targTypeMap, lex) of MatchError error => (* Report the error. *) errorInDatatype(candidSet, targetSet, matchErrorReport(lex, typeEnv, typeEnv) error) | MatchSuccess _ => (* We have already checked for matching a type in the structure to a datatype in the signature. In ML97 we can't rebind an identifier in a signature so each constructor for this datatype must be present in the signature i.e. it can't be hidden by a constructor for another datatype. So we can check the types of the constructors when we check the values. We still need to check that if this has constructors that the candidate does not have more constructors. *) if null targetConstrs then () (* Target is just a type: this isn't a problem. *) else if List.length candidConstrs <= List.length targetConstrs then () (* If it's less then it will be picked up later. *) else let fun checkConstrs(Value{name=candidConstrName, ...}) = if List.exists(fn Value{name, ...} => name=candidConstrName) targetConstrs then () else errorNear(lex, true, near, lno, concat["Error while matching datatype ", candidName, ": constructor ", candidConstrName, " was present in the structure but not in the signature."]); in List.app checkConstrs candidConstrs end end (* Check that a candidate signature (actually the environment part of a structure) matches a target signature. The direction is important because a candidate is allowed to have more components and more polymorphism than the target. As part of the matching process we build up a map of typeIDs in the target to type IDs in the candidate and that is returned as the result. N.B. the map function takes an argument between minTarget and maxTarget. *) fun matchSigs(originalCandidate, originalTarget, near, lno, lex, typeIdEnv, typeEnv) :(int -> typeId) * (int * valueMatching) list = let val candidate = (* The structure. *) let val Signatures { typeIdMap, firstBoundIndex, boundIds, ... } = originalCandidate val _ = case boundIds of [] => () | _ => raise InternalError "Candidate structure with non-empty bound ID list" in if isUndefinedSignature originalCandidate then undefinedSignature else replaceMap(originalCandidate, typeIdMap, firstBoundIndex, [], typeIdEnv) end val target = (* The signature. *) let val Signatures { typeIdMap, firstBoundIndex, boundIds, ... } = originalTarget fun newMap n = if n < firstBoundIndex then typeIdEnv n else List.nth(boundIds, n-firstBoundIndex) in replaceMap(originalTarget, typeIdMap, firstBoundIndex, boundIds, newMap) end local val minTarget = sigMinTypes target and maxTarget = sigMaxTypes target (* All the Bound type IDs in the target are in this range. We create an array to contain the matched IDs from the candidate. *) val matchArray = Array.array(maxTarget-minTarget, NONE) in (* These two functions are used during the match process. *) (* When looking up a Bound ID we return NONE if it is out of the range. Bound IDs below the minimum are treated as global at this level and so only match if they are the same in the target and candidate. *) fun lookupType n = if n < minTarget then NONE else Array.sub(matchArray, n-minTarget) and enterType (n, id) = if n < minTarget then () else Array.update(matchArray, n-minTarget, SOME id) (* This is the result function. If everything is right every entry in the array will be SOME but if we have had an error there may be entries that are still NONE. To prevent an exception we return the undefined type in that case. *) fun resultType n = getOpt(Array.sub(matchArray, n-minTarget), tcIdentifier undefConstr) end (* Match typeIDs for types. This is slightly more complicated than simply assigning the stamps. *) fun matchNames (candidate, target, structPath) : unit = if isUndefinedSignature candidate then () (* Suppress unnecessary messages. *) else univFold (sigTab target, fn (dName, dVal, ()) => if tagIs typeConstrVar dVal then let (* See if there is one with the same name. *) val targetSet as TypeConstrSet(target, targetConstrs) = tagProject typeConstrVar dVal; val printTypeEnv = { lookupType = fn _ => NONE, lookupStruct = fn _ => NONE } fun displayType t = displayTypeConstrs(t, errorDepth lex, printTypeEnv) val typeError = sigStructMatchMsg(lex, near, lno, structPath) displayType in (* Match up the types. This does certain checks but does not check sharing. Equality is checked for. *) case univLookup (sigTab candidate, typeConstrVar, dName) of SOME (candidSet as TypeConstrSet(candid, candidConstrs)) => if not (isUndefinedTypeConstr target) (* just in case *) then ( (* Check for arity and equality - value constructors are checked later. If the target is a bound identifier in the range it can be matched by a candidate. *) case tcIdentifier target of TypeId{idKind=Bound { offset, ...}, ...} => enterType (offset, tcIdentifier candid) | _ => (); if tcArity target <> tcArity candid then typeError(candidSet, targetSet, PrettyString "Types take different numbers of type arguments.") (* Check that it's a datatype before checking for eqtype. *) else if not (null targetConstrs) andalso null candidConstrs then typeError(candidSet, targetSet, PrettyString "Type in structure is not a datatype") else if not(tcIsAbbreviation target) andalso tcEquality target andalso not (permitsEquality candid) then typeError(candidSet, targetSet, PrettyString "Type in structure is not an equality type") else () ) else () | NONE => sigStructMissingMsg(lex, near, lno, structPath) displayType targetSet end else if tagIs structVar dVal then let (* and sub-structures. *) val target = (tagProject structVar) dVal; (* For each target structure: find a candidate with the same name and recursively check them. *) in case univLookup (sigTab candidate, structVar, dName) of SOME candid => matchNames (structSignat candid, structSignat target, structPath ^ dName ^ ".") | NONE => let fun displayStructure s = PrettyBlock(0, false, [], [PrettyString "structure" , PrettyBreak(1, 3), PrettyString(structName s)]) in sigStructMissingMsg(lex, near, lno, structPath) displayStructure target end end else (), (* not a type or structure *) () (* default value for fold *) ) (* matchNames *); val () = matchNames (candidate, target, ""); (* Match the values and exceptions in the signatures. This actually does the checking of types. *) fun matchVals (candidate, target, structPath): (int * valueMatching) list = if isUndefinedSignature candidate then [] (* Suppress unnecessary messages. *) else (* Map the identifiers first, returning the originals if they are not in the map. *) let local fun matchStructures(dName, dVal, matches) = if tagIs typeConstrVar dVal then (* Types *) let (* For each type in the target ... *) val target = tagProject typeConstrVar dVal in (* Find a candidate with the same name. *) case univLookup (sigTab candidate, typeConstrVar, dName) of SOME candid => let (* We don't actually check the value constructors here, just load them if they match. Because of the no-redefinition rule value constructors in the signature must also be present in the value environment so we check them there. *) fun matchConstructor(source as Value{typeOf, ...}, Value{access=Formal addr, ...}, matches) = (addr, ValueMatch { sourceValue = source, coercion = NoCoercion, targetType = typeOf }) :: matches | matchConstructor(_, _, matches) = matches in (* Now check that the types match. *) checkTypeConstrs(candid, target, lookupType, lex, near, lno, typeEnv, structPath); ListPair.foldl matchConstructor matches (tsConstructors candid, tsConstructors target) end | NONE => matches (* If the lookup failed ignore the error - we've already reported it in matchNames *) end else if tagIs structVar dVal then let (* and each sub-structure *) val target = tagProject structVar dVal in (* For each target structure: find a candidate with the same name and recursively check them. *) case univLookup (sigTab candidate, structVar, dName) of SOME candid => let val substructMatch = matchVals (structSignat candid, structSignat target, structPath ^ dName ^ ".") in (* Produce the match instructions for the sub-structure. We only include Formal entries here. It's possible that there might be Global entries in some circumstances. *) case target of Struct{access=Formal addr, ...} => (addr, StructureMatch{ sourceStructure=candid, contentsMatch = substructMatch}) :: matches | _ => matches end | NONE => matches (* Ignore the error - we've already reported it in matchNames *) end else matches; in val structureMatches = univFold(sigTab target, matchStructures, []) end fun displayValue(value as Value {name, locations, typeOf, ...}) = let val decLocation = case List.find (fn DeclaredAt _ => true | _ => false) locations of SOME(DeclaredAt loc) => [ContextLocation loc] | _ => [] val valName = PrettyBlock(0, false, decLocation, [PrettyString name]) fun dispVal(kind, typeof) = PrettyBlock(0, false, [], [ PrettyString kind, PrettyBreak(1, 3), valName, PrettyBreak(0, 0), PrettyString(":"), PrettyBreak(1, 0), display (typeof, errorDepth lex, typeEnv) ]) in case value of Value{class=Constructor _, ...} => (* When displaying the constructor show the function type. We may have rebound the constructor in the candidate structure so that it creates a different datatype. *) dispVal("constructor", typeOf) | Value{class=Exception, ...} => PrettyBlock(0, false, [], PrettyString "exception" :: PrettyBreak(1, 3) :: valName :: ( case getFnArgType typeOf of NONE => [] | SOME excType => [ PrettyBreak (1, 1), PrettyString "of", PrettyBreak (1, 3), display (excType, errorDepth lex, typeEnv) ] )) | _ => dispVal("val", typeOf) end local fun matchLocalValues(dName, dVal, matches) = if tagIs valueVar dVal then let val destVal as Value { typeOf=destTypeOf, class=destClass, access=destAccess, ...} = tagProject valueVar dVal in case univLookup (sigTab candidate, valueVar, dName) of NONE => (sigStructMissingMsg(lex, near, lno, structPath) displayValue destVal; matches) | SOME (candid as Value { typeOf=sourceTypeOf, class=sourceClass, ...}) => let (* If the target is a constructor or exception the candidate must be similar. If the candidate is a constructor or exception this will match a value but requires some coercion. *) datatype matchType = IsOK of valueCoercions | IsWrong of pretty val matchKind = case (destClass, sourceClass) of (Constructor _, Constructor _) => IsOK NoCoercion | (Constructor _, _) => IsWrong(PrettyString "Value is not a constructor") | (Exception, Exception) => IsOK NoCoercion | (Exception, _) => IsWrong(PrettyString "Value is not an exception") | (_, Exception) => IsOK ExceptionToValue | (_, Constructor _) => IsOK ConstructorToValue | _ => IsOK NoCoercion in case matchKind of IsWrong error => ( sigStructMatchMsg(lex, near, lno, structPath) displayValue (candid, destVal, error); matches ) | IsOK coercion => case matchTypes (sourceTypeOf, destTypeOf, lookupType, lex) of MatchSuccess instanceType => ( (* If it matches an entry in the signature it counts as being exported and therefore referenced. *) case candid of Value { references=SOME{exportedRef, ...}, ...} => exportedRef := true | _ => (); (* Add the instance type to the instance types. *) case candid of Value{ instanceTypes=SOME instanceRef, ...} => (* This has to be generalised before it is added here. Unlike normal unification when matching to a signature any polymorphic variables in the target will not have been generalised. *) instanceRef := #1(generalise instanceType) :: !instanceRef | _ => (); case destAccess of Formal destAddr => (destAddr, ValueMatch { sourceValue = candid, coercion = coercion, targetType = instanceType }) :: matches | _ => matches (* This could be global. *) ) | MatchError error => ( sigStructMatchMsg(lex, near, lno, structPath) displayValue (candid, destVal, matchErrorReport(lex, typeEnv, typeEnv) error); matches ) end end else matches in val matchedValues = univFold(sigTab target, matchLocalValues, structureMatches) end in matchedValues end (* matchVals *); val doMatch = matchVals (candidate, target, ""); (* Do the match. *) in (resultType, doMatch) (* Return the function to look up the results. *) end (* matchSigs *); val makeEnv = fn x => let val Env e = makeEnv x in e end; (* Any values in the signature are counted as exported. This case applies if there was no result signature because if there was a signature the values would have been given their references and types in the signature matching. *) fun markValsAsExported resSig = let fun refVals(_, dVal, ()) = if tagIs valueVar dVal then let val valu = tagProject valueVar dVal in case valu of Value {references=SOME{exportedRef, ...}, ...} => exportedRef := true | _ => (); (* If we have exported the value without a signature we use the most general type and discard any, possibly less general, references. *) case valu of Value{ typeOf, instanceTypes=SOME instanceRef, ...} => instanceRef := [#1(generalise typeOf)] | _ => () end else () in univFold(sigTab resSig, refVals, ()) end (* Construct a set of actions for matching a structure to itself. This is only really needed to ensure that type IDs are passed through correctly but we don't actually do them here yet. *) fun makeCopyActions signat : (int * valueMatching) list = let fun matchEntry(_, dVal, matches) = if tagIs structVar dVal then let val str = tagProject structVar dVal in case str of Struct{access=Formal addr, ...} => (addr, StructureMatch{ sourceStructure=str, contentsMatch = makeCopyActions(structSignat str)}) :: matches | _ => matches end else if tagIs valueVar dVal then let val v = tagProject valueVar dVal in case v of Value { access=Formal addr, typeOf, ...} => (addr, ValueMatch { sourceValue = v, coercion = NoCoercion, targetType = typeOf }) :: matches | _ => matches end else if tagIs typeConstrVar dVal then let fun matchConstructor(v as Value{access=Formal addr, typeOf, ...}, matches) = (addr, ValueMatch { sourceValue = v, coercion = NoCoercion, targetType = typeOf }) :: matches | matchConstructor(_, matches) = matches in List.foldl matchConstructor matches (tsConstructors(tagProject typeConstrVar dVal)) end else matches in univFold(sigTab signat, matchEntry, []) end (* Actions to copy the type Ids into the result signature. *) local fun matchTypeIds(_, []) = [] | matchTypeIds(n, (typeId as TypeId{ access = Formal addr, ...}) :: rest) = (addr, TypeIdMatch{ sourceIdNo=n, isEquality=isEquality typeId }) :: matchTypeIds(n+1, rest) | matchTypeIds(_, _) = raise InternalError "matchTypeIds: Not Formal" in fun makeMatchTypeIds destIds = matchTypeIds(0, destIds) end (* Second pass - identify names with values and type-check *) (* Process structure-returning expressions i.e. structure names, struct..end values and functor applications. *) fun structValue(str: structValue, newTypeId: (int*bool*bool*bool*typeIdDescription)->typeId, currentTypeCount, newTypeIdEnv: unit -> int->typeId, Env env, lex, lno, structPath) = let val typeEnv = { lookupType = fn s => case #lookupType env s of NONE => NONE | SOME t => SOME(t, SOME(newTypeIdEnv())), lookupStruct = fn s => case #lookupStruct env s of NONE => NONE | SOME t => SOME(t, SOME(newTypeIdEnv())) } in case str of StructureIdent {name, valRef, location} => let (* Look up the name and save the value. *) val result = lookupStructure ("Structure", {lookupStruct = #lookupStruct env}, name, giveError (str, location, lex)) val () = valRef := result in case result of SOME(Struct{signat, ...}) => signat | NONE => undefinedSignature end | FunctorAppl {name, arg, valRef, nameLoc, fullLoc, argIds, resIds, matchToArgument, ... } => (* The result structure must be copied to generate a new environment. This will make new types so that different applications of the functor yield different types. There may be dependencies between the parameters and result signatures so copying may have to take that into account. *) ( case #lookupFunct env name of NONE => ( giveError (str, nameLoc, lex) ("Functor (" ^ name ^ ") has not been declared"); undefinedSignature ) | SOME functr => let val Functor { arg = Struct{signat=formalArgSig, ...}, result=functorResSig, ...} = functr val () = valRef := SOME functr (* save it till later. *) (* Apply a functor to an argument. The result structure contains a mixture of IDs from the argument structure and generative IDs from the result structure. There are two parts to this process. 1. We have to match the actual argument structure to the formal argument to ensure that IDs are in the right place for the functor. 2. We have to take the actual argument structure and the functor result structure and produce a combination of this as a structure. *) (* IDs: argIDs: A list of pairs of IDs as Selected/Local/Global values and Formal values. This contains the IDs that must be passed into the functor. resIDs: A list of pairs of IDs as Local values and Formal values. The Local value is the location where a new generative ID is stored and the Formal offset is the offset within the run-time vector returned by the signature where the source ID for the generative ID is to be found. *) (* This provides information about the arguments. *) (* Get the actual parameter value. *) val actualArgSig = structValue(arg, newTypeId, currentTypeCount, newTypeIdEnv, Env env, lex, fullLoc, structPath); local (* Check that the actual arguments match formal arguments, and instantiate the variables. *) val (matchResults, matchActions) = matchSigs (actualArgSig, formalArgSig, fn n => displayStructValue(str, n), fullLoc, lex, newTypeIdEnv(), typeEnv); (* Record the code to match to this and include instructions to load the typeIDs. *) val () = matchToArgument := matchActions @ makeMatchTypeIds(sigBoundIds formalArgSig) in val matchResults = matchResults end (* Create a list of the type IDs that the argument must supply. *) local val maxT = sigMaxTypes formalArgSig and minT = sigMinTypes formalArgSig val results = List.tabulate(maxT-minT, fn n => matchResults(n+minT)) val args = ListPair.mapEq(fn(s, d) => { source = s, dest = d })(results, sigBoundIds formalArgSig) in val () = argIds := args; (* Save for code-generation. *) end (* Now create the generative typeIDs. These are IDs that are in the bound ID range of the result signature. Any type IDs inherited from the argument will have type ID values less than sigMinTypes functorResSig. *) local fun makeNewTypeId( oldId as TypeId{idKind=Bound{isDatatype, arity, ...}, description = { name=oldName, ...}, ...}) = let val description = { location = fullLoc, name = oldName, description = "Created from applying functor " ^ name } val newId = newTypeId(arity, false, isEquality oldId, isDatatype, description) in { source = oldId, dest = newId } end | makeNewTypeId _ = raise InternalError "Not Bound" (* The resIds list tells the code-generator where to find the source of each ID in the result structure and where to save the generative ID. *) val sdList = List.map makeNewTypeId (sigBoundIds functorResSig) val _ = resIds := sdList (* Save for code-generation. *) in (* This vector contains the resulting type IDs. They all have Local access. *) val resVector = Vector.fromList(List.map(fn { dest, ...} => dest) sdList) end (* Construct a result signature. This will contain all the IDs created here i.e. IDs in the argument and generative IDs at the start and then all the values and structures returned from the functor. When we come to code-generate we need to 1. Use loadOpaqueIds over the resIDs to create the opaque IDs. 2. Basically, do the same as StructDec to match to the result signature. We don't need to do anything about type IDs from the argument. Processing the argument will ensure that type IDs created in the argument are declared as Locals and if we pass localIDs to matchStructure we will load IDs from both the argument and generative IDs created by loadOpaqueIds. *) val minCopy = Int.min(sigMinTypes formalArgSig, sigMinTypes functorResSig) val idEnv = newTypeIdEnv() fun getCombinedTypeId n = if n < minCopy then idEnv n else if n >= sigMinTypes functorResSig then Vector.sub(resVector, n - sigMinTypes functorResSig) else if n >= sigMinTypes formalArgSig then matchResults n else sigTypeIdMap formalArgSig n val resSig = let val Signatures { name, tab, locations, ... } = functorResSig in makeSignature(name, tab, currentTypeCount(), locations, composeMaps(sigTypeIdMap functorResSig, getCombinedTypeId), []) end in resSig end ) | StructDec {alist, location, matchToResult, ...} => let (* Collection of declarations packaged into a structure or a collection of signatures. *) (* Some of the environment, the types and the value constructors, is generated during the first pass. Get the environment from the structure. *) val structTable = makeSignatureTable () val structEnv = makeEnv structTable val makeLocalTypeId = newTypeId val makeLocalTypeIdEnv = newTypeIdEnv val newEnv = { enterType = #enterType structEnv, enterVal = #enterVal structEnv, enterStruct = #enterStruct structEnv, enterSig = fn _ => raise InternalError "Signature in Struct End", enterFunct = fn _ => raise InternalError "Functor in Struct End", lookupVal = lookupDefault (#lookupVal structEnv) (#lookupVal env), lookupType = lookupDefault (#lookupType structEnv) (#lookupType env), lookupStruct = lookupDefault (#lookupStruct structEnv) (#lookupStruct env), lookupSig = #lookupSig env, (* Global *) lookupFunct = #lookupFunct env, (* Global *) lookupFix = #lookupFix env, (* Fixity declarations are dealt with in the parsing process. They are only processed again in this pass in order to get declarations in the right order. *) enterFix = fn _ => (), allValNames = fn () => (#allValNames structEnv () @ #allValNames env ()) } (* process body of structure *) val () = pass2Struct (alist, makeLocalTypeId, currentTypeCount, makeLocalTypeIdEnv, Env newEnv, lex, lno, structPath); (* We need to make a signature for the result in the form that can be used if there is no explicit signature, for example if this is used as the result of a functor. That means creating Formal values for all the values and structures. These Formal entries define the position in the run-time vector where each of the values and sub-structures are located. We don't include typeIDs in this. Any typeIDs that need to be included in the run-time vector are added by the functor declaration code. *) val finalTable = makeSignatureTable(); val finalEnv = makeEnv finalTable (* Create the result signature and also build the match structure to match to it. *) fun enterItem(dName, dVal, (addrs, matches)) = if tagIs typeConstrVar dVal then let val tConstr as TypeConstrSet(typConstr, valConstrs) = tagProject typeConstrVar dVal in if null valConstrs then (#enterType finalEnv (dName, tConstr); (addrs, matches)) else let (* If this is a datatype constructor convert the value constructors. The "no redefinition" rule for signatures doesn't apply to a structure so the signature we create here could have some constructors that have been hidden by later declarations. We still need the whole value environment in case of datatype replication. *) fun convertConstructor( valVal as Value{class, typeOf, locations, references, name, instanceTypes, ...}, (otherConstrs, (addrs, matches))) = let val formalValue = Value{class=class, name=name, typeOf=typeOf, access=Formal addrs, locations=locations, references=references, instanceTypes=instanceTypes} in (formalValue :: otherConstrs, (addrs + 1, (addrs, ValueMatch { sourceValue = valVal, coercion = NoCoercion, targetType=typeOf}) :: matches)) end val (newConstrs, newAddrMatch) = List.foldl convertConstructor ([], (addrs, matches)) valConstrs val newConstructor = makeTypeConstructor( tcName typConstr, tcTypeVars typConstr, tcIdentifier typConstr, tcLocations typConstr) in #enterType finalEnv (dName, TypeConstrSet(newConstructor, List.rev newConstrs)); newAddrMatch end end else if tagIs structVar dVal then let val strVal = tagProject structVar dVal val locations = structLocations strVal val strSig = structSignat strVal val matchSubStructure = makeCopyActions strSig in #enterStruct finalEnv (dName, makeFormalStruct (dName, strSig, addrs, locations)); (addrs + 1, (addrs, StructureMatch { sourceStructure=strVal, contentsMatch = matchSubStructure}) :: matches) end else if tagIs valueVar dVal then let val valVal = tagProject valueVar dVal in (* If this is a type-dependent function such as PolyML.print we must put in the original type-dependent version not the version which will have frozen its type as 'a. *) case valVal of value as Value{access = Overloaded _, ...} => ( #enterVal finalEnv (dName, value); (addrs, matches) ) | Value{class, typeOf, locations, references, instanceTypes, ...} => let val formalValue = Value{class=class, name=dName, typeOf=typeOf, access=Formal addrs, locations=locations, references=references, instanceTypes=instanceTypes} in #enterVal finalEnv (dName, formalValue); (addrs + 1, (addrs, ValueMatch { sourceValue = valVal, coercion = NoCoercion, targetType=typeOf}) :: matches) end end else (addrs, matches) val () = matchToResult := #2(univFold(structTable, enterItem, (0, []))) val locations = [DeclaredAt location, SequenceNo (newBindingId lex)] val resSig = makeSignature("", finalTable, currentTypeCount(), locations, newTypeIdEnv(), []) in resSig end | LetDec {decs, body = localStr, line, ...} => let (* let strdec in strexp end *) val newEnv = makeEnv (makeSignatureTable()); (* The environment for the local declarations. *) val localEnv = { lookupVal = lookupDefault (#lookupVal newEnv) (#lookupVal env), lookupType = lookupDefault (#lookupType newEnv) (#lookupType env), lookupFix = #lookupFix newEnv, lookupStruct = lookupDefault (#lookupStruct newEnv) (#lookupStruct env), lookupSig = #lookupSig env, lookupFunct = #lookupFunct env, (* Sigs and functs are global *) enterVal = #enterVal newEnv, enterType = #enterType newEnv, (* Fixity declarations are dealt with in the parsing process. At this stage we simply need to make sure that local declarations aren't entered into the global environment. *) enterFix = fn _ => (), enterStruct = #enterStruct newEnv, enterSig = #enterSig newEnv, enterFunct = #enterFunct newEnv, allValNames = fn () => (#allValNames newEnv () @ #allValNames env ()) }; (* Process the local declarations. *) val () = pass2Struct (decs, newTypeId, currentTypeCount, newTypeIdEnv, Env localEnv, lex, line, structPath); in (* There should just be one entry in the "body" list. *) structValue(localStr, newTypeId, currentTypeCount, newTypeIdEnv, Env localEnv, lex, line, structPath) end | SigConstraint { str, csig, opaque, sigLoc, opaqueIds, matchToConstraint, ... } => let val bodyIds = ref [] val startTypes = currentTypeCount() val startTypeEnv = newTypeIdEnv() fun sconstraintMakeTypeId (arity, isVar, eq, isdt, desc) = let val newId = newTypeId(arity, isVar, eq, isdt, desc) in bodyIds := newId :: ! bodyIds; newId end fun sconstraintTypeIdEnv () n = if n < startTypes then startTypeEnv n else valOf( List.find(fn TypeId{idKind=Bound{offset, ...}, ...} => offset = n | _ => raise Subscript) (!bodyIds)) val resSig = structValue(str, sconstraintMakeTypeId, currentTypeCount, sconstraintTypeIdEnv, Env env, lex, lno, structPath); (* Get the explicit signature. *) val explicitSig = sigVal(csig, startTypes, startTypeEnv, Env env, lex, sigLoc) val minExplicitSig = sigMinTypes explicitSig and maxExplicitSig = sigMaxTypes explicitSig (* Match the signature. This instantiates entries in typeMap. *) val (matchResults, matchActions) = matchSigs (resSig, explicitSig, fn n => displayStructValue(str, n), sigLoc, lex, startTypeEnv, typeEnv); val () = matchToConstraint := matchActions val rSig = if opaque then let (* Construct new IDs for the generic IDs. For each ID in the signature we need to make a new Local ID. *) fun makeNewId(oldId as TypeId{idKind=Bound{ isDatatype, arity, ...}, description = { name, ...}, ...}) = let val description = { location = sigLoc, name = name, description = "Created from opaque signature" } in newTypeId(arity, false, isEquality oldId, isDatatype, description) end | makeNewId _ = raise InternalError "Not Bound" val sources = List.tabulate(maxExplicitSig-minExplicitSig, fn n => matchResults(n+minExplicitSig)) val dests = List.map makeNewId (sigBoundIds explicitSig) (* Add the matching IDs to a list. When we create the code for the structure we need to create new run-time ID values using the original equality code and a new ref to hold the printer. *) val () = opaqueIds := ListPair.mapEq (fn (s, d) => { source=s, dest=d }) (sources, dests) (* Create new IDs for all the bound IDs in the signature. *) val v = Vector.fromList dests (* And copy it to put in the names from the structure. *) val currentEnv = newTypeIdEnv() fun oldMap n = if n < minExplicitSig then currentEnv n else Vector.sub (v, n - minExplicitSig) val Signatures{locations, name, tab, typeIdMap, ...} = explicitSig in makeSignature(name, tab, currentTypeCount(), locations, composeMaps(typeIdMap, oldMap), []) end else (* Transparent: Use the IDs from the structure. *) let val newIdEnv = newTypeIdEnv () fun matchedIds n = if n < sigMinTypes explicitSig then newIdEnv n else matchResults n val Signatures{locations, name, tab, typeIdMap, ...} = explicitSig in (* The result signature. This needs to be able to enumerate the type IDs including those we've added. *) makeSignature(name, tab, currentTypeCount(), locations, composeMaps(typeIdMap, matchedIds), []) end in rSig end end (* structValue *) and pass2Struct (strs : structDec list, makeLocalTypeId : (int * bool * bool * bool * typeIdDescription) -> typeId, makeCurrentTypeCount: unit -> int, makeTypeIdEnv: unit -> int -> typeId, Env env : env, lex, lno : LEX.location, structPath: string ) : unit = let fun pass2StructureDec (str : structDec, structList : structBind list, typeIdsForDebug) : unit = let (* Declaration of structures. *) (* The declarations must be made in parallel. i.e. structure A = struct ... end and B = A; binds B to the A in the PREVIOUS environment, not the A being declared. *) val sEnv = (* The new names. *) noDuplicates (fn(name, _, _) => errorNear (lex, true, fn n => displayStruct(str, n), lno, "Structure " ^ name ^ " has already been bound in this declaration") ) (* Any new type Ids we create need to be added onto a list in case we need them for the debugger. *) fun captureIds args = let val id = makeLocalTypeId args in typeIdsForDebug := id :: ! typeIdsForDebug; id end (* Put the new names into this environment. *) fun pass2StructureBind ({name, value, valRef, line, nameLoc, ...}) : unit= let (* Each element in the list is a structure binding. *) val resSig = structValue(value, captureIds, makeCurrentTypeCount, makeTypeIdEnv, Env env, lex, line, structPath ^ name ^ "."); (* Any values in the signature are counted as exported. *) val () = markValsAsExported resSig; (* Now make a local structure variable using this signature. *) val locations = [DeclaredAt nameLoc, SequenceNo (newBindingId lex)] val var = makeLocalStruct (name, resSig, locations) in #enter sEnv (name, var); valRef := SOME var end in List.app pass2StructureBind structList; (* Put them into the enclosing env. *) #apply sEnv (#enterStruct env) end; (* pass2StructureDec *) fun pass2Localdec (decs : structDec list, body : structDec list) : unit = let val newEnv = makeEnv (makeSignatureTable()); (* The environment for the local declarations. *) val localEnv = { lookupVal = lookupDefault (#lookupVal newEnv) (#lookupVal env), lookupType = lookupDefault (#lookupType newEnv) (#lookupType env), lookupFix = #lookupFix newEnv, lookupStruct = lookupDefault (#lookupStruct newEnv) (#lookupStruct env), lookupSig = #lookupSig env, lookupFunct = #lookupFunct env, enterVal = #enterVal newEnv, enterType = #enterType newEnv, enterFix = fn _ => (), enterStruct = #enterStruct newEnv, enterSig = #enterSig newEnv, enterFunct = #enterFunct newEnv, allValNames = fn () => (#allValNames newEnv () @ #allValNames env ()) }; (* Process the local declarations. *) val () = pass2Struct (decs, makeLocalTypeId, makeCurrentTypeCount, makeTypeIdEnv, Env localEnv, lex, lno, structPath); (* This is the environment used for the body of the declaration. Declarations are added both to the local environment and to the surrounding scope. *) (* Look-ups come from the local env *) val bodyEnv = { lookupVal = #lookupVal localEnv, lookupType = #lookupType localEnv, lookupFix = #lookupFix localEnv, lookupStruct = #lookupStruct localEnv, lookupSig = #lookupSig localEnv, lookupFunct = #lookupFunct localEnv, enterVal = fn pair => ( #enterVal newEnv pair; #enterVal env pair ), enterType = fn pair => ( #enterType newEnv pair; #enterType env pair ), enterFix = #enterFix localEnv, enterStruct = fn pair => ( #enterStruct newEnv pair; #enterStruct env pair ), enterSig = fn pair => ( #enterSig newEnv pair; #enterSig env pair ), enterFunct = #enterFunct localEnv, allValNames = #allValNames localEnv }; in (* Now the body. *) pass2Struct (body, makeLocalTypeId, makeCurrentTypeCount, makeTypeIdEnv, Env bodyEnv, lex, lno, structPath) end; (* pass2Localdec *) fun pass2Singleton (dec : parsetree, vars) : unit = let (* Single declaration - may declare several names. *) (* As well as entering the declarations we must keep a list of the value and exception declarations. *) val newEnv = { lookupVal = #lookupVal env, lookupType = #lookupType env, lookupFix = #lookupFix env, lookupStruct = #lookupStruct env, lookupSig = #lookupSig env, lookupFunct = #lookupFunct env, (* Must add the entries onto the end in case a declaration with the same name is made. e.g. local ... in val a=1; val a=2 end. *) enterVal = fn (pair as (_,v)) => ( #enterVal env pair; vars := !vars @ [CoreValue v] ), enterType = fn (pair as (_,t)) => ( #enterType env pair; vars := !vars @ [CoreType t] ), enterFix = fn pair => ( #enterFix env pair; vars := !vars @ [CoreFix pair] ), (* This will only be used if we do `open A' where A contains sub-structures. *) enterStruct = fn (pair as (_,v)) => ( #enterStruct env pair; vars := !vars @ [CoreStruct v] ), enterSig = #enterSig env, enterFunct = #enterFunct env, allValNames = #allValNames env }; (* Create a new type ID for each new datatype. Add the structure path to the name. *) fun makeId (eq, isdt, (args, EmptyType), { location, name, description }) = makeLocalTypeId(List.length args, true, eq, isdt, { location = location, name = structPath ^ name, description = description }) | makeId (_, _, (typeVars, decType), { location, name, description }) = makeTypeFunction( { location = location, name = structPath ^ name, description = description }, (typeVars, decType)) (* Process the body and discard the type. *) val _ : types = pass2 (dec, makeId, Env newEnv, lex, fn _ => false); in () end (* pass2Singleton *) fun pass2Dec (str as StructureDec { bindings, typeIdsForDebug, ... }) = pass2StructureDec (str, bindings, typeIdsForDebug) | pass2Dec(Localdec {decs, body, ...}) = pass2Localdec (decs, body) | pass2Dec(CoreLang {dec, vars, ...}) = pass2Singleton (dec, vars) in List.app pass2Dec strs (* Process all the top level entries. *) end (* pass2Struct *) fun pass2Structs ((strs, _): program, lex : lexan, Env globals : env) : unit = let (* Create a local environment to capture declarations. We don't want to add them to the global environment at this point. *) val newValEnv = UTILITIES.searchList() and newTypeEnv = UTILITIES.searchList() and newStrEnv = UTILITIES.searchList() and newSigEnv = UTILITIES.searchList() and newFuncEnv = UTILITIES.searchList() val lookupVal = lookupDefault (#lookup newValEnv) (#lookupVal globals) and lookupType = lookupDefault (#lookup newTypeEnv) (#lookupType globals) and lookupStruct = lookupDefault (#lookup newStrEnv) (#lookupStruct globals) and lookupSig = lookupDefault (#lookup newSigEnv) (#lookupSig globals) and lookupFunct = lookupDefault (#lookup newFuncEnv) (#lookupFunct globals) fun allValNames () = let val v = ref [] val () = #apply newValEnv (fn (s, _) => v := s :: ! v) in !v @ #allValNames globals () end val env = { lookupVal = lookupVal, lookupType = lookupType, lookupFix = #lookupFix globals, lookupStruct = lookupStruct, lookupSig = lookupSig, lookupFunct = lookupFunct, enterVal = #enter newValEnv, enterType = #enter newTypeEnv, enterFix = fn _ => (), (* ?? Already entered by the parser. *) enterStruct = #enter newStrEnv, enterSig = #enter newSigEnv, enterFunct = #enter newFuncEnv, allValNames = allValNames }; (* Create the free identifiers. These are initially Bound but are replaced by Free after the code has been executed and we have the values for the printer and equality functions. They are only actually created in strdecs but functor or signature topdecs in the same program could refer to them. *) local val typeIds = ref [] in fun topLevelId(arity, isVar, eq, isdt, description) = let val idNumber = topLevelIdNumber() val newId = (if isVar then makeBoundIdWithEqUpdate else makeBoundId) (arity, Local{addr = ref ~1, level = ref baseLevel}, idNumber, eq, isdt, description) in typeIds := newId :: ! typeIds; newId end and topLevelIdNumber() = List.length(!typeIds) and makeTopLevelIdEnv() = (* When we process a topdec we create a top-level ID environment which matches any ID numbers we've already created in this "program" to the actual ID. Generally this will be empty. *) let val typeVec = Vector.fromList(List.rev(!typeIds)) in fn n => Vector.sub(typeVec, n) end end (* We have to check that a type does not contain free variables and turn them into unique monotypes if they exist. This is a bit messy. We have to allow subsequent structure declarations to freeze the types (there's an example on p90 of the Definition) but we can't functors to get access to unfrozen free variables because that can break the type system. *) fun checkValueForFreeTypeVariables(name: string, v: values) = checkForFreeTypeVariables(name, valTypeOf v, lex, codeForUniqueId) (* Find all the values in the structure. *) fun checkStructSigForFreeTypeVariables(name: string, s: signatures) = let fun checkEntry(dName: string, dVal: universal, ()) = if tagIs structVar dVal then checkStructSigForFreeTypeVariables(name ^ dName ^ ".", structSignat((tagProject structVar) dVal)) else if tagIs valueVar dVal then checkValueForFreeTypeVariables(name ^ dName, (tagProject valueVar) dVal) else () in univFold(sigTab s, checkEntry, ()) end fun checkVariables (newValEnv, newStrEnv) = ( #apply newValEnv (fn (s: string, v: values) => checkValueForFreeTypeVariables(s, v)); #apply newStrEnv ( fn (n: string, s: structVals) => checkStructSigForFreeTypeVariables(n^".", structSignat s)) ) fun pass2TopDec ([], envs) = List.app checkVariables envs | pass2TopDec (StrDec(str, typeIds)::rest, envs) = let (* Remember the top-level Ids created in this strdec. *) fun makeId(arity, isVar, eq, isdt, desc) = let val newId = topLevelId(arity, isVar, eq, isdt, desc) in typeIds := newId :: ! typeIds; newId end in (* strdec: structure or core-language topdec. *) pass2Struct([str], makeId, topLevelIdNumber, makeTopLevelIdEnv, Env env, lex, location lex, ""); pass2TopDec(rest, if errorOccurred lex then [] else (newValEnv, newStrEnv) :: envs) end | pass2TopDec((topdec as FunctorDec (structList : functorBind list, lno)) :: rest, envs) = let val () = List.app checkVariables envs (* Check previous variables. *) (* There is a restriction that the same name may not be bound twice. As with other bindings functor bindings happen in parallel. DCJM 6/1/00. *) val sEnv = (* The new names. *) noDuplicates (fn (name, _, _) => errorNear(lex, true, fn n => displayTopDec(topdec, n), lno, "Functor " ^ name ^ " has already been bound in this declaration") ); val startTopLevelIDs = topLevelIdNumber() and topLevelEnv = makeTopLevelIdEnv() (* Put the new names into this environment. *) fun pass2FunctorBind ({name, nameLoc, arg = {name = argName, sigStruct = argSig, valRef = argVal}, body, valRef, resIds, line, matchToResult, debugArgVals, debugArgStructs, debugArgTypeConstrs, ...}: functorBind) = let (* When we apply a functor we share type IDs with the argument if they have an ID less than sigMinTypes for the result signature and treat other IDs as generative. If we don't have an explicit result signature or if we have a transparent signature the type IDs in the result are those returned from the body. To keep the argument IDs separate from newly created IDs we start creating local IDs with offsets after the args. *) val typeStamps = ref startTopLevelIDs; val localStamps = ref [] val argumentSignature = sigVal (argSig, startTopLevelIDs, topLevelEnv, Env env, lex, line) (* TODO: The location here is the location of the argument id if there is one. nameLoc is the location of the name of the functor. *) val locations = [DeclaredAt nameLoc, SequenceNo (newBindingId lex)] val resArg = makeLocalStruct (argName, argumentSignature, locations) (* sigVal will have numbered the bound IDs to start at startTopLevelIDs. We need to enter these bound IDs into the local environment but as Selected entries. *) local fun mkId(TypeId{idKind=Bound{ arity, eqType, isDatatype, offset, ...}, description={ location, name, description}, access = Formal addr, ...}) = TypeId{idKind=Bound { arity = arity, offset = offset, eqType = eqType, isDatatype = isDatatype }, description = { location=location, (* Add the structure name to the argument type IDs. *) name=if argName = "" then name else argName^"."^name, description=description }, access = makeSelected(addr, resArg)} | mkId _ = raise InternalError "mkId: Not Bound or not Formal" in (* argIDVector is part of the environment now. *) val argIDVector = Vector.fromList(List.map mkId (sigBoundIds argumentSignature)) val () = typeStamps := !typeStamps + List.length(sigBoundIds argumentSignature) end val startBodyIDs = ! typeStamps; (* After the arguments. *) local (* We also have to apply the above map to the signature. Structures may not have Formal entries for their type IDs so we must map them to the Selected items. Actually, there's a nasty sort of circularity here; we'd like the Selected entries to use structArg as the base but we can't create it until we have its signature...which uses structArg. *) val argSigWithSelected = let val Signatures { tab, name, locations, typeIdMap, ...} = argumentSignature fun mapToSelected n = if n < startTopLevelIDs then topLevelEnv n else Vector.sub(argIDVector, n-startTopLevelIDs) in makeSignature(name, tab, startBodyIDs, locations, composeMaps(typeIdMap, mapToSelected), []) end in val argEnv = makeEnv (makeSignatureTable()); (* Local name space. *) (* We may either have a single named structure in which case that is the argument or effectively a sig...end block in which case we have to open a dummy structure. *) val () = if argName <> "" then (* Named structure. *) let val structArg = Struct { name = argName, signat = argSigWithSelected, access = structAccess resArg, locations=structLocations resArg } in debugArgStructs := [structArg]; #enterStruct argEnv (argName, structArg) end else (* Open the dummy argument. Similar to "open" in treestruct. *) COPIER.openSignature (argSigWithSelected, { enterType = fn (s,v) => (debugArgTypeConstrs := v :: ! debugArgTypeConstrs; #enterType argEnv (s, v)), enterStruct = fn (name, strVal) => let val argStruct = makeSelectedStruct (strVal, resArg, []) in debugArgStructs := argStruct :: ! debugArgStructs; #enterStruct argEnv (name, argStruct) end, enterVal = fn (name, value) => let val argVal = mkSelectedVar (value, resArg, []) in debugArgVals := argVal :: ! debugArgVals; #enterVal argEnv (name, argVal) end }, "") end val () = argVal := SOME resArg (* Now process the body of the functor using the environment of the arguments to the functor and the global environment. *) val envWithArgs = { lookupVal = lookupDefault (#lookupVal argEnv) (#lookupVal env), lookupType = lookupDefault (#lookupType argEnv) (#lookupType env), lookupFix = #lookupFix env, lookupStruct = lookupDefault (#lookupStruct argEnv) (#lookupStruct env), lookupSig = #lookupSig env, lookupFunct = #lookupFunct env, enterVal = #enterVal env, enterType = #enterType env, enterFix = fn _ => (), enterStruct = #enterStruct env, enterSig = #enterSig env, enterFunct = #enterFunct env, allValNames = fn () => (#allValNames argEnv () @ #allValNames env ()) }; local (* Create local IDs for any datatypes declared in the body or any generative functor applications. *) fun newTypeId(arity, isVar, eq, isdt, desc) = let val n = !typeStamps val () = typeStamps := n + 1; val newId = (if isVar then makeBoundIdWithEqUpdate else makeBoundId) (arity, Local{addr = ref ~1, level = ref baseLevel}, n, eq, isdt, desc) in localStamps := newId :: !localStamps; newId end fun typeIdEnv () = let val localIds = Vector.fromList(List.rev(! localStamps)) in fn n => if n < startTopLevelIDs then topLevelEnv n else if n < startBodyIDs then Vector.sub(argIDVector, n-sigMinTypes argumentSignature) else Vector.sub(localIds, n-startBodyIDs) end in val resSig = structValue(body, newTypeId, fn () => !typeStamps, typeIdEnv, Env envWithArgs, lex, line, "") val () = if errorOccurred lex then () else checkStructSigForFreeTypeVariables(name^"().", resSig) (* This counts as a reference. *) val () = markValsAsExported resSig end; local val startRunTimeOffsets = getNextRuntimeOffset resSig fun convertId(n, id as TypeId{idKind=Bound { offset, isDatatype, arity, ...}, description, ...}) = (* Either inherited from the argument or a new type ID. *) makeBoundId (arity, Formal(n + startRunTimeOffsets), offset, isEquality id, isDatatype, description) | convertId (_, id) = id (* Free or TypeFunction. *) val localVector = Vector.fromList(List.rev(!localStamps)) val bodyVec = Vector.mapi convertId localVector val Signatures { name, tab, typeIdMap, locations, ...} = resSig (* These local IDs are included in the bound ID range for the result signature. Since they were created in the functor new instances will be generated when the functor is applied. *) val newBoundIds = Vector.foldr (op ::) [] bodyVec (* Record the ID map for code-generation. *) val () = resIds := Vector.foldri(fn (n, b, r) => { source=b, dest=Vector.sub(bodyVec, n)} :: r) [] localVector fun resTypeMap n = if n < startTopLevelIDs then topLevelEnv n else if n < startBodyIDs then Vector.sub(argIDVector, n-sigMinTypes argumentSignature) else Vector.sub(bodyVec, n-startBodyIDs) in val functorSig = makeSignature(name, tab, startBodyIDs, locations, composeMaps(typeIdMap, resTypeMap), newBoundIds) val () = matchToResult := makeCopyActions functorSig @ makeMatchTypeIds newBoundIds end (* Now make a local functor variable and put it in the name space. Because functors can only be declared at the top level the only way it can be used is if we have functor F(..) = ... functor G() = ..F.. with no semicolon between them. They will then be taken as a single declaration and F will be picked up as a local. *) (* Set the size of the type map. *) val locations = [DeclaredAt nameLoc, SequenceNo (newBindingId lex)] val var = makeFunctor (name, resArg, functorSig, makeLocal (), locations) in #enter sEnv (name, var); valRef := SOME var end in (* Each element in the list is a functor binding. *) List.app pass2FunctorBind structList; (* Put them into the enclosing env. *) #apply sEnv (#enterFunct env); pass2TopDec(rest, []) end (* FunctorDec *) | pass2TopDec((topdec as SignatureDec (structList : sigBind list, lno)) :: rest, envs) = let val () = List.app checkVariables envs (* Check previous variables. *) (* There is a restriction that the same name may not be bound twice. As with other bindings functor bindings happen in parallel. DCJM 6/1/00. *) val sEnv = (* The new names. *) noDuplicates (fn (name, _, _) => errorNear (lex, true, fn n => displayTopDec(topdec, n), lno, "Signature " ^ name ^ " has already been bound in this declaration") ); val startTopLevelIDs = topLevelIdNumber() and topLevelEnv = makeTopLevelIdEnv() fun pass2SignatureBind ({name, nameLoc, sigStruct, line, sigRef, ...}) = let (* Each element in the list is a signature binding. *) val Signatures { tab, typeIdMap, firstBoundIndex, boundIds, ...} = sigVal (sigStruct, startTopLevelIDs, topLevelEnv, Env env, lex, line) val locations = [DeclaredAt nameLoc, SequenceNo (newBindingId lex)] val namedSig = (* Put in the signature name. *) makeSignature(name, tab, firstBoundIndex, locations, typeIdMap, boundIds) in sigRef := namedSig; (* Remember for pass4. *) #enter sEnv (name, namedSig) end in List.app pass2SignatureBind structList; (* Put them into the enclosing env. *) #apply sEnv (#enterSig env) ; pass2TopDec(rest, []) end in pass2TopDec(strs, []); (* Mark any exported values as referenced. *) #apply newValEnv (fn (s: string, valu: values) => ( (* If we have exported the value we need to mark it as a reference. But if the identifier has been rebound we only want to mark the last reference. Looking the identifier up will return only the last reference. *) case #lookup newValEnv s of SOME(Value { references=SOME{exportedRef, ...}, ...}) => exportedRef := true | _ => (); (* Since it's been exported the instance type is the most general type. We can discard any other instance type info since it cannot be more general. *) case valu of Value{ typeOf, instanceTypes=SOME instanceRef, ...} => instanceRef := [#1(generalise typeOf)] | _ => () ) ) end (*pass2Structs *); (* * * Code-generation phase. * * *) (* Generate code from the expressions and arrange to return the results so that "pass4" can find them. *) fun gencodeStructs ((strs, _), lex) = let (* Before code-generation perform an extra pass through the tree to remove unnecessary polymorphism. The type-checking computes a most general type for a value, typically a function, but it is frequently used in situations where a less general type would suffice. *) local fun leastGenStructDec(StructureDec { bindings, ... }) = (* Declarations are independent so can be processed in order. *) List.app (leastGenStructValue o #value) bindings | leastGenStructDec(CoreLang{dec, ...}) = setLeastGeneralTypes(dec, lex) | leastGenStructDec(Localdec{decs, body, ...}) = ( (* Process the body in reverse order then the declaration in reverse. *) List.foldr (fn (d, ()) => leastGenStructDec d) () body; List.foldr (fn (d, ()) => leastGenStructDec d) () decs ) and leastGenStructValue(StructureIdent _) = () | leastGenStructValue(StructDec {alist, ...}) = (* Declarations in reverse order. *) List.foldr (fn (d, ()) => leastGenStructDec d) () alist | leastGenStructValue(FunctorAppl {arg, ...}) = leastGenStructValue arg | leastGenStructValue(LetDec {decs, body, ...}) = ( (* First the body then the declarations in reverse. *) leastGenStructValue body; List.foldr (fn (d, ()) => leastGenStructDec d) () decs ) | leastGenStructValue(SigConstraint {str, ...}) = leastGenStructValue str fun leastGenTopDec(StrDec(aStruct, _)) = leastGenStructDec aStruct | leastGenTopDec(FunctorDec(fbinds, _)) = List.app(fn{body, ...} => leastGenStructValue body) fbinds | leastGenTopDec(SignatureDec _) = () in val () = (* These are independent so can be processed in order. *) List.app leastGenTopDec strs end (* Apply a function which returns a pair of codelists to a list of structs. This now threads the debugging environment through the functions so the name is no longer really appropriate. DCJM 23/2/01. *) fun mapPair (_: 'a * debuggerStatus -> {code: codeBinding list, debug: debuggerStatus}) [] debug = { code = [], debug = debug } | mapPair f (h::t) debug = let (* Process the list in order. In the case of a declaration sequence later entries in the list may refer to earlier ones. *) val this = f (h, debug); val rest = mapPair f t (#debug this); in (* Return the combined code. *) { code = #code this @ #code rest, debug = #debug rest } end; fun applyMatchActions (code : codetree, actions, sourceIds, mkAddr, level) = let (* Generate a new structure which will match the given signature. A structure is represented by a vector of entries, and its signature is a map which gives the offset in the vector of each value. When we match a signature the candidate structure will in general not have its entries in the same positions as the target. We have to construct a new structure from it with the entries in the correct positions. In most cases the optimiser will simplify this code considerably so there is no harm in using a general mechanism. Nevertheless, we check for the case when we are building a structure which is a direct copy of the original and use the original code if possible. *) fun matchSubStructure (code: codetree, actions: structureMatch): codetree * bool = let val decs = multipleUses (code, fn () => mkAddr 1, level) (* First sort by the address in the destination vector. This previously used Misc.quickSort but that results in a lot of memory allocation for the partially sorted lists. Since we should have exactly N items the range checking in "update" and the "valOf" provide additional checking that all the items are present. *) val a = Array.array(List.length actions, NONE) val () = List.app(fn (i, action) => Array.update(a, i, SOME action)) actions val sortedActions = Array.foldri (fn (n, a, l) => (n, valOf a) :: l) [] a fun applyAction ((destAddr, StructureMatch { sourceStructure, contentsMatch }), (otherCode, allSame)) = let val access = structAccess sourceStructure; (* Since these have come from a signature we might expect all the entries to be "formal". However if the structure is global the entries in the signature may be global, and if the structure is in a "struct .. end" it may be local. *) val (code, equalDest) = case access of Formal sourceAddr => (mkInd (sourceAddr, #load decs level), sourceAddr=destAddr) | _ => (codeStruct (sourceStructure, level), false) val (resCode, isSame) = matchSubStructure (code, contentsMatch: structureMatch) in (resCode::otherCode, allSame andalso equalDest andalso isSame) end | applyAction ((destAddr, ValueMatch { sourceValue as Value{typeOf=sourceTypeOf, name, ...}, coercion, targetType }), (otherCode, allSame)) = let (* Set up a new type variable environment in case this needs to create type values to match a polymorphic source value to a monomorphic context. *) val typeVarMap = TypeVarMap.defaultTypeVarMap(mkAddr, level) (* If the entry is from a signature select from the code. Apply any coercion from constructors to values. *) fun loadCode localLevel = case sourceValue of Value{access=Formal svAddr, ...} => ( case coercion of NoCoercion => mkInd (svAddr, #load decs localLevel) | ExceptionToValue => let fun loadEx l = mkInd (svAddr, #load decs l) in case getFnArgType sourceTypeOf of NONE => mkTuple [loadEx localLevel, mkStr name, CodeZero, codeLocation nullLocation] | SOME _ => let val nLevel = newLevel level in mkProc (mkTuple[loadEx nLevel, mkStr name, mkLoadArgument 0, codeLocation nullLocation], 1, "", getClosure nLevel, 0) end end | ConstructorToValue => (* Extract the injection function/nullary value. *) ValueConstructor.extractInjection(mkInd (svAddr, #load decs localLevel)) ) | _ => ( case coercion of NoCoercion => codeVal (sourceValue, localLevel, typeVarMap, [], lex, location nullLex) | ExceptionToValue => codeExFunction(sourceValue, localLevel, typeVarMap, [], lex, location nullLex) | ConstructorToValue => mkInd(1, codeVal (sourceValue, localLevel, typeVarMap, [], lex, location nullLex)) ) local val (copiedCandidate, sourceVars) = generalise sourceTypeOf val sourceVars = List.filter (fn {equality, ...} => not justForEqualityTypes orelse equality) sourceVars val () = case unifyTypes(copiedCandidate, targetType) of NONE => () | SOME report => (print(name ^ ":\n"); PolyML.print report; raise InternalError "unifyTypes failed in pass 3") val filterTypeVars = List.filter (fn tv => not justForEqualityTypes orelse tvEquality tv) val destVars = filterTypeVars (getPolyTypeVars(targetType, fn _ => NONE)) (* If we have the same polymorphic variables in the source and destination we don't need to apply a coercion. N.B. We may have the same number of polymorphic variables but still have to apply it if we have, for example, fun f x => x matching val f: 'a list -> 'a list. *) fun equalEntry({value=source, ...}, destTv) = case eventual source of TypeVar sourceTv => sameTv(sourceTv, destTv) | _ => false in val (polyCode, justCopy) = if ListPair.allEq equalEntry (sourceVars, destVars) then (loadCode(level) (* Nothing to do. *), (* We're just copying if this is the same address. *) case sourceValue of Value{access=Formal sourceAddr, ...} => destAddr=sourceAddr | _ => false) else if null destVars (* Destination is monomorphic. *) then (applyToInstance(sourceVars, level, typeVarMap, loadCode), false) else let open TypeVarMap val destPolymorphism = List.length destVars val localLevel = newLevel level val argAddrs = List.tabulate(destPolymorphism, fn n => fn l => mkLoadParam(n, l, localLevel)) val argMap = ListPair.zipEq(destVars, argAddrs) val addrs = ref 0 fun mkAddrs n = ! addrs before (addrs := !addrs+n) val newTypeVarMap = extendTypeVarMap(argMap, mkAddrs, localLevel, typeVarMap) (* Apply the source to the parameters provided by the destination. In almost all cases we will be removing polymorphism here but it is possible to add polymorphism through type definitions of the form type 'a t = int. *) val application = applyToInstance(sourceVars, localLevel, newTypeVarMap, loadCode) in (mkProc( mkEnv(getCachedTypeValues newTypeVarMap, application), destPolymorphism, name ^ "(P)", getClosure localLevel, !addrs), false) end end in (mkEnv(TypeVarMap.getCachedTypeValues typeVarMap, polyCode) :: otherCode, (* We can use the original structure if nothing else has changed, the offset in the destination structure is the same as the offset in the source and we don't have any coercion. *) allSame andalso justCopy andalso (case coercion of NoCoercion => true | _ => false)) end | applyAction ((_, TypeIdMatch { sourceIdNo, isEquality }), (otherCode, _)) = (* Get the corresponding source ID. *) (codeAccess(sourceIds(sourceIdNo, isEquality), level) :: otherCode, false) val (codeList, isAllEq) = List.foldr applyAction ([], true) sortedActions in if isAllEq then (code, true) else (mkEnv (#dec decs, mkTuple codeList), false) end in #1 (matchSubStructure (code, actions)) end (* applyMatchActions *) (* If we are declaring a structure with an opaque signature we need to create the run-time IDs for newly generated IDs. *) fun loadOpaqueIds (opaqueIds, mkAddr, level) = let fun decId { dest as TypeId{idKind=dKind, ...}, source } = let val { addr=idAddr, level=idLevel } = vaLocal(idAccess dest) val addr = mkAddr 1; val () = idAddr := addr and () = idLevel := level val isDatatype = case dKind of Bound{isDatatype, ...} => isDatatype | _ => false val idCode = codeGenerativeId{source=source, isEq=isEquality dest, isDatatype=isDatatype, mkAddr=mkAddr, level=level} in mkDec(addr, idCode) end in List.map decId opaqueIds end (* Code-generate a structure value. *) fun structureCode (str, strName, debugEnv, mkAddr, level: level): { code: codeBinding list, load: codetree } = case str of FunctorAppl {arg, valRef = ref functs, argIds=ref argIds, resIds=ref resIds, matchToArgument=ref matchToArgument, ...} => let val {code = argCodeSource, load = argLoadSource, ...} = structureCode (arg, strName, debugEnv, mkAddr, level) (* Match the actual argument to the required arguments. *) fun getMatchedId(n, isEq) = case #source(List.nth (argIds, n)) of id as TypeId{idKind=TypeFn _, ...} => (* Have to generate a function here. *) Global(codeGenerativeId{source=id, isEq=isEq, isDatatype=false(*??*), mkAddr=mkAddr, level=level}) | id => idAccess id val argCode = applyMatchActions(argLoadSource, matchToArgument, getMatchedId, mkAddr, level) (* To produce the generative type IDs we need to save the result vector returned by the functor application and then generate the new type IDs from the IDs in it. To make valid source IDs we have to turn the Formal entries in the signature into Selected entries. *) val resAddr = mkAddr 1 local val dummyResStruct = makeLocalStruct("", undefinedSignature, []) (* Dummy structure. *) val resl = vaLocal (structAccess dummyResStruct); val () = #addr resl := resAddr; val () = #level resl := level fun mkSelected { source = TypeId{idKind, access = Formal addr, description}, dest } = { source = TypeId{idKind=idKind, access = makeSelected(addr, dummyResStruct), description = description }, dest = dest } | mkSelected _ = raise InternalError "makeSelected: Not Bound or not Formal" val resultIds = List.map mkSelected resIds in val loadIds = loadOpaqueIds(resultIds, mkAddr, level) end val functorCode = case functs of SOME(Functor{access=functorAccess, ...}) => codeAccess (functorAccess, level) | NONE => raise InternalError "FunctorAppl: undefined" in (* Evaluate the functor. *) { code = argCodeSource @ (mkDec(resAddr, mkEval (functorCode, [argCode])) :: loadIds), load = mkLoadLocal resAddr } end | StructureIdent {valRef = ref v, ...} => { code = [], load = codeStruct (valOf v, level) } | LetDec {decs, body = localStr, ...} => let (* let strdec in strexp end *) (* Generate the declarations but throw away the loads. *) val typeVarMap = TypeVarMap.defaultTypeVarMap(mkAddr, level) (* TODO: Get the debug environment correct here. *) fun processBody(decs, _, debugEnv, _, _, _) = (decs, debugEnv) val (code, debug) = codeStrdecs(strName, decs, debugEnv, mkAddr, level, typeVarMap, [], processBody) val {code = bodyCode, load = bodyLoad } = structureCode (localStr, strName, debug, mkAddr, level) in { code = TypeVarMap.getCachedTypeValues typeVarMap @ code @ bodyCode, load = bodyLoad } end | StructDec {alist, matchToResult=ref matchToResult, ...} => let val typeVarMap = TypeVarMap.defaultTypeVarMap(mkAddr, level) fun processBody(decs, _, debugEnv, _, _, _) = (decs: codeBinding list, debugEnv) val (coded, _(*debugEnv*)) = codeStrdecs(strName, alist, debugEnv, mkAddr, level, typeVarMap, [], processBody) (* We match to the dummy signature here. If there is a signature outside we will match again. This results in double copying but that should all be sorted out by the optimiser. *) val loads = List.rev(List.foldl(fn (s, l) => codeLoadStrdecs(s, level) @ l) [] alist) in (* The result is a block containing the declarations and code to load the results. *) { code = TypeVarMap.getCachedTypeValues typeVarMap @ coded, load = applyMatchActions (mkTuple loads, matchToResult, fn _ => raise Subscript, mkAddr, level) } end | SigConstraint { str, opaqueIds=ref opaqueIds, matchToConstraint = ref matchToConstraint,... } => let val {code = strCode, load = strLoad, ...} = structureCode (str, strName, debugEnv, mkAddr, level) val tempDecs = multipleUses (strLoad, fn () => mkAddr 1, level); val ids = loadOpaqueIds(opaqueIds, mkAddr, level) in { code = strCode @ #dec tempDecs @ ids, load = applyMatchActions (#load tempDecs level, matchToConstraint, fn _ => raise Subscript, mkAddr, level) } end (* structureCode *) (* We need to generate code for the declaration and then code to load the results into a tuple. *) and codeStrdecs (strName, [], debugEnv, mkAddr, level, typeVarMap, leadingDecs, processBody) = processBody(leadingDecs: codeBinding list, strName, debugEnv, mkAddr, level, typeVarMap) (* Do the continuation. *) | codeStrdecs (strName, (StructureDec { bindings = structList, typeIdsForDebug = ref debugIds, ... }) :: sTail, debugEnv, mkAddr, level, _(*typeVarMap*), leadingDecs, processBody) = let fun codeStructureBind ({name, value, valRef, ...}: structBind, debug) = let val structureVal = valOf(! valRef) val sName = strName ^ name ^ "." val {code = strCode, load = strLoad, ...} = structureCode (value, sName, debug, mkAddr, level) val addr = mkAddr 1 val var = vaLocal (structAccess structureVal) val () = #addr var := addr; val () = #level var := level; val (debugDecs, newDebug) = makeStructDebugEntries([structureVal], debugEnv, level, lex, mkAddr) in (* Get the code and save the result in the variable. *) { code = strCode @ [mkDec (addr, strLoad)] @ debugDecs : codeBinding list, debug = newDebug } end val { code: codeBinding list, debug = strDebug } = (* Code-generate each declaration. *) mapPair codeStructureBind structList debugEnv val (debugIdDecs, idDebug) = makeTypeIdDebugEntries(debugIds, strDebug, level, lex, mkAddr) (* A structure binding may introduce new type IDs either directly or by way of opaque signatures or functor application. Ideally we'd add these using something like markTypeConstructors but for now just start a new environment. *) (* TODO: Check this. It looks as though TypeVarMap.getCachedTypeValues newTypeVarMap always returns the empty list. *) val newTypeVarMap = TypeVarMap.defaultTypeVarMap(mkAddr, level) val (codeRest, debugRest) = codeStrdecs (strName, sTail, idDebug, mkAddr, level, newTypeVarMap, [], processBody) in (leadingDecs @ code @ debugIdDecs @ TypeVarMap.getCachedTypeValues newTypeVarMap @ codeRest, debugRest) end | codeStrdecs (strName, (Localdec {decs, body, ...}) :: sTail, debugEnv, mkAddr, level, typeVarMap, leadingDecs, processBody) = let fun processTail(previousDecs, newStrName, newDebugEnv, newMkAddr, newLevel, newTypeVarMap) = let (* TODO: Get the debug environment right here. *) in codeStrdecs (newStrName, sTail, newDebugEnv, newMkAddr, newLevel, newTypeVarMap, previousDecs, processBody) end fun processBody(previousDecs, newStrName, newDebugEnv, newMkAddr, newLevel, newTypeVarMap) = let (* TODO: Get the debug environment right here. *) in codeStrdecs (newStrName, body, newDebugEnv, newMkAddr, newLevel, newTypeVarMap, previousDecs, processTail) end in (* Process the declarations then the body and then the tail. *) codeStrdecs (strName, decs, debugEnv, mkAddr, level, typeVarMap, leadingDecs, processBody) end | codeStrdecs (strName, (CoreLang {dec, ...}) :: sTail, debugEnv, mkAddr, level, typeVarMap, leadingDecs, processBody) = let fun processTail(newCode, newDebugEnv, newTypeVarMap) = codeStrdecs (strName, sTail, newDebugEnv, mkAddr, level, newTypeVarMap, newCode, processBody) val (code, debug) = gencode (dec, lex, debugEnv, level, mkAddr, typeVarMap, strName, processTail) in (leadingDecs @ code, debug) end (* end codeStrdecs *) (* Generate a list of load instructions to build the result tuple. *) and codeLoadStrdecs(StructureDec { bindings, ... }, _) = let fun loadStructureBind ({valRef = ref v, ...}, loads) = let val { addr=ref addr, ...} = vaLocal (structAccess(valOf v)) in mkLoadLocal addr :: loads end in (* Code-generate each declaration. *) List.foldl loadStructureBind [] bindings end | codeLoadStrdecs(Localdec {body, ...}, level) = List.foldl (fn(s, l) => codeLoadStrdecs(s, level) @ l) [] body | codeLoadStrdecs(CoreLang {vars=ref vars, ...}, level) = let (* Load each variable, exception and type ID (i.e. equality & print function) that has been declared. Since value declarations may be mutually recursive we have to code-generate the declarations first then return the values. *) val typeVarMap = TypeVarMap.defaultTypeVarMap(fn _ => raise InternalError "typeVarMap", level) fun loadVals (CoreValue v, rest) = codeVal (v, level, typeVarMap, [], nullLex, location nullLex) :: rest | loadVals (CoreStruct s, rest) = codeStruct (s, level) :: rest | loadVals (CoreType (TypeConstrSet(_, tcConstructors)), rest) = (* Type IDs are handled separately but we need to load the value constructors if this is a datatype. This is really only because of datatype replication where we need to be able to get the value constructors from the datatype. *) List.rev(List.map( fn v => codeVal (v, level, typeVarMap, [], nullLex, location nullLex)) tcConstructors) @ rest | loadVals (_, rest) = rest in List.foldl loadVals [] vars end fun codeTopdecs (StrDec(str, _), debugEnv, mkAddr) = let open TypeVarMap val level = baseLevel val typeVarMap = TypeVarMap.defaultTypeVarMap(mkAddr, level) val (code, debug) = codeStrdecs("", [str], debugEnv, mkAddr, level, typeVarMap, [], fn(decs, _, debugEnv, _, _, _) => (decs, debugEnv)) in { code = TypeVarMap.getCachedTypeValues typeVarMap @ code, debug = debug } end | codeTopdecs (FunctorDec (structList : functorBind list, _), debugEnv, mkOuterAddr) = let fun codeFunctorBind ({name, arg = {valRef=argValRef, ...}, body, valRef, resIds=ref resIds, matchToResult=ref matchToResult, debugArgVals, debugArgStructs, debugArgTypeConstrs, ...}: functorBind, debugEnv) = let val argVal = valOf(! argValRef) local (* Separate context for each functor binding. *) val address = ref 1 in fun mkAddr n = !address before (address := ! address+n) val level = newLevel baseLevel (* Inside the functor *) end val arg = vaLocal (structAccess argVal) (* Create a local binding for the argument. This allows the new variable to be a local. *) val localAddr = mkAddr 1 val () = #addr arg := localAddr val () = #level arg := level val func = valOf(!valRef) local (* These are the entries for the functor arguments. *) val (typeIdDebugDecs, typeIdDebugEnv) = makeTypeIdDebugEntries(sigBoundIds (structSignat argVal), debugEnv, level, lex, mkAddr) val (structDebugDecs, structDebugEnv) = makeStructDebugEntries(! debugArgStructs, typeIdDebugEnv, level, lex, mkAddr) val typeVarMap = TypeVarMap.defaultTypeVarMap(mkAddr, level) (* ???Check??? *) val (valDebugDecs, valDebugEnv) = makeValDebugEntries(! debugArgVals, structDebugEnv, level, lex, mkAddr, typeVarMap) val (typeDebugDecs, typeDebugEnv) = makeTypeConstrDebugEntries(! debugArgTypeConstrs, valDebugEnv, level, lex, mkAddr) in val fBindDebugDecs = typeIdDebugDecs @ structDebugDecs @ valDebugDecs @ typeDebugDecs val fBindDebugEnv = typeDebugEnv end (* Process the body and make a function out of it. *) local val {code = strCode, load = strLoad, ...} = structureCode (body, name ^ "().", fBindDebugEnv, mkAddr, level) fun getIds(n, isEq) = case #source(List.nth(resIds, n)) of id as TypeId{idKind=TypeFn _, ...} => (* Have to generate a function here. *) Global(codeGenerativeId{source=id, isEq=isEq, isDatatype=false (*??*), mkAddr=mkAddr, level=level}) | id => idAccess id val matchedCode = applyMatchActions(strLoad, matchToResult, getIds, mkAddr, level) in val functorCode = (* The function that implements the functor. *) (if getParameter inlineFunctorsTag (debugParams lex) then mkMacroProc else mkProc) (mkEnv(mkDec(localAddr, mkLoadArgument 0) :: (fBindDebugDecs @ strCode), matchedCode), 1, name, getClosure level, mkAddr 0) end (* Set the address of this variable. Because functors can only be declared at the top level the only way it can be used is if we have functor F(..) = ... functor G() = ..F.. with no semicolon between them. They will then be taken as a single declaration and F will be picked up as a local. *) val addr = mkOuterAddr 1 val Functor { access, ...} = func val var = vaLocal access val () = #addr var := addr; val () = #level var := baseLevel(* Top level *); in { code = [mkDec (addr, functorCode)], debug = debugEnv } end in mapPair codeFunctorBind structList debugEnv end | codeTopdecs(SignatureDec _, debugEnv, _) = { code = [], debug = debugEnv } and loadTopdecs (StrDec(str, ref typeIds)) = let val level = baseLevel val load = codeLoadStrdecs(str, level) (* Load all the IDs created in this topdec even if they're not directly referenced. *) fun loadIds id = codeId(id, level) in load @ List.rev(List.map loadIds typeIds) end | loadTopdecs (FunctorDec (structList, _)) = let fun loadFunctorBind ({valRef, ...}) = let val Functor{access, ...} = valOf(! valRef) val {addr = ref addr, ...} = vaLocal access in mkLoadLocal addr end in List.rev(List.map loadFunctorBind structList) end | loadTopdecs(SignatureDec _) = [] local (* Separate context for each top level item. *) val address = ref 0 in fun mkAddr n = !address before (address := ! address+n) end val coded = (* Process top level list. *) mapPair (fn (str, debug) => codeTopdecs (str, debug, mkAddr)) strs initialDebuggerStatus val loaded = List.foldl (fn (s, l) => loadTopdecs s @ l) [] strs in (* The result is code for a vector containing the results of the declarations which pass4 can use to pull out the values after the code has been run. *) (mkEnv (#code coded, mkTuple(List.rev loaded)), mkAddr 0) end (* gencodeStructs *); (* Once the code has been executed the declarations must be added to the global scope. The type and infix status environments have already been processed so they can be dumped into the global environment unchanged. The values and exceptions, however, have to be picked out the compiled code. Note: The value constructors are actually produced at the same time as their types but are dumped out by enterGlobals. *) (* This previously only processed declarations which required some code-generation and evaluation (structures, values and functors). It now includes types, signatures and fixity so that all declarations can be printed in the order of declaration. DCJM 6/6/02. *) fun pass4Structs (results, (strs: topdec list, _)) = let fun extractStruct(str, mapTypeIds, args as (addr, { fixes, values, structures, signatures, functors, types } )) = case str of StructureDec { bindings, ... } => let fun extractStructureBind ({name, valRef, line, ...}: structBind, (addr, structures)) = let val structCode = mkInd (addr, results) (* We need to replace type IDs with their Global versions. *) local val Struct{signat=Signatures { name, locations, typeIdMap, tab, ...}, ...} = valOf(!valRef) in val resultSig = makeSignature(name, tab, 0, locations, composeMaps(typeIdMap, mapTypeIds), []) end in (* Make a global structure. *) (addr + 1, (name, makeGlobalStruct (name, resultSig, structCode, [DeclaredAt line])) :: structures) end val (newAddr, newstructures) = List.foldl extractStructureBind (addr, structures) bindings in (newAddr, { structures=newstructures, functors=functors, signatures=signatures, fixes=fixes, values=values, types=types }) end | Localdec {body, ...} => List.foldl (fn(s, a) => extractStruct(s, mapTypeIds, a))args body (* Value, exception or type declaration at the top level. *) | CoreLang {vars=ref vars, ...} => let (* Enter the values and exceptions. *) (* Copy the types to replace the type IDs with the versions with Global access. *) fun replaceTypes t = let fun copyId(TypeId{idKind=Bound{ offset, ...}, ...}) = SOME(mapTypeIds offset) | copyId _ = NONE fun replaceTypeConstrs tcon = copyTypeConstr (tcon, copyId, fn x => x, fn s => s) in copyType(t, fn tv=>tv, replaceTypeConstrs) end fun makeDecs (CoreValue(Value{class, name, typeOf, locations, access, ...}), (addr, { fixes, values, structures, signatures, functors, types } )) = let (* Extract the value from the result vector except if we have a type-dependent function e.g. PolyML.print where we must use the type-dependent version. *) val newAccess = case access of Overloaded _ => access | _ => Global(mkInd (addr, results)) (* Replace the typeIDs. *) val newVal = Value{class=class, name=name, typeOf=replaceTypes typeOf, access=newAccess, locations=locations, references = NONE, instanceTypes=NONE} in (addr+1, { fixes=fixes, values=(name, newVal) :: values, structures=structures, signatures=signatures, functors=functors, types=types } ) end | makeDecs (CoreStruct dec, (addr, {fixes, values, structures, signatures, functors, types})) = (* If we open a structure we've created in the same "program" we may have a non-global substructure. We have to process any structures and also map any type IDs. *) let local val Signatures { name, locations, typeIdMap, tab, ...} = structSignat dec in val resultSig = makeSignature(name, tab, 0, locations, composeMaps(typeIdMap, mapTypeIds), []) end val strName = structName dec val newStruct = Struct { name = strName, signat = resultSig, access = Global(mkInd (addr, results)), locations = structLocations dec } in (addr+1, { fixes=fixes, values=values, structures=(strName, newStruct) :: structures, signatures=signatures, functors=functors, types=types } ) end | makeDecs (CoreFix pair, (addr, {fixes, values, structures, signatures, functors, types})) = (addr, { fixes=pair :: fixes, values=values, structures=structures, signatures=signatures, functors=functors, types=types } ) | makeDecs (CoreType (TypeConstrSet(tc, constrs)), (addr, {fixes, values, structures, signatures, functors, types})) = let fun loadConstr(Value{class, name, typeOf, locations, ...}, (addr, others)) = let val newAccess = Global(mkInd (addr, results)) (* Don't bother replacing the type ID here. fullCopyDatatype will do it. *) val newConstr = Value{class=class, name=name, typeOf=typeOf, access=newAccess, locations=locations, references = NONE, instanceTypes=NONE} in (addr+1, others @ [newConstr]) end val (nextAddr, newConstrs) = List.foldl loadConstr (addr, []) constrs val copiedTC = fullCopyDatatype(TypeConstrSet(tc, newConstrs), mapTypeIds, "") val newName = #second(splitString(tcName tc)) in (nextAddr, { fixes=fixes, values=values, structures=structures, signatures=signatures, functors=functors, types=(newName, copiedTC) :: types } ) end in List.foldl makeDecs args vars end fun extractTopDec(str, (addr, env as { fixes, values, structures, signatures, functors, types }, nIds, mapPrevTypIds)) = case str of StrDec(str, ref typeIds) => let (* Create new Free IDs for top-level IDs. *) fun loadId(TypeId{idKind=Bound{eqType, arity, ...}, description, ...}, (n, ids)) = let val newId = makeFreeId(arity, Global(mkInd(n, results)), pling eqType, description) in (n+1, newId :: ids) end | loadId _ = raise InternalError "Not Bound" (* Construct the IDs and reverse the list so the first ID is first*) val (newAddr, mappedIds) = List.foldl loadId (addr, []) typeIds val idMap = Vector.fromList mappedIds fun mapTypeIds n = if n < nIds then mapPrevTypIds n else Vector.sub(idMap, n-nIds) val (resAddr, resEnv) = extractStruct (str, mapTypeIds, (newAddr, env)) in (resAddr, resEnv, nIds + Vector.length idMap, mapTypeIds) end | FunctorDec (structList : functorBind list, _) => let (* Get the functor values. *) fun extractFunctorBind ({name, valRef, ...}: functorBind, (addr, funcs)) = let val code = mkInd (addr, results) val func = valOf(!valRef) (* We need to convert any references to typeIDs created in strdecs in the same "program". *) (* The result signature shares with the argument so we only copy IDs less than the min for the argument signature. *) val Functor {result=fnResult, name=functorName, locations=functorLocations, arg=fnArg as Struct{name = fnArgName, signat=fnArgSig, ...}, ...} = func local val Signatures { name, tab, typeIdMap, boundIds, firstBoundIndex, locations, ... } = fnArgSig fun newMap n = if n < firstBoundIndex then mapPrevTypIds n else List.nth(boundIds, n-firstBoundIndex) in val functorArgSig = makeSignature(name, tab, firstBoundIndex, locations, composeMaps(typeIdMap, newMap), boundIds) val copiedArg = Struct{name=fnArgName, signat=functorArgSig, access=structAccess fnArg, locations=structLocations fnArg} end local val Signatures { name, tab, typeIdMap, boundIds, firstBoundIndex, locations, ... } = fnResult val Signatures { boundIds=argBoundIds, firstBoundIndex=argMinTypes, ...} = functorArgSig fun newMap n = if n >= firstBoundIndex then List.nth(boundIds, n-firstBoundIndex) else if n >= argMinTypes then case List.nth(argBoundIds, n-argMinTypes) of (* Add the argument structure name onto the name of type IDs in the argument. *) TypeId{ access, idKind, description={location, name, description}} => TypeId { access=access, idKind=idKind, description= { location=location, description=description, name=if fnArgName = "" then name else fnArgName^"."^name } } else mapPrevTypIds n in val functorSigResult = makeSignature(name, tab, firstBoundIndex, locations, composeMaps(typeIdMap, newMap), boundIds) end val funcTree = makeFunctor(functorName, copiedArg, functorSigResult, makeGlobal code, functorLocations) in (addr + 1, (name, funcTree) :: funcs) end val (newAddr, newfunctors ) = List.foldl extractFunctorBind (addr, functors) structList in (newAddr, { functors=newfunctors, fixes=fixes, values=values, signatures=signatures, structures=structures, types=types }, nIds, mapPrevTypIds) end | SignatureDec (structList : sigBind list, _) => let (* We need to convert any references to typeIDs created in strdecs in the same "program". *) fun copySignature fnSig = let val Signatures { name, tab, typeIdMap, firstBoundIndex, boundIds, locations, ... } = fnSig fun mapIDs n = if n < firstBoundIndex then mapPrevTypIds n else List.nth(boundIds, n-firstBoundIndex) in makeSignature(name, tab, firstBoundIndex, locations, composeMaps(typeIdMap, mapIDs), boundIds) end val newSigs = List.map (fn ({sigRef=ref s, name, ...}: sigBind) => (name, copySignature s)) structList in (addr, { fixes=fixes, values=values, structures=structures, signatures=newSigs @ signatures, functors=functors, types=types }, nIds, mapPrevTypIds) end val empty = { fixes=[], values=[], structures=[], functors=[], types=[], signatures=[] } val (_, result, _, _) = List.foldl extractTopDec (0, empty, 0, fn _ => raise Subscript) strs; (* The entries in "result" are in reverse order of declaration and may contain duplicates. We need to reverse and filter the lists so that we end up with the lists in order and with duplicates removed. *) fun revFilter result [] = result | revFilter result ((nameValue as (name, _)) ::rest) = let (* Remove any entries further down the list if they have the same name. *) val filtered = List.filter (fn (n,_) => name <> n) rest in revFilter (nameValue :: result) filtered end in { fixes=revFilter [] (#fixes result), values=revFilter [] (#values result), structures=revFilter [] (#structures result), functors=revFilter [] (#functors result), types=revFilter [] (#types result), signatures=revFilter [] (#signatures result) } end (* pass4Structs *) structure Sharing = struct type structDec = structDec type structValue = structValue type structVals = structVals type types = types type parsetree = parsetree type lexan = lexan type pretty = pretty type values = values type typeConstrSet = typeConstrSet type codetree = codetree type signatures = signatures type functors = functors type env = env type sigBind = sigBind and functorBind = functorBind and structBind = structBind type machineWord = machineWord type fixStatus = fixStatus type topdec = topdec type program = program type typeParsetree = typeParsetree type formalArgStruct= formalArgStruct type ptProperties = ptProperties type structSigBind = structSigBind type typeVarForm = typeVarForm type sigs = sigs end end; diff --git a/modules/IntInfAsInt/Date.sml b/modules/IntInfAsInt/Date.sml index 0a9aad9c..56afbfa5 100644 --- a/modules/IntInfAsInt/Date.sml +++ b/modules/IntInfAsInt/Date.sml @@ -1,35 +1,35 @@ (* Title: Rebuild the basis library: Date - Copyright David C.J. Matthews 2016 + Copyright David C.J. Matthews 2016, 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 *) (* Date . *) -useBasis "DateSignature"; +useBasis "DATE.sig"; structure Date: DATE = struct open Date val date = fn { year, month, day, hour, minute, second, offset } => date {year=FixedInt.fromLarge year, month=month, day=FixedInt.fromLarge day, hour=FixedInt.fromLarge hour, minute=FixedInt.fromLarge minute, second=FixedInt.fromLarge second, offset=offset} val year = FixedInt.toLarge o year and day = FixedInt.toLarge o day and hour = FixedInt.toLarge o hour and minute = FixedInt.toLarge o minute and second = FixedInt.toLarge o second and yearDay = FixedInt.toLarge o yearDay end; diff --git a/polyml.pyp b/polyml.pyp index 37ff6e59..4c3bad4d 100644 --- a/polyml.pyp +++ b/polyml.pyp @@ -1,240 +1,241 @@ + - + + - diff --git a/polymlInterpreted.pyp b/polymlInterpreted.pyp index 5e36b9af..17c9ff23 100644 --- a/polymlInterpreted.pyp +++ b/polymlInterpreted.pyp @@ -1,218 +1,219 @@ + - + + -