1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
|
#define SAVEt_ITEM 0
#define SAVEt_SV 1
#define SAVEt_AV 2
#define SAVEt_HV 3
#define SAVEt_INT 4
#define SAVEt_LONG 5
#define SAVEt_I32 6
#define SAVEt_IV 7
#define SAVEt_SPTR 8
#define SAVEt_APTR 9
#define SAVEt_HPTR 10
#define SAVEt_PPTR 11
#define SAVEt_NSTAB 12
#define SAVEt_SVREF 13
#define SAVEt_GP 14
#define SAVEt_FREESV 15
#define SAVEt_FREEOP 16
#define SAVEt_FREEPV 17
#define SAVEt_CLEARSV 18
#define SAVEt_DELETE 19
#define SAVEt_DESTRUCTOR 20
#define SAVEt_REGCONTEXT 21
#define SAVEt_STACK_POS 22
#define SAVEt_I16 23
#define SAVEt_AELEM 24
#define SAVEt_HELEM 25
#define SAVEt_OP 26
#define SAVEt_HINTS 27
#define SAVEt_ALLOC 28
#define SAVEt_GENERIC_SVREF 29
#define SSCHECK(need) if (PL_savestack_ix + need > PL_savestack_max) savestack_grow()
#define SSPUSHINT(i) (PL_savestack[PL_savestack_ix++].any_i32 = (I32)(i))
#define SSPUSHLONG(i) (PL_savestack[PL_savestack_ix++].any_long = (long)(i))
#define SSPUSHIV(i) (PL_savestack[PL_savestack_ix++].any_iv = (IV)(i))
#define SSPUSHPTR(p) (PL_savestack[PL_savestack_ix++].any_ptr = (void*)(p))
#define SSPUSHDPTR(p) (PL_savestack[PL_savestack_ix++].any_dptr = (p))
#define SSPOPINT (PL_savestack[--PL_savestack_ix].any_i32)
#define SSPOPLONG (PL_savestack[--PL_savestack_ix].any_long)
#define SSPOPIV (PL_savestack[--PL_savestack_ix].any_iv)
#define SSPOPPTR (PL_savestack[--PL_savestack_ix].any_ptr)
#define SSPOPDPTR (PL_savestack[--PL_savestack_ix].any_dptr)
#define SAVETMPS save_int((int*)&PL_tmps_floor), PL_tmps_floor = PL_tmps_ix
#define FREETMPS if (PL_tmps_ix > PL_tmps_floor) free_tmps()
#ifdef DEBUGGING
#define ENTER \
STMT_START { \
push_scope(); \
DEBUG_l(WITH_THR(Perl_deb(aTHX_ "ENTER scope %ld at %s:%d\n", \
PL_scopestack_ix, __FILE__, __LINE__))); \
} STMT_END
#define LEAVE \
STMT_START { \
DEBUG_l(WITH_THR(Perl_deb(aTHX_ "LEAVE scope %ld at %s:%d\n", \
PL_scopestack_ix, __FILE__, __LINE__))); \
pop_scope(); \
} STMT_END
#else
#define ENTER push_scope()
#define LEAVE pop_scope()
#endif
#define LEAVE_SCOPE(old) if (PL_savestack_ix > old) leave_scope(old)
/*
* Not using SOFT_CAST on SAVESPTR, SAVEGENERICSV and SAVEFREESV
* because these are used for several kinds of pointer values
*/
#define SAVEI16(i) save_I16(SOFT_CAST(I16*)&(i))
#define SAVEI32(i) save_I32(SOFT_CAST(I32*)&(i))
#define SAVEINT(i) save_int(SOFT_CAST(int*)&(i))
#define SAVEIV(i) save_iv(SOFT_CAST(IV*)&(i))
#define SAVELONG(l) save_long(SOFT_CAST(long*)&(l))
#define SAVESPTR(s) save_sptr((SV**)&(s))
#define SAVEPPTR(s) save_pptr(SOFT_CAST(char**)&(s))
#define SAVEFREESV(s) save_freesv((SV*)(s))
#define SAVEFREEOP(o) save_freeop(SOFT_CAST(OP*)(o))
#define SAVEFREEPV(p) save_freepv(SOFT_CAST(char*)(p))
#define SAVECLEARSV(sv) save_clearsv(SOFT_CAST(SV**)&(sv))
#define SAVEGENERICSV(s) save_generic_svref((SV**)&(s))
#define SAVEDELETE(h,k,l) \
save_delete(SOFT_CAST(HV*)(h), SOFT_CAST(char*)(k), (I32)(l))
#define CALLDESTRUCTOR (*SSPOPDPTR)
#define SAVEDESTRUCTOR(f,p) \
save_destructor((DESTRUCTORFUNC_t)(f), SOFT_CAST(void*)(p))
#define SAVESTACK_POS() \
STMT_START { \
SSCHECK(2); \
SSPUSHINT(PL_stack_sp - PL_stack_base); \
SSPUSHINT(SAVEt_STACK_POS); \
} STMT_END
#define SAVEOP() save_op()
#define SAVEHINTS() \
STMT_START { \
if (PL_hints & HINT_LOCALIZE_HH) \
save_hints(); \
else { \
SSCHECK(2); \
SSPUSHINT(PL_hints); \
SSPUSHINT(SAVEt_HINTS); \
} \
} STMT_END
/* SSNEW() temporarily allocates a specified number of bytes of data on the
* savestack. It returns an integer index into the savestack, because a
* pointer would get broken if the savestack is moved on reallocation.
* SSNEWa() works like SSNEW(), but also aligns the data to the specified
* number of bytes. MEM_ALIGNBYTES is perhaps the most useful. The
* alignment will be preserved therough savestack reallocation *only* if
* realloc returns data aligned to a size divisible by `align'!
*
* SSPTR() converts the index returned by SSNEW/SSNEWa() into a pointer.
*/
#define SSNEW(size) save_alloc(size, 0)
#define SSNEWa(size,align) save_alloc(size, \
(align - ((int)((caddr_t)&PL_savestack[PL_savestack_ix]) % align)) % align)
#define SSPTR(off,type) ((type) ((char*)PL_savestack + off))
/* A jmpenv packages the state required to perform a proper non-local jump.
* Note that there is a start_env initialized when perl starts, and top_env
* points to this initially, so top_env should always be non-null.
*
* Existence of a non-null top_env->je_prev implies it is valid to call
* longjmp() at that runlevel (we make sure start_env.je_prev is always
* null to ensure this).
*
* je_mustcatch, when set at any runlevel to TRUE, means eval ops must
* establish a local jmpenv to handle exception traps. Care must be taken
* to restore the previous value of je_mustcatch before exiting the
* stack frame iff JMPENV_PUSH was not called in that stack frame.
* GSAR 97-03-27
*/
struct jmpenv {
struct jmpenv * je_prev;
Sigjmp_buf je_buf; /* only for use if !je_throw */
int je_ret; /* last exception thrown */
bool je_mustcatch; /* need to call longjmp()? */
void (*je_throw)(int v); /* last for bincompat */
};
typedef struct jmpenv JMPENV;
/*
* Function that catches/throws, and its callback for the
* body of protected processing.
*/
typedef void *(CPERLscope(*protect_body_t)) (pTHX_ va_list);
typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ int *, protect_body_t, ...);
/*
* How to build the first jmpenv.
*
* top_env needs to be non-zero. It points to an area
* in which longjmp() stuff is stored, as C callstack
* info there at least is thread specific this has to
* be per-thread. Otherwise a 'die' in a thread gives
* that thread the C stack of last thread to do an eval {}!
*/
#define JMPENV_BOOTSTRAP \
STMT_START { \
PL_start_env.je_prev = NULL; \
PL_start_env.je_throw = NULL; \
PL_start_env.je_ret = -1; \
PL_start_env.je_mustcatch = TRUE; \
PL_top_env = &PL_start_env; \
} STMT_END
#ifdef OP_IN_REGISTER
#define OP_REG_TO_MEM PL_opsave = op
#define OP_MEM_TO_REG op = PL_opsave
#else
#define OP_REG_TO_MEM NOOP
#define OP_MEM_TO_REG NOOP
#endif
/*
* These exception-handling macros are split up to
* ease integration with C++ exceptions.
*
* To use C++ try+catch to catch Perl exceptions, an extension author
* needs to first write an extern "C" function to throw an appropriate
* exception object; typically it will be or contain an integer,
* because Perl's internals use integers to track exception types:
* extern "C" { static void thrower(int i) { throw i; } }
*
* Then (as shown below) the author needs to use, not the simple
* JMPENV_PUSH, but several of its constitutent macros, to arrange for
* the Perl internals to call thrower() rather than longjmp() to
* report exceptions:
*
* dJMPENV;
* JMPENV_PUSH_INIT(thrower);
* try {
* ... stuff that may throw exceptions ...
* }
* catch (int why) { // or whatever matches thrower()
* JMPENV_POST_CATCH;
* EXCEPT_SET(why);
* switch (why) {
* ... // handle various Perl exception codes
* }
* }
* JMPENV_POP; // don't forget this!
*/
#define dJMPENV JMPENV cur_env
#define JMPENV_PUSH_INIT_ENV(cur_env,THROWFUNC) \
STMT_START { \
cur_env.je_throw = (THROWFUNC); \
cur_env.je_ret = -1; \
cur_env.je_mustcatch = FALSE; \
cur_env.je_prev = PL_top_env; \
PL_top_env = &cur_env; \
OP_REG_TO_MEM; \
} STMT_END
#define JMPENV_PUSH_INIT(THROWFUNC) JMPENV_PUSH_INIT_ENV(cur_env,THROWFUNC)
#define JMPENV_POST_CATCH_ENV(cur_env) \
STMT_START { \
OP_MEM_TO_REG; \
PL_top_env = &cur_env; \
} STMT_END
#define JMPENV_POST_CATCH JMPENV_POST_CATCH_ENV(cur_env)
#define JMPENV_PUSH_ENV(cur_env,v) \
STMT_START { \
JMPENV_PUSH_INIT_ENV(cur_env,NULL); \
EXCEPT_SET_ENV(cur_env,PerlProc_setjmp(cur_env.je_buf, 1)); \
JMPENV_POST_CATCH_ENV(cur_env); \
(v) = EXCEPT_GET_ENV(cur_env); \
} STMT_END
#define JMPENV_PUSH(v) JMPENV_PUSH_ENV(cur_env,v)
#define JMPENV_POP_ENV(cur_env) \
STMT_START { PL_top_env = cur_env.je_prev; } STMT_END
#define JMPENV_POP JMPENV_POP_ENV(cur_env)
#define JMPENV_JUMP(v) \
STMT_START { \
OP_REG_TO_MEM; \
if (PL_top_env->je_prev) { \
if (PL_top_env->je_throw) \
PL_top_env->je_throw(v); \
else \
PerlProc_longjmp(PL_top_env->je_buf, (v)); \
} \
if ((v) == 2) \
PerlProc_exit(STATUS_NATIVE_EXPORT); \
PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); \
PerlProc_exit(1); \
} STMT_END
#define EXCEPT_GET_ENV(cur_env) (cur_env.je_ret)
#define EXCEPT_GET EXCEPT_GET_ENV(cur_env)
#define EXCEPT_SET_ENV(cur_env,v) (cur_env.je_ret = (v))
#define EXCEPT_SET(v) EXCEPT_SET_ENV(cur_env,v)
#define CATCH_GET (PL_top_env->je_mustcatch)
#define CATCH_SET(v) (PL_top_env->je_mustcatch = (v))
|
