diff --git a/basis/FinalPolyML.sml b/basis/FinalPolyML.sml index 7437db85..e4d8a5bc 100644 --- a/basis/FinalPolyML.sml +++ b/basis/FinalPolyML.sml @@ -1,2228 +1,2231 @@ (* Title: Nearly final version of the PolyML structure Author: David Matthews - Copyright David Matthews 2008-9, 2014, 2015-17, 2019-20 + 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 compilerDebugTag (! compilerDebug), 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 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) + tagInject codetreeAfterOptTag (! codetreeAfterOpt), + tagInject compilerDebugTag (! compilerDebug) ], 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/mlsource/MLCompiler/DEBUG.sig b/mlsource/MLCompiler/DEBUG.sig index d0e6910d..0491ed44 100644 --- a/mlsource/MLCompiler/DEBUG.sig +++ b/mlsource/MLCompiler/DEBUG.sig @@ -1,48 +1,49 @@ (* - Copyright (c) 2013-2016, 2020 David C.J. Matthews + Copyright (c) 2013-2016, 2020-21 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Signature for debugging flags *) signature DEBUG = sig val assemblyCodeTag : bool Universal.tag val bindingCounterTag : (unit -> FixedInt.int) Universal.tag val codetreeAfterOptTag : bool Universal.tag val codetreeTag : bool Universal.tag + val compilerDebugTag: int Universal.tag val createPrintFunctionsTag : bool Universal.tag val debugTag : bool Universal.tag val defaults : Universal.universal list val errorDepthTag : FixedInt.int Universal.tag val fileNameTag : string Universal.tag val getParameter : 'a Universal.tag -> Universal.universal list -> 'a val icodeTag : bool Universal.tag val inlineFunctorsTag : bool Universal.tag val lineLengthTag : FixedInt.int Universal.tag val lineNumberTag : (unit -> FixedInt.int) Universal.tag val lowlevelOptimiseTag : bool Universal.tag val maxInlineSizeTag : FixedInt.int Universal.tag val narrowOverloadFlexRecordTag : bool Universal.tag val offsetTag : (unit -> FixedInt.int) Universal.tag val parsetreeTag : bool Universal.tag val printDepthFunTag : (unit -> FixedInt.int) Universal.tag val profileAllocationTag : FixedInt.int Universal.tag val reportExhaustiveHandlersTag : bool Universal.tag val reportUnreferencedIdsTag : bool Universal.tag val reportDiscardedValuesTag: FixedInt.int Universal.tag val reportDiscardNone: FixedInt.int (* No reports *) and reportDiscardFunction: FixedInt.int (* Only report discarded functions *) and reportDiscardNonUnit: FixedInt.int (* Report discarding any non unit values *) end; diff --git a/mlsource/MLCompiler/Debug.ML b/mlsource/MLCompiler/Debug.ML index e844de8e..7ead6f49 100644 --- a/mlsource/MLCompiler/Debug.ML +++ b/mlsource/MLCompiler/Debug.ML @@ -1,127 +1,131 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited - Modified David C.J. Matthews 2008, 2013, 2015-16, 2020. + Modified David C.J. Matthews 2008, 2013, 2015-16, 2020-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 *) structure Debug: DEBUG = struct local open Universal in (* Get the current line number. *) val lineNumberTag: (unit->FixedInt.int) tag = tag() (* Get the current offset (position on line or in file). *) val offsetTag: (unit->FixedInt.int) tag = tag() (* File name. *) val fileNameTag: string tag = tag() (* Binding counter *) val bindingCounterTag: (unit->FixedInt.int) tag = tag() (* How much to print in error messages? default 6 *) val errorDepthTag: FixedInt.int tag = tag() (* Control print depth in PolyML.print. *) val printDepthFunTag: (unit->FixedInt.int) tag = tag() (* Length of line in PolyML.print. error messages etc. *) val lineLengthTag: FixedInt.int tag = tag() (* Compile in debugging code? default false *) val debugTag: bool tag = tag() (* Compilation fine tuning. *) (* Should functors be made inline? default true. *) val inlineFunctorsTag: bool tag = tag() (* Control how big functions should be before they're not inlined. *) val maxInlineSizeTag: FixedInt.int tag = tag() (* Add profile information to each allocation? default zero. At the moment this is effectively a bool but having an int allows for the possibility of recording different information. *) val profileAllocationTag: FixedInt.int tag = tag() (* Compiler debugging. *) (* Print parsetree after parsing? default false *) val parsetreeTag: bool tag = tag() (* Print codetree after compiling? default false *) val codetreeTag: bool tag = tag() (* Print the optimised code after compiling? default false *) val codetreeAfterOptTag: bool tag = tag() (* Print x86 intermediate code in code-generator? default false *) val icodeTag: bool tag = tag() (* Switch on/off low-level optimisation. *) val lowlevelOptimiseTag: bool tag = tag() (* Print assembly code in code-generator? default false *) val assemblyCodeTag: bool tag = tag() + (* General switch for compiler debugging. Generally does nothing. *) + val compilerDebugTag: int tag = tag() + (* Report unreferenced identifiers as warnings *) val reportUnreferencedIdsTag: bool tag = tag() (* Report catch-all handlers as warnings *) val reportExhaustiveHandlersTag: bool tag = tag() (* Use a narrow context to resolve overloading and flexible records. *) val narrowOverloadFlexRecordTag: bool tag = tag() (* Create print functions for datatypes based on the constructors. *) val createPrintFunctionsTag: bool tag = tag() (* Warning level for discarding values *) val reportDiscardedValuesTag: FixedInt.int tag = tag() val reportDiscardNone = 0: FixedInt.int (* No reports *) and reportDiscardFunction = 1: FixedInt.int (* Only report discarded functions *) and reportDiscardNonUnit = 2: FixedInt.int (* Report discarding any non unit values *) - + (* To avoid circularity of dependencies a few tags are defined elsewhere: *) (* ValueOps.printSpaceTag: ValueOps.nameSpace tag Pretty.printOutputTag: (pretty->unit) tag Pretty.compilerOutputTag: (pretty->unit) tag Lex.errorMessageProcTag: (pretty * bool * FixedInt.int -> unit) tag ExportTreeString.rootTreeTag: (unit -> exportTree) tag *) val defaults = [ tagInject lineNumberTag (fn () => 0), (* Zero line number *) tagInject offsetTag (fn () => 0), (* Zero offset *) tagInject fileNameTag "", tagInject bindingCounterTag (fn () => 0), (* Zero counter *) tagInject inlineFunctorsTag true, tagInject maxInlineSizeTag 80, tagInject profileAllocationTag 0, tagInject parsetreeTag false, tagInject codetreeTag false, tagInject icodeTag false, tagInject lowlevelOptimiseTag true, tagInject assemblyCodeTag false, tagInject codetreeAfterOptTag false, + tagInject compilerDebugTag 0, tagInject errorDepthTag 6, tagInject printDepthFunTag (fn () => 0), tagInject lineLengthTag 77, tagInject debugTag false, tagInject reportUnreferencedIdsTag false, tagInject reportExhaustiveHandlersTag false, tagInject narrowOverloadFlexRecordTag false, tagInject createPrintFunctionsTag true, tagInject reportDiscardedValuesTag reportDiscardFunction ] fun getParameter (t:'a tag) (tagList: universal list) :'a = case List.find (tagIs t) tagList of SOME a => tagProject t a | NONE => (* Use the default *) ( case List.find (tagIs t) defaults of SOME a => tagProject t a | NONE => raise Misc.InternalError "tag missing" ) end end; diff --git a/mlsource/MLCompiler/INITIALISE_.ML b/mlsource/MLCompiler/INITIALISE_.ML index e0d8c63f..73870562 100644 --- a/mlsource/MLCompiler/INITIALISE_.ML +++ b/mlsource/MLCompiler/INITIALISE_.ML @@ -1,2074 +1,2075 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited Updated David C.J. Matthews 2008-9, 2012, 2013, 2015-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 *) (* Title: Initialise ML Global Declarations. Author: Dave Matthews,Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) functor INITIALISE_ ( structure LEX: LEXSIG structure TYPETREE : TYPETREESIG structure STRUCTVALS : STRUCTVALSIG structure VALUEOPS : VALUEOPSSIG structure CODETREE : CODETREESIG structure EXPORTTREE: EXPORTTREESIG structure DATATYPEREP: DATATYPEREPSIG structure TYPEIDCODE: TYPEIDCODESIG structure MAKE: MAKESIG structure ADDRESS : AddressSig structure DEBUG: DEBUG structure DEBUGGER : DEBUGGER structure PRETTY : PRETTYSIG structure PRINTTABLE: PRINTTABLESIG structure MISC : sig val unescapeString : string -> string exception Conversion of string; (* string to int conversion failure *) end structure VERSION: sig val compilerVersion: string val versionNumber: int end structure UNIVERSALTABLE: sig type universal = Universal.universal type univTable type 'a tag = 'a Universal.tag val univLookup: univTable * 'a tag * string -> 'a option val fold: (string * universal * 'a -> 'a) -> 'a -> univTable -> 'a end sharing STRUCTVALS.Sharing = VALUEOPS.Sharing = TYPETREE.Sharing = EXPORTTREE.Sharing = PRETTY.Sharing = CODETREE.Sharing = MAKE.Sharing = ADDRESS = DATATYPEREP.Sharing = TYPEIDCODE.Sharing = DEBUGGER.Sharing = LEX.Sharing = PRINTTABLE.Sharing sharing STRUCTVALS.Sharing = VALUEOPS.Sharing = TYPETREE.Sharing = EXPORTTREE.Sharing = PRETTY.Sharing = CODETREE.Sharing = MAKE.Sharing = ADDRESS = DATATYPEREP.Sharing = TYPEIDCODE.Sharing = DEBUGGER.Sharing = LEX.Sharing = PRINTTABLE.Sharing = UNIVERSALTABLE ) : sig type gEnv val initGlobalEnv : {globalTable : gEnv, intIsArbitraryPrecision: bool } -> unit end = struct open STRUCTVALS; open TYPETREE open VALUEOPS; open CODETREE; open ADDRESS; open MAKE; open MISC; open EXPORTTREE open DATATYPEREP val intInfType = mkTypeConstruction ("int", intInfConstr, [], []) and realType = mkTypeConstruction ("real", realConstr, [], []) and charType = mkTypeConstruction ("char", charConstr, [], []) and wordType = mkTypeConstruction ("word", wordConstr, [], []) val declInBasis = [DeclaredAt inBasis] fun applyList _ [] = () | applyList f (h :: t) = (f h : unit; applyList f t); fun initGlobalEnv{globalTable : gEnv, intIsArbitraryPrecision: bool } = let val Env globalEnv = MAKE.gEnvAsEnv globalTable val enterGlobalValue = #enterVal globalEnv; val enterGlobalType = #enterType globalEnv; (* Some routines to help make the types. *) local (* careful - STRUCTVALS.intType differs from TYPETREE.intType *) open TYPETREE; in (* Make some type variables *) fun makeEqTV () = mkTypeVar (generalisable, true, false, false) fun makeTV () = mkTypeVar (generalisable, false, false, false) fun makePrintTV() = mkTypeVar (generalisable, false, false, true) fun makeTypeVariable() = makeTv {value=emptyType, level=generalisable, equality=false, nonunifiable=false, printable=false} (* Make some functions *) infixr 5 ->> fun a ->> b = mkFunctionType (a, b); infix 7 **; fun a ** b = mkProductType [a, b]; (* Type identifiers for the types of the declarations. *) val Int = if intIsArbitraryPrecision then intInfType else fixedIntType val String = stringType; val Bool = boolType; val Unit = unitType; val Char = charType; val Word = wordType; val Real = realType val Exn = exnType val mkTypeConstruction = mkTypeConstruction; val () = setPreferredInt(if intIsArbitraryPrecision then intInfConstr else fixedIntConstr) end; fun makePolymorphic(tvs, c) = let open TYPEIDCODE val tvs = List.filter(fn TypeVar tv => not justForEqualityTypes orelse tvEquality tv | _ => false) tvs in if null tvs then c else mkInlproc(c, List.length tvs, "", [], 0) end (* Function to make a type identifier with a pretty printer that just prints "?". None of the types are equality types so the equality function is empty. *) local fun monotypePrinter _ = PRETTY.PrettyString "?" in fun defaultEqAndPrintCode () = let open TypeValue val code = createTypeValue{ eqCode = CodeZero, printCode = mkConst (toMachineWord (ref monotypePrinter)), boxedCode = boxedNever, sizeCode = singleWord } in Global (genCode(code, [], 0) ()) end end fun makeTypeAbbreviation(name, fullName, typeVars, typeResult, locations) = makeTypeConstructor( name, typeVars, makeTypeFunction(basisDescription fullName, (typeVars, typeResult)), locations) (* Make an opaque type and add it to an environment. *) fun makeAndDeclareOpaqueType(typeName, fullName, env) = let val typeconstr = makeTypeConstructor(typeName, [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription fullName), declInBasis); in #enterType env (typeName, TypeConstrSet(typeconstr, [])); mkTypeConstruction (typeName, typeconstr, [], declInBasis) end; (* List of something *) fun List (base : types) : types = mkTypeConstruction ("list", tsConstr listConstr, [base], declInBasis); (* ref something *) fun Ref (base : types) : types = mkTypeConstruction ("ref", refConstr, [base], declInBasis); fun Option (base : types) : types = mkTypeConstruction ("option", tsConstr optionConstr, [base], declInBasis); (* Type-dependent functions. *) fun mkSpecialFun (name:string, typeof:types, opn: typeDependent) : values = makeOverloaded (name, typeof, opn); (* Overloaded functions. *) fun mkOverloaded (name:string) (typeof: types) : values = mkSpecialFun(name, typeof, TypeDep) (* Make a structure. Returns the table as an environment so that entries can be added to the structure. *) fun makeStructure(parentEnv, name) = let val str as Struct{signat=Signatures{tab, ...}, ...} = makeEmptyGlobal name val () = #enterStruct parentEnv (name, str) val Env env = makeEnv tab in env end val () = enterGlobalType ("unit", TypeConstrSet(unitConstr, [])); local val falseCons = mkGconstr ("false", Bool, createNullaryConstructor(EnumForm{tag=0w0, maxTag=0w1}, [], "false"), true, 2, declInBasis) val trueCons = mkGconstr ("true", Bool, createNullaryConstructor(EnumForm{tag=0w1, maxTag=0w1}, [], "true"), true, 2, declInBasis) val boolEnv = makeStructure(globalEnv, "Bool") (* Bool structure *) val notFn = mkGvar("not", Bool ->> Bool, mkUnaryFn BuiltIns.NotBoolean, declInBasis) in val () = #enterType boolEnv ("bool", TypeConstrSet(boolConstr, [trueCons, falseCons])) val () = #enterVal boolEnv ("true", trueCons) val () = #enterVal boolEnv ("false", falseCons) val () = #enterVal boolEnv ("not", notFn) end; val () = enterGlobalType ("int", TypeConstrSet(if intIsArbitraryPrecision then intInfConstr else fixedIntConstr, [])) val () = enterGlobalType ("char", TypeConstrSet(charConstr, [])) val () = enterGlobalType ("string", TypeConstrSet(stringConstr, [])) val () = enterGlobalType ("real", TypeConstrSet(realConstr, [])) val () = (* Enter :: and nil. *) List.app(fn(tv as Value{name, ...}) => enterGlobalValue(name, tv)) (tsConstructors listConstr) val () = enterGlobalType ("list", listConstr); val () = (* Enter NONE and SOME. *) List.app(fn(tv as Value{name, ...}) => enterGlobalValue(name, tv)) (tsConstructors optionConstr) val () = enterGlobalType ("option", optionConstr); local val refCons = let val a = mkTypeVar(generalisable, false, false, false) in mkGconstr ("ref", a ->> Ref a, createUnaryConstructor(RefForm, [a], "ref"), false, 1, declInBasis) end in val () = enterGlobalType ("ref", TypeConstrSet(refConstr, [refCons])); val () = enterGlobalValue ("ref", refCons); end local open BuiltIns fun monoTypePrinter _ = PRETTY.PrettyString "?" val idCode = let open TypeValue val equalLongWordFn = mkInlproc( mkBinary(LargeWordComparison TestEqual, mkLoadArgument 0, mkLoadArgument 1), 2, "EqualLargeWord()", [], 0) val code = createTypeValue{ eqCode=equalLongWordFn, printCode=mkConst (toMachineWord (ref monoTypePrinter)), boxedCode = boxedNever, sizeCode = singleWord } in Global (genCode(code, [], 0) ()) end in val largeWordType = makeTypeConstructor("word", [], makeFreeId(0, idCode, true, basisDescription "LargeWord.word"), declInBasis) val LargeWord = mkTypeConstruction ("LargeWord.word", largeWordType, [], declInBasis) end val () = enterGlobalType ("exn", TypeConstrSet(exnConstr, [])); val () = enterGlobalType ("word", TypeConstrSet(wordConstr, [])); val runCallEnv = makeStructure(globalEnv, "RunCall") fun enterRunCall (name : string, entry : codetree, typ : types) : unit = let val value = mkGvar (name, typ, entry, declInBasis); in #enterVal runCallEnv (name, value) end local (* unsafeCast. Can be used to convert any value to any type. *) val a = makeTV () val b = makeTV () val unsafeCastEntry = mkInlproc (mkLoadArgument 0 (* just the parameter *), 1, "unsafeCast(1)", [], 0) in val () = enterRunCall ("unsafeCast", makePolymorphic([a, b], unsafeCastEntry), a ->> b) end local val a = makeTV() and b = makeTV() open BuiltIns in (* isShort - test if a value is tagged rather than being an address. *) val () = enterRunCall ("isShort", makePolymorphic([a], mkUnaryFn IsTaggedValue), a ->> Bool) (* pointer equality *) val () = enterRunCall ("pointerEq", makePolymorphic([a], mkBinaryFn PointerEq), a ** a ->> Bool) (* load a word. The index is in words and is always zero or positive. *) val () = enterRunCall ("loadWord", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLWord{isImmutable=false})), a ** Word ->> b) (* Load a word from an immutable. *) val () = enterRunCall ("loadWordFromImmutable", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLWord{isImmutable=true})), a ** Word ->> b) (* load a byte. The index is in bytes and is always zero or positive. Probably the result should be a Word8.word value or a char. *) val () = enterRunCall ("loadByte", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLByte{isImmutable=false})), a ** Word ->> b) (* Load a byte from an immutable. *) val () = enterRunCall ("loadByteFromImmutable", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLByte{isImmutable=true})), a ** Word ->> b) (* Get the length of a heap cell. *) val () = enterRunCall ("memoryCellLength", makePolymorphic([a], mkUnaryFn MemoryCellLength), a ->> Word) (* Return the flags. Perhaps this could return a Word8.word value instead of a word. *) val () = enterRunCall ("memoryCellFlags", makePolymorphic([a], mkUnaryFn MemoryCellFlags), a ->> Word) (* Return the number of bytes per word. This is a constant since we have separate pre-built compilers for 32-bit and 64-bit. N.B. The byte order is not a constant since we only have a single pre-built compiler for little-endian and big-endian interpreted code. *) val () = enterRunCall ("bytesPerWord", mkConst(toMachineWord wordSize), Word) (* Store a word *) val () = enterRunCall ("storeWord", makePolymorphic([a, b], mkStoreOperationFn(LoadStoreMLWord{isImmutable=false})), mkProductType[a, Word, b] ->> Unit) (* Store a byte *) val () = enterRunCall ("storeByte", makePolymorphic([a, b], mkStoreOperationFn(LoadStoreMLByte{isImmutable=false})), mkProductType[a, Word, b] ->> Unit) (* Lock a mutable cell. *) val () = enterRunCall ("clearMutableBit", makePolymorphic([a], mkUnaryFn ClearMutableFlag), a ->> Unit) (* Allocate a byte cell. The second argument is the flags byte. It might be better if this were a Word8.word value. *) val () = enterRunCall ("allocateByteMemory", makePolymorphic([a], mkBinaryFn AllocateByteMemory), Word ** Word ->> a) (* Allocate a word cell. *) val () = enterRunCall ("allocateWordMemory", makePolymorphic([a, b], mkAllocateWordMemoryFn), mkProductType[Word, Word, a] ->> b) (* Byte vector operations. *) val () = enterRunCall ("byteVectorEqual", makePolymorphic([a], mkBlockOperationFn BlockOpEqualByte), mkProductType[a, a, Word, Word, Word] ->> Bool) val () = enterRunCall ("byteVectorCompare", makePolymorphic([a], mkBlockOperationFn BlockOpCompareByte), mkProductType[a, a, Word, Word, Word] ->> Int) (* Block moves. *) val () = enterRunCall ("moveBytes", makePolymorphic([a], mkBlockOperationFn (BlockOpMove{isByteMove=true})), mkProductType[a, a, Word, Word, Word] ->> Unit) val () = enterRunCall ("moveWords", makePolymorphic([a], mkBlockOperationFn (BlockOpMove{isByteMove=false})), mkProductType[a, a, Word, Word, Word] ->> Unit) (* Untagged loads and stores. *) val () = enterRunCall ("loadUntagged", mkLoadOperationFn LoadStoreUntaggedUnsigned, String ** Word ->> Word) val () = enterRunCall ("storeUntagged", mkStoreOperationFn LoadStoreUntaggedUnsigned, mkProductType[String, Word, Word] ->> Unit) val () = enterRunCall ("touch", makePolymorphic([a], mkUnaryFn TouchAddress), a ->> Unit) end local val debugOpts = [] (* Place to add debugging if necessary. *) (* [tagInject Pretty.compilerOutputTag (Pretty.prettyPrint(print, 70)), tagInject assemblyCodeTag true] *) fun makeCall rtsCall n entryName = rtsCall (entryName, n, debugOpts) val makeFastCall = makeCall CODETREE.Foreign.rtsCallFast (* We need to wrap this so that the arguments are passed in registers. *) fun makeRunCallTupled (argTypes, resultType, callN) : codetree = let val width = List.length argTypes val name = "rtsCall" ^ Int.toString width; local val f = mkLoadClosure 0 (* first item from enclosing scope *) val tuple = mkLoadArgument 0 (* the inner parameter *) val args = case argTypes of [singleType] => [(tuple, singleType)] | argTypes => let val argVals = List.tabulate(width, fn n => mkInd (n, tuple)) in ListPair.zipEq(argVals, argTypes) end in val innerBody = mkCall (f, args, resultType) end local (* The closure contains the address of the RTS call. *) val f = mkEval(mkConst callN, [mkLoadArgument 0]) val innerLambda = mkInlproc (innerBody, 1, name ^ "(1)", [mkLoadLocal 0], 0) in val outerBody = mkEnv([mkDec (0, f)], innerLambda) end val outerLambda = mkInlproc (outerBody, 1, name, [], 1) in outerLambda end (* "Full" calls pass the thread Id as the first parameter. *) fun makeRunCallTupledFull (argTypes, resultType) = let val width = List.length argTypes val callN = toMachineWord(makeFastCall(width + 1)) val name = "rtsCall" ^ Int.toString width; local val f = mkLoadClosure 0 (* first item from enclosing scope *) val tuple = mkLoadArgument 0 (* the inner parameter *) val args = case argTypes of [singleType] => [(tuple, singleType)] | argTypes => let val argVals = List.tabulate(width, fn n => mkInd (n, tuple)) in ListPair.zipEq(argVals, argTypes) end in val innerBody = mkEnv( [ mkDec(0, mkCall (f, (getCurrentThreadId, GeneralType) :: args, resultType)), mkNullDec checkRTSException ], mkLoadLocal 0) end local (* The closure contains the address of the RTS call. *) val f = mkEval(mkConst callN, [mkLoadArgument 0]) (* This creates the actual call. *) val innerLambda = mkInlproc (innerBody, 1, name ^ "(1)", [mkLoadLocal 0], 1) in val outerBody = mkEnv([mkDec (0, f)], innerLambda) end val outerLambda = mkInlproc (outerBody, 1, name, [], 1) in outerLambda end local val a = makeTV () and b = makeTV () fun makeInlCode(makeCall, name) = let val call1 = toMachineWord(makeCall 1) val body = mkEval(mkConst call1, [mkLoadArgument 0]) val proc = mkInlproc (body, 1, name, [], 0) in makePolymorphic([a, b], proc) end in val rtsCallFast1Entry = makeInlCode(makeFastCall, "rtsCallFast1") end local val a = makeTV () and b = makeTV () and c = makeTV () and d = makeTV () and e = makeTV () and f = makeTV () fun makeRtsCall(n, makeCall) = makeRunCallTupled(List.tabulate(n, fn _ => GeneralType), GeneralType, toMachineWord(makeCall n)) fun makeFullRtsCall n = makeRunCallTupledFull(List.tabulate(n, fn _ => GeneralType), GeneralType) in val rtsCallFull0Entry = makePolymorphic([a], makeFullRtsCall 0) and rtsCallFast0Entry = makePolymorphic([a], makeRtsCall(0, makeFastCall)) val rtsCall0Type = String ->> Unit ->> a val rtsCall1Type = String ->> a ->> b val rtsCallFull1Entry = makePolymorphic([a, b], makeFullRtsCall 1) val rtsCallFull2Entry = makePolymorphic([a, b, c], makeFullRtsCall 2) and rtsCallFast2Entry = makePolymorphic([a, b, c], makeRtsCall(2, makeFastCall)) val rtsCall2Type = String ->> TYPETREE.mkProductType [a,b] ->> c val rtsCallFull3Entry = makePolymorphic([a, b, c, d], makeFullRtsCall 3) val rtsCallFast3Entry = makePolymorphic([a, b, c, d], makeRtsCall(3, makeFastCall)) val rtsCall3Type = String ->> TYPETREE.mkProductType [a,b,c] ->> d val rtsCallFull4Entry = makePolymorphic([a, b, c, d, e], makeFullRtsCall 4) val rtsCallFast4Entry = makePolymorphic([a, b, c, d, e], makeRtsCall(4, makeFastCall)) val rtsCall4Type = String ->> TYPETREE.mkProductType [a,b,c,d] ->> e val rtsCallFull5Entry = makePolymorphic([a, b, c, d, e, f], makeFullRtsCall 5) val rtsCall5Type = String ->> TYPETREE.mkProductType [a,b,c,d,e] ->> f end in val () = enterRunCall ("rtsCallFull0", rtsCallFull0Entry, rtsCall0Type) val () = enterRunCall ("rtsCallFast0", rtsCallFast0Entry, rtsCall0Type) val () = enterRunCall ("rtsCallFull1", rtsCallFull1Entry, rtsCall1Type) val () = enterRunCall ("rtsCallFast1", rtsCallFast1Entry, rtsCall1Type) val () = enterRunCall ("rtsCallFull2", rtsCallFull2Entry, rtsCall2Type) val () = enterRunCall ("rtsCallFast2", rtsCallFast2Entry, rtsCall2Type) val () = enterRunCall ("rtsCallFull3", rtsCallFull3Entry, rtsCall3Type) val () = enterRunCall ("rtsCallFast3", rtsCallFast3Entry, rtsCall3Type) val () = enterRunCall ("rtsCallFast4", rtsCallFast4Entry, rtsCall4Type) val () = enterRunCall ("rtsCallFull4", rtsCallFull4Entry, rtsCall4Type) val () = enterRunCall ("rtsCallFull5", rtsCallFull5Entry, rtsCall5Type) val makeRunCallTupled = makeRunCallTupled (* Needed for reals. *) end local (* Create nullary exception. *) fun makeException0(name, id) = let val exc = Value{ name = name, typeOf = TYPETREE.exnType, access = Global(mkConst(toMachineWord id)), class = Exception, locations = declInBasis, references = NONE, instanceTypes=NONE } in #enterVal runCallEnv (name, exc) end (* Create exception with parameter. *) and makeException1(name, id, exType) = let val exc = Value{ name = name, typeOf = exType ->> TYPETREE.exnType, access = Global(mkConst(toMachineWord id)), class = Exception, locations = declInBasis, references = NONE, instanceTypes=NONE } in #enterVal runCallEnv (name, exc) end (* Exception numbers. Most of these are hard-coded in the RTS. *) val EXC_interrupt = 1 val EXC_syserr = 2 val EXC_size = 4 val EXC_overflow = 5 val EXC_divide = 7 val EXC_conversion = 8 val EXC_XWindows = 10 val EXC_subscript = 11 val EXC_thread = 12 val EXC_Bind = 100 (* In Match compiler. *) val EXC_Match = 101 val EXC_Fail = 103 in val () = List.app makeException0 [ ("Interrupt", EXC_interrupt), ("Size", EXC_size), ("Bind", EXC_Bind), ("Div", EXC_divide), ("Match", EXC_Match), ("Overflow", EXC_overflow), ("Subscript", EXC_subscript) ] val () = List.app makeException1 [ ("Fail", EXC_Fail, String), ("Conversion", EXC_conversion, String), ("XWindows", EXC_XWindows, String), ("Thread", EXC_thread, String), ("SysErr", EXC_syserr, String ** Option LargeWord) ] end (* Standard Basis structures for basic types. These contain the definitions of the basic types and operations on them. The structures are extended in the basis library and overloaded functions are extracted from them. *) local val largeIntEnv = makeStructure(globalEnv, "LargeInt") (* The comparison operations take two arbitrary precision ints and a general "compare" function that returns a fixed precision int. *) val compareType = mkProductType[intInfType, intInfType, intInfType ** intInfType ->> fixedIntType] ->> Bool val arithType = mkProductType[intInfType, intInfType, intInfType ** intInfType ->> intInfType] ->> intInfType fun enterArbitrary(name, oper, typ) = let val value = mkGvar (name, typ, mkArbitraryFn oper, declInBasis) in #enterVal largeIntEnv (name, value) end in val () = #enterType largeIntEnv ("int", TypeConstrSet(intInfConstr, [])) (* These functions are used internally. *) val () = enterArbitrary("less", ArbCompare BuiltIns.TestLess, compareType) val () = enterArbitrary("greater", ArbCompare BuiltIns.TestGreater, compareType) val () = enterArbitrary("lessEq", ArbCompare BuiltIns.TestLessEqual, compareType) val () = enterArbitrary("greaterEq", ArbCompare BuiltIns.TestGreaterEqual, compareType) val () = enterArbitrary("add", ArbArith BuiltIns.ArithAdd, arithType) val () = enterArbitrary("subtract", ArbArith BuiltIns.ArithSub, arithType) val () = enterArbitrary("multiply", ArbArith BuiltIns.ArithMult, arithType) end local val fixedIntEnv = makeStructure(globalEnv, "FixedInt") open BuiltIns fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal fixedIntEnv (name, value) end val compareType = fixedIntType ** fixedIntType ->> Bool and binaryType = fixedIntType ** fixedIntType ->> fixedIntType fun enterComparison(name, test) = enterBinary(name, WordComparison{test=test, isSigned=true}, compareType) and enterBinaryOp(name, oper) = enterBinary(name, FixedPrecisionArith oper, binaryType) in val () = #enterType fixedIntEnv ("int", TypeConstrSet(fixedIntConstr, [])) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("quot", ArithQuot) val () = enterBinaryOp("rem", ArithRem) end local open BuiltIns val largeWordEnv = makeStructure(globalEnv, "LargeWord") fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal largeWordEnv (name, value) end val compareType = LargeWord ** LargeWord ->> Bool and binaryType = LargeWord ** LargeWord ->> LargeWord and shiftType = LargeWord ** Word ->> LargeWord (* The shift amount is a Word. *) fun enterComparison(name, test) = enterBinary(name, LargeWordComparison test, compareType) and enterBinaryOp(name, oper) = enterBinary(name, LargeWordArith oper, binaryType) and enterBinaryLogical(name, oper) = enterBinary(name, LargeWordLogical oper, binaryType) and enterBinaryShift(name, oper) = enterBinary(name, LargeWordShift oper, shiftType) in val () = #enterType largeWordEnv ("word", TypeConstrSet(largeWordType, [])) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("div", ArithDiv) val () = enterBinaryOp("mod", ArithMod) val () = enterBinaryLogical("orb", LogicalOr) val () = enterBinaryLogical("andb", LogicalAnd) val () = enterBinaryLogical("xorb", LogicalXor) val () = enterBinaryShift("<<", ShiftLeft) val () = enterBinaryShift(">>", ShiftRightLogical) val () = enterBinaryShift("~>>", ShiftRightArithmetic) val LargeWord = LargeWord end local val wordStructEnv = makeStructure(globalEnv, "Word") open BuiltIns fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal wordStructEnv (name, value) end val compareType = Word ** Word ->> Bool and binaryType = Word ** Word ->> Word fun enterComparison(name, test) = enterBinary(name, WordComparison{test=test, isSigned=false}, compareType) and enterBinaryOp(name, oper) = enterBinary(name, WordArith oper, binaryType) and enterBinaryLogical(name, oper) = enterBinary(name, WordLogical oper, binaryType) and enterBinaryShift(name, oper) = enterBinary(name, WordShift oper, binaryType) val toLargeWordFn = mkGvar ("toLargeWord", Word ->> LargeWord, mkUnaryFn UnsignedToLongWord, declInBasis) and toLargeWordXFn = mkGvar ("toLargeWordX", Word ->> LargeWord, mkUnaryFn SignedToLongWord, declInBasis) and fromLargeWordFn = mkGvar ("fromLargeWord", LargeWord ->> Word, mkUnaryFn LongWordToTagged, declInBasis) in val () = #enterType wordStructEnv ("word", TypeConstrSet(wordConstr, [])) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("div", ArithDiv) val () = enterBinaryOp("mod", ArithMod) val () = enterBinaryLogical("orb", LogicalOr) val () = enterBinaryLogical("andb", LogicalAnd) val () = enterBinaryLogical("xorb", LogicalXor) val () = enterBinaryShift("<<", ShiftLeft) val () = enterBinaryShift(">>", ShiftRightLogical) val () = enterBinaryShift("~>>", ShiftRightArithmetic) val () = #enterVal wordStructEnv ("toLargeWord", toLargeWordFn) val () = #enterVal wordStructEnv ("toLargeWordX", toLargeWordXFn) val () = #enterVal wordStructEnv ("fromLargeWord", fromLargeWordFn) end local val charEnv = makeStructure(globalEnv, "Char") open BuiltIns (* Comparison functions are the same as Word. *) fun enterComparison(name, test) = let val typ = Char ** Char ->> Bool val entry = mkBinaryFn(WordComparison{test=test, isSigned=false}) val value = mkGvar (name, typ, entry, declInBasis) in #enterVal charEnv (name, value) end in val () = #enterType charEnv ("char", TypeConstrSet(charConstr, [])) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) end local val stringEnv = makeStructure(globalEnv, "String") in val () = #enterType stringEnv ("string", TypeConstrSet(stringConstr, [])) end local val realEnv = makeStructure(globalEnv, "Real") (* These are only used in Real so are included here rather than in RunCall. rtsCallFastRealtoReal is used for functions such as sqrt. rtsCallFastGeneraltoReal is used for Real.fromLargeInt. *) val debugOpts = [] (* Place to add debugging if necessary. *) fun makeFastRealRealCall entryName = CODETREE.Foreign.rtsCallFastRealtoReal (entryName, debugOpts) and makeFastRealRealRealCall entryName = CODETREE.Foreign.rtsCallFastRealRealtoReal (entryName, debugOpts) and makeFastIntInfRealCall entryName = CODETREE.Foreign.rtsCallFastGeneraltoReal (entryName, debugOpts) and makeFastRealGeneralRealCall entryName = CODETREE.Foreign.rtsCallFastRealGeneraltoReal (entryName, debugOpts) val rtsCallFastR_REntry = makeRunCallTupled([DoubleFloatType], DoubleFloatType, toMachineWord makeFastRealRealCall) (* This needs to be tupled. *) val rtsCallFastRR_REntry = makeRunCallTupled([DoubleFloatType, DoubleFloatType], DoubleFloatType, toMachineWord makeFastRealRealRealCall) and rtsCallFastRI_REntry = makeRunCallTupled([DoubleFloatType, GeneralType], DoubleFloatType, toMachineWord makeFastRealGeneralRealCall) val rtsCallFastI_REntry = makeRunCallTupled([GeneralType], DoubleFloatType, toMachineWord makeFastIntInfRealCall) val rtsCallFastF_F = mkGvar ("rtsCallFastR_R", String ->> Real ->> Real, rtsCallFastR_REntry, declInBasis) val rtsCallFastFF_F = mkGvar ("rtsCallFastRR_R", String ->> Real ** Real ->> Real, rtsCallFastRR_REntry, declInBasis) val rtsCallFastFG_F = mkGvar ("rtsCallFastRI_R", String ->> Real ** Int ->> Real, rtsCallFastRI_REntry, declInBasis) val rtsCallFastG_F = mkGvar ("rtsCallFastI_R", String ->> intInfType ->> Real, rtsCallFastI_REntry, declInBasis) fun enterUnary(name, oper, typ) = let val value = mkGvar (name, typ, mkUnaryFn oper, declInBasis) in #enterVal realEnv (name, value) end fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal realEnv (name, value) end val compareType = Real ** Real ->> Bool and binaryType = Real ** Real ->> Real and unaryType = Real ->> Real and realToFixType = Real ->> fixedIntType open BuiltIns IEEEReal fun enterComparison(name, test) = enterBinary(name, RealComparison(test, PrecDouble), compareType) and enterBinaryOp(name, oper) = enterBinary(name, RealArith(oper, PrecDouble), binaryType) in val () = #enterType realEnv ("real", TypeConstrSet(realConstr, [])) val () = #enterVal realEnv ("rtsCallFastR_R", rtsCallFastF_F) val () = #enterVal realEnv ("rtsCallFastRR_R", rtsCallFastFF_F) val () = #enterVal realEnv ("rtsCallFastRI_R", rtsCallFastFG_F) val () = #enterVal realEnv ("rtsCallFastI_R", rtsCallFastG_F) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterComparison("==", TestEqual) (* real is not an eqtype. *) (* Included unordered mainly because it's easy to implement isNan. *) val () = enterComparison("unordered", TestUnordered) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("/", ArithDiv) val () = enterUnary("~", RealNeg PrecDouble, unaryType) val () = enterUnary("abs", RealAbs PrecDouble, unaryType) val () = enterUnary("fromFixedInt", RealFixedInt PrecDouble, fixedIntType ->> Real) val () = enterUnary("truncFix", RealToInt(PrecDouble, TO_ZERO), realToFixType) val () = enterUnary("roundFix", RealToInt(PrecDouble, TO_NEAREST), realToFixType) val () = enterUnary("ceilFix", RealToInt(PrecDouble, TO_POSINF), realToFixType) val () = enterUnary("floorFix", RealToInt(PrecDouble, TO_NEGINF), realToFixType) end local val real32Env = makeStructure(globalEnv, "Real32") val floatType = mkTypeConstruction ("real", floatConstr, [], []) val Float = floatType val debugOpts = [] (* Place to add debugging if necessary. *) fun makeFastFloatFloatCall entryName = CODETREE.Foreign.rtsCallFastFloattoFloat (entryName, debugOpts) and makeFastFloatFloatFloatCall entryName = CODETREE.Foreign.rtsCallFastFloatFloattoFloat (entryName, debugOpts) and makeFastIntInfFloatCall entryName = CODETREE.Foreign.rtsCallFastGeneraltoFloat (entryName, debugOpts) and makeFastFloatGeneralFloatCall entryName = CODETREE.Foreign.rtsCallFastFloatGeneraltoFloat (entryName, debugOpts) val rtsCallFastR_REntry = makeRunCallTupled([SingleFloatType], SingleFloatType, toMachineWord makeFastFloatFloatCall) (* This needs to be tupled. *) val rtsCallFastRR_REntry = makeRunCallTupled([SingleFloatType, SingleFloatType], SingleFloatType, toMachineWord makeFastFloatFloatFloatCall) and rtsCallFastRI_REntry = makeRunCallTupled([SingleFloatType, GeneralType], SingleFloatType, toMachineWord makeFastFloatGeneralFloatCall) val rtsCallFastI_REntry = makeRunCallTupled([GeneralType], SingleFloatType, toMachineWord makeFastIntInfFloatCall) val rtsCallFastF_F = mkGvar ("rtsCallFastF_F", String ->> Float ->> Float, rtsCallFastR_REntry, declInBasis) val rtsCallFastFF_F = mkGvar ("rtsCallFastFF_F", String ->> Float ** Float ->> Float, rtsCallFastRR_REntry, declInBasis) val rtsCallFastFG_F = mkGvar ("rtsCallFastFI_F", String ->> Float ** Int ->> Float, rtsCallFastRI_REntry, declInBasis) val rtsCallFastG_F = mkGvar ("rtsCallFastI_F", String ->> intInfType ->> Float, rtsCallFastI_REntry, declInBasis) fun enterUnary(name, oper, typ) = let val value = mkGvar (name, typ, mkUnaryFn oper, declInBasis) in #enterVal real32Env (name, value) end fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal real32Env (name, value) end val compareType = Float ** Float ->> Bool and binaryType = Float ** Float ->> Float and unaryType = Float ->> Float and floatToFixType = Float ->> fixedIntType open BuiltIns IEEEReal fun enterComparison(name, test) = enterBinary(name, RealComparison(test, PrecSingle), compareType) and enterBinaryOp(name, oper) = enterBinary(name, RealArith(oper, PrecSingle), binaryType) in val () = #enterType real32Env ("real", TypeConstrSet(floatConstr, [])) val () = enterUnary("toLarge", BuiltIns.FloatToDouble, floatType ->> Real) (* Conversion with the current rounding mode. *) and () = enterUnary("fromReal", BuiltIns.DoubleToFloat NONE, Real ->> floatType) (* There are various versions of this function for each of the rounding modes. *) and () = enterUnary("fromRealRound", BuiltIns.DoubleToFloat (SOME IEEEReal.TO_NEAREST), Real ->> floatType) and () = enterUnary("fromRealTrunc", BuiltIns.DoubleToFloat (SOME IEEEReal.TO_ZERO), Real ->> floatType) and () = enterUnary("fromRealCeil", BuiltIns.DoubleToFloat (SOME IEEEReal.TO_POSINF), Real ->> floatType) and () = enterUnary("fromRealFloor", BuiltIns.DoubleToFloat (SOME IEEEReal.TO_NEGINF), Real ->> floatType) val () = #enterVal real32Env ("rtsCallFastR_R", rtsCallFastF_F) val () = #enterVal real32Env ("rtsCallFastRR_R", rtsCallFastFF_F) val () = #enterVal real32Env ("rtsCallFastRI_R", rtsCallFastFG_F) val () = #enterVal real32Env ("rtsCallFastI_R", rtsCallFastG_F) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterComparison("==", TestEqual) (* Real32.real is not an eqtype. *) val () = enterComparison("unordered", TestUnordered) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("/", ArithDiv) val () = enterUnary("~", RealNeg PrecSingle, unaryType) val () = enterUnary("abs", RealAbs PrecSingle, unaryType) val () = enterUnary("truncFix", RealToInt(PrecSingle, TO_ZERO), floatToFixType) val () = enterUnary("roundFix", RealToInt(PrecSingle, TO_NEAREST), floatToFixType) val () = enterUnary("ceilFix", RealToInt(PrecSingle, TO_POSINF), floatToFixType) val () = enterUnary("floorFix", RealToInt(PrecSingle, TO_NEGINF), floatToFixType) end val bootstrapEnv = makeStructure(globalEnv, "Bootstrap") fun enterBootstrap (name : string, entry : codetree, typ : types) : unit = let val value = mkGvar (name, typ, entry, declInBasis) in #enterVal bootstrapEnv (name, value) end local val threadEnv = makeStructure(globalEnv, "Thread") open TypeValue fun monoTypePrinter _ = PRETTY.PrettyString "?" val code = createTypeValue{ eqCode=equalPointerOrWordFn, printCode=mkConst (toMachineWord (ref monoTypePrinter)), boxedCode=boxedAlways, sizeCode=singleWord } (* Thread.thread type. This is an equality type with pointer equality. *) val threadConstr= makeTypeConstructor ( "thread", [], makeFreeId(0, Global (genCode(code, [], 0) ()), true, basisDescription "thread"), [DeclaredAt inBasis]) val threadType = mkTypeConstruction ("thread", threadConstr, [], []); val selfFunction = mkGvar ("self", Unit ->> threadType, getCurrentThreadIdFn, declInBasis) val atExAddFunction = mkGvar("atomicExchAdd", Ref Word ** Word ->> Word, mkBinaryFn BuiltIns.AtomicExchangeAdd, declInBasis) val atResetFunction = mkGvar("atomicReset", Ref Word ->> Unit, mkUnaryFn BuiltIns.AtomicReset, declInBasis) val cpuPauseFunction = mkGvar("cpuPause", Unit ->> Unit, cpuPauseFn, declInBasis) in val () = #enterType threadEnv ("thread", TypeConstrSet(threadConstr, [])) val () = #enterVal threadEnv ("self", selfFunction) val () = #enterVal threadEnv ("atomicExchAdd", atExAddFunction) val () = #enterVal threadEnv ("atomicReset", atResetFunction) val () = #enterVal threadEnv ("cpuPause", cpuPauseFunction) end local val fmemEnv = makeStructure(globalEnv, "ForeignMemory") val a = makeTV() (* We don't have Word8.word or Word32.word at this point so the easiest way to deal with this is to make them polymorphic. *) val get8Function = mkGvar("get8", LargeWord ** Word ->> a, makePolymorphic([a], mkLoadOperationFn LoadStoreC8), declInBasis) val get16Function = mkGvar("get16", LargeWord ** Word ->> Word, mkLoadOperationFn LoadStoreC16, declInBasis) val get32Function = mkGvar("get32", LargeWord ** Word ->> a, makePolymorphic([a], mkLoadOperationFn LoadStoreC32), declInBasis) val get64Function = mkGvar("get64", LargeWord ** Word ->> LargeWord, mkLoadOperationFn LoadStoreC64, declInBasis) val getFloatFunction = mkGvar("getFloat", LargeWord ** Word ->> Real, mkLoadOperationFn LoadStoreCFloat, declInBasis) val getDoubleFunction = mkGvar("getDouble", LargeWord ** Word ->> Real, mkLoadOperationFn LoadStoreCDouble, declInBasis) val set8Function = mkGvar("set8", mkProductType[LargeWord, Word, a] ->> Unit, makePolymorphic([a], mkStoreOperationFn LoadStoreC8), declInBasis) val set16Function = mkGvar("set16", mkProductType[LargeWord, Word, Word] ->> Unit, mkStoreOperationFn LoadStoreC16, declInBasis) val set32Function = mkGvar("set32", mkProductType[LargeWord, Word, a] ->> Unit, makePolymorphic([a], mkStoreOperationFn LoadStoreC32), declInBasis) val set64Function = mkGvar("set64", mkProductType[LargeWord, Word, LargeWord] ->> Unit, mkStoreOperationFn LoadStoreC64, declInBasis) val setFloatFunction = mkGvar("setFloat", mkProductType[LargeWord, Word, Real] ->> Unit, mkStoreOperationFn LoadStoreCFloat, declInBasis) val setDoubleFunction = mkGvar("setDouble", mkProductType[LargeWord, Word, Real] ->> Unit, mkStoreOperationFn LoadStoreCDouble, declInBasis) val allocCStackFn = mkGvar("allocCStack", Word ->> LargeWord, mkUnaryFn BuiltIns.AllocCStack, declInBasis) val freeCStackFn = mkGvar("freeCStack", LargeWord ** Word ->> Unit, mkBinaryFn BuiltIns.FreeCStack, declInBasis) in val () = #enterVal fmemEnv ("get8", get8Function) val () = #enterVal fmemEnv ("get16", get16Function) val () = #enterVal fmemEnv ("get32", get32Function) val () = #enterVal fmemEnv ("get64", get64Function) val () = #enterVal fmemEnv ("getFloat", getFloatFunction) val () = #enterVal fmemEnv ("getDouble", getDoubleFunction) val () = #enterVal fmemEnv ("set8", set8Function) val () = #enterVal fmemEnv ("set16", set16Function) val () = #enterVal fmemEnv ("set32", set32Function) val () = #enterVal fmemEnv ("set64", set64Function) val () = #enterVal fmemEnv ("setFloat", setFloatFunction) val () = #enterVal fmemEnv ("setDouble", setDoubleFunction) val () = #enterVal fmemEnv ("allocCStack", allocCStackFn) (* Free is a binary operation that takes both the allocated address and the size. The size is used by the compiled code where this is implemented using the C-stack. The allocated address is intended for possible use by the interpreter where so that it can be implemented as malloc/free. *) val () = #enterVal fmemEnv ("freeCStack", freeCStackFn) end local val foreignEnv = makeStructure(globalEnv, "Foreign") local val EXC_foreign = 23 val foreignException = Value{ name = "Foreign", typeOf = String ->> TYPETREE.exnType, access = Global(mkConst(toMachineWord EXC_foreign)), class = Exception, locations = declInBasis, references = NONE, instanceTypes=NONE } in val () = #enterVal foreignEnv ("Foreign", foreignException) end val arg0 = mkLoadArgument 0 val arg1 = mkLoadArgument 1 local val callForeignCall = mkEval(mkConst (toMachineWord CODETREE.Foreign.foreignCall), [arg0]) val innerBody = mkEval(mkLoadClosure 0, [mkInd(0, arg0), mkInd(1, arg0), mkInd(2, arg0)]) val outerBody = mkEnv([mkDec(0, callForeignCall)], mkInlproc(innerBody, 1, "foreignCall(1)(1)", [mkLoadLocal 0], 0)) in val foreignCallEntry = mkInlproc(outerBody, 1, "foreignCall(1)", [], 1) end local (* Build a callback. First apply the compiler to the abi/argtype/restype values. Then apply the result to a function to generate the final C callback code. The C callback code calls the function with two arguments. Here we have to pass it a function that expects a tuple and unwrap it. *) val innerMost = mkInlproc(mkEval(mkLoadClosure 0, [mkTuple[arg0, arg1]]), 2, "buildCallBack(1)(1)2", [mkLoadArgument 0], 0) val resultFn = mkInlproc(mkEval(mkLoadClosure 0, [innerMost]), 1, "buildCallBack(1)(1)", [mkLoadLocal 0], 0) val firstBuild = mkEval(mkConst (toMachineWord CODETREE.Foreign.buildCallBack), [arg0]) val outerBody = mkEnv([mkDec(0, firstBuild)], resultFn) in val buildCallBackEntry = mkInlproc(outerBody, 1, "buildCallBack(1)", [], 1) end (* Abi - an eqtype. An enumerated type or short int. *) local open TypeValue fun monotypePrinter _ = PRETTY.PrettyString "?" val code = createTypeValue{ eqCode = equalTaggedWordFn, printCode = mkConst (toMachineWord (ref monotypePrinter)), boxedCode = boxedNever, sizeCode = singleWord } val abiEqAndPrint = Global (genCode(code, [], 0) ()) in val abiConstr = makeTypeConstructor("abi", [], makeFreeId(0, abiEqAndPrint, true, basisDescription "Foreign.LowLevel.abi"), declInBasis) end val () = #enterType foreignEnv ("abi", TypeConstrSet(abiConstr, [])) val abiType = mkTypeConstruction ("abi", abiConstr, [], declInBasis) (* It would be possible to put the definition of cType in here but it's complicated. It's easier to use an opaque type and put in a cast later. *) val ctypeConstr = makeTypeConstructor("ctype", [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription "Foreign.LowLevel.ctype"), declInBasis) val () = #enterType foreignEnv ("ctype", TypeConstrSet(ctypeConstr, [])) val ffiType = mkTypeConstruction ("ctype", ctypeConstr, [], declInBasis) val foreignCallType = mkProductType[abiType, List ffiType, ffiType] ->> mkProductType[LargeWord, LargeWord, LargeWord] ->> Unit val buildCallBackType = mkProductType[abiType, List ffiType, ffiType] ->> (mkProductType[LargeWord, LargeWord] ->> Unit) ->> LargeWord fun enterForeign (name, entry, typ) = #enterVal foreignEnv (name, mkGvar (name, typ, entry, declInBasis)) in val () = enterForeign("foreignCall", foreignCallEntry, foreignCallType) val () = enterForeign("buildCallBack", buildCallBackEntry, buildCallBackType) (* Apply the abiList function here. The ABIs depend on the platform in the interpreted version. *) val () = enterForeign("abiList", mkConst(toMachineWord(CODETREE.Foreign.abiList())), List (String ** abiType)) end local fun addVal (name : string, value : 'a, typ : types) : unit = enterBootstrap (name, mkConst (toMachineWord value), typ) (* These are only used during the bootstrap phase. Replacements are installed once the appropriate modules of the basis library are compiled. *) fun intOfString s = let val radix = if String.size s >= 3 andalso String.substring(s, 0, 2) = "0x" orelse String.size s >= 4 andalso String.substring(s, 0, 3) = "~0x" then StringCvt.HEX else StringCvt.DEC in case StringCvt.scanString (Int.scan radix) s of NONE => raise Conversion "Invalid integer constant" | SOME res => res end fun wordOfString s = let val radix = if String.size s > 2 andalso String.sub(s, 2) = #"x" then StringCvt.HEX else StringCvt.DEC in case StringCvt.scanString (Word.scan radix) s of NONE => raise Conversion "Invalid word constant" | SOME res => res end fun unescapeChar (s: string) : char = let fun rdr i = if i = size s then NONE else SOME(String.sub(s, i), i+1) in case Char.scan rdr 0 of NONE => (* Bad conversion *) raise Conversion "Invalid string constant" | SOME(res, _) => res end open PRINTTABLE val convstringCode = genCode(mkConst(toMachineWord unescapeString), [], 0) () val convintCode = genCode(mkConst(toMachineWord intOfString), [], 0) () val convwordCode = genCode(mkConst(toMachineWord wordOfString), [], 0) () val convcharCode = genCode(mkConst(toMachineWord unescapeChar), [], 0) () in (* We need this for compatibility with the 5.8.2 bootstrap. *) val () = addVal ("convString", unescapeString: string -> string, String ->> String) (* Flag to indicate which version of Int to compile *) val () = addVal ("intIsArbitraryPrecision", intIsArbitraryPrecision, Bool) (* Install the overloads now. *) val () = addOverload("convString", stringConstr, convstringCode) val () = addOverload("convInt", fixedIntConstr, convintCode) val () = addOverload("convInt", intInfConstr, convintCode) val () = addOverload("convWord", wordConstr, convwordCode) val () = addOverload("convChar", charConstr, convcharCode) end (* The only reason we have vector here is to get equality right. We need vector to be an equality type and to have a specific equality function. *) local fun polyTypePrinter _ _ = PRETTY.PrettyString "?" (* The equality function takes the base equality type as an argument. The inner function takes two arguments which are the two vectors to compare, checks the lengths and if they're equal applies the base equality to each field. *) val eqCode = mkInlproc( mkProc( mkEnv([ (* Length of the items. *) mkDec(0, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 0)), mkDec(1, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 1)), mkMutualDecs[(2, (* Loop function. *) mkProc( mkIf( (* Finished? *) mkEqualTaggedWord(mkLoadClosure 0, mkLoadArgument 0), CodeTrue, (* Yes, all equal. *) mkIf( mkEval( TypeValue.extractEquality(mkLoadClosure 2), (* Base equality fn *) [ mkLoadOperation(LoadStoreMLWord{isImmutable=true}, mkLoadClosure 3, mkLoadArgument 0), mkLoadOperation(LoadStoreMLWord{isImmutable=true}, mkLoadClosure 4, mkLoadArgument 0) ]), mkEval(mkLoadClosure 1, (* Recursive call with index+1. *) [ mkBinary(BuiltIns.WordArith BuiltIns.ArithAdd, mkLoadArgument 0, mkConst(toMachineWord 1)) ]), CodeFalse (* Not equal elements - result false *) ) ), 1, "vector-loop", [mkLoadLocal 0 (* Length *), mkLoadLocal 2 (* Loop function *), mkLoadClosure 0 (* Base equality function *), mkLoadArgument 0 (* Vector 0 *), mkLoadArgument 1 (* Vector 1 *)], 0))] ], mkIf( (* Test the lengths. *) mkEqualTaggedWord(mkLoadLocal 0, mkLoadLocal 1), (* Equal - test the contents. *) mkEval(mkLoadLocal 2, [CodeZero]), CodeFalse (* Not same length- result false *) ) ), 2, "vector-eq", [mkLoadArgument 0], 3), 1, "vector-eq()", [], 0) val idCode = (* Polytype *) let open TypeValue val code = createTypeValue{ eqCode=eqCode, printCode=mkConst (toMachineWord (ref polyTypePrinter)), boxedCode=mkInlproc(boxedAlways, 1, "boxed-vector", [], 0), sizeCode=mkInlproc(singleWord, 1, "size-vector", [], 0)} in Global (genCode(code, [], 0) ()) end in val vectorType = makeTypeConstructor("vector", [makeTypeVariable()], makeFreeId(1, idCode, true, basisDescription "vector"), declInBasis) val () = enterGlobalType ("vector", TypeConstrSet(vectorType, [])) end (* We also need a type with byte-wise equality. *) local fun monoTypePrinter _ = PRETTY.PrettyString "?" (* This is a monotype equality function that takes two byte vectors and compares them byte-by-byte for equality. Because they are vectors of bytes it's unsafe to load the whole words which could look like addresses if the bottom bit happens to be zero. *) val eqCode = mkProc( mkEnv([ (* Length of the items. *) mkDec(0, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 0)), mkDec(1, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 1)) ], mkIf( (* Test the lengths. *) mkEqualTaggedWord(mkLoadLocal 0, mkLoadLocal 1), (* Equal - test the contents. *) mkEnv([ (* ByteVecEqual takes a byte length so we have to multiply by the number of bytes per word. *) mkDec(2, mkBinary(BuiltIns.WordArith BuiltIns.ArithMult, mkConst(toMachineWord RunCall.bytesPerWord), mkLoadLocal 0)) ], mkBlockOperation{kind=BlockOpEqualByte, leftBase=mkLoadArgument 0, rightBase=mkLoadArgument 1, leftIndex=CodeZero, rightIndex=CodeZero, length=mkLoadLocal 2}), CodeFalse (* Not same length- result false *) ) ), 2, "byteVector-eq", [], 3) val idCode = (* Polytype *) let open TypeValue val code = createTypeValue{ eqCode=eqCode, printCode=mkConst (toMachineWord (ref monoTypePrinter)), boxedCode=boxedAlways, sizeCode=singleWord} in Global (genCode(code, [], 0) ()) end in val byteVectorType = makeTypeConstructor("byteVector", [], makeFreeId(0, idCode, true, basisDescription "byteVector"), declInBasis) val () = #enterType bootstrapEnv ("byteVector", TypeConstrSet(byteVectorType, [])) end (* We also need array and Array2.array to be passed through here so that they have the special property of being eqtypes even if their argument is not. "array" is defined to be in the global environment. *) val () = enterGlobalType ("array", TypeConstrSet(arrayConstr, [])) val () = #enterType bootstrapEnv ("array", TypeConstrSet(array2Constr, [])) val () = #enterType bootstrapEnv ("byteArray", TypeConstrSet(byteArrayConstr, [])) (* "=', '<>', PolyML.print etc are type-specific function which appear to be polymorphic. The compiler recognises these and treats them specially. For (in)equality that means generating type-specific versions of the equality operations; for print etc that means printing in a type-specific way. They can become true polymorphic functions and lose their type-specificity. For (in)equality that means defaulting to structure equality which is normal and expected behaviour. For print etc that means losing the ability to print and just printing "?" so it's important to avoid that happening. "open" treats type-specific functions specially and retains the type-specificity. That's important to allow the prelude code to expand the PolyML structure. *) local val eqType = let val a = makeEqTV () in a ** a ->> Bool end val eqVal = mkSpecialFun("=", eqType, Equal) in val () = enterGlobalValue ("=", eqVal) end local val neqType = let val a = makeEqTV () in a ** a ->> Bool end val neqVal = mkSpecialFun("<>", neqType, NotEqual) in val () = enterGlobalValue ("<>", neqVal) end val polyMLEnv = makeStructure(globalEnv, "PolyML") val enterPolyMLVal = #enterVal polyMLEnv local (* This version of the environment must match that used in the NameSpace structure. *) open TYPETREE (* Create a new structure for them. *) val nameSpaceEnv = makeStructure(polyMLEnv, "NameSpace") (* Substructures. *) val valuesEnv = makeStructure(nameSpaceEnv, "Values") and typesEnv = makeStructure(nameSpaceEnv, "TypeConstrs") and fixesEnv = makeStructure(nameSpaceEnv, "Infixes") and structsEnv = makeStructure(nameSpaceEnv, "Structures") and sigsEnv = makeStructure(nameSpaceEnv, "Signatures") and functsEnv = makeStructure(nameSpaceEnv, "Functors") (* Types for the basic values. These are opaque. *) val valueVal = makeAndDeclareOpaqueType("value", "PolyML.NameSpace.Values.value", valuesEnv) (* Representation of the type of a value. *) val Types = makeAndDeclareOpaqueType("typeExpression", "PolyML.NameSpace.Values.typeExpression", valuesEnv) val typeVal = makeAndDeclareOpaqueType("typeConstr", "PolyML.NameSpace.TypeConstrs.typeConstr", typesEnv) val fixityVal = makeAndDeclareOpaqueType("fixity", "PolyML.NameSpace.Infixes.fixity", fixesEnv) val signatureVal = makeAndDeclareOpaqueType("signatureVal", "PolyML.NameSpace.Signatures.signatureVal", sigsEnv) val structureVal = makeAndDeclareOpaqueType("structureVal", "PolyML.NameSpace.Structures.structureVal", structsEnv) val functorVal = makeAndDeclareOpaqueType("functorVal", "PolyML.NameSpace.Functors.functorVal", functsEnv) (* nameSpace type. Labelled record. *) fun createFields(name, vType): { name: string, typeof: types} list = let val enterFun = String ** vType ->> Unit val lookupFun = String ->> Option vType val allFun = Unit ->> List (String ** vType) in [mkLabelEntry("enter" ^ name, enterFun), mkLabelEntry("lookup" ^ name, lookupFun), mkLabelEntry("all" ^ name, allFun)] end (* We have to use the same names as we use in the env type because we're passing "env" values through the bootstrap. *) val valTypes = [("Val", valueVal), ("Type", typeVal), ("Fix", fixityVal), ("Struct", structureVal), ("Sig", signatureVal), ("Funct", functorVal)] val fields = List.foldl (fn (p,l) => createFields p @ l) [] valTypes val recordType = makeTypeAbbreviation("nameSpace", "PolyML.NameSpace.nameSpace", [], mkLabelled(sortLabels fields, true), declInBasis); val () = #enterType nameSpaceEnv ("nameSpace", TypeConstrSet(recordType, [])); (* The result type of the compiler includes valueVal etc. *) val resultFields = List.map TYPETREE.mkLabelEntry [("values", List(String ** valueVal)), ("fixes", List(String ** fixityVal)), ("types", List(String ** typeVal)), ("structures", List(String ** structureVal)), ("signatures", List(String ** signatureVal)), ("functors", List(String ** functorVal))] in val nameSpaceType = mkTypeConstruction ("nameSpace", recordType, [], declInBasis) val execResult = mkLabelled(sortLabels resultFields, true) type execResult = { fixes: (string * fixStatus) list, values: (string * values) list, structures: (string * structVals) list, signatures: (string * signatures) list, functors: (string * functors) list, types: (string * typeConstrSet) list } val valueVal = valueVal val typeVal = typeVal val fixityVal = fixityVal val signatureVal = signatureVal val structureVal = structureVal val functorVal = functorVal val Types = Types val valuesEnv = valuesEnv and typesEnv = typesEnv and fixesEnv = fixesEnv and structsEnv = structsEnv and sigsEnv = sigsEnv and functsEnv = functsEnv end local val typeconstr = locationConstr val () = #enterType polyMLEnv ("location", typeconstr); in val Location = mkTypeConstruction ("location", tsConstr typeconstr, [], declInBasis) end (* Interface to the debugger. *) local open TYPETREE val debuggerEnv = makeStructure(polyMLEnv, "DebuggerInterface") (* Make these opaque at this level. *) val locationPropList = makeAndDeclareOpaqueType("locationPropList", "PolyML.DebuggerInterface.locationPropList", debuggerEnv) val typeId = makeAndDeclareOpaqueType("typeId", "PolyML.DebuggerInterface.typeId", debuggerEnv) val machineWordType = makeAndDeclareOpaqueType("machineWord", "PolyML.DebuggerInterface.machineWord", debuggerEnv) (* For long term security keep these as different from global types and sigs. Values in the static environment need to be copied before they are global. *) val localType = makeAndDeclareOpaqueType("localType", "PolyML.DebuggerInterface.localType", debuggerEnv) val localTypeConstr = makeAndDeclareOpaqueType("localTypeConstr", "PolyML.DebuggerInterface.localTypeConstr", debuggerEnv) val localSig = makeAndDeclareOpaqueType("localSig", "PolyML.DebuggerInterface.localSig", debuggerEnv) open DEBUGGER (* Entries in the static list. This type is only used within the implementation of DebuggerInterface in the basis library and does not appear in the final signature. *) val environEntryConstr = makeTypeConstructor("environEntry", [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription "PolyML.DebuggerInterface.environEntry"), declInBasis) val environEntryType = mkTypeConstruction ("environEntry", environEntryConstr, [], declInBasis) val constrs = (* Order is significant. *) [ ("EnvEndFunction", mkProductType[String, Location, localType]), ("EnvException", mkProductType[String, localType, locationPropList]), ("EnvStartFunction", mkProductType[String, Location, localType]), ("EnvStructure", mkProductType[String, localSig, locationPropList]), ("EnvTConstr", String ** localTypeConstr), ("EnvTypeid", typeId ** typeId), ("EnvVConstr", mkProductType[String, localType, Bool, Int, locationPropList]), ("EnvValue", mkProductType[String, localType, locationPropList]) ] (* This representation must match the representation defined in DEBUGGER_.sml. *) val numConstrs = List.length constrs val {constrs=constrReps, ...} = chooseConstrRepr(constrs, []) val constructors = ListPair.map (fn ((s,t), code) => mkGconstr(s, t ->> environEntryType, code, false, numConstrs, declInBasis)) (constrs, constrReps) val () = List.app (fn c => #enterVal debuggerEnv(valName c, c)) constructors (* Put these constructors onto the type. *) val () = #enterType debuggerEnv ("environEntry", TypeConstrSet(environEntryConstr, constructors)) (* Debug state type. *) val debugStateConstr = makeTypeAbbreviation("debugState", "PolyML.DebuggerInterface.debugState", [], mkProductType[List environEntryType, List machineWordType, Location], declInBasis) val () = #enterType debuggerEnv ("debugState", TypeConstrSet(debugStateConstr, [])) val debugStateType = mkTypeConstruction ("debugState", debugStateConstr, [], declInBasis) in val () = applyList (fn (name, v, t) => #enterVal debuggerEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("makeValue", toMachineWord(makeValue: debugState -> string * types * locationProp list * machineWord -> values), debugStateType ->> mkProductType[String, localType, locationPropList, machineWordType] ->> valueVal), ("makeException", toMachineWord(makeException: debugState -> string * types * locationProp list * machineWord -> values), debugStateType ->> mkProductType[String, localType, locationPropList, machineWordType] ->> valueVal), ("makeConstructor", toMachineWord(makeConstructor: debugState -> string * types * bool * int * locationProp list * machineWord -> values), debugStateType ->> mkProductType[String, localType, Bool, Int, locationPropList, machineWordType] ->> valueVal), ("makeAnonymousValue", toMachineWord(makeAnonymousValue: debugState -> types * machineWord -> values), debugStateType ->> mkProductType[localType, machineWordType] ->> valueVal), ("makeStructure", toMachineWord(makeStructure: debugState -> string * signatures * locationProp list * machineWord -> structVals), debugStateType ->> mkProductType[String, localSig, locationPropList, machineWordType] ->> structureVal), ("makeTypeConstr", toMachineWord(makeTypeConstr: debugState -> typeConstrSet -> typeConstrSet), debugStateType ->> localTypeConstr ->> typeVal), ("unitValue", toMachineWord(mkGvar("", unitType, CodeZero, []): values), valueVal), (* Used as a default *) ("setOnEntry", toMachineWord(setOnEntry: (string * PolyML.location -> unit) option -> unit), Option (String ** Location ->> Unit) ->> Unit), ("setOnExit", toMachineWord(setOnExit: (string * PolyML.location -> unit) option -> unit), Option (String ** Location ->> Unit) ->> Unit), ("setOnExitException", toMachineWord(setOnExitException: (string * PolyML.location -> exn -> unit) option -> unit), Option (String ** Location ->> Exn ->> Unit) ->> Unit), ("setOnBreakPoint", toMachineWord(setOnBreakPoint: (PolyML.location * bool ref -> unit) option -> unit), Option (Location ** Ref Bool ->> Unit) ->> Unit) ] end local val typeconstr = contextConstr in val () = #enterType polyMLEnv ("context", typeconstr); val () = List.app(fn(tv as Value{name, ...}) => #enterVal polyMLEnv(name, tv)) (tsConstructors typeconstr) end local val typeconstr = prettyConstr in val () = #enterType polyMLEnv ("pretty", typeconstr); val () = List.app(fn(tv as Value{name, ...}) => #enterVal polyMLEnv(name, tv)) (tsConstructors typeconstr) val PrettyType = mkTypeConstruction ("pretty", tsConstr typeconstr, [], declInBasis) end local val printType = let val a = makePrintTV () in a ->> a end; val printVal = mkSpecialFun("print", printType, Print); in val () = enterPolyMLVal ("print", printVal); end; local val makeStringType = let val a = makePrintTV () in a ->> String end; val makeStringVal = mkSpecialFun("makestring", makeStringType, MakeString); in val () = enterPolyMLVal ("makestring", makeStringVal); end; local val prettyType = let val a = makePrintTV () in a ** fixedIntType ->> PrettyType end; val prettyVal = mkSpecialFun("prettyRepresentation", prettyType, GetPretty); in val () = enterPolyMLVal ("prettyRepresentation", prettyVal); end; local (* addPrettyPrinter is the new function to install a pretty printer. *) val a = makeTV () val b = makeTV () val addPrettyType = (TYPETREE.fixedIntType ->> b ->> a ->> PrettyType) ->> Unit; val addPrettyVal = mkSpecialFun("addPrettyPrinter", addPrettyType, AddPretty); in val () = enterPolyMLVal ("addPrettyPrinter", addPrettyVal); end; (* This goes in RunCall since it's only for the basis library. *) local val addOverloadType = let val a = makeTV () and b = makeTV () in (a ->> b) ->> String ->> Unit end; val addOverloadVal = mkSpecialFun("addOverload", addOverloadType, AddOverload); in val () = #enterVal runCallEnv ("addOverload", addOverloadVal); end local (* Add a function to switch the default integer type. *) fun setType isArbitrary = setPreferredInt(if isArbitrary then intInfConstr else fixedIntConstr) in val () = #enterVal runCallEnv ("setDefaultIntTypeArbitrary", mkGvar ("setDefaultIntTypeArbitrary", Bool ->> Unit, mkConst (toMachineWord setType), declInBasis)) end local val sourceLocVal = mkSpecialFun("sourceLocation", Unit ->> Location, GetLocation); in val () = enterPolyMLVal ("sourceLocation", sourceLocVal); end; local (* This is used as one of the arguments to the compiler function. *) open TYPETREE val uniStructEnv = makeStructure(bootstrapEnv, "Universal") fun enterUniversal (name : string, entry : codetree, typ : types) : unit = let val value = mkGvar (name, typ, entry, declInBasis); in #enterVal uniStructEnv (name, value) end; local fun polyTypePrinter _ _ = PRETTY.PrettyString "?" open TypeValue val idCode = let val code = createTypeValue{ eqCode=CodeZero, (* Not an equality type *) printCode=mkConst (toMachineWord (ref polyTypePrinter)), boxedCode=mkInlproc(boxedEither(* Assume worst case *), 1, "boxed-tag", [], 0), sizeCode=mkInlproc(singleWord, 1, "size-tag", [], 0)} in Global (genCode(code, [], 0) ()) end in (* type 'a tag *) val tagConstr = makeTypeConstructor("tag", [makeTypeVariable()], makeFreeId(1, idCode, false, basisDescription "tag"), declInBasis); val () = #enterType uniStructEnv ("tag", TypeConstrSet(tagConstr, [])) end (* type universal *) val univConstr = makeTypeConstructor("universal", [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription "universal"), declInBasis); val () = #enterType uniStructEnv ("universal", TypeConstrSet(univConstr, [])); fun Tag base = mkTypeConstruction ("tag", tagConstr, [base], declInBasis) val Universal = mkTypeConstruction ("universal", univConstr, [], declInBasis) val a = makeTV() (* val tagInject : 'a tag -> 'a -> universal *) val injectType = Tag a ->> a ->> Universal val () = enterUniversal ("tagInject", makePolymorphic([a], mkConst (toMachineWord (Universal.tagInject: 'a Universal.tag -> 'a -> Universal.universal))), injectType) (* We don't actually need tagIs and tagProject since this is only used for the compiler. Universal is redefined in the basis library. *) val projectType = Tag a ->> Universal ->> a val () = enterUniversal ("tagProject", makePolymorphic([a], mkConst (toMachineWord(Universal.tagProject: 'a Universal.tag -> Universal.universal -> 'a))), projectType) val testType = Tag a ->> Universal ->> Bool val () = enterUniversal ("tagIs", makePolymorphic([a], mkConst (toMachineWord(Universal.tagIs: 'a Universal.tag -> Universal.universal -> bool))), testType) in val Tag = Tag and Universal = Universal end local open TYPETREE (* Parsetree properties datatype. *) val propConstr = makeTypeConstructor("ptProperties", [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription "PolyML.ptProperties"), declInBasis); val PtProperties = mkTypeConstruction ("ptProperties", propConstr, [], declInBasis) (* Parsetree type. *) val parseTreeConstr = makeTypeAbbreviation("parseTree", "PolyML.parseTree", [], Location ** List PtProperties, declInBasis); val ParseTree = mkTypeConstruction ("parseTree", parseTreeConstr, [], declInBasis) val () = #enterType polyMLEnv ("parseTree", TypeConstrSet(parseTreeConstr, [])); val constrs = (* Order is significant. *) [ ("PTbreakPoint", Ref Bool), ("PTcompletions", List String), ("PTdeclaredAt", Location), ("PTdefId", fixedIntType), ("PTfirstChild", Unit ->> ParseTree), ("PTnextSibling", Unit ->> ParseTree), ("PTopenedAt", Location), ("PTparent", Unit ->> ParseTree), ("PTpreviousSibling", Unit ->> ParseTree), ("PTprint", fixedIntType ->> PrettyType), ("PTreferences", Bool ** List Location), ("PTrefId", fixedIntType), ("PTstructureAt", Location), ("PTtype", Types) ]; (* This representation must match the representation defined in ExportTree.sml. *) val numConstrs = List.length constrs val {constrs=constrReps, ...} = chooseConstrRepr(constrs, []) val constructors = ListPair.map (fn ((s,t), code) => mkGconstr(s, t ->> PtProperties, code, false, numConstrs, declInBasis)) (constrs, constrReps) val () = List.app (fn c => #enterVal polyMLEnv(valName c, c)) constructors (* Put these constructors onto the type. *) val () = #enterType polyMLEnv ("ptProperties", TypeConstrSet(propConstr, constructors)); in val ParseTree = ParseTree and PtProperties = PtProperties end local open TYPETREE val compilerType : types = mkProductType[nameSpaceType, Unit ->> Option Char, List Universal] ->> mkProductType[Option ParseTree, Option (Unit ->> execResult)] type compilerType = nameSpace * (unit -> char option) * Universal.universal list -> exportTree option * (unit->execResult) option in val () = enterBootstrap ("use", mkConst (toMachineWord ((useIntoEnv globalTable []): string -> unit)), String ->> Unit) val () = enterBootstrap ("useWithParms", mkConst (toMachineWord ((useIntoEnv globalTable): Universal.universal list -> string -> unit)), List Universal ->> String ->> Unit) val () = enterPolyMLVal("compiler", mkGvar ("compiler", compilerType, mkConst (toMachineWord (compiler: compilerType)), declInBasis)); val () = enterBootstrap("globalSpace", mkConst (toMachineWord(gEnvAsNameSpace globalTable: nameSpace)), nameSpaceType) (* Add a print function so we can print a message at the start of a bootstrap phase. *) val () = enterBootstrap("print", mkConst (toMachineWord TextIO.print), String ->> Unit) end; local val ty = TYPETREE.mkOverloadSet[] val addType = ty ** ty ->> ty; val negType = ty ->> ty; val cmpType = ty ** ty ->> Bool; in val () = enterGlobalValue ("+", mkOverloaded "+" addType); val () = enterGlobalValue ("-", mkOverloaded "-" addType); val () = enterGlobalValue ("*", mkOverloaded "*" addType); val () = enterGlobalValue ("~", mkOverloaded "~" negType); val () = enterGlobalValue ("abs", mkOverloaded "abs" negType); val () = enterGlobalValue (">=", mkOverloaded ">=" cmpType); val () = enterGlobalValue ("<=", mkOverloaded "<=" cmpType); val () = enterGlobalValue (">", mkOverloaded ">" cmpType); val () = enterGlobalValue ("<", mkOverloaded "<" cmpType); (* The following overloads are added in ML97 *) val () = enterGlobalValue ("div", mkOverloaded "div" addType); val () = enterGlobalValue ("mod", mkOverloaded "mod" addType); val () = enterGlobalValue ("/", mkOverloaded "/" addType); end; local open DEBUG; local open TYPETREE val fields = [ mkLabelEntry("location", Location), mkLabelEntry("hard", Bool), mkLabelEntry("message", PrettyType), mkLabelEntry("context", Option PrettyType) ] in val errorMessageProcType = mkLabelled(sortLabels fields, true) ->> Unit type errorMessageProcType = { location: location, hard: bool, message: pretty, context: pretty option } -> unit end local open TYPETREE val optNav = Option(Unit->>ParseTree) val fields = [ mkLabelEntry("parent", optNav), mkLabelEntry("next", optNav), mkLabelEntry("previous", optNav) ] in val navigationType = mkLabelled(sortLabels fields, true) type navigationType = { parent: (unit->exportTree) option, next: (unit->exportTree) option, previous: (unit->exportTree) option } end type 'a tag = 'a Universal.tag in val () = applyList (fn (name, v, t) => enterBootstrap(name, mkConst v, t)) [ ("compilerVersion", toMachineWord (VERSION.compilerVersion: string), String), ("compilerVersionNumber", toMachineWord (VERSION.versionNumber: int), Int), ("lineNumberTag", toMachineWord (lineNumberTag : (unit->FixedInt.int) tag), Tag (Unit->>fixedIntType)), ("offsetTag", toMachineWord (offsetTag: (unit->FixedInt.int) tag), Tag (Unit->>fixedIntType)), ("fileNameTag", toMachineWord (fileNameTag: string tag), Tag String), ("bindingCounterTag", toMachineWord (bindingCounterTag: (unit->FixedInt.int) tag), Tag (Unit->>fixedIntType)), ("maxInlineSizeTag", toMachineWord (maxInlineSizeTag: FixedInt.int tag), Tag fixedIntType), ("assemblyCodeTag", toMachineWord (assemblyCodeTag: bool tag), Tag Bool), ("parsetreeTag", toMachineWord (parsetreeTag: bool tag), Tag Bool), ("codetreeTag", toMachineWord (codetreeTag: bool tag), Tag Bool), ("icodeTag", toMachineWord (icodeTag: bool tag), Tag Bool), ("lowlevelOptimiseTag", toMachineWord (lowlevelOptimiseTag: bool tag), Tag Bool), ("codetreeAfterOptTag", toMachineWord (codetreeAfterOptTag: bool tag), Tag Bool), ("inlineFunctorsTag", toMachineWord (inlineFunctorsTag: bool tag), Tag Bool), + ("compilerDebugTag", toMachineWord (compilerDebugTag: int tag), Tag Int), ("debugTag", toMachineWord (debugTag: bool tag), Tag Bool), ("printDepthFunTag", toMachineWord (DEBUG.printDepthFunTag: (unit->FixedInt.int) tag), Tag (Unit->>fixedIntType)), ("errorDepthTag", toMachineWord (DEBUG.errorDepthTag: FixedInt.int tag), Tag fixedIntType), ("lineLengthTag", toMachineWord (DEBUG.lineLengthTag: FixedInt.int tag), Tag fixedIntType), ("profileAllocationTag", toMachineWord (DEBUG.profileAllocationTag: FixedInt.int tag), Tag fixedIntType), ("printOutputTag", toMachineWord (PRETTY.printOutputTag: (pretty->unit) tag), Tag (PrettyType->>Unit)) , ("compilerOutputTag", toMachineWord (PRETTY.compilerOutputTag: (pretty->unit) tag), Tag (PrettyType->>Unit)), ("errorMessageProcTag", toMachineWord (LEX.errorMessageProcTag: errorMessageProcType tag), Tag errorMessageProcType), ("rootTreeTag", toMachineWord (EXPORTTREE.rootTreeTag: navigation tag), Tag navigationType), ("reportUnreferencedIdsTag", toMachineWord (reportUnreferencedIdsTag: bool tag), Tag Bool), ("reportExhaustiveHandlersTag", toMachineWord (reportExhaustiveHandlersTag: bool tag), Tag Bool), ("narrowOverloadFlexRecordTag", toMachineWord (narrowOverloadFlexRecordTag: bool tag), Tag Bool), ("createPrintFunctionsTag", toMachineWord (createPrintFunctionsTag: bool tag), Tag Bool), ("reportDiscardedValuesTag", toMachineWord (reportDiscardedValuesTag: FixedInt.int tag), Tag fixedIntType) ] end; (* PolyML.CodeTree structure. This exports the CodeTree structure into the ML space. *) local open CODETREE val codetreeEnv = makeStructure(polyMLEnv, "CodeTree") fun createType typeName = makeAndDeclareOpaqueType(typeName, "PolyML.CodeTree." ^ typeName, codetreeEnv) val CodeTree = createType "codetree" and MachineWord = createType "machineWord" and CodeBinding = createType "codeBinding" (* For the moment export these only for the general argument and result types. *) fun simpleFn (code, nArgs, name, closure, nLocals) = mkFunction{body=code, argTypes=List.tabulate(nArgs, fn _ => GeneralType), resultType=GeneralType, name=name, closure=closure, numLocals=nLocals} and simpleInlineFn (code, nArgs, name, closure, nLocals) = mkInlineFunction{body=code, argTypes=List.tabulate(nArgs, fn _ => GeneralType), resultType=GeneralType, name=name, closure=closure, numLocals=nLocals} and simpleCall(func, args) = mkCall(func, List.map (fn c => (c, GeneralType)) args, GeneralType) in val CodeTree = CodeTree val () = applyList (fn (name, v, t) => #enterVal codetreeEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("pretty", toMachineWord (CODETREE.pretty: codetree -> pretty), CodeTree ->> PrettyType), ("mkConstant", toMachineWord(mkConst: machineWord -> codetree), MachineWord ->> CodeTree), ("genCode", toMachineWord (genCode: codetree * Universal.universal list * int -> (unit->codetree)), mkProductType[CodeTree, List Universal, Int] ->> (Unit ->> CodeTree)), ("evalue", toMachineWord (evalue: codetree -> machineWord option), CodeTree ->> Option MachineWord), ("mkFunction", toMachineWord (simpleFn: codetree * int * string * codetree list * int -> codetree), mkProductType[CodeTree, Int, String, List CodeTree, Int] ->> CodeTree), ("mkInlineFunction", toMachineWord (simpleInlineFn: codetree * int * string * codetree list * int -> codetree), mkProductType[CodeTree, Int, String, List CodeTree, Int] ->> CodeTree), ("mkCall", toMachineWord (simpleCall: codetree * codetree list -> codetree), CodeTree ** List CodeTree ->> CodeTree), ("mkLoadLocal", toMachineWord (mkLoadLocal: int -> codetree), Int ->> CodeTree), ("mkLoadArgument", toMachineWord (mkLoadArgument: int -> codetree), Int ->> CodeTree), ("mkLoadClosure", toMachineWord (mkLoadClosure: int -> codetree), Int ->> CodeTree), ("mkDec", toMachineWord (mkDec: int * codetree -> codeBinding), Int ** CodeTree ->> CodeBinding), ("mkInd", toMachineWord (mkInd: int * codetree -> codetree), Int ** CodeTree ->> CodeTree), ("mkIf", toMachineWord (mkIf: codetree * codetree * codetree -> codetree), mkProductType[CodeTree, CodeTree, CodeTree] ->> CodeTree), ("mkWhile", toMachineWord (mkWhile: codetree * codetree -> codetree), CodeTree ** CodeTree ->> CodeTree), ("mkLoop", toMachineWord (mkLoop: codetree list -> codetree), List CodeTree ->> CodeTree), ("mkBeginLoop", toMachineWord (mkBeginLoop: codetree * (int * codetree) list -> codetree), CodeTree ** List(Int ** CodeTree) ->> CodeTree), ("mkEnv", toMachineWord (mkEnv: codeBinding list * codetree -> codetree), List CodeBinding ** CodeTree ->> CodeTree), ("mkMutualDecs", toMachineWord (mkMutualDecs: (int * codetree) list -> codeBinding), List(Int ** CodeTree) ->> CodeBinding), ("mkTuple", toMachineWord (mkTuple: codetree list -> codetree), List CodeTree ->> CodeTree), ("mkRaise", toMachineWord (mkRaise: codetree -> codetree), CodeTree ->> CodeTree), ("mkHandle", toMachineWord (mkHandle: codetree * codetree * int -> codetree), mkProductType[CodeTree, CodeTree, Int] ->> CodeTree), ("mkNullDec", toMachineWord (mkNullDec: codetree -> codeBinding), CodeTree ->> CodeBinding) ] end local (* Finish off the NameSpace structure now we have types such as pretty. *) open TYPETREE (* The exported versions expect full name spaces as arguments. Because we convert the exported versions to machineWord and give them types as data structures the compiler can't actually check that the type we give matched the internal type. *) fun makeTypeEnv NONE = { lookupType = fn _ => NONE, lookupStruct = fn _ => NONE } | makeTypeEnv(SOME(nameSpace: nameSpace)): printTypeEnv = { lookupType = fn s => case #lookupType nameSpace s of NONE => NONE | SOME t => SOME(t, NONE), lookupStruct = fn s => case #lookupStruct nameSpace s of NONE => NONE | SOME t => SOME(t, NONE) } local (* Values substructure. This also has operations related to type expressions. *) fun codeForValue (Value{access = Global code, class = ValBound, ...}) = code | codeForValue _ = raise Fail "Not a global value" and exportedDisplayTypeExp(ty, depth, nameSpace: nameSpace option) = TYPETREE.display(ty, depth, makeTypeEnv nameSpace) and exportedDisplayValues(valu, depth, nameSpace: nameSpace option) = displayValues(valu, depth, makeTypeEnv nameSpace) and propsForValue (Value {locations, typeOf, ...}) = PTtype typeOf :: mapLocationProps locations fun isConstructor (Value{class = Exception, ...}) = true | isConstructor (Value{class = Constructor _, ...}) = true | isConstructor _ = false fun isException (Value{class = Exception, ...}) = true | isException _ = false in val () = applyList (fn (name, v, t) => #enterVal valuesEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord (valName: values -> string), valueVal ->> String), ("print", toMachineWord (printValues: values * FixedInt.int -> pretty), mkProductType[valueVal, fixedIntType] ->> PrettyType), ("printWithType", toMachineWord (exportedDisplayValues: values * FixedInt.int * nameSpace option -> pretty), mkProductType[valueVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("printType", toMachineWord(exportedDisplayTypeExp: types * FixedInt.int * nameSpace option -> pretty), mkProductType[Types, fixedIntType, Option nameSpaceType] ->> PrettyType), ("typeof", toMachineWord (valTypeOf: values -> types), valueVal ->> Types), ("code", toMachineWord (codeForValue: values -> codetree), valueVal ->> CodeTree), ("properties", toMachineWord (propsForValue: values ->ptProperties list), valueVal ->> List PtProperties), ("isConstructor", toMachineWord(isConstructor: values -> bool), valueVal ->> Bool), ("isException", toMachineWord(isException: values -> bool), valueVal ->> Bool) ] end local (* TypeConstrs substructure. *) fun exportedDisplayTypeConstr(tyCons, depth, nameSpace: nameSpace option) = TYPETREE.displayTypeConstrs(tyCons, depth, makeTypeEnv nameSpace) and propsForTypeConstr (TypeConstrSet(TypeConstrs {locations, ...}, _)) = mapLocationProps locations and nameForType (TypeConstrSet(TypeConstrs{name, ...}, _)) = name in val () = applyList (fn (name, v, t) => #enterVal typesEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForType: typeConstrSet -> string), typeVal ->> String), ("print", toMachineWord (exportedDisplayTypeConstr: typeConstrSet * FixedInt.int * nameSpace option -> pretty), mkProductType[typeVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("properties", toMachineWord (propsForTypeConstr: typeConstrSet ->ptProperties list), typeVal ->> List PtProperties) ] end local (* Structures substructure *) fun exportedDisplayStructs(str, depth, nameSpace: nameSpace option) = displayStructures(str, depth, makeTypeEnv nameSpace) and codeForStruct (Struct{access = Global code, ...}) = code | codeForStruct _ = raise Fail "Not a global structure" and propsForStruct (Struct {locations, ...}) = mapLocationProps locations and nameForStruct (Struct{name, ...}) = name fun nameSpaceForStruct(baseStruct as Struct{signat=Signatures { tab, ...}, ...}): nameSpace = let open UNIVERSALTABLE fun lookupVal s = case univLookup (tab, valueVar, s) of NONE => NONE | SOME v => SOME(makeSelectedValue(v, baseStruct)) and lookupType s = case univLookup (tab, typeConstrVar, s) of NONE => NONE | SOME t => SOME(makeSelectedType(t, baseStruct)) and lookupStruct s = case univLookup (tab, structVar, s) of NONE => NONE | SOME s => SOME(makeSelectedStructure(s, baseStruct)) local fun extractItems t tab = UNIVERSALTABLE.fold (fn (s, u, l) => if Universal.tagIs t u then (s, Universal.tagProject t u) :: l else l ) [] tab in fun allValues() = map(fn (s, v) => (s, makeSelectedValue(v, baseStruct))) (extractItems valueVar tab) and allTypes() = map(fn (s, t) => (s, makeSelectedType(t, baseStruct))) (extractItems typeConstrVar tab) and allStructs() = map(fn (s, v) => (s, makeSelectedStructure(v, baseStruct))) (extractItems structVar tab) end fun enterFunction _ = raise Fail "updating a structure is not possible." (* Raise an exception for any attempt to enter a new value. Return empty for the classes that can't exist in a structure. *) in { lookupVal = lookupVal, lookupType = lookupType, lookupStruct = lookupStruct, lookupFix = fn _ => NONE, lookupSig = fn _ => NONE, lookupFunct = fn _ => NONE, enterVal = enterFunction, enterType = enterFunction, enterFix = enterFunction, enterStruct = enterFunction, enterSig = enterFunction, enterFunct = enterFunction, allVal = allValues, allType = allTypes, allStruct = allStructs, allFix = fn () => [], allSig = fn () => [], allFunct = fn () => [] } end in val () = applyList (fn (name, v, t) => #enterVal structsEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForStruct: structVals -> string), structureVal ->> String), ("print", toMachineWord (exportedDisplayStructs: structVals * FixedInt.int * nameSpace option -> pretty), mkProductType[structureVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("code", toMachineWord (codeForStruct: structVals -> codetree), structureVal ->> CodeTree), ("properties", toMachineWord (propsForStruct: structVals ->ptProperties list), structureVal ->> List PtProperties), ("contents", toMachineWord(nameSpaceForStruct: structVals -> nameSpace), structureVal ->> nameSpaceType) ] end local (* Signatures substructure *) fun exportedDisplaySigs(sign, depth, nameSpace: nameSpace option) = displaySignatures(sign, depth, makeTypeEnv nameSpace) and propsForSig (Signatures {locations, ...}) = mapLocationProps locations and nameForSig (Signatures{name, ...}) = name in val () = applyList (fn (name, v, t) => #enterVal sigsEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForSig: signatures -> string), signatureVal ->> String), ("print", toMachineWord (exportedDisplaySigs: signatures * FixedInt.int * nameSpace option -> pretty), mkProductType[signatureVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("properties", toMachineWord (propsForSig: signatures ->ptProperties list), signatureVal ->> List PtProperties) ] end local (* Functors substructure *) fun exportedDisplayFunctors(funct, depth, nameSpace: nameSpace option) = displayFunctors(funct, depth, makeTypeEnv nameSpace) and codeForFunct (Functor{access = Global code, ...}) = code | codeForFunct _ = raise Fail "Not a global functor" and propsForFunctor (Functor {locations, ...}) = mapLocationProps locations and nameForFunctor (Functor{name, ...}) = name in val () = applyList (fn (name, v, t) => #enterVal functsEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForFunctor: functors -> string), functorVal ->> String), ("print", toMachineWord (exportedDisplayFunctors: functors * FixedInt.int * nameSpace option -> pretty), mkProductType[functorVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("code", toMachineWord (codeForFunct: functors -> codetree), functorVal ->> CodeTree), ("properties", toMachineWord (propsForFunctor: functors ->ptProperties list), functorVal ->> List PtProperties) ] end local (* Infixes substructure *) fun nameForFix(FixStatus(s, _)) = s in val () = applyList (fn (name, v, t) => #enterVal fixesEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForFix: fixStatus -> string), fixityVal ->> String), ("print", toMachineWord (displayFixStatus: fixStatus -> pretty), fixityVal ->> PrettyType) ] end in end in () end (* initGlobalEnv *); end;