develooper Front page | perl.perl5.porters | Postings from August 2001

Re: [PATCH] Adding callbacks to the core

Thread Previous
From:
David M. Lloyd
Date:
August 21, 2001 11:33
Subject:
Re: [PATCH] Adding callbacks to the core
Message ID:
Pine.LNX.4.33.0108211332310.1027-100000@homebody.freemm.org

* Correction, this patch is against 11722.  Sorry :-)


On Tue, 21 Aug 2001, David M. Lloyd wrote:

> Here's the patches necessary to add C callbacks to the core.  Per your
> suggestions, I have rolled the callback check into the signal check code.
>
> All tests pass on RH Linux 7.1 and Solaris 2.8.
>
> Patches are against 11709.
>
> Please send me your comments/abuse.
>
> - D
>
> <dmlloyd@tds.net>
>
> ---------- Forwarded message ----------
> Date: Tue, 21 Aug 2001 10:42:40 -0500
> From: Dave Lloyd <usrodl@tomservo.workpc.tds.net>
>
> --- perl-current/perl.c	Fri Aug 17 00:24:14 2001
> +++ perl-devel/perl.c	Mon Aug 20 17:56:58 2001
> @@ -230,6 +230,8 @@
>  	(void)PerlIO_close(PerlIO_importFILE(stdprn, 0));
>  #endif
>      }
> +
> +    MUTEX_INIT(&PL_callback_mutex);
>
>      PL_nrs = newSVpvn("\n", 1);
>      PL_rs = SvREFCNT_inc(PL_nrs);
> @@ -830,6 +832,8 @@
>      Safefree(PL_reentrant_buffer->tmbuff);
>      Safefree(PL_reentrant_buffer);
>  #endif
> +
> +    MUTEX_DESTROY(&PL_callback_mutex);
>
>      sv_free_arenas();
>
> --- perl-current/embed.pl	Fri Aug 17 00:24:14 2001
> +++ perl-devel/embed.pl	Mon Aug 20 18:17:37 2001
> @@ -2623,6 +2623,10 @@
>  Apd	|char*	|sv_pvn_force_flags|SV* sv|STRLEN* lp|I32 flags
>  Apd	|char*	|sv_2pv_flags	|SV* sv|STRLEN* lp|I32 flags
>  Ap	|char*	|my_atof2	|const char *s|NV* value
> +Apd	|CALLBACK * |register_callback	|void (*callback)(void *data)
> +Apd	|void	    |enable_callback    |CALLBACK *cbptr|void *data
> +Apd	|void	    |disable_callback   |CALLBACK *cbptr
> +Apd	|void	    |free_callback  	|CALLBACK *cbptr
>
>  END_EXTERN_C
>
> --- perl-current/mg.c	Sat Aug 18 10:30:25 2001
> +++ perl-devel/mg.c	Tue Aug 21 08:53:46 2001
> @@ -1047,6 +1047,8 @@
>      PL_psig_pend[sig]++;
>      /* And one to say _a_ signal is pending */
>      PL_sig_pending = 1;
> +    /* And finally a flag to say that an event is pending */
> +    PL_event_pending = 1;
>  }
>
>  Signal_t
> @@ -1061,17 +1063,126 @@
>  #endif
>  }
>
> +/* Maybe despatch_signals isn't a good name anymore */
> +
>  void
>  Perl_despatch_signals(pTHX)
>  {
> -    int sig;
> -    PL_sig_pending = 0;
> -    for (sig = 1; sig < SIG_SIZE; sig++) {
> -	if (PL_psig_pend[sig]) {
> -	    PL_psig_pend[sig] = 0;
> -	    (*PL_sighandlerp)(sig);
> +    PL_event_pending = 0;
> +    if (PL_sig_pending) {
> +	int sig;
> +	PL_sig_pending = 0;
> +	for (sig = 1; sig < SIG_SIZE; sig++) {
> +	    if (PL_psig_pend[sig]) {
> +		PL_psig_pend[sig] = 0;
> +		(*PL_sighandlerp)(sig);
> +	    }
> +	}
> +    }
> +    if (PL_callback_head != NULL) {
> +	CALLBACK *cur, *next;
> +
> +        for (cur = PL_callback_head; cur != NULL; cur = next) {
> +            next = cur->next;
> +            (*cur->callback)(cur->data);
> +        }
> +    }
> +}
> +
> +/*
> +=for apidoc register_callback
> +
> +Register a callback that can be enabled via C<enable_callback>.  This
> +can be called at any time.
> +
> +=cut
> +*/
> +CALLBACK *
> +Perl_register_callback(pTHX_ void (*callback)(void *))
> +{
> +    CALLBACK *cbptr;
> +    New(0,cbptr,1,CALLBACK);
> +    cbptr->next = NULL;
> +    cbptr->prev = NULL;
> +    cbptr->callback = callback;
> +    return cbptr;
> +}
> +
> +/*
> +=for apidoc enable_callback
> +
> +Enable a callback previously registered with C<register_callback>.  The
> +callback will be called in between every opcode from then on until
> +B<disable_callback> or B<free_callback> is called.  This can be called
> +at any time.  If the callback is already enabled, it will remain enabled
> +but the I<data> parameter will be updated.
> +
> +=cut
> +*/
> +void
> +Perl_enable_callback(pTHX_ CALLBACK *cbptr, void *data)
> +{
> +    MUTEX_LOCK(&PL_callback_mutex);
> +
> +    cbptr->data = data;
> +    if (! cbptr->enabled) {
> +	if (PL_callback_head != NULL) {
> +            PL_callback_head->prev = cbptr;
>  	}
> +	cbptr->next = PL_callback_head;
> +	cbptr->prev = NULL;
> +	PL_callback_head = cbptr;
> +	cbptr->enabled = 1;
>      }
> +
> +    MUTEX_UNLOCK(&PL_callback_mutex);
> +}
> +
> +/*
> +=for apidoc disable_callback
> +
> +Disable a previously registered callback.  If the callback is not enabled,
> +does nothing.
> +
> +=cut
> +*/
> +
> +void
> +Perl_disable_callback(pTHX_ CALLBACK *cbptr)
> +{
> +    MUTEX_LOCK(&PL_callback_mutex);
> +
> +    if (cbptr->enabled) {
> +	if (PL_callback_head == cbptr) {
> +            PL_callback_head = cbptr->next;
> +	}
> +	if (cbptr->prev != NULL) {
> +            cbptr->prev->next = cbptr->next;
> +	}
> +	if (cbptr->next != NULL) {
> +            cbptr->next->prev = cbptr->prev;
> +	}
> +	cbptr->next = cbptr->prev = NULL;
> +	cbptr->enabled = 0;
> +    }
> +
> +    MUTEX_UNLOCK(&PL_callback_mutex);
> +}
> +
> +/*
> +=for apidoc free_callback
> +
> +Free resources associated with a callback.  If the callback is enabled, it
> +will be disabled.
> +
> +=cut
> +*/
> +
> +void
> +Perl_free_callback(pTHX_ CALLBACK *cbptr)
> +{
> +    Perl_disable_callback(aTHX_ cbptr);
> +    Safefree(cbptr);
>  }
>
>  int
> --- perl-current/perl.h	Sat Aug 18 10:40:29 2001
> +++ perl-devel/perl.h	Mon Aug 20 18:10:29 2001
> @@ -1693,6 +1693,18 @@
>
>  #endif
>
> +/* Callback structure */
> +
> +struct perl_callback {
> +    struct perl_callback *next;
> +    struct perl_callback *prev;
> +    int enabled;
> +    void (*callback)(void *);
> +    void *data;
> +};
> +
> +typedef struct perl_callback CALLBACK;
> +
>  struct perl_mstats {
>      UV *nfree;
>      UV *ntotal;
> @@ -3846,7 +3858,7 @@
>  #ifndef PERL_MICRO
>  #   ifndef PERL_OLD_SIGNALS
>  #		ifndef PERL_ASYNC_CHECK
> -#			define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals()
> +#			define PERL_ASYNC_CHECK() if (PL_event_pending) despatch_signals()
>  #		endif
>  #   endif
>  #endif
> --- perl-current/intrpvar.h	Sat Aug 18 10:30:25 2001
> +++ perl-devel/intrpvar.h	Mon Aug 20 17:54:49 2001
> @@ -487,6 +487,13 @@
>
>  PERLVAR(Isavebegin,     bool)	/* save BEGINs for compiler	*/
>
> +PERLVARI(Icallback_head, CALLBACK *, NULL)  /* Pointer to first waiting callback */
> +PERLVARI(Ievent_pending, int, 0)    	    /* Flag that indicates that an event is pending */
> +
> +#if defined(USE_THREADS) || defined(USE_ITHREADS)
> +PERLVAR(Icallback_mutex, perl_mutex)	/* Mutex for adding callbacks in a threadsafe manner */
> +#endif
> +
>  /* New variables must be added to the very end for binary compatibility.
>   * XSUB.h provides wrapper functions via perlapi.h that make this
>   * irrelevant, but not all code may be expected to #include XSUB.h. */
>
>

- D

<dmlloyd@tds.net>


Thread Previous


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About