1(* 2 Title: Source level debugger for Poly/ML 3 Author: David Matthews 4 Copyright (c) David Matthews 2000, 2014, 2015, 2020 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 20functor DEBUGGER_ ( 21 22 structure STRUCTVALS : STRUCTVALSIG 23 structure VALUEOPS : VALUEOPSSIG 24 structure CODETREE : CODETREESIG 25 structure TYPETREE: TYPETREESIG 26 structure ADDRESS : AddressSig 27 structure COPIER: COPIERSIG 28 structure TYPEIDCODE: TYPEIDCODESIG 29 structure LEX : LEXSIG 30 structure DEBUG: DEBUG 31 32 structure UTILITIES : 33 sig 34 val splitString: string -> { first:string,second:string } 35 end 36 37sharing STRUCTVALS.Sharing = VALUEOPS.Sharing = TYPETREE.Sharing = COPIER.Sharing = 38 TYPEIDCODE.Sharing = CODETREE.Sharing = ADDRESS = LEX.Sharing 39) 40: DEBUGGER 41= 42struct 43 open STRUCTVALS VALUEOPS CODETREE COPIER TYPETREE DEBUG 44 45 (* The static environment contains these kinds of entries. *) 46 datatype environEntry = 47 EnvValue of string * types * locationProp list 48 | EnvException of string * types * locationProp list 49 | EnvVConstr of string * types * bool * int * locationProp list 50 | EnvTypeid of { original: typeId, freeId: typeId } 51 | EnvStructure of string * signatures * locationProp list 52 | EnvTConstr of string * typeConstrSet 53 | EnvStartFunction of string * location * types 54 | EnvEndFunction of string * location * types 55 56 local 57 open ADDRESS 58 in 59 (* Entries in the thread data. The RTS allocates enough space for this. 60 The first entry is 5 because earlier entries are used by Thread.Thread. *) 61 val threadIdStack = mkConst(toMachineWord 0w5) (* The static/dynamic/location entries for calling fns *) 62 and threadIdCurrentStatic = mkConst(toMachineWord 0w6) (* The static info for bindings i.e. name/type. *) 63 and threadIdCurrentDynamic = mkConst(toMachineWord 0w7) (* Dynamic infor for bindings i.e. actual run-time value. *) 64 and threadIdCurrentLocation = mkConst(toMachineWord 0w8) (* Location in code: line number/offset etc. *) 65 66 (* Global function entries. These could be in storage allocated by the RTS. *) 67 (* Specialised option type here. Because a function is always boxed this 68 avoids the need for an extra level of indirection. *) 69 datatype ('a, 'b) functionOpt = NoFunction | AFunction of 'a -> 'b 70 val globalOnEntry = ref NoFunction 71 and globalOnExit = ref NoFunction 72 and globalOnExitExc = ref NoFunction 73 and globalOnBreakPoint = ref NoFunction 74 75 val onEntryCode = 76 mkLoadOperation(LoadStoreMLWord{isImmutable=false}, mkConst(toMachineWord globalOnEntry), CodeZero) 77 and onExitCode = 78 mkLoadOperation(LoadStoreMLWord{isImmutable=false}, mkConst(toMachineWord globalOnExit), CodeZero) 79 and onExitExcCode = 80 mkLoadOperation(LoadStoreMLWord{isImmutable=false}, mkConst(toMachineWord globalOnExitExc), CodeZero) 81 and onBreakPointCode = 82 mkLoadOperation(LoadStoreMLWord{isImmutable=false}, mkConst(toMachineWord globalOnBreakPoint), CodeZero) 83 84 (* We need to ensure that any break-point code preserves the state. It could be modified 85 if we hit a break-point and run the interactive debugger with PolyML.Compiler.debug true. *) 86 fun wrap (f:'a -> unit) (x: 'a) : unit = 87 let 88 val threadId: address = RunCall.unsafeCast(Thread.Thread.self()) 89 val stack = loadWord(threadId, 0w5) 90 and static = loadWord(threadId, 0w6) 91 and dynamic = loadWord(threadId, 0w7) 92 and location = loadWord(threadId, 0w8) 93 94 fun restore () = 95 ( 96 assignWord(threadId, 0w5, stack); 97 assignWord(threadId, 0w6, static); 98 assignWord(threadId, 0w7, dynamic); 99 assignWord(threadId, 0w8, location) 100 ) 101 in 102 f x handle exn => (restore(); PolyML.Exception.reraise exn); 103 restore() 104 end 105 106 fun setOnEntry NONE = globalOnEntry := NoFunction 107 | setOnEntry (SOME(f: string * PolyML.location -> unit)) = globalOnEntry := AFunction (wrap f) 108 109 and setOnExit NONE = globalOnExit := NoFunction 110 | setOnExit (SOME(f: string * PolyML.location -> unit)) = globalOnExit := AFunction (wrap f) 111 112 and setOnExitException NONE = globalOnExitExc := NoFunction 113 | setOnExitException (SOME(f: string * PolyML.location -> exn -> unit)) = 114 globalOnExitExc := AFunction (fn x => wrap (f x)) 115 116 and setOnBreakPoint NONE = globalOnBreakPoint := NoFunction 117 | setOnBreakPoint (SOME(f: PolyML.location * bool ref -> unit)) = globalOnBreakPoint := AFunction (wrap f) 118 end 119 120 121 122 (* When stopped at a break-point any Bound ids must be replaced by Free ids. 123 We make new Free ids at this point. *) 124 fun envTypeId (id as TypeId{ description, idKind = Bound{arity, ...}, ...}) = 125 EnvTypeid { original = id, freeId = makeFreeId(arity, Global CodeZero, isEquality id, description) } 126 | envTypeId id = EnvTypeid { original = id, freeId = id } 127 128 fun searchEnvs match (staticEntry :: statics, dlist as dynamicEntry :: dynamics) = 129 ( 130 case (match (staticEntry, dynamicEntry), staticEntry) of 131 (SOME result, _) => SOME result 132 | (NONE, EnvTypeid _) => searchEnvs match (statics, dynamics) 133 | (NONE, EnvVConstr _) => searchEnvs match (statics, dynamics) 134 | (NONE, EnvValue _) => searchEnvs match (statics, dynamics) 135 | (NONE, EnvException _) => searchEnvs match (statics, dynamics) 136 | (NONE, EnvStructure _) => searchEnvs match (statics, dynamics) 137 | (NONE, EnvStartFunction _) => searchEnvs match (statics, dynamics) 138 | (NONE, EnvEndFunction _) => searchEnvs match (statics, dynamics) 139 (* EnvTConstr doesn't have an entry in the dynamic list *) 140 | (NONE, EnvTConstr _) => searchEnvs match (statics, dlist) 141 142 ) 143 144 | searchEnvs _ _ = NONE 145 (* N.B. It is possible to have ([EnvTConstr ...], []) in the arguments so we can't treat 146 that if either the static or dynamic list is nil and the other non-nil as an error. *) 147 148 (* Exported functions that appear in PolyML.DebuggerInterface. *) 149 type debugState = environEntry list * machineWord list * location 150 151 fun searchType ((clist, rlist, _): debugState) typeid = 152 let 153 fun match (EnvTypeid{original, freeId }, valu) = 154 if sameTypeId(original, typeid) 155 then 156 case freeId of 157 TypeId{description, idKind as Free _, ...} => 158 (* This can occur for datatypes inside functions. *) 159 SOME(TypeId { access= Global(mkConst valu), idKind=idKind, description=description}) 160 | _ => raise Misc.InternalError "searchType: TypeFunction" 161 else NONE 162 | match _ = NONE 163 in 164 case (searchEnvs match (clist, rlist), typeid) of 165 (SOME t, _) => t 166 | (NONE, TypeId{description, idKind = TypeFn typeFn, ...}) => makeTypeFunction(description, typeFn) 167 168 | (NONE, typeid as TypeId{description, idKind = Bound{arity, ...}, ...}) => 169 (* The type ID is missing. Make a new temporary ID. *) 170 makeFreeId(arity, Global(TYPEIDCODE.codeForUniqueId()), isEquality typeid, description) 171 172 | (NONE, typeid as TypeId{description, idKind = Free{arity, ...}, ...}) => 173 (* The type ID is missing. Make a new temporary ID. *) 174 makeFreeId(arity, Global(TYPEIDCODE.codeForUniqueId()), isEquality typeid, description) 175 176 end 177 178 (* Values must be copied so that compile-time type IDs are replaced by their run-time values. *) 179 fun makeTypeConstr (state: debugState) (TypeConstrSet(tcons, (*tcConstructors*) _)) = 180 let 181 val typeID = searchType state (tcIdentifier tcons) 182 val newTypeCons = 183 makeTypeConstructor(tcName tcons, tcTypeVars tcons, typeID, tcLocations tcons) 184 185 val newValConstrs = (*map copyAConstructor tcConstructors*) [] 186 in 187 TypeConstrSet(newTypeCons, newValConstrs) 188 end 189 190 (* When creating a structure we have to add a type map that will look up the bound Ids. *) 191 fun makeStructure state (name, rSig, locations, valu) = 192 let 193 local 194 val Signatures{ name = sigName, tab, typeIdMap, firstBoundIndex, locations=sigLocs, ... } = rSig 195 fun getFreeId n = searchType state (makeBoundId(0 (* ??? *), Global CodeZero, n, false, false, basisDescription "")) 196 in 197 val newSig = makeSignature(sigName, tab, firstBoundIndex, sigLocs, composeMaps(typeIdMap, getFreeId), []) 198 end 199 in 200 makeGlobalStruct (name, newSig, mkConst valu, locations) 201 end 202 203 local 204 fun runTimeType (state: debugState) ty = 205 let 206 fun copyId(TypeId{idKind=Free _, access=Global _ , ...}) = NONE (* Use original *) 207 | copyId id = SOME(searchType state id) 208 in 209 copyType (ty, fn x => x, 210 fn tcon => copyTypeConstr (tcon, copyId, fn x => x, fn s => s)) 211 end 212 213 (* Return the value as a constant. In almost all cases we just return the value. 214 The exception is when we have an equality type variable. In that case we must 215 return a function because we will use applyToInstanceType to apply it to the 216 instance type(s). 217 N.B. This is probably because of the way that allowGeneralisation side-effects 218 the type variables resulting in local type variables becoming generic. *) 219 fun getValue(valu, ty) = 220 let 221 val filterTypeVars = List.filter (fn tv => not TYPEIDCODE.justForEqualityTypes orelse tvEquality tv) 222 val polyVars = filterTypeVars (getPolyTypeVars(ty, fn _ => NONE)) 223 val nPolyVars = List.length polyVars 224 in 225 if nPolyVars = 0 226 then mkConst valu 227 else mkInlproc(mkConst valu, nPolyVars, "poly", [], 0) 228 end 229 in 230 fun makeValue state (name, ty, location, valu) = 231 mkGvar(name, runTimeType state ty, getValue(valu, ty), location) 232 233 and makeException state (name, ty, location, valu) = 234 mkGex(name, runTimeType state ty, getValue(valu, ty), location) 235 236 and makeConstructor state (name, ty, nullary, count, location, valu) = 237 makeValueConstr(name, runTimeType state ty, nullary, count, Global(getValue(valu, ty)), location) 238 239 and makeAnonymousValue state (ty, valu) = 240 makeValue state ("", ty, [], valu) 241 end 242 243 (* Functions to make the debug entries. These are needed both in CODEGEN_PARSETREE for 244 the core language and STRUCTURES for the module language. *) 245 (* Debugger status within the compiler. 246 During compilation the environment is built up as a pair 247 consisting of the static data and code to compute the run-time data. 248 The static data, a constant at run-time, holds the 249 variable names and types. The run-time code, when executed at 250 run-time, returns the address of a list holding the actual values 251 of the variables. "dynEnv" is always a "load" from a (codetree) 252 variable. It has type level->codetree rather than codetree 253 because the next reference could be inside an inner function. 254 "lastLoc" is the last location that was *) 255 type debuggerStatus = 256 {staticEnv: environEntry list, dynEnv: level->codetree, lastLoc: location} 257 258 val initialDebuggerStatus: debuggerStatus = 259 {staticEnv = [], dynEnv = fn _ => CodeZero, lastLoc = LEX.nullLocation } 260 261 (* Set the current state in the thread data. *) 262 fun updateState (level, mkAddr) (decs, debugEnv: debuggerStatus as {staticEnv, dynEnv, ...}) = 263 let 264 open ADDRESS 265 val threadId = multipleUses(getCurrentThreadId, fn () => mkAddr 1, level) 266 fun assignItem(offset, value) = 267 mkNullDec(mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, offset, value)) 268 val newDecs = 269 decs @ #dec threadId @ 270 [assignItem(threadIdCurrentStatic, mkConst(toMachineWord staticEnv)), 271 assignItem(threadIdCurrentDynamic, dynEnv level)] 272 in 273 (newDecs, debugEnv) 274 end 275 276 fun makeValDebugEntries (vars: values list, debugEnv: debuggerStatus, level, lex, mkAddr, typeVarMap) = 277 if getParameter debugTag (LEX.debugParams lex) 278 then 279 let 280 fun loadVar (var, (decs, {staticEnv, dynEnv, lastLoc, ...})) = 281 let 282 val loadVal = 283 codeVal (var, level, typeVarMap, [], lex, LEX.nullLocation) 284 val newEnv = 285 (* Create a new entry in the environment. *) 286 mkDatatype [ loadVal (* Value. *), dynEnv level ] 287 val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) 288 val ctEntry = 289 case var of 290 Value{class=Exception, name, typeOf, locations, ...} => 291 EnvException(name, typeOf, locations) 292 | Value{class=Constructor{nullary, ofConstrs, ...}, name, typeOf, locations, ...} => 293 EnvVConstr(name, typeOf, nullary, ofConstrs, locations) 294 | Value{name, typeOf, locations, ...} => 295 EnvValue(name, typeOf, locations) 296 in 297 (decs @ dec, {staticEnv = ctEntry :: staticEnv, dynEnv = load, lastLoc = lastLoc}) 298 end 299 in 300 updateState (level, mkAddr) (List.foldl loadVar ([], debugEnv) vars) 301 end 302 else ([], debugEnv) 303 304 fun makeTypeConstrDebugEntries(typeCons, debugEnv, level, lex, mkAddr) = 305 if not (getParameter debugTag (LEX.debugParams lex)) 306 then ([], debugEnv) 307 else 308 let 309 fun foldIds(tc :: tcs, {staticEnv, dynEnv, lastLoc, ...}) = 310 let 311 val cons = tsConstr tc 312 val id = tcIdentifier cons 313 val {second = typeName, ...} = UTILITIES.splitString(tcName cons) 314 in 315 if tcIsAbbreviation (tsConstr tc) 316 then foldIds(tcs, {staticEnv=EnvTConstr(typeName, tc) :: staticEnv, dynEnv=dynEnv, lastLoc = lastLoc}) 317 else 318 let 319 (* This code will build a cons cell containing the run-time value 320 associated with the type Id as the hd and the rest of the run-time 321 environment as the tl. *) 322 val loadTypeId = TYPEIDCODE.codeId(id, level) 323 val newEnv = mkDatatype [ loadTypeId, dynEnv level ] 324 val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) 325 (* Make an entry for the type constructor itself as well as the new type id. 326 The type Id is used both for the type constructor and also for any values 327 of the type. *) 328 val (decs, newEnv) = 329 foldIds(tcs, {staticEnv=EnvTConstr(typeName, tc) :: envTypeId id :: staticEnv, dynEnv=load, lastLoc = lastLoc}) 330 in 331 (dec @ decs, newEnv) 332 end 333 end 334 | foldIds([], debugEnv) = ([], debugEnv) 335 in 336 updateState (level, mkAddr) (foldIds(typeCons, debugEnv)) 337 end 338 339 fun makeStructDebugEntries (strs: structVals list, debugEnv, level, lex, mkAddr) = 340 if getParameter debugTag (LEX.debugParams lex) 341 then 342 let 343 fun loadStruct (str as Struct { name, signat, locations, ...}, (decs, {staticEnv, dynEnv, lastLoc, ...})) = 344 let 345 val loadStruct = codeStruct (str, level) 346 val newEnv = mkDatatype [ loadStruct (* Structure. *), dynEnv level ] 347 val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) 348 val ctEntry = EnvStructure(name, signat, locations) 349 in 350 (decs @ dec, {staticEnv=ctEntry :: staticEnv, dynEnv=load, lastLoc = lastLoc}) 351 end 352 in 353 updateState (level, mkAddr) (List.foldl loadStruct ([], debugEnv) strs) 354 end 355 else ([], debugEnv) 356 357 (* Create debug entries for typeIDs. The idea is that if we stop in the debugger we 358 can access the type ID, particularly for printing values of the type. 359 "envTypeId" creates a free id for each bound id but the print and equality 360 functions are extracted when we are stopped in the debugger. *) 361 fun makeTypeIdDebugEntries(typeIds, debugEnv, level, lex, mkAddr) = 362 if not (getParameter debugTag (LEX.debugParams lex)) 363 then ([], debugEnv) 364 else 365 let 366 fun foldIds(id :: ids, {staticEnv, dynEnv, lastLoc, ...}) = 367 let 368 (* This code will build a cons cell containing the run-time value 369 associated with the type Id as the hd and the rest of the run-time 370 environment as the tl. *) 371 val loadTypeId = 372 case id of TypeId { access = Formal addr, ... } => 373 (* If we are processing functor arguments we will have a Formal here. *) 374 mkInd(addr, mkLoadArgument 0) 375 | _ => TYPEIDCODE.codeId(id, level) 376 val newEnv = mkDatatype [ loadTypeId, dynEnv level ] 377 val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) 378 val (decs, newEnv) = 379 foldIds(ids, {staticEnv=envTypeId id :: staticEnv, dynEnv=load, lastLoc = lastLoc}) 380 in 381 (dec @ decs, newEnv) 382 end 383 | foldIds([], debugEnv) = ([], debugEnv) 384 in 385 updateState (level, mkAddr) (foldIds(typeIds, debugEnv)) 386 end 387 388 (* Update the location info in the thread data if we want debugging info. 389 If the location has not changed don't do anything. Whether it has changed 390 could depend on whether we're only counting line numbers or whether we 391 have more precise location info with the IDE. *) 392 fun updateDebugLocation(debuggerStatus as {staticEnv, dynEnv, lastLoc, ...}, location, lex) = 393 if not (getParameter debugTag (LEX.debugParams lex)) orelse lastLoc = location 394 then ([], debuggerStatus) 395 else 396 let 397 open ADDRESS 398 val setLocation = 399 mkStoreOperation(LoadStoreMLWord{isImmutable=false}, 400 getCurrentThreadId, threadIdCurrentLocation, mkConst(toMachineWord location)) 401 in 402 ([mkNullDec setLocation], {staticEnv=staticEnv, dynEnv=dynEnv, lastLoc=location}) 403 end 404 405 (* Add debugging calls on entry and exit to a function. *) 406 fun wrapFunctionInDebug(codeBody: debuggerStatus -> codetree, name: string, argCode, argType, resType: types, location, 407 entryEnv: debuggerStatus, level, lex, mkAddr) = 408 if not (getParameter debugTag (LEX.debugParams lex)) 409 then codeBody entryEnv (* Code-generate the body without any wrapping. *) 410 else 411 let 412 open ADDRESS 413 414 val functionName = name (* TODO: munge this to get the root. *) 415 416 fun addStartExitEntry({staticEnv, dynEnv, lastLoc, ...}, code, ty, startExit) = 417 let 418 val newEnv = mkDatatype [ code, dynEnv level ] 419 val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) 420 val ctEntry = startExit(functionName, location, ty) 421 in 422 (dec, {staticEnv=ctEntry :: staticEnv, dynEnv=load, lastLoc = lastLoc}) 423 end 424 425 (* All the "on" functions take this as an argument. *) 426 val onArgs = [mkConst(toMachineWord(functionName, location))] 427 428 val threadId = multipleUses(getCurrentThreadId, fn () => mkAddr 1, level) 429 fun loadIdEntry offset = 430 multipleUses(mkLoadOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, offset), fn () => mkAddr 1, level) 431 val currStatic = loadIdEntry threadIdCurrentStatic 432 and currDynamic = loadIdEntry threadIdCurrentDynamic 433 and currLocation = loadIdEntry threadIdCurrentLocation 434 and currStack = loadIdEntry threadIdStack 435 436 (* At the start of the function: 437 1. Push the previous state to the stack. 438 2. Create a debugging entry for the arguments 439 3. Update the state to the state on entry, including the args 440 4. Call the global onEntry function if it's set 441 5. Call the local onEntry function if it's set *) 442 (* Save the previous state. *) 443 val assignStack = 444 mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, threadIdStack, 445 mkDatatype[ 446 #load currStatic level, #load currDynamic level, 447 #load currLocation level, #load currStack level]) 448 449 val prefixCode = 450 #dec threadId @ #dec currStatic @ #dec currDynamic @ #dec currLocation @ #dec currStack @ [mkNullDec assignStack] 451 452 (* Make a debugging entry for the arguments. This needs to be set 453 before we call onEntry so we can produce tracing info. It also needs 454 to be passed to the body of the function so that it is included in the 455 debug status of the rest of the body. *) 456 local 457 val {staticEnv, dynEnv, lastLoc, ...} = entryEnv 458 val newEnv = mkDatatype [ argCode, dynEnv level ] 459 val { dec, load } = multipleUses (newEnv, fn () => mkAddr 1, level) 460 val ctEntry = EnvStartFunction(functionName, location, argType) 461 in 462 val debuggerDecs = dec 463 val bodyDebugEnv = {staticEnv = ctEntry :: staticEnv, dynEnv = load, lastLoc = lastLoc} 464 end 465 466 local 467 val {staticEnv, dynEnv, ...} = bodyDebugEnv 468 val assignStatic = 469 mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, threadIdCurrentStatic, 470 mkConst(toMachineWord staticEnv)) 471 val assignDynamic = 472 mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, threadIdCurrentDynamic, 473 dynEnv level) 474 val assignLocation = 475 mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, threadIdCurrentLocation, 476 mkConst(toMachineWord location)) 477 val onEntryFn = multipleUses(onEntryCode, fn () => mkAddr 1, level) 478 val optCallOnEntry = 479 mkIf(mkTagTest(#load onEntryFn level, 0w0, 0w0), CodeZero, mkEval(#load onEntryFn level, onArgs)) 480 in 481 val entryCode = debuggerDecs @ 482 [mkNullDec assignStatic, mkNullDec assignDynamic, mkNullDec assignLocation] @ 483 #dec onEntryFn @ [mkNullDec optCallOnEntry] 484 end 485 486 (* Restore the state. Used both if the function returns normally or if 487 it raises an exception. We use the old state rather than popping the stack 488 because that is more reliable if we have an asynchronous exception. *) 489 local 490 (* Set the entry in the thread vector to an entry from the top-of-stack. *) 491 fun restoreEntry(offset, value) = 492 mkNullDec( 493 mkStoreOperation(LoadStoreMLWord{isImmutable=false}, #load threadId level, offset, value)) 494 in 495 val restoreState = 496 [restoreEntry(threadIdCurrentStatic, #load currStatic level), 497 restoreEntry(threadIdCurrentDynamic, #load currDynamic level), 498 restoreEntry(threadIdCurrentLocation, #load currLocation level), 499 restoreEntry(threadIdStack, #load currStack level)] 500 end 501 502 local 503 (* If an exception is raised we need to call the onExitException entry, restore the state 504 and reraise the exception. *) 505 (* There are potential race conditions here if we have asynchronous exceptions. *) 506 val exPacketAddr = mkAddr 1 507 val onExitExcFn = multipleUses(onExitExcCode, fn () => mkAddr 1, level) 508 (* OnExitException has an extra curried argument - the exception packet. *) 509 val optCallOnExitExc = 510 mkIf(mkTagTest(#load onExitExcFn level, 0w0, 0w0), CodeZero, 511 mkEval(mkEval(#load onExitExcFn level, onArgs), [mkLoadLocal exPacketAddr])) 512 in 513 val exPacketAddr = exPacketAddr 514 val exceptionCase = 515 mkEnv(#dec onExitExcFn @ [mkNullDec optCallOnExitExc] @ restoreState, 516 mkRaise(mkLoadLocal exPacketAddr)) 517 end 518 519 (* Code for the body and the exception. *) 520 val bodyCode = 521 multipleUses(mkHandle(codeBody bodyDebugEnv, exceptionCase, exPacketAddr), fn () => mkAddr 1, level) 522 523 (* Code for normal exit. *) 524 local 525 val endFn = addStartExitEntry(entryEnv, #load bodyCode level, resType, EnvEndFunction) 526 val (rtEnvDec, _) = updateState (level, mkAddr) endFn 527 528 val onExitFn = multipleUses(onExitCode, fn () => mkAddr 1, level) 529 val optCallOnExit = 530 mkIf(mkTagTest(#load onExitFn level, 0w0, 0w0), CodeZero, mkEval(#load onExitFn level, onArgs)) 531 in 532 val exitCode = rtEnvDec @ #dec onExitFn @ [mkNullDec optCallOnExit] 533 end 534 in 535 mkEnv(prefixCode @ entryCode @ #dec bodyCode @ exitCode @ restoreState, #load bodyCode level) 536 end 537 538 type breakPoint = bool ref 539 540 (* Create a local break point and check the global and local break points. *) 541 fun breakPointCode(breakPoint, location, level, lex, mkAddr) = 542 if not (getParameter debugTag (LEX.debugParams lex)) then [] 543 else 544 let 545 open ADDRESS 546 (* Create a new local breakpoint and assign it to the ref. 547 It is possible for the ref to be already assigned a local breakpoint 548 value if we are compiling a match. In that case the same expression 549 may be code-generated more than once but we only want one local 550 break-point. *) 551 val localBreakPoint = 552 case breakPoint of 553 ref (SOME bpt) => bpt 554 | r as ref NONE => 555 let val b = ref false in r := SOME b; b end; 556 (* Call the breakpoint function if it's defined. *) 557 val globalBpt = multipleUses(onBreakPointCode, fn () => mkAddr 1, level) 558 val testCode = 559 mkIf( 560 mkNot(mkTagTest(#load globalBpt level, 0w0, 0w0)), 561 mkEval(#load globalBpt level, 562 [mkTuple[mkConst(toMachineWord location), mkConst(toMachineWord localBreakPoint)]]), 563 CodeZero 564 ) 565 in 566 #dec globalBpt @ [mkNullDec testCode] 567 end 568 569 structure Sharing = 570 struct 571 type types = types 572 type values = values 573 type machineWord = machineWord 574 type fixStatus = fixStatus 575 type structVals = structVals 576 type typeConstrSet = typeConstrSet 577 type signatures = signatures 578 type functors = functors 579 type locationProp = locationProp 580 type environEntry = environEntry 581 type typeId = typeId 582 type level = level 583 type lexan = lexan 584 type codeBinding = codeBinding 585 type codetree = codetree 586 type typeVarMap = typeVarMap 587 type debuggerStatus = debuggerStatus 588 end 589end; 590