1(* 2 Title: Nearly final version of the PolyML structure 3 Author: David Matthews 4 Copyright David Matthews 2008-9, 2014, 2015-17, 2019-20 5 6 This library is free software; you can redistribute it and/or 7 modify it under the terms of the GNU Lesser General Public 8 License version 2.1 as published by the Free Software Foundation. 9 10 This library is distributed in the hope that it will be useful, 11 but WITHOUT ANY WARRANTY; without even the implied warranty of 12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 Lesser General Public License for more details. 14 15 You should have received a copy of the GNU Lesser General Public 16 License along with this library; if not, write to the Free Software 17 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 18*) 19 20(* 21Based on: 22 23 Title: Poly Make Program. 24 Author: Dave Matthews, Cambridge University Computer Laboratory 25 Copyright Cambridge University 1985 26*) 27 28 29(* 30This is the version of the PolyML structure that can be compiled after we 31have the rest of the basis library. In particular it binds in TextIO.stdIn 32and TextIO.stdOut. 33 34This contains the top-level read-eval-print loop as well as "use" and 35Poly/ML's "make". 36 37The rootFunction has now been pulled out into a separate file and is added on 38after this. 39*) 40local 41 (* A hash table with a mutex that protects against multiple threads 42 rehashing the table by entering values at the same time. *) 43 structure ProtectedTable :> 44 sig 45 type 'a ptable 46 val create: unit -> 'a ptable 47 val lookup: 'a ptable -> string -> 'a option 48 val enter: 'a ptable -> string * 'a -> unit 49 val all: 'a ptable -> unit -> (string * 'a) list 50 val delete: 'a ptable -> string -> unit 51 end 52 = 53 struct 54 open HashArray Thread.Mutex LibraryIOSupport 55 type 'a ptable = 'a hash * mutex 56 57 fun create () = (hash 10, mutex()) 58 and lookup(tab, mutx) = protect mutx (fn s => sub(tab, s)) 59 and enter(tab, mutx) = protect mutx (fn (s, v) => update(tab, s, v)) 60 and all(tab, mutx) = protect mutx (fn () => fold (fn (s, v, l) => ((s, v) :: l)) [] tab) 61 and delete(tab, mutx) = protect mutx (fn s => HashArray.delete (tab, s)) 62 end 63 64 fun quickSort _ ([]:'a list) = [] 65 | quickSort _ ([h]:'a list) = [h] 66 | quickSort (leq:'a -> 'a -> bool) ((h::t) :'a list) = 67 let 68 val (after, befor) = List.partition (leq h) t 69 in 70 quickSort leq befor @ (h :: quickSort leq after) 71 end 72 73 open PolyML.NameSpace 74 75 local 76 open ProtectedTable 77 val fixTable = create() and sigTable = create() and valTable = create() 78 and typTable = create() and fncTable = create() and strTable = create() 79 in 80 val globalNameSpace: PolyML.NameSpace.nameSpace = 81 { 82 lookupFix = lookup fixTable, 83 lookupSig = lookup sigTable, 84 lookupVal = lookup valTable, 85 lookupType = lookup typTable, 86 lookupFunct = lookup fncTable, 87 lookupStruct = lookup strTable, 88 enterFix = enter fixTable, 89 enterSig = enter sigTable, 90 enterVal = enter valTable, 91 enterType = enter typTable, 92 enterFunct = enter fncTable, 93 enterStruct = enter strTable, 94 allFix = all fixTable, 95 allSig = all sigTable, 96 allVal = all valTable, 97 allType = all typTable, 98 allFunct = all fncTable, 99 allStruct = all strTable 100 } 101 102 val forgetFix = delete fixTable 103 and forgetSig = delete sigTable 104 and forgetVal = delete valTable 105 and forgetType = delete typTable 106 and forgetFunct = delete fncTable 107 and forgetStruct = delete strTable 108 end 109 110 local 111 open PolyML (* For prettyprint datatype *) 112 113 (* Install a pretty printer for parsetree properties. This isn't done in 114 the compiler. *) 115 fun prettyProps depth _ l = 116 if depth <= 0 then PrettyString "..." 117 else prettyProp(l, depth-1) 118 119 (* Use prettyRepresentation to print most of the arguments *) 120 and prettyProp(PTbreakPoint b, d) = blockArg("PTbreakPoint", prettyRepresentation(b, d)) 121 | prettyProp(PTcompletions s, d) = blockArg("PTcompletions", prettyRepresentation(s, d)) 122 | prettyProp(PTdeclaredAt l, d) = blockArg("PTdeclaredAt", prettyRepresentation(l, d)) 123 | prettyProp(PTdefId i, d) = blockArg("PTdefId", prettyRepresentation(i, d)) 124 | prettyProp(PTfirstChild _, _) = blockArg("PTfirstChild", PrettyString "fn") 125 | prettyProp(PTnextSibling _, _) = blockArg("PTnextSibling", PrettyString "fn") 126 | prettyProp(PTopenedAt f, d) = blockArg("PTopenedAt", prettyRepresentation(f, d)) 127 | prettyProp(PTparent _, _) = blockArg("PTparent", PrettyString "fn") 128 | prettyProp(PTpreviousSibling _, _)= blockArg("PTpreviousSibling", PrettyString "fn") 129 | prettyProp(PTprint _, _) = blockArg("PTprint", PrettyString "fn") 130 | prettyProp(PTreferences f, d) = blockArg("PTreferences", prettyRepresentation(f, d)) 131 | prettyProp(PTrefId f, d) = blockArg("PTrefId", prettyRepresentation(f, d)) 132 | prettyProp(PTstructureAt f, d) = blockArg("PTstructureAt", prettyRepresentation(f, d)) 133 | prettyProp(PTtype f, d) = blockArg("PTtype", prettyRepresentation(f, d)) 134 135 and blockArg (s, arg) = 136 PrettyBlock(3, true, [], [PrettyString s, PrettyBreak(1, 1), parenthesise arg]) 137 138 and parenthesise(p as PrettyBlock(_, _, _, PrettyString "(" :: _)) = p 139 | parenthesise(p as PrettyBlock(_, _, _, PrettyString "{" :: _)) = p 140 | parenthesise(p as PrettyBlock(_, _, _, PrettyString "[" :: _)) = p 141 | parenthesise(p as PrettyBlock(_, _, _, _ :: _)) = 142 PrettyBlock(3, true, [], [ PrettyString "(", PrettyBreak(0, 0), p, PrettyBreak(0, 0), PrettyString ")" ]) 143 | parenthesise p = p 144 145 in 146 val () = addPrettyPrinter prettyProps 147 end 148 149 (* PolyML.compiler takes a list of these parameter values. They all 150 default so it's possible to pass only those that are actually 151 needed. *) 152 datatype compilerParameters = 153 CPOutStream of string->unit 154 (* Output stream for debugging and other output from the compiler. 155 Provides a default stream for other output. Default: TextIO.print *) 156 | CPNameSpace of PolyML.NameSpace.nameSpace 157 (* Name space to look up and enter results. Default: globalNameSpace *) 158 | CPErrorMessageProc of 159 { message: PolyML.pretty, hard: bool, location: PolyML.location, context: PolyML.pretty option } -> unit 160 (* Called by the compiler to generate error messages. 161 Arguments (message, isHard, lineNo, context). message is the message. 162 isHard is true if this is an error, false if a warning. 163 location is the file-name, line number and position. context is an 164 optional extra piece of information showing the part of the parse tree 165 where the error was detected. 166 Default: print this to CPOutStream value using CPLineNo and CPFileName. *) 167 | CPLineNo of unit -> int 168 (* Called by the compiler to get the current "line number". This is passed 169 to CPErrorMessageProc and the debugger. It may actually be a more general 170 location than a source line. Default: fn () => 0 i.e. no line numbering. *) 171 | CPLineOffset of unit -> int 172 (* Called by the compiler to get the current "offset". This is passed 173 to CPErrorMessageProc and the debugger. This may either be an offset on 174 the current file, a byte offset or simply zero. 175 Default: fn () => 0 i.e. no line offset. *) 176 | CPFileName of string 177 (* The current file being compiled. This is used by the default CPErrorMessageProc 178 and the debugger. Default: "" i.e. interactive stream. *) 179 | CPPrintInAlphabeticalOrder of bool 180 (* Whether to sort the results by alphabetical order before printing them. Applies 181 only to the default CPResultFun. Default value of printInAlphabeticalOrder. *) 182 | CPResultFun of { 183 fixes: (string * Infixes.fixity) list, values: (string * Values.value) list, 184 structures: (string * Structures.structureVal) list, signatures: (string * Signatures.signatureVal) list, 185 functors: (string * Functors.functorVal) list, types: (string * TypeConstrs.typeConstr) list} -> unit 186 (* Function to apply to the result of compiling and running the code. 187 Default: print and enter the values into CPNameSpace. *) 188 | CPCompilerResultFun of 189 PolyML.parseTree option * 190 ( unit -> { 191 fixes: (string * Infixes.fixity) list, values: (string * Values.value) list, 192 structures: (string * Structures.structureVal) list, signatures: (string * Signatures.signatureVal) list, 193 functors: (string * Functors.functorVal) list, types: (string * TypeConstrs.typeConstr) list}) option -> unit -> unit 194 (* Function to process the result of compilation. This can be used to capture the 195 parse tree even if type-checking fails. 196 Default: Execute the code and call the result function if the compilation 197 succeeds. Raise an exception if the compilation failed. *) 198 | CPProfiling of int 199 (* Deprecated: No longer used. *) 200 | CPTiming of bool 201 (* Deprecated: No longer used. *) 202 | CPDebug of bool 203 (* Control whether calls to the debugger should be inserted into the compiled 204 code. This allows breakpoints to be set, values to be examined and printed 205 and functions to be traced at the cost of extra run-time overhead. 206 Default: value of PolyML.Compiler.debug *) 207 | CPPrintDepth of unit->int 208 (* This controls the depth of printing if the default CPResultFun is used. It 209 is also bound into any use of PolyML.print in the compiled code and will 210 be called to get the print depth whenever that code is executed. 211 Default: Get the current value of PolyML.print_depth. *) 212 | CPPrintStream of string->unit 213 (* This is bound into any occurrence of PolyML.print and is used to produce 214 the outut. Default: CPOutStream. *) 215 | CPErrorDepth of int 216 (* Controls the depth of context to produce in error messages. 217 Default : value of PolyML.error_depth. *) 218 | CPLineLength of int 219 (* Bound into any occurrences of PolyML.print. This is the length of a line 220 used in the pretty printer. Default: value of PolyML.line_length. *) 221 | CPRootTree of 222 { 223 parent: (unit -> PolyML.parseTree) option, 224 next: (unit -> PolyML.parseTree) option, 225 previous: (unit -> PolyML.parseTree) option 226 } 227 (* This can be used to provide a parent for parse trees created by the 228 compiler. This appears as a PTparent property in the tree. 229 The default is NONE which does not to provide a parent. *) 230 | CPAllocationProfiling of int 231 (* Controls whether to add profiling information to each allocation. Currently 232 zero means no profiling and one means add the allocating function. *) 233 234 | CPDebuggerFunction of int * Values.value * int * string * string * nameSpace -> unit 235 (* Deprecated: No longer used. *) 236 237 | CPBindingSeq of unit -> int 238 (* Used to create a sequence no for PTdefId properties. This can be used in an IDE 239 to allocate a unique Id for an identifier. Default fn _ => 0. *) 240 241 (* References for control and debugging. *) 242 val timing = ref false 243 and printDepth: int ref = ref 0 244 and errorDepth: int ref = ref 6 245 and lineLength: int ref = ref 77 246 and allocationProfiling = ref false 247 248 val assemblyCode = ref false 249 and codetree = ref false 250 and codetreeAfterOpt = ref false 251 and icode = ref false 252 and parsetree = ref false 253 and reportUnreferencedIds = ref false 254 and reportExhaustiveHandlers = ref false 255 and narrowOverloadFlexRecord = ref false 256 and createPrintFunctions = ref true 257 and reportDiscardFunction = ref true 258 and reportDiscardNonUnit = ref false 259 val lowlevelOptimise = ref true 260 261 val debug = ref false 262 val inlineFunctors = ref true 263 val maxInlineSize: int ref = ref 80 264 val printInAlphabeticalOrder = ref true 265 val traceCompiler = ref false (* No longer used. *) 266 267 fun prettyPrintWithIDEMarkup(stream : string -> unit, lineWidth : int): PolyML.pretty -> unit = 268 let 269 open PolyML 270 val openDeclaration = "\u001bD" 271 val closeDeclaration = "\u001bd" 272 val separator = "\u001b," 273 val finalSeparator = "\u001b;" 274 275 fun beginMarkup context = 276 case List.find (fn ContextLocation _ => true | _ => false) context of 277 SOME (ContextLocation{file,startLine,startPosition,endPosition, ...}) => 278 let 279 (* In the unlikely event there's an escape character in the 280 file name convert it to ESC-ESC. *) 281 fun escapeEscapes #"\u001b" = "\u001b\u001b" 282 | escapeEscapes c = str c 283 in 284 stream openDeclaration; 285 stream(String.translate escapeEscapes file); 286 stream separator; 287 stream(FixedInt.toString startLine); 288 stream separator; 289 stream(FixedInt.toString startPosition); 290 stream separator; 291 stream(FixedInt.toString endPosition); 292 stream finalSeparator 293 end 294 | _ => () 295 296 fun endMarkup context = 297 List.app (fn ContextLocation _ => stream closeDeclaration | _ => ()) context 298 in 299 prettyMarkup (beginMarkup, endMarkup) (stream, lineWidth) 300 end; 301 302 (* useMarkupInOutput is set according to the setting of *) 303 val useMarkupInOutput = ref false 304 fun prettyPrintWithOptionalMarkup(stream, lineWidth) = 305 if ! useMarkupInOutput then prettyPrintWithIDEMarkup(stream, lineWidth) 306 else PolyML.prettyPrint(stream, lineWidth) 307 308 (* Top-level prompts. *) 309 val prompt1 = ref "> " and prompt2 = ref "# "; 310 311 fun printOut s = 312 TextIO.print s 313 (* If we get an exception while writing to stdOut we've got 314 a big problem and can't continue. It could happen if 315 we have closed stdOut. Try reporting the error through 316 stdErr and exit. *) 317 handle Thread.Thread.Interrupt => raise Thread.Thread.Interrupt 318 | exn => 319 ( 320 ( 321 TextIO.output(TextIO.stdErr, 322 concat["Exception ", exnName exn, 323 " raised while writing to stdOut.\n"]); 324 TextIO.flushOut TextIO.stdErr (* probably unnecessary. *) 325 ) handle _ => (); 326 (* Get out without trying to do anything else. *) 327 OS.Process.terminate OS.Process.failure 328 ) 329 330 (* Default function to print and enter a value. *) 331 fun printAndEnter (inOrder: bool, space: PolyML.NameSpace.nameSpace, 332 stream: string->unit, depth: int) 333 { fixes: (string * Infixes.fixity) list, values: (string * Values.value) list, 334 structures: (string * Structures.structureVal) list, signatures: (string * Signatures.signatureVal) list, 335 functors: (string * Functors.functorVal) list, types: (string * TypeConstrs.typeConstr) list}: unit = 336 let 337 (* We need to merge the lists to sort them alphabetically. *) 338 datatype decKind = 339 FixStatusKind of Infixes.fixity 340 | TypeConstrKind of TypeConstrs.typeConstr 341 | SignatureKind of Signatures.signatureVal 342 | StructureKind of Structures.structureVal 343 | FunctorKind of Functors.functorVal 344 | ValueKind of Values.value 345 346 val decList = 347 map (fn (s, f) => (s, FixStatusKind f)) fixes @ 348 map (fn (s, f) => (s, TypeConstrKind f)) types @ 349 map (fn (s, f) => (s, SignatureKind f)) signatures @ 350 map (fn (s, f) => (s, StructureKind f)) structures @ 351 map (fn (s, f) => (s, FunctorKind f)) functors @ 352 map (fn (s, f) => (s, ValueKind f)) values 353 354 fun kindToInt(FixStatusKind _) = 0 355 | kindToInt(TypeConstrKind _) = 1 356 | kindToInt(SignatureKind _) = 2 357 | kindToInt(StructureKind _) = 3 358 | kindToInt(FunctorKind _) = 4 359 | kindToInt(ValueKind _) = 5 360 361 fun order (s1: string, k1) (s2, k2) = 362 if s1 = s2 then kindToInt k1 <= kindToInt k2 363 else s1 <= s2 364 365 (* Don't sort the declarations if we want them in declaration order. *) 366 val sortedDecs = 367 if inOrder then quickSort order decList else decList 368 369 fun enterDec(n, FixStatusKind f) = #enterFix space (n,f) 370 | enterDec(n, TypeConstrKind t) = #enterType space (n,t) 371 | enterDec(n, SignatureKind s) = #enterSig space (n,s) 372 | enterDec(n, StructureKind s) = #enterStruct space (n,s) 373 | enterDec(n, FunctorKind f) = #enterFunct space (n,f) 374 | enterDec(n, ValueKind v) = #enterVal space (n,v) 375 376 fun printDec(_, FixStatusKind f) = 377 prettyPrintWithOptionalMarkup (stream, !lineLength) (Infixes.print f) 378 379 | printDec(_, TypeConstrKind t) = 380 prettyPrintWithOptionalMarkup (stream, !lineLength) (TypeConstrs.print(t, FixedInt.fromInt depth, SOME space)) 381 382 | printDec(_, SignatureKind s) = 383 prettyPrintWithOptionalMarkup (stream, !lineLength) (Signatures.print(s, FixedInt.fromInt depth, SOME space)) 384 385 | printDec(_, StructureKind s) = 386 prettyPrintWithOptionalMarkup (stream, !lineLength) (Structures.print(s, FixedInt.fromInt depth, SOME space)) 387 388 | printDec(_, FunctorKind f) = 389 prettyPrintWithOptionalMarkup (stream, !lineLength) (Functors.print(f, FixedInt.fromInt depth, SOME space)) 390 391 | printDec(_, ValueKind v) = 392 if Values.isConstructor v andalso not (Values.isException v) 393 then () (* Value constructors are printed with the datatype. *) 394 else prettyPrintWithOptionalMarkup (stream, !lineLength) (Values.printWithType(v, FixedInt.fromInt depth, SOME space)) 395 396 in 397 (* First add the declarations to the name space and then print them. Doing it this way 398 improves the printing of types since these require look-ups in the name space. For 399 instance the constructors of a datatype from an opened structure should not include 400 the structure name but that will only work once the datatype itself is in the global 401 name-space. *) 402 List.app enterDec sortedDecs; 403 if depth > 0 then List.app printDec sortedDecs else () 404 end 405 406 local 407 open Bootstrap Bootstrap.Universal 408 (* To allow for the possibility of changing the representation we don't make Universal 409 be the same as Bootstrap.Universal. *) 410 411 (* Default error message function. *) 412 fun defaultErrorProc printString 413 {message: PolyML.pretty, hard: bool, 414 location={startLine, startPosition, endPosition, file, ...}: PolyML.location, 415 context: PolyML.pretty option} = 416 let 417 open PolyML 418 val fullMessage = 419 case context of 420 NONE => message 421 | SOME ctxt => 422 PrettyBlock(0, true, [], 423 [ message, PrettyBreak(1, 0), 424 PrettyBlock(2, false, [], [PrettyString "Found near", PrettyBreak(1, 0), ctxt]) 425 ]) 426 in 427 if ! useMarkupInOutput 428 then (* IDE mark-up of error messages. This is actually the same as within the IDE. *) 429 let 430 val openError = "\u001bE" 431 val closeError = "\u001be" 432 val separator = "\u001b," 433 val finalSeparator = "\u001b;" 434 in 435 printString( 436 concat 437 [ 438 openError, 439 if hard then "E" else "W", separator, 440 file, (* TODO double any escapes. *) separator, 441 FixedInt.toString startLine, separator, 442 FixedInt.toString startPosition, separator, 443 FixedInt.toString endPosition, finalSeparator 444 ] 445 ); 446 prettyPrintWithIDEMarkup(printString, !lineLength) fullMessage; 447 printString closeError 448 end 449 else (* Plain text form. *) 450 ( 451 printString(concat 452 ( (if file = "" then ["poly: "] else [file, ":"]) @ 453 (if startLine = 0 then [] else [FixedInt.toString startLine]) @ 454 (if startPosition = 0 then [": "] else [".", FixedInt.toString startPosition, "-", FixedInt.toString endPosition, ": "]) @ 455 (if hard then ["error: "] else ["warning: "]) )); 456(* ( (if hard then ["Error-"] else ["Warning-"]) @ 457 (if file = "" then [] else [" in '", file, "',"]) @ 458 (if startLine = 0 then [] else [" line ", Int.toString startLine]) @ 459 (if startLine = 0 andalso file = "" then [] else [".\n"]))); *) 460 PolyML.prettyPrint(printString, !lineLength) fullMessage 461 ) 462 end 463 in 464 (* This function ends up as PolyML.compiler. *) 465 fun polyCompiler (getChar: unit->char option, parameters: compilerParameters list) = 466 let 467 (* Find the first item that matches or return the default. *) 468 fun find _ def [] = def 469 | find f def (hd::tl) = 470 case f hd of 471 SOME s => s 472 | NONE => find f def tl 473 474 val outstream = find (fn CPOutStream s => SOME s | _ => NONE) TextIO.print parameters 475 val nameSpace = find (fn CPNameSpace n => SOME n | _ => NONE) globalNameSpace parameters 476 val lineNo = find (fn CPLineNo l => SOME l | _ => NONE) (fn () => 0) parameters 477 val lineOffset = find (fn CPLineOffset l => SOME l | _ => NONE) (fn () => 0) parameters 478 val fileName = find (fn CPFileName s => SOME s | _ => NONE) "" parameters 479 val printInOrder = find (fn CPPrintInAlphabeticalOrder t => SOME t | _ => NONE) 480 (! printInAlphabeticalOrder) parameters 481 val printDepth = find (fn CPPrintDepth f => SOME f | _ => NONE) (fn () => !printDepth) parameters 482 val resultFun = find (fn CPResultFun f => SOME f | _ => NONE) 483 (printAndEnter(printInOrder, nameSpace, outstream, printDepth())) parameters 484 val printString = find (fn CPPrintStream s => SOME s | _ => NONE) outstream parameters 485 val errorProc = find (fn CPErrorMessageProc f => SOME f | _ => NONE) (defaultErrorProc printString) parameters 486 val debugging = find (fn CPDebug t => SOME t | _ => NONE) (! debug) parameters 487 val allocProfiling = find(fn CPAllocationProfiling l => SOME l | _ => NONE) (if !allocationProfiling then 1 else 0) parameters 488 val bindingSeq = find(fn CPBindingSeq l => SOME l | _ => NONE) (fn () => 0) parameters 489 local 490 (* Default is to filter the parse tree argument. *) 491 fun defaultCompilerResultFun (_, NONE) = raise Fail "Static Errors" 492 | defaultCompilerResultFun (_, SOME code) = fn () => resultFun(code()) 493 in 494 val compilerResultFun = find (fn CPCompilerResultFun f => SOME f | _ => NONE) 495 defaultCompilerResultFun parameters 496 end 497 498 (* TODO: Make this available as a parameter. *) 499 val prettyOut = prettyPrintWithOptionalMarkup(printString, !lineLength) 500 501 val compilerOut = prettyPrintWithOptionalMarkup(outstream, !lineLength) 502 503 (* Parent tree defaults to empty. *) 504 val parentTree = 505 find (fn CPRootTree f => SOME f | _ => NONE) 506 { parent = NONE, next = NONE, previous = NONE } parameters 507 508 (* Pass all the settings. Some of these aren't included in the parameters datatype (yet?). *) 509 val treeAndCode = 510 PolyML.compiler(nameSpace, getChar, 511 [ 512 tagInject errorMessageProcTag errorProc, 513 tagInject compilerOutputTag compilerOut, 514 tagInject lineNumberTag (FixedInt.fromInt o lineNo), 515 tagInject offsetTag (FixedInt.fromInt o lineOffset), 516 tagInject fileNameTag fileName, 517 tagInject bindingCounterTag (FixedInt.fromInt o bindingSeq), 518 tagInject inlineFunctorsTag (! inlineFunctors), 519 tagInject maxInlineSizeTag (FixedInt.fromInt(! maxInlineSize)), 520 tagInject parsetreeTag (! parsetree), 521 tagInject codetreeTag (! codetree), 522 tagInject icodeTag (! icode), 523 tagInject lowlevelOptimiseTag (! lowlevelOptimise), 524 tagInject assemblyCodeTag (! assemblyCode), 525 tagInject codetreeAfterOptTag (! codetreeAfterOpt), 526 tagInject profileAllocationTag (FixedInt.fromInt allocProfiling), 527 tagInject errorDepthTag (FixedInt.fromInt(! errorDepth)), 528 tagInject printDepthFunTag (FixedInt.fromInt o printDepth), 529 tagInject lineLengthTag (FixedInt.fromInt(! lineLength)), 530 tagInject debugTag debugging, 531 tagInject printOutputTag prettyOut, 532 tagInject rootTreeTag parentTree, 533 tagInject reportUnreferencedIdsTag (! reportUnreferencedIds), 534 tagInject reportExhaustiveHandlersTag (! reportExhaustiveHandlers), 535 tagInject narrowOverloadFlexRecordTag (! narrowOverloadFlexRecord), 536 tagInject createPrintFunctionsTag (! createPrintFunctions), 537 tagInject reportDiscardedValuesTag 538 (if ! reportDiscardNonUnit then 2 else if ! reportDiscardFunction then 1 else 0) 539 ]) 540 in 541 compilerResultFun treeAndCode 542 end 543 544 (* Top-level read-eval-print loop. This is the normal top-level loop and is 545 also used for the debugger. *) 546 fun topLevel {isDebug, nameSpace, exitLoop, exitOnError, isInteractive, startExec, endExec } = 547 let 548 (* This is used as the main read-eval-print loop. It is also invoked 549 by running code that has been compiled with the debug option on 550 when it stops at a breakpoint. In that case debugEnv contains an 551 environment formed from the local variables. This is placed in front 552 of the normal top-level environment. *) 553 554 (* Don't use the end_of_stream because it may have been set by typing 555 EOT to the command we were running. *) 556 val endOfFile = ref false; 557 val realDataRead = ref false; 558 val lastWasEol = ref true; 559 560 (* Each character typed is fed into the compiler but leading 561 blank lines result in the prompt remaining as firstPrompt until 562 significant characters are typed. *) 563 fun readin () : char option = 564 let 565 val () = 566 if isInteractive andalso !lastWasEol (* Start of line *) 567 then if !realDataRead 568 then printOut (if isDebug then "debug " ^ !prompt2 else !prompt2) 569 else printOut (if isDebug then "debug " ^ !prompt1 else !prompt1) 570 else (); 571 in 572 case TextIO.input1 TextIO.stdIn of 573 NONE => (endOfFile := true; NONE) 574 | SOME #"\n" => ( lastWasEol := true; SOME #"\n" ) 575 | SOME ch => 576 ( 577 lastWasEol := false; 578 if ch <> #" " 579 then realDataRead := true 580 else (); 581 SOME ch 582 ) 583 end; (* readin *) 584 585 (* Remove all buffered but unread input. *) 586 fun flushInput () = 587 case TextIO.canInput(TextIO.stdIn, 1) of 588 SOME 1 => (TextIO.inputN(TextIO.stdIn, 1); flushInput()) 589 | _ => (* No input waiting or we're at EOF. *) () 590 591 fun readEvalPrint () : unit = 592 let 593 in 594 realDataRead := false; 595 (* Compile and then run the code. *) 596 let 597 val startCompile = Timer.startCPUTimer() 598 599 (* Compile a top-level declaration/expression. *) 600 val code = 601 polyCompiler (readin, [CPNameSpace nameSpace, CPOutStream printOut]) 602 (* Don't print any times if this raises an exception. *) 603 handle exn as Fail s => 604 ( 605 printOut(s ^ "\n"); 606 flushInput(); 607 lastWasEol := true; 608 PolyML.Exception.reraise exn 609 ) 610 611 val endCompile = Timer.checkCPUTimer startCompile 612 613 (* Run the code *) 614 val startRun = Timer.startCPUTimer() 615 val () = startExec() (* Enable any debugging *) 616 (* Run the code and capture any exception (temporarily). *) 617 val finalResult = (code(); NONE) handle exn => SOME exn 618 val () = endExec() (* Turn off debugging *) 619 (* Print the times if required. *) 620 val endRun = Timer.checkCPUTimer startRun 621 val () = 622 if !timing 623 then printOut( 624 concat["Timing - compile: ", Time.fmt 1 (#usr endCompile + #sys endCompile), 625 " run: ", Time.fmt 1 (#usr endRun + #sys endRun), "\n"]) 626 else () 627 in 628 case finalResult of 629 NONE => () (* No exceptions raised. *) 630 | SOME exn => (* Report exceptions in running code. *) 631 let 632 open PolyML PolyML.Exception 633 val exLoc = 634 case exceptionLocation exn of 635 NONE => [] 636 | SOME loc => [ContextLocation loc] 637 in 638 prettyPrintWithOptionalMarkup(TextIO.print, ! lineLength) 639 (PrettyBlock(0, false, [], 640 [ 641 PrettyBlock(0, false, exLoc, [PrettyString "Exception-"]), 642 PrettyBreak(1, 3), 643 prettyRepresentation(exn, FixedInt.fromInt(! printDepth)), 644 PrettyBreak(1, 3), 645 PrettyString "raised" 646 ])); 647 PolyML.Exception.reraise exn 648 end 649 end 650 end; (* readEvalPrint *) 651 652 fun handledLoop () : unit = 653 ( 654 (* Process a single top-level command. *) 655 readEvalPrint() 656 handle Thread.Thread.Interrupt => 657 (* Allow ^C to terminate the debugger and raise Interrupt in 658 the called program. *) 659 if exitOnError then OS.Process.exit OS.Process.failure 660 else if isDebug then (flushInput(); raise Thread.Thread.Interrupt) 661 else () 662 | _ => 663 if exitOnError 664 then OS.Process.exit OS.Process.failure 665 else (); 666 (* Exit if we've seen end-of-file or we're in the debugger 667 and we've run "continue". *) 668 if !endOfFile orelse exitLoop() then () 669 else handledLoop () 670 ) 671 in 672 handledLoop () 673 end 674 end 675 676 val suffixes = ref ["", ".ML", ".sml", ".sig"] 677 678 679 (*****************************************************************************) 680 (* "use": compile from a file. *) 681 (*****************************************************************************) 682 683 val useFileTag: string option Universal.tag = Universal.tag() 684 fun getUseFileName(): string option = Option.join (Thread.Thread.getLocal useFileTag) 685 686 fun use (originalName: string): unit = 687 let 688 (* use "f" first tries to open "f" but if that fails it tries "f.ML", "f.sml" etc. *) 689 (* We use the functional layer and a reference here rather than TextIO.input1 because 690 that requires locking round every read to make it thread-safe. We know there's 691 only one thread accessing the stream so we don't need it here. *) 692 fun trySuffixes [] = 693 (* Not found - attempt to open the original and pass back the 694 exception. *) 695 (TextIO.getInstream(TextIO.openIn originalName), originalName) 696 | trySuffixes (s::l) = 697 (TextIO.getInstream(TextIO.openIn (originalName ^ s)), originalName ^ s) 698 handle IO.Io _ => trySuffixes l 699 (* First in list is the name with no suffix. *) 700 val (inStream, fileName) = trySuffixes("" :: ! suffixes) 701 val stream = ref inStream 702 (* Record the file name. This allows nested calls to "use" to set the 703 correct path. *) 704 val oldName = getUseFileName() 705 val () = Thread.Thread.setLocal(useFileTag, SOME fileName) 706 707 val lineNo = ref 1; 708 fun getChar () : char option = 709 case TextIO.StreamIO.input1 (! stream) of 710 NONE => NONE 711 | SOME (eoln as #"\n", strm) => 712 ( 713 lineNo := !lineNo + 1; 714 stream := strm; 715 SOME eoln 716 ) 717 | SOME(c, strm) => (stream := strm; SOME c) 718 in 719 while not (TextIO.StreamIO.endOfStream(!stream)) do 720 let 721 val code = polyCompiler(getChar, [CPFileName fileName, CPLineNo(fn () => !lineNo)]) 722 handle exn => 723 ( TextIO.StreamIO.closeIn(!stream); PolyML.Exception.reraise exn ) 724 in 725 code() handle exn => 726 ( 727 (* Report exceptions in running code. *) 728 TextIO.print ("Exception- " ^ exnMessage exn ^ " raised\n"); 729 TextIO.StreamIO.closeIn (! stream); 730 Thread.Thread.setLocal(useFileTag, oldName); 731 PolyML.Exception.reraise exn 732 ) 733 end; 734 (* Normal termination: close the stream. *) 735 TextIO.StreamIO.closeIn (! stream); 736 Thread.Thread.setLocal(useFileTag, oldName) 737 738 end (* use *) 739 740 local 741 open Time 742 in 743 fun maxTime (x : time, y : time): time = 744 if x < y then y else x 745 end 746 747 exception ObjNotFile; 748 749 type 'a tag = 'a Universal.tag; 750 751 fun splitFilename (name: string) : string * string = 752 let 753 val {dir, file } = OS.Path.splitDirFile name 754 in 755 (dir, file) 756 end 757 758 (* Make *) 759 (* There are three possible states - The object may have been checked, 760 it may be currently being compiled, or it may not have been 761 processed yet. *) 762 datatype compileState = NotProcessed | Searching | Checked; 763 764 fun longName (directory, file) = OS.Path.joinDirFile{dir=directory, file = file} 765 766 local 767 fun fileReadable (fileTuple as (directory, object)) = 768 (* Use OS.FileSys.isDir just to test if the file/directory exists. *) 769 if (OS.FileSys.isDir (longName fileTuple); false) handle OS.SysErr _ => true 770 then false 771 else 772 let 773 (* Check that the object is present in the directory with the name 774 given and not a case-insensitive version of it. This avoids 775 problems with "make" attempting to recursively make Array etc 776 because they contain signatures ARRAY. *) 777 open OS.FileSys 778 val d = openDir (if directory = "" then "." else directory) 779 fun searchDir () = 780 case readDir d of 781 NONE => false 782 | SOME f => f = object orelse searchDir () 783 val present = searchDir() 784 in 785 closeDir d; 786 present 787 end 788 789 fun findFileTuple _ [] = NONE 790 | findFileTuple (directory, object) (suffix :: suffixes) = 791 let 792 val fileName = object ^ suffix 793 val fileTuple = (directory, fileName) 794 in 795 if fileReadable fileTuple 796 then SOME fileTuple 797 else findFileTuple (directory, object) suffixes 798 end 799 800 in 801 fun filePresent (directory : string, kind: string option, object : string) = 802 let 803 (* Construct suffixes with the architecture and version number in so 804 we can compile architecture- and version-specific code. *) 805 val archSuffix = "." ^ String.map Char.toLower (PolyML.architecture()) 806 val versionSuffix = "." ^ Int.toString Bootstrap.compilerVersionNumber 807 val extraSuffixes = 808 case kind of 809 NONE => [archSuffix, versionSuffix, ""] 810 | SOME k => ["." ^ k ^ archSuffix, "." ^ k ^ versionSuffix, "." ^ k, archSuffix, versionSuffix, ""] 811 val standardSuffixes = 812 case kind of 813 SOME "signature" => ".sig" :: ! suffixes 814 | _ => !suffixes 815 val addedSuffixes = 816 List.foldr(fn (i, l) => (List.map (fn s => s ^ i) extraSuffixes) @ l) [] standardSuffixes 817 in 818 (* For each of the suffixes in the list try it. *) 819 findFileTuple (directory, object) addedSuffixes 820 end 821 end 822 823 (* See if the corresponding file is there and if it is a directory. *) 824 fun testForDirectory (name: string) : bool = 825 OS.FileSys.isDir name handle OS.SysErr _ => false (* No such file. *) 826 827 (* Time stamps. *) 828 type timeStamp = Time.time; 829 val firstTimeStamp : timeStamp = Time.zeroTime; 830 831 local 832 open ProtectedTable 833 (* Global tables to hold information about entities that have been made using "make". *) 834 val timeStampTable: timeStamp ptable = create() 835 and dependencyTable: string list ptable = create() 836 in 837 (* When was the entity last built? Returns zeroTime if it hasn't. *) 838 fun lastMade (objectName : string) : timeStamp = 839 getOpt(lookup timeStampTable objectName, firstTimeStamp) 840 841 (* Get the dependencies as an option type. *) 842 val getMakeDependencies = lookup dependencyTable 843 844 (* Set the time stamp and dependencies. *) 845 fun updateMakeData(objectName, times, depends) = 846 ( 847 enter timeStampTable (objectName, times); 848 enter dependencyTable (objectName, depends) 849 ) 850 end 851 852 (* Main make function *) 853 fun make (targetName: string) : unit = 854 let 855 local 856 val sourceDateEpochEnv : string option = OS.Process.getEnv "SOURCE_DATE_EPOCH"; 857 in 858 val sourceDateEpoch : timeStamp option = 859 case sourceDateEpochEnv of 860 NONE => NONE 861 | SOME s => 862 (case LargeInt.fromString s of 863 NONE => NONE 864 | SOME t => SOME(Time.fromSeconds t) handle Time.Time => NONE) 865 end; 866 867 (* Get the current time. *) 868 val newTimeStamp : unit -> timeStamp = case sourceDateEpoch of 869 NONE => Time.now 870 | SOME t => fn _ => t; 871 (* Get the date of a file. *) 872 val fileTimeStamp : string -> timeStamp = case sourceDateEpoch of 873 NONE => OS.FileSys.modTime 874 | SOME t => fn _ => t; 875 876 (* This serves two purposes. It provides a list of objects which have been 877 re-made to prevent them being made more than once, and it also prevents 878 circular dependencies from causing infinite loops (e.g. let x = f(x)) *) 879 local 880 open HashArray; 881 val htab : compileState hash = hash 10; 882 in 883 fun lookupStatus (name: string) : compileState = 884 getOpt(sub (htab, name), NotProcessed); 885 886 fun setStatus (name: string, cs: compileState) : unit = 887 update (htab, name, cs) 888 end; 889 890 (* Remove leading directory names to get the name of the object itself. 891 e.g. "../compiler/parsetree/gencode" yields simply "gencode". *) 892 val (dirName,objectName) = splitFilename targetName; 893 894 (* Looks to see if the file is in the current directory. If it is and 895 the file is newer than the corresponding object then it must be 896 remade. If it is a directory then we attempt to remake the 897 directory by compiling the "bind" file. This will only actually be 898 executed if it involves some identifier which is newer than the 899 result object. *) 900 fun remakeObj (objName: string, kind: string option, findDirectory: string option -> string -> string) = 901 let 902 (* Find a directory that contains this object. An exception will be 903 raised if it is not there. *) 904 val directory = findDirectory kind objName 905 val fullName = 906 if directory = "" (* Work around for bug. *) 907 then objName 908 else OS.Path.joinDirFile{dir=directory, file=objName} 909 910 val objIsDir = testForDirectory fullName 911 val here = fullName 912 913 (* Look to see if the file exists, possibly with an extension, 914 and get the extended version. *) 915 val fileTuple = 916 let 917 (* If the object is a directory the source is in the bind file. *) 918 val (dir : string, file : string) = 919 if objIsDir 920 then (here,"ml_bind") 921 else (directory, objName); 922 in 923 case filePresent (dir, kind, file) of 924 SOME res' => res' 925 | NONE => raise Fail ("No such file or directory ("^file^","^dir^")") 926 end ; 927 928 val fileName = longName fileTuple; 929 930 val newFindDirectory : string option -> string -> string = 931 if objIsDir 932 then 933 let 934 (* Look in this directory then in the ones above. *) 935 fun findDirectoryHere kind (name: string) : string = 936 case filePresent (here, kind, name) of 937 NONE => findDirectory kind name (* not in this directory *) 938 | _ => here; 939 in 940 findDirectoryHere 941 end 942 else findDirectory 943 944 (* Compiles a file. *) 945 fun remakeCurrentObj () = 946 let 947 val () = print ("Making " ^ objName ^ "\n"); 948 local 949 (* Keep a list of the dependencies. *) 950 val deps : bool HashArray.hash = HashArray.hash 10; 951 952 fun addDep name = 953 if getOpt(HashArray.sub (deps, name), true) 954 then HashArray.update(deps, name, true) 955 else (); 956 957 (* Called by the compiler to look-up a global identifier. *) 958 fun lookupMakeEnv (globalLook, kind: string option) (name: string) : 'a option = 959 let 960 (* Have we re-declared it ? *) 961 val res = lookupStatus name; 962 in 963 case res of 964 NotProcessed => 965 ( 966 (* Compile the dependency. *) 967 remakeObj (name, kind, newFindDirectory); 968 (* Add this to the dependencies. *) 969 addDep name 970 ) 971 972 | Searching => (* In the process of making it *) 973 print("Circular dependency: " ^ name ^ " depends on itself\n") 974 975 | Checked => addDep name; (* Add this to the dependencies. *) 976 977 (* There was previously a comment about returning NONE here if 978 we had a problem remaking a dependency. *) 979 globalLook name 980 end (* lookupMakeEnv *) 981 982 (* Enter the declared value in the table. Usually this will be the 983 target we are making. Also set the state to "Checked". The 984 state is set to checked when we finish making the object but 985 setting it now suppresses messages about circular dependencies 986 if we use the identifier within the file. *) 987 fun enterMakeEnv (kind : string, enterGlobal) (name: string, v: 'a) : unit = 988 ( 989 (* Put in the value. *) 990 enterGlobal (name, v); 991 print ("Created " ^ kind ^ " " ^ name ^ "\n"); 992 993 (* The name we're declaring may appear to be a dependency 994 but isn't, so don't include it in the list. *) 995 HashArray.update (deps, name, false); 996 997 if name = objName 998 then 999 let 1000 (* Put in the dependencies i.e. those names set to true in the table. *) 1001 val depends = 1002 HashArray.fold (fn (s, v, l) => if v then s :: l else l) [] deps; 1003 1004 (* Put in a time stamp for the new object. We need to make 1005 sure that it is no older than the newest object it depends 1006 on. In theory that should not be a problem but clocks on 1007 different machines can get out of step leading to objects 1008 made later having earlier time stamps. *) 1009 val newest = 1010 List.foldl (fn (s: string, t: timeStamp) => 1011 maxTime (lastMade s, t)) (fileTimeStamp fileName) depends; 1012 1013 val timeStamp = maxTime(newest, newTimeStamp()); 1014 in 1015 setStatus (name, Checked); 1016 updateMakeData(name, timeStamp, depends) 1017 end 1018 else () 1019 ) (* enterMakeEnv *); 1020 1021 in 1022 val makeEnv = 1023 { 1024 lookupFix = #lookupFix globalNameSpace, 1025 lookupVal = #lookupVal globalNameSpace, 1026 lookupType = #lookupType globalNameSpace, 1027 lookupSig = lookupMakeEnv (#lookupSig globalNameSpace, SOME "signature"), 1028 lookupStruct = lookupMakeEnv (#lookupStruct globalNameSpace, SOME "structure"), 1029 lookupFunct = lookupMakeEnv (#lookupFunct globalNameSpace, SOME "functor"), 1030 enterFix = #enterFix globalNameSpace, 1031 enterVal = #enterVal globalNameSpace, 1032 enterType = #enterType globalNameSpace, 1033 enterStruct = enterMakeEnv ("structure", #enterStruct globalNameSpace), 1034 enterSig = enterMakeEnv ("signature", #enterSig globalNameSpace), 1035 enterFunct = enterMakeEnv ("functor", #enterFunct globalNameSpace), 1036 allFix = #allFix globalNameSpace, 1037 allVal = #allVal globalNameSpace, 1038 allType = #allType globalNameSpace, 1039 allSig = #allSig globalNameSpace, 1040 allStruct = #allStruct globalNameSpace, 1041 allFunct = #allFunct globalNameSpace 1042 }; 1043 end; (* local for makeEnv *) 1044 1045 val inputFile = OS.Path.joinDirFile{dir= #1 fileTuple, file= #2 fileTuple} 1046 1047 val inStream = TextIO.openIn inputFile; 1048 1049 val () = 1050 let (* scope of exception handler to close inStream *) 1051 val endOfStream = ref false; 1052 val lineNo = ref 1; 1053 1054 fun getChar () : char option = 1055 case TextIO.input1 inStream of 1056 NONE => (endOfStream := true; NONE) (* End of file *) 1057 | eoln as SOME #"\n" => (lineNo := !lineNo + 1; eoln) 1058 | c => c 1059 in 1060 while not (!endOfStream) do 1061 let 1062 val code = polyCompiler(getChar, 1063 [CPNameSpace makeEnv, CPFileName fileName, CPLineNo(fn () => !lineNo)]) 1064 in 1065 code () 1066 handle exn as Fail _ => PolyML.Exception.reraise exn 1067 | exn => 1068 ( 1069 print ("Exception- " ^ exnMessage exn ^ " raised\n"); 1070 PolyML.Exception.reraise exn 1071 ) 1072 end 1073 end (* body of scope of inStream *) 1074 handle exn => (* close inStream if an error occurs *) 1075 ( 1076 TextIO.closeIn inStream; 1077 PolyML.Exception.reraise exn 1078 ) 1079 in (* remake normal termination *) 1080 TextIO.closeIn inStream 1081 end (* remakeCurrentObj *) 1082 1083 in (* body of remakeObj *) 1084 setStatus (objName, Searching); 1085 1086 (* If the file is newer than the object then we definitely must remake it. 1087 Otherwise we look at the dependency list and check those. If the result 1088 of that check is that one of the dependencies is newer than the object 1089 (probably because it has just been recompiled) we have to recompile 1090 the file. Compiling a file also checks the dependencies and recompiles 1091 them, generating a new dependency list. That is why we don't check the 1092 dependency list if the object is out of date with the file. Also if the 1093 file has been changed it may no longer depend on the things it used to 1094 depend on. *) 1095 1096 let 1097 val objDate = lastMade objName 1098 1099 fun maybeRemake (s:string) : unit = 1100 case lookupStatus s of 1101 NotProcessed => (* see if it's a file. *) 1102 (* Compile the dependency. *) 1103 remakeObj(s, kind, newFindDirectory) 1104 1105 | Searching => (* In the process of making it *) 1106 print ("Circular dependency: " ^ s ^ " depends on itself\n") 1107 1108 | Checked => () (* do nothing *) 1109 1110 open Time 1111 (* Process each entry and return true if 1112 any is newer than the target. *) 1113 val processChildren = 1114 List.foldl 1115 (fn (child:string, parentNeedsMake:bool) => 1116 ( 1117 maybeRemake child; 1118 (* Find its date and see if it is newer. *) 1119 parentNeedsMake orelse lastMade child > objDate 1120 ) 1121 ) 1122 false; 1123 in 1124 if objDate < fileTimeStamp fileName orelse 1125 ( 1126 (* Get the dependency list. There may not be one if 1127 this object has not been compiled with "make". *) 1128 case getMakeDependencies objName of 1129 SOME d => processChildren d 1130 | NONE => true (* No dependency list - must use "make" on it. *) 1131 ) 1132 then remakeCurrentObj () 1133 else () 1134 end; 1135 1136 (* Mark it as having been checked. *) 1137 setStatus (objName, Checked) 1138 end (* body of remakeObj *) 1139 1140 (* If the object is not a file mark it is checked. It may be a 1141 pervasive or it may be missing. In either case mark it as checked 1142 to save searching for it again. *) 1143 handle 1144 ObjNotFile => setStatus (objName, Checked) 1145 1146 | exn => (* Compilation (or execution) error. *) 1147 ( 1148 (* Mark as checked to prevent spurious messages. *) 1149 setStatus (objName, Checked); 1150 raise exn 1151 ) 1152 in (* body of make *) 1153 (* Check that the target exists. *) 1154 case filePresent (dirName, NONE, objectName) of 1155 NONE => 1156 let 1157 val dir = 1158 if dirName = "" then "" 1159 else " (directory "^dirName^")"; 1160 val s = "File "^objectName^" not found" ^ dir 1161 in 1162 print (s ^ "\n"); 1163 raise Fail s 1164 end 1165 1166 | _ => 1167 let 1168 val targetIsDir = testForDirectory targetName; 1169 1170 (* If the target we are making is a directory all the objects 1171 must be in the directory. If it is a file we allow references 1172 to other objects in the same directory. Objects not found must 1173 be pervasive. *) 1174 fun findDirectory kind (s: string) : string = 1175 if (not targetIsDir orelse s = objectName) andalso 1176 isSome(filePresent(dirName, kind, s)) 1177 then dirName 1178 else raise ObjNotFile; 1179 in 1180 remakeObj (objectName, NONE, findDirectory) 1181 handle exn => 1182 ( 1183 print (targetName ^ " was not declared\n"); 1184 PolyML.Exception.reraise exn 1185 ) 1186 end 1187 end (* make *) 1188 1189in 1190 structure PolyML = 1191 struct 1192 open PolyML 1193 (* We must not have a signature on the result otherwise print and makestring 1194 will be given polymorphic types and will only produce "?" *) 1195 1196 val globalNameSpace = globalNameSpace 1197 1198 val use = use and make = make 1199 val suffixes = suffixes and getUseFileName = getUseFileName 1200 val compiler = polyCompiler 1201 1202 val prettyPrintWithIDEMarkup = prettyPrintWithIDEMarkup 1203 1204 structure Compiler = 1205 struct 1206 datatype compilerParameters = datatype compilerParameters 1207 1208 val compilerVersion = Bootstrap.compilerVersion 1209 val compilerVersionNumber = Bootstrap.compilerVersionNumber 1210 1211 val forgetSignature: string -> unit = forgetSig 1212 and forgetStructure: string -> unit = forgetStruct 1213 and forgetFunctor: string -> unit = forgetFunct 1214 and forgetValue: string -> unit = forgetVal 1215 and forgetType: string -> unit = forgetType 1216 and forgetFixity: string -> unit = forgetFix 1217 1218 fun signatureNames (): string list = #1(ListPair.unzip (#allSig globalNameSpace ())) 1219 and structureNames (): string list = #1(ListPair.unzip (#allStruct globalNameSpace ())) 1220 and functorNames (): string list = #1(ListPair.unzip (#allFunct globalNameSpace ())) 1221 and valueNames (): string list = #1(ListPair.unzip (#allVal globalNameSpace ())) 1222 and typeNames (): string list = #1(ListPair.unzip (#allType globalNameSpace ())) 1223 and fixityNames (): string list = #1(ListPair.unzip (#allFix globalNameSpace ())) 1224 1225 val prompt1 = prompt1 and prompt2 = prompt2 1226 and timing = timing and printDepth = printDepth 1227 and errorDepth = errorDepth and lineLength = lineLength 1228 and allocationProfiling = allocationProfiling 1229 1230 val assemblyCode = assemblyCode and codetree = codetree 1231 and codetreeAfterOpt = codetreeAfterOpt and icode = icode 1232 and parsetree = parsetree and reportUnreferencedIds = reportUnreferencedIds 1233 and lowlevelOptimise = lowlevelOptimise and reportExhaustiveHandlers = reportExhaustiveHandlers 1234 and narrowOverloadFlexRecord = narrowOverloadFlexRecord 1235 and createPrintFunctions = createPrintFunctions 1236 and reportDiscardFunction = reportDiscardFunction 1237 and reportDiscardNonUnit = reportDiscardNonUnit 1238 1239 val debug = debug 1240 val inlineFunctors = inlineFunctors 1241 val maxInlineSize = maxInlineSize 1242 val printInAlphabeticalOrder = printInAlphabeticalOrder 1243 val traceCompiler = traceCompiler 1244 end 1245 1246 (* Debugger control. Extend DebuggerInterface set up by INITIALISE. Replaces the original DebuggerInterface. *) 1247 structure DebuggerInterface: 1248 sig 1249 type debugState 1250 val debugFunction: debugState -> string 1251 val debugFunctionArg: debugState -> PolyML.NameSpace.Values.value 1252 val debugFunctionResult: debugState -> PolyML.NameSpace.Values.value 1253 val debugLocation: debugState -> PolyML.location 1254 val debugNameSpace: debugState -> PolyML.NameSpace.nameSpace 1255 val debugLocalNameSpace: debugState -> PolyML.NameSpace.nameSpace 1256 val debugState: Thread.Thread.thread -> debugState list 1257 1258 val setOnBreakPoint: (PolyML.location * bool ref -> unit) option -> unit 1259 val setOnEntry: (string * PolyML.location -> unit) option -> unit 1260 val setOnExit: (string * PolyML.location -> unit) option -> unit 1261 val setOnExitException: (string * PolyML.location -> exn -> unit) option -> unit 1262 end = 1263 struct 1264 open PolyML.DebuggerInterface 1265 1266 fun debugState(t: Thread.Thread.thread): debugState list = 1267 let 1268 val stack = RunCall.loadWord(t, 0w5) 1269 and static = RunCall.loadWord(t, 0w6) 1270 and dynamic = RunCall.loadWord(t, 0w7) 1271 and locationInfo = RunCall.loadWord(t, 0w8) 1272 1273 (* Turn the chain of saved entries along with the current top entry 1274 into a list. The bottom entry will generally be the state from 1275 non-debugging code and needs to be filtered out. *) 1276 fun toList r = 1277 if RunCall.isShort r 1278 then [] 1279 else 1280 let 1281 val s = RunCall.loadWordFromImmutable(r, 0w0) 1282 and d = RunCall.loadWordFromImmutable(r, 0w1) 1283 and l = RunCall.loadWordFromImmutable(r, 0w2) 1284 and n = RunCall.loadWordFromImmutable(r, 0w3) 1285 in 1286 if RunCall.isShort s orelse 1287 RunCall.isShort l 1288 then toList n 1289 else (s, d, l) :: toList n 1290 end 1291 in 1292 if RunCall.isShort static orelse RunCall.isShort locationInfo 1293 then toList stack 1294 else (static, dynamic, locationInfo) :: toList stack 1295 end 1296 1297 fun searchEnvs match (staticEntry :: statics, dlist as dynamicEntry :: dynamics) = 1298 ( 1299 case (match (staticEntry, dynamicEntry), staticEntry) of 1300 (SOME result, _) => SOME result 1301 | (NONE, EnvTypeid _) => searchEnvs match (statics, dynamics) 1302 | (NONE, EnvVConstr _) => searchEnvs match (statics, dynamics) 1303 | (NONE, EnvValue _) => searchEnvs match (statics, dynamics) 1304 | (NONE, EnvException _) => searchEnvs match (statics, dynamics) 1305 | (NONE, EnvStructure _) => searchEnvs match (statics, dynamics) 1306 | (NONE, EnvStartFunction _) => searchEnvs match (statics, dynamics) 1307 | (NONE, EnvEndFunction _) => searchEnvs match (statics, dynamics) 1308 (* EnvTConstr doesn't have an entry in the dynamic list *) 1309 | (NONE, EnvTConstr _) => searchEnvs match (statics, dlist) 1310 1311 ) 1312 1313 | searchEnvs _ _ = NONE 1314 (* N.B. It is possible to have ([EnvTConstr ...], []) in the arguments so we can't assume 1315 that if either the static or dynamic list is nil and the other non-nil it's an error. *) 1316 1317 (* Function argument. This should always be present but if 1318 it isn't just return unit. That's probably better than 1319 an exception here. *) 1320 fun debugFunctionArg (state: debugState as (cList, rList, _)) = 1321 let 1322 val d = (cList, rList) 1323 fun match (EnvStartFunction(_, _, ty), valu) = 1324 SOME(makeAnonymousValue state (ty, valu)) 1325 | match _ = NONE 1326 in 1327 getOpt(searchEnvs match d, unitValue) 1328 end 1329 1330 (* Function result - only valid in exit function. *) 1331 and debugFunctionResult (state: debugState as (cList, rList, _)) = 1332 let 1333 val d = (cList, rList) 1334 fun match (EnvEndFunction(_, _, ty), valu) = 1335 SOME(makeAnonymousValue state(ty, valu)) 1336 | match _ = NONE 1337 in 1338 getOpt(searchEnvs match d, unitValue) 1339 end 1340 1341 (* debugFunction just looks at the static data. 1342 There should always be an EnvStartFunction entry. *) 1343 fun debugFunction ((cList, _, _): debugState): string = 1344 ( 1345 case List.find(fn (EnvStartFunction _) => true | _ => false) cList of 1346 SOME(EnvStartFunction(s, _, _)) => s 1347 | _ => "?" 1348 ) 1349 1350 fun debugLocation ((_, _, locn): debugState) = locn 1351 1352 fun nameSpace localOnly (state: debugState as (clist, rlist, _)) : nameSpace = 1353 let 1354 val debugEnviron = (clist, rlist) 1355 1356 (* Lookup and "all" functions for the environment. We can't easily use a general 1357 function for the lookup because we have dynamic entries for values and structures 1358 but not for type constructors. *) 1359 fun lookupValues (EnvValue(name, ty, location) :: ntl, valu :: vl) s = 1360 if name = s 1361 then SOME(makeValue state (name, ty, location, valu)) 1362 else lookupValues(ntl, vl) s 1363 1364 | lookupValues (EnvException(name, ty, location) :: ntl, valu :: vl) s = 1365 if name = s 1366 then SOME(makeException state (name, ty, location, valu)) 1367 else lookupValues(ntl, vl) s 1368 1369 | lookupValues (EnvVConstr(name, ty, nullary, count, location) :: ntl, valu :: vl) s = 1370 if name = s 1371 then SOME(makeConstructor state (name, ty, nullary, count, location, valu)) 1372 else lookupValues(ntl, vl) s 1373 1374 | lookupValues (EnvTConstr _ :: ntl, vl) s = lookupValues(ntl, vl) s 1375 1376 | lookupValues (EnvStartFunction _ :: ntl, _ :: vl) s = 1377 if localOnly then NONE else lookupValues(ntl, vl) s 1378 1379 | lookupValues (_ :: ntl, _ :: vl) s = lookupValues(ntl, vl) s 1380 1381 | lookupValues _ _ = 1382 (* The name we are looking for isn't in 1383 the environment. 1384 The lists should be the same length. *) 1385 NONE 1386 1387 fun allValues (EnvValue(name, ty, location) :: ntl, valu :: vl) = 1388 (name, makeValue state (name, ty, location, valu)) :: allValues(ntl, vl) 1389 1390 | allValues (EnvException(name, ty, location) :: ntl, valu :: vl) = 1391 (name, makeException state (name, ty, location, valu)) :: allValues(ntl, vl) 1392 1393 | allValues (EnvVConstr(name, ty, nullary, count, location) :: ntl, valu :: vl) = 1394 (name, makeConstructor state (name, ty, nullary, count, location, valu)) :: allValues(ntl, vl) 1395 1396 | allValues (EnvTConstr _ :: ntl, vl) = allValues(ntl, vl) 1397 1398 | allValues (EnvStartFunction _ :: ntl, _ :: vl) = 1399 if localOnly then [] else allValues(ntl, vl) 1400 1401 | allValues (_ :: ntl, _ :: vl) = allValues(ntl, vl) 1402 | allValues _ = [] 1403 1404 fun lookupTypes (EnvTConstr (name, tCons) :: ntl, vl) s = 1405 if name = s 1406 then SOME (makeTypeConstr state tCons) 1407 else lookupTypes(ntl, vl) s 1408 1409 | lookupTypes (EnvStartFunction _ :: ntl, _ :: vl) s = 1410 if localOnly then NONE else lookupTypes(ntl, vl) s 1411 1412 | lookupTypes (_ :: ntl, _ :: vl) s = lookupTypes(ntl, vl) s 1413 | lookupTypes _ _ = NONE 1414 1415 fun allTypes (EnvTConstr(name, tCons) :: ntl, vl) = 1416 (name, makeTypeConstr state tCons) :: allTypes(ntl, vl) 1417 | allTypes (EnvStartFunction _ :: ntl, _ :: vl) = 1418 if localOnly then [] else allTypes(ntl, vl) 1419 | allTypes (_ :: ntl, _ :: vl) = allTypes(ntl, vl) 1420 | allTypes _ = [] 1421 1422 fun lookupStructs (EnvStructure (name, rSig, locations) :: ntl, valu :: vl) s = 1423 if name = s 1424 then SOME(makeStructure state (name, rSig, locations, valu)) 1425 else lookupStructs(ntl, vl) s 1426 1427 | lookupStructs (EnvTConstr _ :: ntl, vl) s = lookupStructs(ntl, vl) s 1428 1429 | lookupStructs (EnvStartFunction _ :: ntl, _ :: vl) s = 1430 if localOnly then NONE else lookupStructs(ntl, vl) s 1431 | lookupStructs (_ :: ntl, _ :: vl) s = lookupStructs(ntl, vl) s 1432 | lookupStructs _ _ = NONE 1433 1434 fun allStructs (EnvStructure (name, rSig, locations) :: ntl, valu :: vl) = 1435 (name, makeStructure state (name, rSig, locations, valu)) :: allStructs(ntl, vl) 1436 1437 | allStructs (EnvTypeid _ :: ntl, _ :: vl) = allStructs(ntl, vl) 1438 | allStructs (EnvStartFunction _ :: ntl, _ :: vl) = 1439 if localOnly then [] else allStructs(ntl, vl) 1440 | allStructs (_ :: ntl, vl) = allStructs(ntl, vl) 1441 | allStructs _ = [] 1442 1443 (* We have a full environment here for future expansion but at 1444 the moment only some of the entries are used. *) 1445 fun noLook _ = NONE 1446 and noEnter _ = raise Fail "Cannot update this name space" 1447 and allEmpty _ = [] 1448 in 1449 { 1450 lookupVal = lookupValues debugEnviron, 1451 lookupType = lookupTypes debugEnviron, 1452 lookupFix = noLook, 1453 lookupStruct = lookupStructs debugEnviron, 1454 lookupSig = noLook, lookupFunct = noLook, enterVal = noEnter, 1455 enterType = noEnter, enterFix = noEnter, enterStruct = noEnter, 1456 enterSig = noEnter, enterFunct = noEnter, 1457 allVal = fn () => allValues debugEnviron, 1458 allType = fn () => allTypes debugEnviron, 1459 allFix = allEmpty, 1460 allStruct = fn () => allStructs debugEnviron, 1461 allSig = allEmpty, 1462 allFunct = allEmpty } 1463 end 1464 1465 val debugNameSpace = nameSpace false and debugLocalNameSpace = nameSpace true 1466 end 1467 1468 local 1469 open DebuggerInterface 1470 1471 fun debugLocation(d: debugState): string * PolyML.location = 1472 (debugFunction d, DebuggerInterface.debugLocation d) 1473 1474 fun getStack() = debugState(Thread.Thread.self()) 1475 (* These are only relevant when we are stopped at the debugger but 1476 we need to use globals here so that the debug functions such 1477 as "variables" and "continue" will work. *) 1478 val inDebugger = ref false 1479 (* Current stack and debug level. *) 1480 val currentStack = ref [] 1481 fun getCurrentStack() = 1482 if !inDebugger then !currentStack else raise Fail "Not stopped in debugger" 1483 val debugLevel = ref 0 1484 (* Set to true to exit the debug loop. Set by commands such as "continue". *) 1485 val exitLoop = ref false 1486 (* Exception packet sent if this was continueWithEx. *) 1487 val debugExPacket: exn option ref = ref NONE 1488 1489 (* Call tracing. *) 1490 val tracing = ref false 1491 val breakNext = ref false 1492 (* Single stepping. *) 1493 val stepDebug = ref false 1494 val stepDepth = ref ~1 (* Only break at a stack size less than this. *) 1495 (* Break points. We have three breakpoint lists: a list of file-line 1496 pairs, a list of function names and a list of exceptions. *) 1497 val lineBreakPoints = ref [] 1498 and fnBreakPoints = ref [] 1499 and exBreakPoints = ref [] 1500 1501 fun checkLineBreak (file, line) = 1502 let 1503 fun findBreak [] = false 1504 | findBreak ((f, l) :: rest) = 1505 (l = line andalso f = file) orelse findBreak rest 1506 in 1507 findBreak (! lineBreakPoints) 1508 end 1509 1510 fun checkFnBreak exact name = 1511 let 1512 (* When matching a function name we allow match if the name 1513 we're looking for matches the last component of the name 1514 we have. e.g. if we set a break for "f" we match F().S.f . *) 1515 fun matchName n = 1516 if name = n then true 1517 else if exact then false 1518 else 1519 let 1520 val nameLen = size name 1521 and nLen = size n 1522 fun isSeparator #"-" = true 1523 | isSeparator #")" = true 1524 | isSeparator #"." = true 1525 | isSeparator _ = false 1526 in 1527 nameLen > nLen andalso String.substring(name, nameLen - nLen, nLen) = n 1528 andalso isSeparator(String.sub(name, nameLen - nLen - 1)) 1529 end 1530 in 1531 List.exists matchName (! fnBreakPoints) 1532 end 1533 1534 (* Get the exception id from an exception packet. The id is 1535 the first word in the packet. It's a mutable so treat it 1536 as an int ref here. The packet, though, is immutable. *) 1537 fun getExnId(ex: exn): int ref = RunCall.loadWordFromImmutable (ex, 0w0) 1538 1539 fun checkExnBreak(ex: exn) = 1540 let val exnId = getExnId ex in List.exists (fn n => n = exnId) (! exBreakPoints) end 1541 1542 fun getArgResult stack get = 1543 case stack of 1544 hd :: _ => Values.print(get hd, FixedInt.fromInt(!printDepth)) 1545 | _ => PrettyString "?" 1546 1547 fun printTrace (funName, location, stack, argsAndResult) = 1548 let 1549 (* This prints a block with the argument and, if we're exiting the result. 1550 The function name is decorated with the location. 1551 TODO: This works fine so long as the recursion depth is not too deep 1552 but once it gets too wide the pretty-printer starts breaking the lines. *) 1553 val block = 1554 PrettyBlock(0, false, [], 1555 [ 1556 PrettyBreak(FixedInt.fromInt(length stack), 0), 1557 PrettyBlock(0, false, [], 1558 [ 1559 PrettyBlock(0, false, [ContextLocation location], [PrettyString funName]), 1560 PrettyBreak(1, 3) 1561 ] @ argsAndResult) 1562 ]) 1563 in 1564 prettyPrintWithOptionalMarkup (TextIO.print, !lineLength) block 1565 end 1566 1567 (* Try to print the appropriate line from the file.*) 1568 fun printSourceLine(prefix, fileName: string, line: FixedInt.int, funName: string, justLocation) = 1569 let 1570 open TextIO 1571 open PolyML 1572 (* Use the pretty printer here because that allows us to provide a link to the 1573 function in the markup so the IDE can go straight to it. *) 1574 val prettyOut = prettyPrintWithOptionalMarkup (printOut, !lineLength) 1575 val lineInfo = 1576 concat( 1577 [prefix] @ 1578 (if fileName = "" then [] else [fileName, " "]) @ 1579 (if line = 0 then [] else [" line:", FixedInt.toString line, " "]) @ 1580 ["function:", funName]) 1581 in 1582 (* First just print where we are. *) 1583 prettyOut( 1584 PrettyBlock(0, true, 1585 [ContextLocation{file=fileName,startLine=line, endLine=line,startPosition=0,endPosition=0}], 1586 [PrettyString lineInfo])); 1587 (* Try to print it. This may fail if the file name was not a full path 1588 name and we're not in the correct directory. *) 1589 if justLocation orelse fileName = "" then () 1590 else 1591 let 1592 val fd = openIn fileName 1593 fun pLine n = 1594 case inputLine fd of 1595 NONE => () 1596 | SOME s => if n = 1 then printOut s else pLine(n-1) 1597 in 1598 pLine line; 1599 closeIn fd 1600 end handle IO.Io _ => () (* If it failed simply ignore the error. *) 1601 end 1602 1603 (* These functions are installed as global callbacks if necessary. *) 1604 fun onEntry (funName, location as {file, startLine, ...}: PolyML.location) = 1605 ( 1606 if ! tracing 1607 then 1608 let 1609 val stack = getStack() 1610 val arg = getArgResult stack debugFunctionArg 1611 in 1612 printTrace(funName, location, stack, [arg]) 1613 end 1614 else (); 1615 (* We don't actually break here because at this stage we don't 1616 have any variables declared. *) 1617 (* TODO: If for whatever reason we fail to find the breakpoint we need to cancel 1618 the pending break in the exit code. Otherwise we could try and break 1619 in some other code. *) 1620 if checkLineBreak (file, startLine) orelse checkFnBreak false funName 1621 then (breakNext := true; setOnBreakPoint(SOME onBreakPoint)) 1622 else () 1623 ) 1624 1625 and onExit (funName, location) = 1626 ( 1627 if ! tracing 1628 then 1629 let 1630 val stack = getStack() 1631 val arg = getArgResult stack debugFunctionArg 1632 val res = getArgResult stack debugFunctionResult 1633 in 1634 printTrace(funName, location, stack, 1635 [arg, PrettyBreak(1, 3), PrettyString "=", PrettyBreak(1, 3), res]) 1636 end 1637 else () 1638 ) 1639 1640 and onExitException(funName, location) exn = 1641 ( 1642 if ! tracing 1643 then 1644 let 1645 val stack = getStack() 1646 val arg = getArgResult stack debugFunctionArg 1647 in 1648 printTrace(funName, location, stack, 1649 [arg, PrettyBreak(1, 3), PrettyString "=", PrettyBreak(1, 3), 1650 PrettyString "raised", PrettyBreak(1, 3), PrettyString(exnName exn)]) 1651 end 1652 else (); 1653 if checkExnBreak exn 1654 then enterDebugger () 1655 else () 1656 ) 1657 1658 and onBreakPoint({file, startLine, ...}: PolyML.location, _) = 1659 ( 1660 if (!stepDebug andalso (!stepDepth < 0 orelse List.length(getStack()) <= !stepDepth)) orelse 1661 checkLineBreak (file, startLine) orelse ! breakNext 1662 then enterDebugger () 1663 else () 1664 ) 1665 1666 (* Set the callbacks when beginning to run some code. *) 1667 and setCallBacks () = 1668 ( 1669 setOnEntry(if !tracing orelse not(null(! fnBreakPoints)) then SOME onEntry else NONE); 1670 setOnExit(if !tracing then SOME onExit else NONE); 1671 setOnExitException(if !tracing orelse not(null(! exBreakPoints)) then SOME onExitException else NONE); 1672 setOnBreakPoint(if !tracing orelse ! stepDebug orelse not(null(! lineBreakPoints)) then SOME onBreakPoint else NONE) 1673 ) 1674 1675 (* Clear all callbacks when exiting debuggable code. *) 1676 and clearCallBacks () = 1677 ( 1678 setOnEntry NONE; 1679 setOnExit NONE; 1680 setOnExitException NONE; 1681 setOnBreakPoint NONE; 1682 (* Clear all stepping. *) 1683 breakNext := false; 1684 stepDebug := false; 1685 stepDepth := ~1; 1686 (* Clear the debugger state *) 1687 debugLevel := 0; 1688 currentStack := [] 1689 ) 1690 1691 and enterDebugger () = 1692 let 1693 (* Clear the onXXX functions to prevent any recursion. *) 1694 val () = clearCallBacks () 1695 val () = inDebugger := true 1696 (* Remove any type-ahead. *) 1697 fun flushInput () = 1698 case TextIO.canInput(TextIO.stdIn, 1) of 1699 SOME 1 => (TextIO.inputN(TextIO.stdIn, 1); flushInput()) 1700 | _ => () 1701 val () = flushInput () 1702 1703 val () = exitLoop := false 1704 (* Save the stack on entry. If we execute any code with 1705 debugging enabled while we're in the debugger we could 1706 change this. *) 1707 val () = currentStack := getStack() 1708 1709 val () = 1710 case !currentStack of 1711 hd :: _ => 1712 let 1713 val (funName, {file, startLine, ...}) = debugLocation hd 1714 in 1715 printSourceLine("", file, startLine, funName, false) 1716 end 1717 | [] => () (* Shouldn't happen. *) 1718 1719 val compositeNameSpace = 1720 (* Compose any debugEnv with the global environment. Create a new temporary environment 1721 to contain any bindings made within the shell. They are discarded when we continue 1722 from the break-point. Previously, bindings were made in the global environment but 1723 that is problematic. It is possible to capture local types in the bindings which 1724 could actually be different at the next breakpoint. *) 1725 let 1726 val fixTab = ProtectedTable.create() and sigTab = ProtectedTable.create() 1727 and valTab = ProtectedTable.create() and typTab = ProtectedTable.create() 1728 and fncTab = ProtectedTable.create() and strTab = ProtectedTable.create() 1729 (* The debugging environment depends on the currently selected stack frame. *) 1730 fun debugEnv() = debugNameSpace (List.nth(!currentStack, !debugLevel)) 1731 fun dolookup f t s = 1732 case ProtectedTable.lookup t s of NONE => (case f (debugEnv()) s of NONE => f globalNameSpace s | v => v) | v => v 1733 fun getAll f t () = ProtectedTable.all t () @ f (debugEnv()) () @ f globalNameSpace () 1734 in 1735 { 1736 lookupFix = dolookup #lookupFix fixTab, 1737 lookupSig = dolookup #lookupSig sigTab, 1738 lookupVal = dolookup #lookupVal valTab, 1739 lookupType = dolookup #lookupType typTab, 1740 lookupFunct = dolookup #lookupFunct fncTab, 1741 lookupStruct = dolookup #lookupStruct strTab, 1742 enterFix = ProtectedTable.enter fixTab, 1743 enterSig = ProtectedTable.enter sigTab, 1744 enterVal = ProtectedTable.enter valTab, 1745 enterType = ProtectedTable.enter typTab, 1746 enterFunct = ProtectedTable.enter fncTab, 1747 enterStruct = ProtectedTable.enter strTab, 1748 allFix = getAll #allFix fixTab, 1749 allSig = getAll #allSig sigTab, 1750 allVal = getAll #allVal valTab, 1751 allType = getAll #allType typTab, 1752 allFunct = getAll #allFunct fncTab, 1753 allStruct = getAll #allStruct strTab 1754 } 1755 end 1756 in 1757 topLevel 1758 { isDebug = true, nameSpace = compositeNameSpace, exitLoop = fn _ => ! exitLoop, 1759 exitOnError = false, isInteractive = true, 1760 (* Don't enable debugging for anything run within the debug level. *) 1761 startExec = fn () => (), endExec = fn () => () } 1762 (* If we type control-C to the debugger we exit it and 1763 raise Interrupt within the debuggee without re-enabling 1764 any breakpoints. *) 1765 handle exn => (inDebugger := false; raise exn); 1766 1767 inDebugger := false; 1768 setCallBacks(); (* Re-enable debugging. *) 1769 1770 (* If this was continueWithEx raise the exception. *) 1771 case ! debugExPacket of 1772 NONE => () 1773 | SOME exn => (debugExPacket := NONE; raise exn) 1774 end 1775 in 1776 (* Normal, non-debugging top-level loop. *) 1777 fun shell () = 1778 let 1779 val argList = CommandLine.arguments() 1780 fun switchOption option = List.exists(fn s => s = option) argList 1781 (* Generate mark-up in IDE code when printing if the option has been given 1782 on the command line. *) 1783 val () = useMarkupInOutput := switchOption "--with-markup" 1784 val exitOnError = switchOption"--error-exit" 1785 val interactive = 1786 switchOption "-i" orelse 1787 let 1788 open TextIO OS 1789 open StreamIO TextPrimIO IO 1790 val s = getInstream stdIn 1791 val (r, v) = getReader s 1792 val RD { ioDesc, ...} = r 1793 in 1794 setInstream(stdIn, mkInstream(r,v)); 1795 case ioDesc of 1796 SOME io => (kind io = Kind.tty handle SysErr _ => false) 1797 | _ => false 1798 end 1799 in 1800 topLevel 1801 { isDebug = false, nameSpace = globalNameSpace, exitLoop = fn _ => false, 1802 isInteractive = interactive, exitOnError = exitOnError, 1803 startExec = setCallBacks, endExec = clearCallBacks } 1804 end 1805 1806 structure Debug = 1807 struct 1808 (* Functions that are only relevant when called from the debugger. These 1809 check the debugging state using getCurrentStack which raises an 1810 exception if we're not in the debugger. *) 1811 (* "step" causes the debugger to be entered on the next call. 1812 "stepOver" enters the debugger on the next call when the stack is no larger 1813 than it is at present. 1814 "stepOut" enters the debugger on the next call when the stack is smaller 1815 than it is at present. *) 1816 fun step () = 1817 let 1818 val _ = getCurrentStack() 1819 in 1820 stepDebug := true; stepDepth := ~1; exitLoop := true 1821 end 1822 1823 and stepOver() = 1824 let 1825 val stack = getCurrentStack() 1826 in 1827 stepDebug := true; stepDepth := List.length stack; exitLoop := true 1828 end 1829 1830 and stepOut() = 1831 let 1832 val stack = getCurrentStack() 1833 in 1834 stepDebug := true; stepDepth := List.length stack - 1; exitLoop := true 1835 end 1836 1837 and continue () = 1838 let 1839 val _ = getCurrentStack() 1840 in 1841 stepDebug := false; stepDepth := ~1; exitLoop := true 1842 end 1843 1844 and continueWithEx exn = 1845 let 1846 val _ = getCurrentStack() 1847 in 1848 stepDebug := false; stepDepth := ~1; exitLoop := true; debugExPacket := SOME exn 1849 end 1850 1851 (* Stack traversal. *) 1852 fun up () = 1853 let 1854 val stack = getCurrentStack() 1855 in 1856 if !debugLevel < List.length stack -1 1857 then 1858 let 1859 val _ = debugLevel := !debugLevel + 1; 1860 val (funName, {startLine, file, ...}) = 1861 debugLocation(List.nth(stack, !debugLevel)) 1862 in 1863 printSourceLine("", file, startLine, funName, false) 1864 end 1865 else TextIO.print "Top of stack.\n" 1866 end 1867 1868 and down () = 1869 let 1870 val stack = getCurrentStack() 1871 in 1872 if !debugLevel = 0 1873 then TextIO.print "Bottom of stack.\n" 1874 else 1875 let 1876 val () = debugLevel := !debugLevel - 1; 1877 val (funName, {startLine, file, ...}) = 1878 debugLocation(List.nth(stack, !debugLevel)) 1879 in 1880 printSourceLine("", file, startLine, funName, false) 1881 end 1882 end 1883 1884 (* Just print the functions without any other context. *) 1885 fun stack () : unit = 1886 let 1887 fun printTrace(d, n) = 1888 let 1889 val (funName, {file, startLine, ...}) = debugLocation d 1890 (* If this is the current level prefix it with > *) 1891 val prefix = if n = !debugLevel then "> " else " " 1892 in 1893 printSourceLine(prefix, file, startLine, funName, true); 1894 n+1 1895 end 1896 in 1897 ignore (List.foldl printTrace 0 (getCurrentStack())) 1898 end 1899 1900 local 1901 fun printVal v = 1902 prettyPrintWithOptionalMarkup(TextIO.print, !lineLength) 1903 (NameSpace.Values.printWithType(v, FixedInt.fromInt(!printDepth), SOME globalNameSpace)) 1904 fun printStack (stack: debugState) = 1905 List.app (fn (_,v) => printVal v) (#allVal (debugNameSpace stack) ()) 1906 in 1907 (* Print all variables at the current level. *) 1908 fun variables() = 1909 printStack (List.nth(getCurrentStack(), !debugLevel)) 1910 (* Print all the levels. *) 1911 and dump() = 1912 let 1913 fun printLevel stack = 1914 let 1915 val (funName, _) = debugLocation stack 1916 in 1917 TextIO.print(concat["Function ", funName, ":"]); 1918 printStack stack; 1919 TextIO.print "\n" 1920 end 1921 in 1922 List.app printLevel (getCurrentStack()) 1923 end 1924 (* Print local variables at the current level. *) 1925 and locals() = 1926 let 1927 val stack = List.nth(getCurrentStack(), !debugLevel) 1928 in 1929 List.app (fn (_,v) => printVal v) (#allVal (debugLocalNameSpace stack) ()) 1930 end 1931 end 1932 1933 (* Functions to adjust tracing and breakpointing. May be called 1934 either within or outside the debugger. *) 1935 fun trace b = tracing := b 1936 1937 fun breakAt (file, line) = 1938 if checkLineBreak(file, line) then () (* Already there. *) 1939 else lineBreakPoints := (file, line) :: ! lineBreakPoints 1940 1941 fun clearAt (file, line) = 1942 let 1943 fun findBreak [] = (TextIO.print "No such breakpoint.\n"; []) 1944 | findBreak ((f, l) :: rest) = 1945 if l = line andalso f = file 1946 then rest else (f, l) :: findBreak rest 1947 in 1948 lineBreakPoints := findBreak (! lineBreakPoints) 1949 end 1950 1951 fun breakIn name = 1952 if checkFnBreak true name then () (* Already there. *) 1953 else fnBreakPoints := name :: ! fnBreakPoints 1954 1955 fun clearIn name = 1956 let 1957 fun findBreak [] = (TextIO.print "No such breakpoint.\n"; []) 1958 | findBreak (n :: rest) = 1959 if name = n then rest else n :: findBreak rest 1960 in 1961 fnBreakPoints := findBreak (! fnBreakPoints) 1962 end 1963 1964 fun breakEx exn = 1965 if checkExnBreak exn then () (* Already there. *) 1966 else exBreakPoints := getExnId exn :: ! exBreakPoints 1967 1968 fun clearEx exn = 1969 let 1970 val exnId = getExnId exn 1971 fun findBreak [] = (TextIO.print "No such breakpoint.\n"; []) 1972 | findBreak (n :: rest) = 1973 if exnId = n then rest else n :: findBreak rest 1974 in 1975 exBreakPoints := findBreak (! exBreakPoints) 1976 end 1977 1978 end 1979 end 1980 1981 structure CodeTree = 1982 struct 1983 open PolyML.CodeTree 1984 (* Add options to the code-generation phase. *) 1985 val genCode = 1986 fn (code, numLocals) => 1987 let 1988 open Bootstrap Bootstrap.Universal 1989 val compilerOut = prettyPrintWithOptionalMarkup(TextIO.print, !lineLength) 1990 in 1991 genCode(code, 1992 [ 1993 tagInject compilerOutputTag compilerOut, 1994 tagInject maxInlineSizeTag (FixedInt.fromInt(! maxInlineSize)), 1995 tagInject codetreeTag (! codetree), 1996 tagInject icodeTag (! icode), 1997 tagInject lowlevelOptimiseTag (! lowlevelOptimise), 1998 tagInject assemblyCodeTag (! assemblyCode), 1999 tagInject codetreeAfterOptTag (! codetreeAfterOpt) 2000 ], numLocals) 2001 end 2002 end 2003 2004 (* Original print_depth etc functions. *) 2005 fun timing b = Compiler.timing := b 2006 and print_depth i = Compiler.printDepth := i 2007 and error_depth i = Compiler.errorDepth := i 2008 and line_length i = Compiler.lineLength := i 2009 2010 (* Legacy exception_trace. *) 2011 structure Exception = 2012 struct 2013 open Exception 2014 fun exception_trace f = f() (* Backwards compatibility *) 2015 end 2016 2017 (* Include it in the PolyML structure for backwards compatibility. *) 2018 val exception_trace = Exception.exception_trace 2019 2020 local 2021 val systemProfile : int -> (int * string) list = 2022 RunCall.rtsCallFull1 "PolyProfiling" 2023 2024 fun printProfile profRes = 2025 let 2026 (* Sort in ascending order. *) 2027 val sorted = quickSort (fn (a, _) => fn (b, _) => a <= b) profRes 2028 2029 fun doPrint (count, name) = 2030 let 2031 val cPrint = Int.toString count 2032 val prefix = 2033 CharVector.tabulate(Int.max(0, 10-size cPrint), fn _ => #" ") 2034 in 2035 TextIO.output(TextIO.stdOut, concat[prefix, cPrint, " ", name, "\n"]) 2036 end 2037 2038 val total = List.foldl (fn ((c,_),s) => c+s) 0 profRes 2039 in 2040 List.app doPrint sorted; 2041 if total = 0 then () 2042 else TextIO.print(concat["Total ", Int.toString total, "\n"]) 2043 end 2044 in 2045 2046 structure Profiling = 2047 struct 2048 datatype profileMode = 2049 ProfileTime (* old mode 1 *) 2050 | ProfileAllocations (* old mode 2 *) 2051 | ProfileLongIntEmulation (* old mode 3 - No longer used*) 2052 | ProfileTimeThisThread (* old mode 6 *) 2053 | ProfileMutexContention 2054 2055 fun profileStream (stream: (int * string) list -> unit) mode f arg = 2056 let 2057 (* Control profiling. This may raise Fail if profiling is turned on when it 2058 is already on or if there is insufficient memory. *) 2059 val code = 2060 case mode of 2061 ProfileTime => 1 2062 | ProfileAllocations => 2 2063 | ProfileLongIntEmulation => 3 2064 | ProfileTimeThisThread => 6 2065 | ProfileMutexContention => 7 2066 val _ = systemProfile code (* Discard the result *) 2067 val result = 2068 f arg handle exn => (stream(systemProfile 0); PolyML.Exception.reraise exn) 2069 in 2070 stream(systemProfile 0); 2071 result 2072 end 2073 2074 fun profile mode f arg = profileStream printProfile mode f arg 2075 2076 (* Live data profiles show the current state. We need to run the 2077 GC to produce the counts. *) 2078 datatype profileDataMode = 2079 ProfileLiveData 2080 | ProfileLiveMutableData 2081 2082 fun profileDataStream(stream: (int * string) list -> unit) mode = 2083 let 2084 val code = 2085 case mode of 2086 ProfileLiveData => 4 2087 | ProfileLiveMutableData => 5 2088 val _ = systemProfile code (* Discard the result *) 2089 val () = PolyML.fullGC() 2090 in 2091 stream(systemProfile 0) 2092 end 2093 2094 val profileData = profileDataStream printProfile 2095 end 2096 end 2097 2098 (* Saving and loading state. *) 2099 structure SaveState = 2100 struct 2101 local 2102 val getOS: int = LibrarySupport.getOSType() 2103 2104 val loadMod: string -> Universal.universal list = RunCall.rtsCallFull1 "PolyLoadModule" 2105 and systemDir: unit -> string = RunCall.rtsCallFull0 "PolyGetModuleDirectory" 2106 in 2107 fun loadModuleBasic (fileName: string): Universal.universal list = 2108 (* If there is a path separator use the name and don't search further. *) 2109 if OS.Path.dir fileName <> "" 2110 then loadMod fileName 2111 else 2112 let 2113 (* Path elements are separated by semicolons in Windows but colons in Unix. *) 2114 val sepInPathList = if getOS = 1 then #";" else #":" 2115 val pathList = 2116 case OS.Process.getEnv "POLYMODPATH" of 2117 NONE => [] 2118 | SOME s => String.fields (fn ch => ch = sepInPathList) s 2119 2120 fun findFile [] = NONE 2121 | findFile (hd::tl) = 2122 (* Try actually loading the file. That way we really check we have a module. *) 2123 SOME(loadMod (OS.Path.joinDirFile{dir=hd, file=fileName})) 2124 handle Fail _ => findFile tl | OS.SysErr _ => findFile tl 2125 in 2126 case findFile pathList of 2127 SOME l => l (* Found *) 2128 | NONE => 2129 let 2130 val sysDir = systemDir() 2131 val inSysDir = 2132 if sysDir = "" then NONE else findFile[sysDir] 2133 in 2134 case inSysDir of 2135 SOME l => l 2136 | NONE => raise Fail("Unable to find module ``" ^ fileName ^ "''") 2137 end 2138 end 2139 end 2140 2141 val saveChild: string * int -> unit = RunCall.rtsCallFull2 "PolySaveState" 2142 2143 fun saveState f = saveChild (f, 0); 2144 2145 val showHierarchy: unit -> string list = RunCall.rtsCallFull0 "PolyShowHierarchy" 2146 2147 local 2148 val doRename: string * string -> unit = RunCall.rtsCallFull2 "PolyRenameParent" 2149 in 2150 fun renameParent{ child: string, newParent: string }: unit = doRename(child, newParent) 2151 end 2152 2153 val showParent: string -> string option = RunCall.rtsCallFull1 "PolyShowParent" 2154 and loadState: string -> unit = RunCall.rtsCallFull1 "PolyLoadState" 2155 2156 local 2157 val loadHier: string list -> unit = RunCall.rtsCallFull1 "PolyLoadHierarchy" 2158 in 2159 (* Load hierarchy takes a list of file names in order with the parents 2160 before the children. It's easier for the RTS if this is reversed. *) 2161 fun loadHierarchy (s: string list): unit = loadHier (List.rev s) 2162 end 2163 2164 (* Module loading and storing. *) 2165 structure Tags = 2166 struct 2167 val structureTag: (string * PolyML.NameSpace.Structures.structureVal) Universal.tag = Universal.tag() 2168 val functorTag: (string * PolyML.NameSpace.Functors.functorVal) Universal.tag = Universal.tag() 2169 val signatureTag: (string * PolyML.NameSpace.Signatures.signatureVal) Universal.tag = Universal.tag() 2170 val valueTag: (string * PolyML.NameSpace.Values.value) Universal.tag = Universal.tag() 2171 val typeTag: (string * PolyML.NameSpace.TypeConstrs.typeConstr) Universal.tag = Universal.tag() 2172 val fixityTag: (string * PolyML.NameSpace.Infixes.fixity) Universal.tag = Universal.tag() 2173 val startupTag: (unit -> unit) Universal.tag = Universal.tag() 2174 end 2175 2176 local 2177 val saveMod: string * Universal.universal list -> unit = RunCall.rtsCallFull2 "PolyStoreModule" 2178 in 2179 fun saveModuleBasic(_, []) = raise Fail "Cannot create an empty module" 2180 | saveModuleBasic(name, contents) = saveMod(name, contents) 2181 end 2182 2183 fun saveModule(s, {structs, functors, sigs, onStartup}) = 2184 let 2185 fun dolookup (look, tag, kind) s = 2186 case look globalNameSpace s of 2187 SOME v => Universal.tagInject tag (s, v) 2188 | NONE => raise Fail (concat[kind, " ", s, " has not been declared"]) 2189 val structVals = map (dolookup(#lookupStruct, Tags.structureTag, "Structure")) structs 2190 val functorVals = map (dolookup(#lookupFunct, Tags.functorTag, "Functor")) functors 2191 val sigVals = map (dolookup(#lookupSig, Tags.signatureTag, "Signature")) sigs 2192 val startVal = 2193 case onStartup of 2194 SOME f => [Universal.tagInject Tags.startupTag f] 2195 | NONE => [] 2196 in 2197 saveModuleBasic(s, structVals @ functorVals @ sigVals @ startVal) 2198 end 2199 2200 fun loadModule s = 2201 let 2202 val ulist = loadModuleBasic s 2203 (* Find and run the start-up function. If it raises an exception we 2204 don't go further. *) 2205 val startFn = List.find (Universal.tagIs Tags.startupTag) ulist 2206 val () = 2207 case startFn of SOME f => (Universal.tagProject Tags.startupTag f) () | NONE => () 2208 fun extract (tag:'a Universal.tag): Universal.universal list -> 'a list = 2209 List.mapPartial( 2210 fn s => if Universal.tagIs tag s then SOME(Universal.tagProject tag s) else NONE) 2211 in 2212 (* Add the entries and print them in the same way as top-level bindings. *) 2213 printAndEnter(! printInAlphabeticalOrder, globalNameSpace, TextIO.print, !printDepth) 2214 { 2215 fixes = extract Tags.fixityTag ulist, 2216 values = extract Tags.valueTag ulist, 2217 structures = extract Tags.structureTag ulist, 2218 signatures = extract Tags.signatureTag ulist, 2219 functors = extract Tags.functorTag ulist, 2220 types = extract Tags.typeTag ulist 2221 } 2222 end 2223 end 2224 2225 val loadModule = SaveState.loadModule 2226 2227 end 2228end (* PolyML. *); 2229