Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Fix the problem properly |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | bug-87271f7cd6 |
Files: | files | file ages | folders |
SHA3-256: |
e15875e0c3de88f02ca71c376659ccf9 |
User & Date: | dkf 2024-05-17 13:28:51 |
Context
2024-05-17
| ||
13:29 | Remove the band-aid Closed-Leaf check-in: 6f7807664e user: dkf tags: bug-87271f7cd6 | |
13:28 | Fix the problem properly check-in: e15875e0c3 user: dkf tags: bug-87271f7cd6 | |
11:11 | Starting to clean up the mess. The extra frame info can have the same lifespan as the method itself. check-in: 2b8c097bdc user: dkf tags: bug-87271f7cd6 | |
Changes
Changes to generic/tclOOInt.h.
︙ | ︙ | |||
93 94 95 96 97 98 99 100 101 102 103 104 105 106 | * before the method executes. */ TclOO_PostCallProc *postCallProc; /* Callback to allow for additional cleanup * after the method executes. */ GetFrameInfoValueProc *gfivProc; /* Callback to allow for fine tuning of how * the method reports itself. */ ExtraFrameInfo efi; /* Space used to store data for [info frame] */ Tcl_Interp *interp; /* Interpreter in which to compute the name of * the method. */ Tcl_Method method; /* Method to compute the name of. */ int callSiteFlags; /* Flags from the call chain. Only interested * in whether this is a constructor or * destructor, which we can't know until then | > | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | * before the method executes. */ TclOO_PostCallProc *postCallProc; /* Callback to allow for additional cleanup * after the method executes. */ GetFrameInfoValueProc *gfivProc; /* Callback to allow for fine tuning of how * the method reports itself. */ Command cmd; /* Space used to connect to [info frame] */ ExtraFrameInfo efi; /* Space used to store data for [info frame] */ Tcl_Interp *interp; /* Interpreter in which to compute the name of * the method. */ Tcl_Method method; /* Method to compute the name of. */ int callSiteFlags; /* Flags from the call chain. Only interested * in whether this is a constructor or * destructor, which we can't know until then |
︙ | ︙ |
Changes to generic/tclOOMethod.c.
︙ | ︙ | |||
21 22 23 24 25 26 27 | * used in a procedure-like method. */ typedef struct { CallFrame *framePtr; /* Reference to the call frame itself (it's * actually allocated on the Tcl stack). */ ProcErrorProc *errProc; /* The error handler for the body. */ | | < < | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | * used in a procedure-like method. */ typedef struct { CallFrame *framePtr; /* Reference to the call frame itself (it's * actually allocated on the Tcl stack). */ ProcErrorProc *errProc; /* The error handler for the body. */ Tcl_Obj *nameObj; /* The "name" of the command. Only used for a * few moments, so not reference. */ } PMFrameData; /* * Structure used to pass information about variable resolution to the * on-the-ground resolvers used when working with resolved compiled variables. */ |
︙ | ︙ | |||
68 69 70 71 72 73 74 | void *clientData, void **newClientData); static void MethodErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void ConstructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void DestructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); | < < | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | void *clientData, void **newClientData); static void MethodErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void ConstructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void DestructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static Tcl_Obj * RenderMethodName(void *clientData); static Tcl_Obj * RenderDeclarerName(void *clientData); static int InvokeForwardMethod(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static void DeleteForwardMethod(void *clientData); static int CloneForwardMethod(Tcl_Interp *interp, |
︙ | ︙ | |||
107 108 109 110 111 112 113 114 115 116 117 118 119 120 | * Helper macros (derived from things private to tclVar.c) */ #define TclVarTable(contextNs) \ ((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable)) #define TclVarHashGetValue(hPtr) \ ((Tcl_Var) ((char *)hPtr - TclOffset(VarInHash, entry))) /* * ---------------------------------------------------------------------- * * Tcl_NewInstanceMethod -- * * Attach a method to an object instance. | > > > > > > > > > > > > > > | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 | * Helper macros (derived from things private to tclVar.c) */ #define TclVarTable(contextNs) \ ((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable)) #define TclVarHashGetValue(hPtr) \ ((Tcl_Var) ((char *)hPtr - TclOffset(VarInHash, entry))) static inline ProcedureMethod * AllocProcedureMethodRecord( int flags) { ProcedureMethod *pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod)); memset(pmPtr, 0, sizeof(ProcedureMethod)); pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; pmPtr->flags = flags & USE_DECLARER_NS; pmPtr->refCount = 1; pmPtr->cmd.clientData = &pmPtr->efi; return pmPtr; } /* * ---------------------------------------------------------------------- * * Tcl_NewInstanceMethod -- * * Attach a method to an object instance. |
︙ | ︙ | |||
327 328 329 330 331 332 333 | int argsLen; ProcedureMethod *pmPtr; Tcl_Method method; if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } | < < < < < | | 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 | int argsLen; ProcedureMethod *pmPtr; Tcl_Method method; if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } pmPtr = AllocProcedureMethodRecord(flags); method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj, argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); if (method == NULL) { ckfree(pmPtr); } else if (pmPtrPtr != NULL) { *pmPtrPtr = pmPtr; } |
︙ | ︙ | |||
388 389 390 391 392 393 394 | procName = "<destructor>"; } else if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } else { procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj)); } | < < < < < | | 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 | procName = "<destructor>"; } else if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } else { procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj)); } pmPtr = AllocProcedureMethodRecord(flags); method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName, argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); if (argsLen == -1) { Tcl_DecrRefCount(argsObj); } if (method == NULL) { |
︙ | ︙ | |||
667 668 669 670 671 672 673 | if (TclOOObjectDestroyed(((CallContext *)context)->oPtr) || Tcl_InterpDeleted(interp) ) { return TclNRObjectContextInvokeNext(interp, context, objc, objv, Tcl_ObjectContextSkippedArgs(context)); } | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > | 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 | if (TclOOObjectDestroyed(((CallContext *)context)->oPtr) || Tcl_InterpDeleted(interp) ) { return TclNRObjectContextInvokeNext(interp, context, objc, objv, Tcl_ObjectContextSkippedArgs(context)); } /* * Finishes filling out the extra frame info so that [info frame] works if * that is not already set up. */ if (pmPtr->efi.length == 0) { Tcl_Method method = Tcl_ObjectContextMethod(context); pmPtr->efi.length = 2; pmPtr->efi.fields[0].name = "method"; pmPtr->efi.fields[0].proc = RenderMethodName; pmPtr->efi.fields[0].clientData = pmPtr; pmPtr->callSiteFlags = ((CallContext *) context)->callPtr->flags & (CONSTRUCTOR | DESTRUCTOR); pmPtr->interp = interp; pmPtr->method = method; if (pmPtr->gfivProc != NULL) { pmPtr->efi.fields[1].name = ""; pmPtr->efi.fields[1].proc = pmPtr->gfivProc; pmPtr->efi.fields[1].clientData = pmPtr; } else { if (Tcl_MethodDeclarerObject(method) != NULL) { pmPtr->efi.fields[1].name = "object"; } else { pmPtr->efi.fields[1].name = "class"; } pmPtr->efi.fields[1].proc = RenderDeclarerName; pmPtr->efi.fields[1].clientData = pmPtr; } } /* * Allocate the special frame data. */ fdPtr = (PMFrameData *)TclStackAlloc(interp, sizeof(PMFrameData)); |
︙ | ︙ | |||
698 699 700 701 702 703 704 | if (pmPtr->preCallProc != NULL) { int isFinished; result = pmPtr->preCallProc(pmPtr->clientData, interp, context, (Tcl_CallFrame *) fdPtr->framePtr, &isFinished); if (isFinished || result != TCL_OK) { | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 | if (pmPtr->preCallProc != NULL) { int isFinished; result = pmPtr->preCallProc(pmPtr->clientData, interp, context, (Tcl_CallFrame *) fdPtr->framePtr, &isFinished); if (isFinished || result != TCL_OK) { Tcl_PopCallFrame(interp); TclStackFree(interp, fdPtr->framePtr); if (pmPtr->refCount-- <= 1) { DeleteProcedureMethodRecord(pmPtr); } TclStackFree(interp, fdPtr); return result; } } /* * Now invoke the body of the method. */ TclNRAddCallback(interp, FinalizePMCall, pmPtr, context, fdPtr, NULL); return TclNRInterpProcCore(interp, fdPtr->nameObj, Tcl_ObjectContextSkippedArgs(context), fdPtr->errProc); } static int FinalizePMCall( void *data[], Tcl_Interp *interp, int result) { ProcedureMethod *pmPtr = (ProcedureMethod *)data[0]; |
︙ | ︙ | |||
787 788 789 790 791 792 793 | if (pmPtr->postCallProc) { result = pmPtr->postCallProc(pmPtr->clientData, interp, context, Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)), result); } | < < < < < < < | 767 768 769 770 771 772 773 774 775 776 777 778 779 780 | if (pmPtr->postCallProc) { result = pmPtr->postCallProc(pmPtr->clientData, interp, context, Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)), result); } /* * Scrap the special frame data now that we're done with it. Note that we * are inlining DeleteProcedureMethod() here; this location is highly * sensitive when it comes to performance! */ if (pmPtr->refCount-- <= 1) { |
︙ | ︙ | |||
858 859 860 861 862 863 864 | mPtr->declaringClassPtr->thisPtr->namespacePtr; } else { nsPtr = (Namespace *) mPtr->declaringObjectPtr->namespacePtr; } } /* | < < < < < < < < | < | < < < < < < > | | < < < < < < < < < | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 | mPtr->declaringClassPtr->thisPtr->namespacePtr; } else { nsPtr = (Namespace *) mPtr->declaringObjectPtr->namespacePtr; } } /* * Compile the body. * * [Bug 2037727] Always call TclProcCompileProc so that we check not only * that we have bytecode, but also that it remains valid. Note that we set * the namespace of the code here directly; this is a hack, but the * alternative is *so* slow... */ pmPtr->procPtr->cmdPtr = &pmPtr->cmd; if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) { ByteCode *codePtr = pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; codePtr->nsPtr = nsPtr; } result = TclProcCompileProc(interp, pmPtr->procPtr, pmPtr->procPtr->bodyPtr, nsPtr, "body of method", TclGetString(fdPtr->nameObj)); if (result != TCL_OK) { return result; } /* * Make the stack frame and fill it out with information about this call. * This operation doesn't ever actually fail. */ (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, (Tcl_Namespace *) nsPtr, FRAME_IS_PROC|FRAME_IS_METHOD); fdPtr->framePtr->clientData = contextPtr; fdPtr->framePtr->objc = objc; fdPtr->framePtr->objv = objv; fdPtr->framePtr->procPtr = pmPtr->procPtr; return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOOSetupVariableResolver, etc. -- * |
︙ | ︙ | |||
1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 | * Create the actual copy of the method record, manufacturing a new proc * record. */ pm2Ptr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; Tcl_IncrRefCount(argsObj); Tcl_IncrRefCount(bodyObj); if (TclCreateProc(interp, NULL, "", argsObj, bodyObj, &pm2Ptr->procPtr) != TCL_OK) { Tcl_DecrRefCount(argsObj); Tcl_DecrRefCount(bodyObj); ckfree(pm2Ptr); | > > | 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 | * Create the actual copy of the method record, manufacturing a new proc * record. */ pm2Ptr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; pm2Ptr->cmd.clientData = &pm2Ptr->efi; pm2Ptr->efi.length = 0; /* Trigger a reinit of this. */ Tcl_IncrRefCount(argsObj); Tcl_IncrRefCount(bodyObj); if (TclCreateProc(interp, NULL, "", argsObj, bodyObj, &pm2Ptr->procPtr) != TCL_OK) { Tcl_DecrRefCount(argsObj); Tcl_DecrRefCount(bodyObj); ckfree(pm2Ptr); |
︙ | ︙ |
Changes to tests/oo.test.
︙ | ︙ | |||
3292 3293 3294 3295 3296 3297 3298 | lsort {q w e r t y u i o p}; # Overwrite the Tcl stack info frame 0 } [c new] test } -match glob -cleanup { c destroy } -result {* cmd {info frame 0} method test class ::c level 0} | | | | > | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | < | < < < > > | 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 | lsort {q w e r t y u i o p}; # Overwrite the Tcl stack info frame 0 } [c new] test } -match glob -cleanup { c destroy } -result {* cmd {info frame 0} method test class ::c level 0} # Common code for oo-22.{3,4,5,6} oo::class create WorkerBase oo::class create WorkerSupport { superclass oo::class WorkerBase variable result stop method WithWorkers {nworkers args script} { set workers {} try { for {set n 1} {$n <= $nworkers} {incr n} { lappend workers [set worker [[self] new]] $worker schedule {*}$args } return [uplevel 1 $script] } finally { foreach worker $workers {$worker destroy} } } method run {nworkers} { set result {} set stopvar [my varname stop] set stop false my WithWorkers $nworkers [list my Work [my varname result]] { after idle [namespace code {set stop true}] vwait $stopvar } return $result } } oo::class create Worker { superclass WorkerBase method schedule {args} { set coro [namespace current]::coro if {![llength [info commands $coro]]} { coroutine $coro {*}$args } } method Work args {error unimplemented} method dump {} { info frame [expr {[info frame] - 1}] } } test oo-22.3 {OO and coroutines and info frame: Bug 87271f7cd6} -body { # Triggers a crash with incorrectly restored pmPtr->procPtr->cmdPtr WorkerSupport create A { superclass Worker method Work {var} { after 0 [info coroutine] yield lappend $var [my dump] } } A run 2 } -cleanup { catch {rename dump {}} catch {A destroy} } -match glob -result {{* method Work class ::A *} {* method Work class ::A *}} test oo-22.4 {OO and coroutines and info frame: Bug 87271f7cd6} -body { # Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr WorkerSupport create A { superclass Worker method Work {var} { after 0 [info coroutine] yield lappend $var [my dump] } } # Copies the methods, changing the declarer # Test it works with the source class still around oo::copy A B B run 2 } -cleanup { catch {rename dump {}} catch {A destroy} catch {B destroy} } -match glob -result {{* method Work class ::B *} {* method Work class ::B *}} test oo-22.5 {OO and coroutines and info frame: Bug 87271f7cd6} -body { # Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr WorkerSupport create A { superclass Worker method Work {var} { after 0 [info coroutine] yield lappend $var [my dump] } } # Copies the methods, changing the declarer # Test it works with the source class deleted oo::copy A B catch {A destroy} B run 2 } -cleanup { catch {rename dump {}} catch {B destroy} } -match glob -result {{* method Work class ::B *} {* method Work class ::B *}} test oo-22.6 {OO and coroutines and info frame: Bug 87271f7cd6} -body { # Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr WorkerSupport create A { superclass Worker method Work {var} { after 0 [info coroutine] yield lappend $var [my dump] } } # Copies the methods, changing the declarer # Test it works in the original source class with the copy around oo::copy A B B run 2 A run 2 } -cleanup { catch {rename dump {}} catch {A destroy} catch {B destroy} } -match glob -result {{* method Work class ::A *} {* method Work class ::A *}} WorkerBase destroy # Prove that the issue in [Bug 1865054] isn't an issue any more test oo-23.1 {Self-like derivation; complex case!} -setup { oo::class create SELF { superclass oo::class unexport create new # Next is just a convenience |
︙ | ︙ |