diff --git a/basis/FinalPolyML.582.sml b/basis/FinalPolyML.582.sml deleted file mode 100644 index b8b57fd0..00000000 --- a/basis/FinalPolyML.582.sml +++ /dev/null @@ -1,2229 +0,0 @@ -(* - Title: Nearly final version of the PolyML structure - Author: David Matthews - Copyright David Matthews 2008-9, 2014, 2015-17, 2019-21 - - 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 compilerDebug = ref 0 - 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", ".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) [] 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 compilerDebug = compilerDebug - 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/Real32.582.sml b/basis/Real32.582.sml deleted file mode 100644 index 8913a55d..00000000 --- a/basis/Real32.582.sml +++ /dev/null @@ -1,328 +0,0 @@ -(* - Title: Real32 structure. - Author: David Matthews - Copyright David Matthews 2018, 2021 - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -(* - This structure implements 32-bit real values, at least on X86. On other - platforms it is whatever "float" is. - N.B. This uses the X87 floating point instructions on X86/32. The precision - on the X87 is set to 64-bits which is correct for the Real.real operations - but involves an extra stage of rounding for Real32.real. That means that - the results may not be strictly accurate. -*) - -structure Real32: REAL where type real = Real32.real = -struct - open Real32 (* Inherit the type and the built-in functions. *) - open IEEEReal - - (* On both the X86 and ARM there is only a single conversion from - double to float using the current rounding mode. If we want - a specific rounding mode we need to set the rounding. *) - fun fromLarge mode value = - let - val current = getRoundingMode() - val () = setRoundingMode mode - val result = fromReal value - val () = setRoundingMode current - in - result - end - - val fromRealRound = fromLarge TO_NEAREST - - (* Defined to use the current rounding mode. *) - val fromInt = fromReal o Real.fromInt (* TODO *) - and fromLargeInt = fromReal o Real.fromLargeInt - - val zero = fromInt 0 and one = fromInt 1 and four = fromInt 4 - - local - (* The General call is now only used to get constants. *) - val doFloatFloat : int*unit->real = RunCall.rtsCallFull2 "PolyRealGeneral" - and doFloatInt : int*unit->int = RunCall.rtsCallFull2 "PolyRealGeneral" - fun callFloat n x = doFloatFloat(n, x) - and callFloatToInt n x = doFloatInt(n, x) - in - val radix : int = callFloatToInt 30 () - val precision : int = callFloatToInt 31 () - val maxFinite : real = callFloat 32 () - val minNormalPos : real = callFloat 33 () - val minPos : real = callFloat 34() - end - - val posInf : real = one/zero; - val negInf : real = ~one/zero; - - infix 4 == != ?=; - - val op != : real * real -> bool = not o op == - - local - in - (* isNan can be defined in terms of unordered. *) - fun isNan x = unordered(x, x) - - (* NAN values do not match and infinities when multiplied by 0 produce NAN. *) - fun isFinite x = x * zero == zero - - val copySign : (real * real) -> real = rtsCallFastFF_F "PolyRealFCopySign" - - (* Get the sign bit by copying the sign onto a finite value and then - testing. This works for non-finite values and zeros. *) - fun signBit r = copySign(one, r) < zero - - (* If we assume that all functions produce normalised results where - possible, the only subnormal values will be those smaller than - minNormalPos. *) - fun isNormal x = isFinite x andalso abs x >= minNormalPos - - fun class x = - if isFinite x then if x == zero then ZERO - else if abs x >= minNormalPos then NORMAL - else SUBNORMAL - else if isNan x then NAN - else (* not finite and not Nan *) INF - - fun sign x = - if isNan x then raise General.Domain - else if x == zero then 0 else if x < zero then ~1 else 1 - end - - fun sameSign (x, y) = signBit x = signBit y - - (* Returns the minimum. In the case where one is a NaN it returns the - other. In that case the comparison will be false. *) - fun min (a: real, b: real): real = if a < b orelse isNan b then a else b - (* Similarly for max. *) - fun max (a: real, b: real): real = if a > b orelse isNan b then a else b - - fun checkFloat x = - if isFinite x then x - else if isNan x then raise General.Div else raise General.Overflow - - (* On certain platforms e.g. mips, toLarge does not preserve - the sign on nans. We deal with the non-finite cases here. *) - - (* Use the Real versions for the moment. *) - fun toManExp r = - if not (isFinite r) orelse r == zero - (* Nan, infinities and +/-0 all return r in the mantissa. - We include 0 to preserve its sign. *) - then {man=r, exp=0} - else - let - val {man, exp} = Real.toManExp(toLarge r) - in - {man = fromRealRound man, exp = exp } - end - - and fromManExp {man, exp} = - if not (isFinite man) orelse man == zero - (* Nan, infinities and +/-0 in the mantissa all return - their argument. *) - then man - else fromRealRound(Real.fromManExp{man=toLarge man, exp=exp}) - - fun compare (r1, r2) = - if r1 == r2 then General.EQUAL - else if r1 < r2 then General.LESS - else if r1 > r2 then General.GREATER - else raise Unordered - - fun compareReal (r1, r2) = - if r1 == r2 then EQUAL - else if r1 < r2 then LESS - else if r1 > r2 then GREATER - else UNORDERED - - fun op ?= (x, y) = unordered(x, y) orelse x == y - - (* Although these may be built in in some architectures it's - probably not worth treating them specially at the moment. *) - fun *+ (x: real, y: real, z: real): real = x*y+z - and *- (x: real, y: real, z: real): real = x*y-z - - val realFloor = rtsCallFastF_F "PolyRealFFloor" - and realCeil = rtsCallFastF_F "PolyRealFCeil" - and realTrunc = rtsCallFastF_F "PolyRealFTrunc" - and realRound = rtsCallFastF_F "PolyRealFRound" - - val rem = rtsCallFastFF_F "PolyRealFRem" - - (* Split a real into whole and fractional parts. The fractional part must have - the same sign as the number even if it is zero. *) - fun split r = - let - val whole = realTrunc r - val frac = r - whole - in - { whole = whole, - frac = - if not (isFinite r) - then if isNan r then r else (* Infinity *) if r < zero then ~zero else zero - else if frac == zero then if signBit r then ~zero else zero - else frac } - end - - (* Get the fractional part of a real. *) - fun realMod r = #frac(split r) - - val nextAfter = rtsCallFastFF_F "PolyRealFNextAfter" - - fun toLargeInt mode r = Real.toLargeInt mode (toLarge r) - - local - (* These are defined to raise Domain rather than Overflow on Nans. *) - fun checkNan x = if isNan x then raise Domain else x - (* If int is fixed we use the hardware conversions otherwise we convert - it to real and use the real to arbitrary conversions. *) - in - val floor = - if Bootstrap.intIsArbitraryPrecision - then LargeInt.toInt o toLargeInt IEEEReal.TO_NEGINF else FixedInt.toInt o floorFix o checkNan - and ceil = - if Bootstrap.intIsArbitraryPrecision - then LargeInt.toInt o toLargeInt IEEEReal.TO_POSINF else FixedInt.toInt o ceilFix o checkNan - and trunc = - if Bootstrap.intIsArbitraryPrecision - then LargeInt.toInt o toLargeInt IEEEReal.TO_ZERO else FixedInt.toInt o truncFix o checkNan - and round = - if Bootstrap.intIsArbitraryPrecision - then LargeInt.toInt o toLargeInt IEEEReal.TO_NEAREST else FixedInt.toInt o roundFix o checkNan - - fun toInt IEEEReal.TO_NEGINF = floor - | toInt IEEEReal.TO_POSINF = ceil - | toInt IEEEReal.TO_ZERO = trunc - | toInt IEEEReal.TO_NEAREST = round - end - - (* The order of evaluation here is important. See Test175. *) - fun fmt fm = - let val doFmt = Real.fmt fm in fn r => doFmt (toLarge r) end - - val toString = Real.toString o toLarge - - (* Scan input source for a valid number. The format is the same as - for double precision. Convert it using the current rounding mode. *) - fun scan getc src = - case Real.scan getc src of - NONE => NONE - | SOME (r, a) => SOME(fromReal r, a) - - val fromString = StringCvt.scanString scan - - (* toDecimal: It's particularly important to handle the nan case - here because toLarge loses the sign bit on some architectures. *) - fun toDecimal r = - let - val sign = signBit r - val kind = class r - in - case kind of - ZERO => { class = ZERO, sign = sign, digits=[], exp = 0 } - | INF => { class = INF, sign = sign, digits=[], exp = 0 } - | NAN => { class = NAN, sign = sign, digits=[], exp = 0 } - | _ => (* NORMAL/SUBNORMAL *) Real.toDecimal(toLarge r) - end - - (* Convert from decimal. This is defined to use TO_NEAREST. - We need to handle NaNs specially because fromRealRound loses - the sign on a NaN. *) - local - val posNan = abs(zero / zero) - val negNan = ~posNan - in - fun fromDecimal { class = INF, sign=true, ...} = SOME negInf - | fromDecimal { class = INF, sign=false, ...} = SOME posInf - | fromDecimal { class = NAN, sign=true, ... } = SOME negNan - | fromDecimal { class = NAN, sign=false, ... } = SOME posNan - | fromDecimal arg = Option.map fromRealRound (Real.fromDecimal arg) - end - - structure Math = - struct - type real = real - - val sqrt = rtsCallFastF_F "PolyRealFSqrt" - and sin = rtsCallFastF_F "PolyRealFSin" - and cos = rtsCallFastF_F "PolyRealFCos" - and atan = rtsCallFastF_F "PolyRealFArctan" - and exp = rtsCallFastF_F "PolyRealFExp" - and ln = rtsCallFastF_F "PolyRealFLog" - and tan = rtsCallFastF_F "PolyRealFTan" - and asin = rtsCallFastF_F "PolyRealFArcSin" - and acos = rtsCallFastF_F "PolyRealFArcCos" - and log10 = rtsCallFastF_F "PolyRealFLog10" - and sinh = rtsCallFastF_F "PolyRealFSinh" - and cosh = rtsCallFastF_F "PolyRealFCosh" - and tanh = rtsCallFastF_F "PolyRealFTanh" - - val atan2 = rtsCallFastFF_F "PolyRealFAtan2" - val pow = rtsCallFastFF_F "PolyRealFPow" - - (* Derived values. *) - val e = exp one - val pi = four * atan one - end - - - (* Converter for literal constants. Copied from Real. *) - local - fun convReal (s: string) : real = - let - (* Set the rounding mode to TO_NEAREST whatever the current - rounding mode. Otherwise the result of compiling a piece of - code with a literal constant could depend on what the rounding - mode was set to. We should always support TO_NEAREST. *) - val oldRounding = IEEEReal.getRoundingMode() - val () = IEEEReal.setRoundingMode IEEEReal.TO_NEAREST - val scanResult = StringCvt.scanString scan s - val () = IEEEReal.setRoundingMode oldRounding - in - case scanResult of - NONE => raise RunCall.Conversion "Invalid real constant" - | SOME res => res - end - in - (* Install this as a conversion function for real literals. *) - val (): unit = RunCall.addOverload convReal "convReal" - end - -end; - - -val () = RunCall.addOverload Real32.>= ">=" -and () = RunCall.addOverload Real32.<= "<=" -and () = RunCall.addOverload Real32.> ">" -and () = RunCall.addOverload Real32.< "<" -and () = RunCall.addOverload Real32.+ "+" -and () = RunCall.addOverload Real32.- "-" -and () = RunCall.addOverload Real32.* "*" -and () = RunCall.addOverload Real32.~ "~" -and () = RunCall.addOverload Real32.abs "abs" -and () = RunCall.addOverload Real32./ "/"; - - -(* Install print function. *) -local - fun print_real _ _ (r: Real32.real) = - PolyML.PrettyString(Real32.fmt (StringCvt.GEN(SOME 10)) r) -in - val () = PolyML.addPrettyPrinter print_real; -end; diff --git a/basis/Thread.582.sml b/basis/Thread.582.sml deleted file mode 100644 index 5625ca65..00000000 --- a/basis/Thread.582.sml +++ /dev/null @@ -1,769 +0,0 @@ -(* - Title: Thread package for ML. - Author: David C. J. Matthews - Copyright (c) 2007-2014, 2018-21 - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -(* This signature and structure are not part of the standard basis library - but are included here because they depend on the Time structure and are - in turn dependencies of the BasicIO structure. *) - -(*!Earlier versions of Poly/ML have provided a form of concurrent execution through - the Process structure. Version 5.1 introduces - new thread primitives in the Thread structure. This structure is modelled on - the Posix thread (pthread) package but simplified and modified for ML. The aim - is to provide an efficient implementation of parallelism particularly to enable - ML programs to make use of multi-core processors while minimising the changes - needed to existing code. The Process structure will continue to be available - as a library written on top of these primitives but new programs should use - the Thread structure directly. - -The thread package differs from pthreads in a number of ways. -There is no join function to wait for the completion of a thread. -This can be written using mutexes and condition variables. -Cancellation and signal handling are combined into the interrupt -functions. (The Poly/ML Signal structure handles signals for all the -threads together). The effect of explicit cancellation is achieved -using the interrupt function. This causes an interrupt to be -generated in a specific thread. Alternatively an interrupt can be -broadcast to all threads. This is most likely to be used -interactively to kill threads that appear to have gone out of -control. The normal top-level handler for a console interrupt will -generate this. Threads can choose how or whether they respond to -these interrupts. A thread that is doing processor-intensive work -probably needs to be able to be interrupted asynchronously whereas if -it is communicating with other threads the presence of asynchronous -interrupts makes correct programming difficult. -*) - -signature THREAD = -sig - (*!The Thread exception can be raised by various of the functions in the - structure if they detect an error.*) - exception Thread of string (* Raised if an operation fails. *) - - structure Thread: - sig - (*!The type of a thread identifier.*) - eqtype thread - - (* Thread attributes - This may be extended. *) - (*!The type of a thread attribute. Thread attributes are - properties of the thread that are set initially when the thread is - created but can subsequently be modified by the thread itself. The - thread attribute type may be extended in the future to include things - like scheduling priority. The current thread attributes control the - way interrupt exceptions are delivered to the thread. - - `EnableBroadcastInterrupt` controls whether the thread will receive an interrupt sent using - `broadcastInterrupt` or as a result of pressing the console interrupt - key. If this is false the thread will not receive them. The default - for a new thread if this is not specified is false. - - `InterruptState` controls when and whether interrupts are delivered to the - thread. This includes broadcast interrupts and also interrupts directed at - a specific thread with the interrupt call. - `InterruptDefer` means the thread - will not receive any interrupts. However, if the thread has previously been - interrupted the interrupt may be delivered when the thread calls setAttributes - to change its interrupt state. `InterruptSynch` - means interrupts are delivered - synchronously. An interrupt will be delayed until an interruption point. An - interruption point is one of: `testInterrupt`, - `ConditionVar.wait`, `ConditionVar.waitUntil` - and various library calls that may block, such as IO calls, pause etc. N.B. - `Mutex.lock` is not an interruption point even though it can result in a thread - blocking for an indefinite period. `InterruptAsynch` means interrupts are delivered - asynchronously i.e. at a suitable point soon after they are triggered. - `InterruptAsynchOnce` - means that only a single interrupt is delivered asynchronously after which - the interrupt state is changed to `InterruptSynch`. It allows a thread to tidy - up and if necessary indicate that it has been interrupted without the risk - of a second asynchronous interrupt occurring in the handler for the first - interrupt. If this attribute is not specified when a thread is created the - default is `InterruptSynch`. - - `MaximumMLStack` was added in version 5.5.3. It controls the maximum size the - ML stack may grow to. It is an option type where NONE allows the stack to - grow to the limit of the available memory whereas SOME n limits the stack - to n words. This is approximate since there is some rounding involved. When - the limit is reached the thread is sent an Interrupt exception.*) - datatype threadAttribute = - (* Does this thread accept a broadcast interrupt? The default is not to - accept broadcast interrupts. *) - EnableBroadcastInterrupt of bool - (* How to handle interrupts. The default is to handle interrupts synchronously. *) - | InterruptState of interruptState - (* Maximum size of the ML stack in words. NONE means unlimited *) - | MaximumMLStack of int option - - and interruptState = - InterruptDefer (* Defer any interrupts. *) - | InterruptSynch (* Interrupts are delivered synchronously. An interrupt - will be delayed until an interruption point. An interruption point - is one of: testInterrupt, ConditionVar.wait, ConditionVar.waitUntil - and various library calls that may block, such as IO calls, pause etc. - N.B. Mutex.lock is not an interruption point even though it can result - in a thread blocking for an indefinite period. *) - | InterruptAsynch (* Interrupts are delivered asynchronously i.e. at a suitable - point soon after they are triggered. *) - | InterruptAsynchOnce (* As InterruptAsynch except that only a single interrupt - is delivered asynchronously after which the interrupt state is changed to - InterruptSynch. It allows a thread to tidy up and if necessary indicate - that it has been interrupted without the risk of a second asynchronous - interrupt occurring in the handler for the first interrupt. *) - - (*!Fork a thread. Starts a new thread running - the function argument. The attribute list gives initial values for thread attributes - which can be modified by the thread itself. Any unspecified attributes take - default values. The thread is terminated when the thread function returns, if - it raises an uncaught exception or if it calls `exit`;*) - val fork: (unit->unit) * threadAttribute list -> thread - - (*!Terminate this thread. *) - val exit: unit -> unit - (*!Test if a thread is still running or has terminated. This function should be - used with care. The thread may be on the point of terminating and still appear - to be active.*) - val isActive: thread -> bool - - (*!Test whether thread ids are the same. This is provided for backwards compatibility - since `thread` is an eqtype. *) - val equal: thread * thread -> bool - (*!Return the thread identifier for the current thread. *) - val self: unit -> thread - - exception Interrupt (* = SML90.Interrupt *) - (*!Send an Interrupt exception to a specific thread. When and indeed whether - the exception is actually delivered will depend on the interrupt state - of the target thread. Raises Thread if the thread is no longer running, - so an exception handler should be used unless the thread is known to - be blocked. *) - val interrupt: thread -> unit - (*!Send an interrupt exception to every thread which is set to accept it. *) - val broadcastInterrupt: unit -> unit - (*!If this thread is handling interrupts synchronously, test to see - if it has been interrupted. If so it raises the - `Interrupt` exception. *) - val testInterrupt: unit -> unit - (*!Terminate a thread. This should be used as a last resort. Normally - a thread should be allowed to clean up and terminate by using the - interrupt call. Raises Thread if the thread is no longer running, - so an exception handler should be used unless the thread is known to - be blocked. *) - val kill: thread -> unit - - (*!Get and set thread-local store for the calling thread. The store is a - tagged associative memory which is initially empty for a new thread. - A thread can call setLocal to add or replace items in its store and - call getLocal to return values if they exist. The Universal structure - contains functions to make new tags as well as injection, projection and - test functions. *) - val getLocal: 'a Universal.tag -> 'a option - and setLocal: 'a Universal.tag * 'a -> unit - - (*!Change the specified attribute(s) for the calling thread. Unspecified - attributes remain unchanged. *) - val setAttributes: threadAttribute list -> unit - (*!Get the values of attributes. *) - val getAttributes: unit -> threadAttribute list - - (*!Return the number of processors that will be used to run threads - and the number of physical processors if that is available. *) - val numProcessors: unit -> int - and numPhysicalProcessors: unit -> int option - end - - structure Mutex: - sig - (*!A mutex provides simple mutual exclusion. A thread can lock - a mutex and until it unlocks it no other thread will be able to lock it. - Locking and unlocking are intended to be fast in the situation when - there is no other process attempting to lock the mutex. - These functions may not work correctly if an asynchronous interrupt - is delivered during the calls. A thread should use synchronous interrupt - when using these calls. *) - type mutex - (*!Make a new mutex *) - val mutex: unit -> mutex - (*!Lock a mutex. If the mutex is currently locked the thread is - blocked until it is unlocked. If a thread tries to lock a mutex that - it has previously locked the thread will deadlock. - N.B. `thread` is not an interruption point - (a point where synchronous - interrupts are delivered) even though a thread can be blocked indefinitely. *) - val lock: mutex -> unit - (*!Unlock a mutex and allow any waiting threads to run. The behaviour - if the mutex was not previously locked by the calling thread is undefined. *) - val unlock: mutex -> unit - (*!Attempt to lock the mutex. Returns true if the mutex was not - previously locked and has now been locked by the calling thread. Returns - false if the mutex was previously locked, including by the calling thread. *) - val trylock: mutex -> bool - end - - structure ConditionVar: - sig - (*!Condition variables are used to provide communication - between threads. A condition variable is used in conjunction with a mutex - and usually a reference to establish and test changes in state. The normal - use is for one thread to lock a mutex, test the reference and then wait on - the condition variable, releasing the lock on the mutex while it does so. - Another thread may then lock the mutex, update the reference, unlock the - mutex, and signal the condition variable. This wakes up the first thread - and reacquires the lock allowing the thread to test the updated reference - with the lock held. - More complex communication mechanisms, such as blocking channels, can - be written in terms of condition variables. *) - type conditionVar - (*!Make a new condition variable. *) - val conditionVar: unit -> conditionVar - (*!Release the mutex and block until the condition variable is signalled. When - wait returns the mutex will have been re-acquired. - - If the thread is handling interrupts synchronously this function can be interrupted - using the `Thread.interrupt` function or, if the thread is set to - accept broadcast interrupts, `Thread.broadcastInterrupt`. The thread - will re-acquire the mutex before the exception is delivered. An exception - will only be delivered in this case if the interrupt is sent before the condition - variable is signalled. If the interrupt is sent after the condition variable - is signalled the function will return normally even if it has not yet re-acquired - the mutex. The interrupt state will be delivered on the next call to "wait", - `Thread.testInterrupt` or other blocking call. - - A thread should never call this function if it may receive an asynchronous - interrupt. It should always set its interrupt state to either - `InterruptSynch` - or `InterruptDefer` beforehand. - An asynchronous interrupt may leave the condition - variable and the mutex in an indeterminate state and could lead to deadlock. - - A condition variable should only be associated with one mutex at a time. - All the threads waiting on a condition variable should pass the same mutex - as argument.*) - val wait: conditionVar * Mutex.mutex -> unit - (*!As wait except that it blocks until either the condition - variable is signalled or the time (absolute) is reached. Either way - the mutex is reacquired so there may be a further delay if it is held - by another thread. *) - val waitUntil: conditionVar * Mutex.mutex * Time.time -> bool - (*!Wake up one thread if any are waiting on the condition variable. - If there are several threads waiting for the condition variable one will be - selected to run and will run as soon as it has re-acquired the lock.*) - val signal: conditionVar -> unit - (*!Wake up all threads waiting on the condition variable. *) - val broadcast: conditionVar -> unit - end - -end; - -structure Thread :> THREAD = -struct - exception Thread = RunCall.Thread - - structure Thread = - struct - open Thread (* Created in INITIALISE with thread type and self function. *) - - (* Equality is pointer equality. *) - val equal : thread*thread->bool = op = - - datatype threadAttribute = - EnableBroadcastInterrupt of bool - | InterruptState of interruptState - | MaximumMLStack of int option - - and interruptState = - InterruptDefer - | InterruptSynch - | InterruptAsynch - | InterruptAsynchOnce - - (* Convert attributes to bits and a mask. *) - fun attrsToWord (at: threadAttribute list): Word.word * Word.word = - let - (* Check that a particular attribute appears only once. - As well as accumulating the actual bits in the result we - also accumulate the mask of bits. If any of these - reappear we raise an exception. *) - fun checkRepeat(r, acc, set, mask) = - if Word.andb(set, mask) <> 0w0 - then raise Thread "The same attribute appears more than once in the list" - else convert(r, acc, Word.orb(set, mask)) - - and convert([], acc, set) = (acc, set) - | convert(EnableBroadcastInterrupt true :: r, acc, set) = - checkRepeat(r, Word.orb(acc, 0w1), set, 0w1) - | convert(EnableBroadcastInterrupt false :: r, acc, set) = - checkRepeat(r, acc (* No bit *), set, 0w1) - | convert(InterruptState s :: r, acc, set) = - checkRepeat(r, Word.orb(setIstateBits s, acc), set, 0w6) - | convert(MaximumMLStack _ :: r, acc, set) = - convert(r, acc, set) - in - convert(at, 0w0, 0w0) - end - - and setIstateBits InterruptDefer = 0w0 - | setIstateBits InterruptSynch = 0w2 - | setIstateBits InterruptAsynch = 0w4 - | setIstateBits InterruptAsynchOnce = 0w6 - - fun getIstateBits(w: Word.word): interruptState = - let - val ibits = Word.andb(w, 0w6) - in - if ibits = 0w0 - then InterruptDefer - else if ibits = 0w2 - then InterruptSynch - else if ibits = 0w4 - then InterruptAsynch - else InterruptAsynchOnce - end - - fun wordToAttrs w = - let - (* Enable broadcast - true if bottom bit is set. *) - val bcast = EnableBroadcastInterrupt(Word.andb(w, 0w1) = 0w1) - in - [bcast, InterruptState(getIstateBits w)] - end - - exception Interrupt = RunCall.Interrupt - - (* The thread id is opaque outside this structure but is actually a six - word mutable object. - Word 0: Index into thread table (used inside the RTS only) - Word 1: Flags: initialised by the RTS and set by this code - Word 2: Thread local store: read and set by this code. - Word 3: IntRequest: Set by the RTS if there is an interrupt pending - Word 4: Maximum ML stack size. Unlimited is stored here as zero - *) - val threadIdFlags = 0w1 - and threadIdThreadLocal = 0w2 - and threadIdIntRequest = 0w3 - and threadIdStackSize = 0w4 - - fun getLocal (t: 'a Universal.tag) : 'a option = - let - val root: Universal.universal ref list = - RunCall.loadWord(self(), threadIdThreadLocal) - - fun doFind [] = NONE - | doFind ((ref v)::r) = - if Universal.tagIs t v - then SOME(Universal.tagProject t v) - else doFind r - in - doFind root - end - - fun setLocal (t: 'a Universal.tag, newVal: 'a) : unit = - let - (* See if we already have this in the list. *) - val root: Universal.universal ref list = - RunCall.loadWord(self(), threadIdThreadLocal) - - fun doFind [] = - (* Not in the list - Add it. *) - RunCall.storeWord - (self(), threadIdThreadLocal, - ref (Universal.tagInject t newVal) :: root) - | doFind (v::r) = - if Universal.tagIs t (!v) - (* If it's in the list update it. *) - then v := Universal.tagInject t newVal - else doFind r - - in - doFind root - end - - local - val threadTestInterrupt: unit -> unit = RunCall.rtsCallFull0 "PolyThreadTestInterrupt" - in - fun testInterrupt() = - (* If there is a pending request the word in the thread object - will be non-zero. *) - if RunCall.loadWord(self(), threadIdIntRequest) <> 0 - then threadTestInterrupt() - else () - end - - val exit: unit -> unit = RunCall.rtsCallFull0 "PolyThreadKillSelf" - and isActive: thread -> bool = RunCall.rtsCallFast1 "PolyThreadIsActive" - and broadcastInterrupt: unit -> unit = RunCall.rtsCallFull0 "PolyThreadBroadcastInterrupt" - - local - fun getAttrWord (me: thread) : Word.word = - RunCall.loadWord(me, threadIdFlags) - - fun getStackSizeAsInt (me: thread) : int = - RunCall.loadWord(me, threadIdStackSize) - - and getStackSize me : int option = - case getStackSizeAsInt me of - 0 => NONE - | s => SOME s - - fun newStackSize ([], default) = default - | newStackSize (MaximumMLStack NONE :: _, _) = 0 - | newStackSize (MaximumMLStack (SOME n) :: _, _) = - if n <= 0 then raise Thread "The stack size must be greater than zero" else n - | newStackSize (_ :: l, default) = newStackSize (l, default) - - val threadMaxStackSize: int -> unit = RunCall.rtsCallFull1 "PolyThreadMaxStackSize" - in - (* Set attributes. Only changes the values that are specified. The - others remain the same. *) - fun setAttributes (attrs: threadAttribute list) : unit = - let - val me = self() - val oldValues: Word.word = getAttrWord me - val (newValue, mask) = attrsToWord attrs - val stack = newStackSize(attrs, getStackSizeAsInt me) - in - RunCall.storeWord (self(), threadIdFlags, - Word.orb(newValue, Word.andb(Word.notb mask, oldValues))); - if stack = getStackSizeAsInt me - then () else threadMaxStackSize stack; - (* If we are now handling interrupts asynchronously check whether - we have a pending interrupt now. This will only be effective - if we were previously handling them synchronously or blocking - them. *) - if Word.andb(newValue, 0w4) = 0w4 - then testInterrupt() - else () - end - - fun getAttributes() : threadAttribute list = - let - val me = self() - in - MaximumMLStack (getStackSize me) :: wordToAttrs(getAttrWord me) - end - - (* These are used in the ConditionVar structure. They affect only the - interrupt handling bits. *) - fun getInterruptState(): interruptState = getIstateBits(getAttrWord(self())) - and setInterruptState(s: interruptState): unit = - RunCall.storeWord (self(), threadIdFlags, - Word.orb(setIstateBits s, Word.andb(Word.notb 0w6, getAttrWord(self())))) - - local - (* The default for a new thread is to ignore broadcasts and handle explicit - interrupts synchronously. *) - val (defaultAttrs, _) = - attrsToWord[EnableBroadcastInterrupt false, InterruptState InterruptSynch] - val threadForkFunction: - (unit->unit) * word * int -> thread = RunCall.rtsCallFull3 "PolyThreadForkThread" - in - fun fork(f:unit->unit, attrs: threadAttribute list): thread = - let - (* Any attributes specified explicitly override the defaults. *) - val (attrWord, mask) = attrsToWord attrs - val attrValue = Word.orb(attrWord, Word.andb(Word.notb mask, defaultAttrs)) - val stack = newStackSize(attrs, 0 (* Default is unlimited *)) - (* Run the function and exit whether it returns normally or raises an exception. *) - fun threadFunction () = (f() handle _ => ()) before exit() - in - threadForkFunction(threadFunction, attrValue, stack) - end - end - end - - local - (* Send an interrupt to a thread. If it returns false - the thread did not exist and this should raise an exception. *) - val threadSendInterrupt: thread -> bool = RunCall.rtsCallFast1 "PolyThreadInterruptThread" - in - fun interrupt(t: thread) = - if threadSendInterrupt t - then () - else raise Thread "Thread does not exist" - end - - local - val threadKillThread: thread -> bool = RunCall.rtsCallFast1 "PolyThreadKillThread" - in - fun kill(t: thread) = - if threadKillThread t - then () - else raise Thread "Thread does not exist" - end - - val numProcessors: unit -> int = RunCall.rtsCallFast0 "PolyThreadNumProcessors" - - local - val numberOfPhysical: unit -> int = - RunCall.rtsCallFast0 "PolyThreadNumPhysicalProcessors" - in - fun numPhysicalProcessors(): int option = - (* It is not always possible to get this information *) - case numberOfPhysical() of 0 => NONE | n => SOME n - end - end - - structure Mutex = - struct - type mutex = Word.word ref - val mutex = LibrarySupport.volatileWordRef (* Initially 0=unlocked. *) - open Thread (* atomicExchangeAdd, atomicReset and cpuPause are set up by Initialise. *) - - val threadMutexBlock: mutex -> unit = RunCall.rtsCallFull1 "PolyThreadMutexBlock" - val threadMutexUnlock: mutex -> unit = RunCall.rtsCallFull1 "PolyThreadMutexUnlock" - - (* A mutex is implemented as a Word.word ref. It is initially set to 0 and locked - by atomically incrementing it. If it was previously unlocked the result will - by one but if it was already locked it will be some positive value. When it - is unlocked it is atomically decremented. If there was no contention the result - will again be 0 but if some other thread tried to lock it the result will be - one or positive. In that case the unlocking thread needs to call in to the - RTS to wake up the blocked thread. - - The cost of contention on the lock is very high. To try to avoid this we - first loop (spin) to see if we can get the lock without contention. *) - - val spin_cycle = 20000 - fun spin (m: mutex, c: int) = - if atomicExchAdd(m, 0w0) = 0w0 then () - else if c = spin_cycle then () - else (cpuPause(); spin(m, c+1)); - - fun lock (m: mutex): unit = - let - val () = spin(m, 0) - val oldValue = atomicExchAdd(m, 0w1) - in - if oldValue = 0w0 - then () (* We've acquired the lock. *) - else (* It's locked. We return when we have the lock. *) - ( - threadMutexBlock m; - lock m (* Try again. *) - ) - end - - fun unlock (m: mutex): unit = - let - val oldValue = atomicExchAdd(m, ~ 0w1) - in - if oldValue = 0w1 - then () (* No contention. *) - else - (* Another thread has blocked and we have to release it. We can safely - set the value to 0 here to release the lock. If another thread - acquires it before we have woken up the other threads that's fine. - Equally, if another thread incremented the count and saw it was - still locked it will enter the RTS and try to acquire the lock - there. - It's probably better to reset it here rather than within the RTS - since it allows another thread to acquire the lock immediately - rather than after the rather long process of entering the RTS. - Resetting this needs to be atomic with respect to atomic increment - and decrement. That's not a problem on X86 so a simple assignment - is sufficient but in the interpreter at least it's necessary to - acquire a lock. *) - ( - atomicReset m; - threadMutexUnlock m - ) - end - - (* Try to lock the mutex. If it was previously unlocked then lock it and - return true otherwise return false. Because we don't block here there is - the possibility that the thread that has locked it could release the lock - shortly afterwards. The check for atomicExchangeAdd(m, 0w0) = 0w0 - is an optimisation and the idea is that we avoid the increment which will - cause the thread that actually has the lock to have to call into the - RTS to release the, non-existent, blocked threa. - There is a small chance that another thread could lock the mutex between the - test and the atomicIncr. In that case the atomicIncr would - return a value > 1 and the function that locked the mutex will have to - call into the RTS to reset it when it is unlocked. *) - fun trylock (m: mutex): bool = - if atomicExchAdd(m, 0w0) = 0w0 andalso atomicExchAdd(m, 0w1) = 0w0 - then true (* We've acquired the lock. *) - else false (* The lock was taken. *) - end - - structure ConditionVar = - struct - open Thread - - (* A condition variable contains a lock and a list of suspended threads. *) - type conditionVar = { lock: Mutex.mutex, threads: thread list ref } - fun conditionVar(): conditionVar = - { lock = Mutex.mutex(), threads = LibrarySupport.volatileListRef() } - - local - val threadCondVarWait: Mutex.mutex -> unit = RunCall.rtsCallFull1 "PolyThreadCondVarWait" - and threadCondVarWaitUntil: Mutex.mutex * Time.time -> unit = RunCall.rtsCallFull2 "PolyThreadCondVarWaitUntil" - in - fun innerWait({lock, threads}: conditionVar, m: Mutex.mutex, t: Time.time option) : bool = - let - val me = self() (* My thread id. *) - - fun waitAgain() = - let - fun doFind [] = false | doFind(h::t) = equal(h, me) orelse doFind t - - fun removeThis [] = raise Fail "Thread missing in list" - | removeThis (h::t) = if equal(h, me) then t else h :: removeThis t - - val () = - case t of - SOME time => threadCondVarWaitUntil(lock, time) - | NONE => threadCondVarWait lock - - val () = Mutex.lock lock (* Get the lock again. *) - - (* Are we still on the list? If so we haven't been explicitly woken - up. We've either timed out, been interrupted or simply returned - because the RTS needed to process some asynchronous results. *) - val stillThere = doFind(!threads) - open Time (* For >= *) - in - if not stillThere - then (* We're done. *) - ( - Mutex.unlock lock; - true - ) - else if (case t of NONE => false | SOME t => Time.now() >= t) - then (* We've timed out. *) - ( - threads := removeThis(! threads); - Mutex.unlock lock; - false - ) - else - ( - (* See if we've been interrupted. If so remove ourselves - and exit. *) - testInterrupt() - handle exn => (threads := removeThis(! threads); Mutex.unlock lock; raise exn); - (* Otherwise just keep waiting. *) - waitAgain() - ) - end - in - Mutex.lock lock; (* Lock the internal mutex. *) - Mutex.unlock m; (* Unlock the external mutex *) - threads := me :: !threads; (* Add ourselves to the list. *) - waitAgain() (* Wait and return the result when we're done. *) - end - - fun doWait(c: conditionVar, m: Mutex.mutex, t: Time.time option) : bool = - let - val originalIntstate = getInterruptState() - (* Set this to handle interrupts synchronously unless we're already - ignoring them. *) - val () = - if originalIntstate = InterruptDefer - then () - else setInterruptState InterruptSynch; - - (* Wait for the condition. If it raises an exception we still - need to reacquire the lock unless we were handling interrupts - asynchronously. *) - val result = - innerWait(c, m, t) handle exn => - ( - (* We had an exception. If we were handling exceptions synchronously - we reacquire the lock. If it was set to InterruptAsynchOnce this - counts as a single asynchronous exception and we restore the - state as InterruptSynch. *) - case originalIntstate of - InterruptDefer => (* Shouldn't happen? *) Mutex.lock m - | InterruptSynch => Mutex.lock m - | InterruptAsynch => setInterruptState InterruptAsynch - | InterruptAsynchOnce => setInterruptState InterruptSynch; - - raise exn (* Reraise the exception*) - ) - in - (* Restore the original interrupt state first. *) - setInterruptState originalIntstate; - (* Normal return. Reacquire the lock before returning. *) - Mutex.lock m; - result - end - - fun wait(c: conditionVar, m: Mutex.mutex) : unit = - (doWait(c, m, NONE); ()) - and waitUntil(c: conditionVar, m: Mutex.mutex, t: Time.time) : bool = - doWait(c, m, SOME t) - end - - local - (* This call wakes up the specified thread. If the thread has already been - interrupted and is not ignoring interrupts it returns false. Otherwise - it wakes up the thread and returns true. We have to use this because - we define that if a thread is interrupted before it is signalled then - it raises Interrupt. *) - val threadCondVarWake: thread -> bool = RunCall.rtsCallFast1 "PolyThreadCondVarWake" - - (* Wake a single thread if we can (signal). *) - fun wakeOne [] = [] - | wakeOne (thread::rest) = - if threadCondVarWake thread - then rest - else thread :: wakeOne rest - (* Wake all threads (broadcast). *) - fun wakeAll [] = [] (* Always returns the empty list. *) - | wakeAll (thread::rest) = (threadCondVarWake thread; wakeAll rest) - - fun signalOrBroadcast({lock, threads}: conditionVar, wakeThreads) : unit = - let - val originalState = getInterruptState() - in - (* Set this to handle interrupts synchronously unless we're already - ignoring them. We need to do this to avoid an asynchronous - interrupt which could leave the internal lock in an inconsistent state. *) - if originalState = InterruptDefer - then () - else setInterruptState InterruptSynch; - (* Get the condition var lock. *) - Mutex.lock lock; - threads := wakeThreads(! threads); - Mutex.unlock lock; - setInterruptState originalState; (* Restore original state. *) - (* Test if we were interrupted while we were handling - interrupts synchronously. *) - if originalState = InterruptAsynch orelse originalState = InterruptAsynchOnce - then testInterrupt() - else () - end - in - fun signal cv = signalOrBroadcast(cv, wakeOne) - and broadcast cv = signalOrBroadcast(cv, wakeAll) - end - end -end; - -local - fun prettyMutex _ _ (_: Thread.Mutex.mutex) = PolyML.PrettyString "?" - and prettyThread _ _ (_: Thread.Thread.thread) = PolyML.PrettyString "?" - and prettyCondVar _ _ (_: Thread.ConditionVar.conditionVar) = PolyML.PrettyString "?" -in - val () = PolyML.addPrettyPrinter prettyMutex - and () = PolyML.addPrettyPrinter prettyThread - and () = PolyML.addPrettyPrinter prettyCondVar -end; - -