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/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/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/build.sml b/basis/build.sml index 1ba418d6..1700067a 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 + Copyright David C.J. Matthews 2000, 2005, 2015-16, 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 *) (* 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/OS.sml"; val () = Bootstrap.use "basis/ExnPrinter.sml"; (* Relies on OS. *) val () = Bootstrap.use "basis/InitialPolyML.ML"; (* Relies on OS. *) val () = Bootstrap.use "basis/IO.sml"; val () = Bootstrap.use "basis/PRIM_IO.sml"; val () = Bootstrap.use "basis/PrimIO.sml"; (*val () = Bootstrap.use "basis/TextPrimIO.sml"; val () = Bootstrap.use "basis/BinPrimIO.sml"; *) val () = Bootstrap.use "basis/LibraryIOSupport.sml"; val () = Bootstrap.use "basis/STREAM_IO.sml"; val () = Bootstrap.use "basis/BasicStreamIO.sml"; val () = Bootstrap.use "basis/IMPERATIVE_IO.sml"; val () = Bootstrap.use "basis/ImperativeIO.sml"; val () = Bootstrap.use "basis/TextIO.sml"; val () = Bootstrap.use "basis/BinIO.sml"; val () = Bootstrap.use "basis/NetHostDB.sml"; val () = Bootstrap.use "basis/NetProtDB.sml"; val () = Bootstrap.use "basis/NetServDB.sml"; val () = Bootstrap.use "basis/Socket.sml"; val () = Bootstrap.use "basis/GenericSock.sml"; val () = Bootstrap.use "basis/INetSock.sml"; val () = Bootstrap.use "basis/UnixSock.sml"; val () = Bootstrap.use "basis/PackRealBig.sml"; (* also declares PackRealLittle *) val () = Bootstrap.use "basis/PackWord8Big.sml"; (* also declares Pack8Little. ...*) val () = Bootstrap.use "basis/Array2Signature.sml"; val () = Bootstrap.use "basis/Array2.sml"; val () = Bootstrap.use "basis/IntArray2.sml"; val () = Bootstrap.use "basis/SML90.sml"; val () = Bootstrap.use "basis/Weak.sml"; val () = Bootstrap.use "basis/Signal.sml"; val () = Bootstrap.use "basis/BIT_FLAGS.sml"; val () = Bootstrap.use "basis/SingleAssignment.sml"; (* Build Windows or Unix structure as appropriate. *) local val getOS: int = LibrarySupport.getOSType() in val () = if getOS = 0 then ( Bootstrap.use "basis/Posix.sml"; Bootstrap.use "basis/Unix.sml") else if getOS = 1 then (Bootstrap.use "basis/Windows.sml") else () end; val () = Bootstrap.use "basis/HashArray.ML"; val () = Bootstrap.use "basis/UniversalArray.ML"; val () = Bootstrap.use "basis/PrettyPrinter.sml"; (* Add PrettyPrinter to PolyML structure. *) val () = Bootstrap.use "basis/ASN1.sml"; val () = Bootstrap.use "basis/Statistics.ML"; (* Add Statistics to PolyML structure. *) val () = Bootstrap.use "basis/ForeignConstants.sml"; val () = Bootstrap.use "basis/ForeignMemory.sml"; val () = Bootstrap.useWithParms [Bootstrap.Universal.tagInject Bootstrap.maxInlineSizeTag 1000] "basis/Foreign.sml"; val () = Bootstrap.use "basis/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/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 15699664..43d8ecb0 100644 --- a/mlsource/MLCompiler/INITIALISE_.ML +++ b/mlsource/MLCompiler/INITIALISE_.ML @@ -1,1930 +1,1930 @@ (* 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 and makeFullCall = makeCall CODETREE.Foreign.rtsCallFull (* We need to wrap this so that the arguments are passed in registers. *) fun makeRunCallTupled (argTypes, resultType, callN) : codetree = let val width = List.length argTypes val name = "rtsCall" ^ Int.toString width; local val f = mkLoadClosure 0 (* first item from enclosing scope *) val tuple = mkLoadArgument 0 (* the inner parameter *) val args = case argTypes of [singleType] => [(tuple, singleType)] | argTypes => let val argVals = List.tabulate(width, fn n => mkInd (n, tuple)) in ListPair.zipEq(argVals, argTypes) end in val innerBody = mkCall (f, args, resultType) end local (* The closure contains the address of the RTS call. *) val f = mkEval(mkConst callN, [mkLoadArgument 0]) val innerLambda = mkInlproc (innerBody, 1, name ^ "(1)", [mkLoadLocal 0], 0) in val outerBody = mkEnv([mkDec (0, f)], innerLambda) end val outerLambda = mkInlproc (outerBody, 1, name, [], 1) in outerLambda end local val a = makeTV () and b = makeTV () fun makeInlCode(makeCall, name) = let val call1 = toMachineWord(makeCall 1) val body = mkEval(mkConst call1, [mkLoadArgument 0]) val proc = mkInlproc (body, 1, name, [], 0) in makePolymorphic([a, b], proc) end in val rtsCallFull1Entry = makeInlCode(makeFullCall, "rtsCallFull1") and rtsCallFast1Entry = makeInlCode(makeFastCall, "rtsCallFast1") end local val a = makeTV () and b = makeTV () and c = makeTV () and d = makeTV () and e = makeTV () fun makeRtsCall(n, makeCall) = makeRunCallTupled(List.tabulate(n, fn _ => GeneralType), GeneralType, toMachineWord(makeCall n)) in val rtsCallFull0Entry = makePolymorphic([a], makeRtsCall(0, makeFullCall)) and rtsCallFast0Entry = makePolymorphic([a], makeRtsCall(0, makeFastCall)) val rtsCall0Type = String ->> Unit ->> a val rtsCall1Type = String ->> a ->> b val rtsCallFull2Entry = makePolymorphic([a, b, c], makeRtsCall(2, makeFullCall)) and rtsCallFast2Entry = makePolymorphic([a, b, c], makeRtsCall(2, makeFastCall)) val rtsCall2Type = String ->> TYPETREE.mkProductType [a,b] ->> c val rtsCallFull3Entry = makePolymorphic([a, b, c, d], makeRtsCall(3, makeFullCall)) val rtsCallFast3Entry = makePolymorphic([a, b, c, d], makeRtsCall(3, makeFastCall)) val rtsCall3Type = String ->> TYPETREE.mkProductType [a,b,c] ->> d val rtsCallFast4Entry = makePolymorphic([a, b, c, d, e], makeRtsCall(4, makeFastCall)) val rtsCall4Type = String ->> TYPETREE.mkProductType [a,b,c,d] ->> e 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 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/polyml.pyp b/polyml.pyp index 1d79a09e..5044cdfe 100644 --- a/polyml.pyp +++ b/polyml.pyp @@ -1,240 +1,241 @@ + - + + -