My favorites | Sign in
Project Home Wiki Issues Source
Repository:
Checkout   Browse   Changes   Clones  
Changes to /lib/B/Stackobj.pm
edda0c5ca8cd vs. 0076fb5bf0fb Compare: vs.  Format:
Revision 0076fb5bf0fb
Go to: 
Project members, sign in to write a code review
/lib/B/Stackobj.pm   edda0c5ca8cd /lib/B/Stackobj.pm   0076fb5bf0fb
1 # Stackobj.pm 1 # Stackobj.pm
2 # 2 #
3 # Copyright (c) 1996 Malcolm Beattie 3 # Copyright (c) 1996 Malcolm Beattie
4 # Copyright (c) 2010 Reini Urban 4 # Copyright (c) 2010 Reini Urban
5 # Copyright (c) 2012 cPanel Inc 5 # Copyright (c) 2012 cPanel Inc
6 # 6 #
7 # You may distribute under the terms of either the GNU General Public 7 # You may distribute under the terms of either the GNU General Public
8 # License or the Artistic License, as specified in the README file. 8 # License or the Artistic License, as specified in the README file.
9 # 9 #
10 package B::Stackobj; 10 package B::Stackobj;
11 11
12 our $VERSION = '1.10'; 12 our $VERSION = '1.10';
13 13
14 use Exporter (); 14 use Exporter ();
15 @ISA = qw(Exporter); 15 @ISA = qw(Exporter);
16 @EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED 16 @EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED
17 VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY); 17 VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
18 %EXPORT_TAGS = ( 18 %EXPORT_TAGS = (
19 types => [qw(T_UNKNOWN T_DOUBLE T_INT)], 19 types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
20 flags => [ 20 flags => [
21 qw(VALID_INT VALID_DOUBLE VALID_SV 21 qw(VALID_INT VALID_DOUBLE VALID_SV
22 VALID_UNSIGNED REGISTER TEMPORARY) 22 VALID_UNSIGNED REGISTER TEMPORARY)
23 ] 23 ]
24 ); 24 );
25 25
26 use Carp qw(confess); 26 use Carp qw(confess);
27 use strict; 27 use strict;
28 use B qw(class SVf_IOK SVf_NOK SVf_IVisUV SVf_ROK); 28 use B qw(class SVf_IOK SVf_NOK SVf_IVisUV SVf_ROK);
29 use B::C qw(ivx nvx); 29 use B::C qw(ivx nvx);
30 use Config; 30 use Config;
31 31
32 # Types 32 # Types
33 sub T_UNKNOWN () { 0 } 33 sub T_UNKNOWN () { 0 }
34 sub T_DOUBLE () { 1 } 34 sub T_DOUBLE () { 1 }
35 sub T_INT () { 2 } 35 sub T_INT () { 2 }
36 sub T_SPECIAL () { 3 } 36 sub T_SPECIAL () { 3 }
37 37
38 # Flags 38 # Flags
39 sub VALID_INT () { 0x01 } 39 sub VALID_INT () { 0x01 }
40 sub VALID_UNSIGNED () { 0x02 } 40 sub VALID_UNSIGNED () { 0x02 }
41 sub VALID_DOUBLE () { 0x04 } 41 sub VALID_DOUBLE () { 0x04 }
42 sub VALID_SV () { 0x08 } 42 sub VALID_SV () { 0x08 }
43 sub REGISTER () { 0x10 } # no implicit write-back when calling subs 43 sub REGISTER () { 0x10 } # no implicit write-back when calling subs
44 sub TEMPORARY () { 0x20 } # no implicit write-back needed at all 44 sub TEMPORARY () { 0x20 } # no implicit write-back needed at all
45 sub SAVE_INT () { 0x40 } # if int part needs to be saved at all 45 sub SAVE_INT () { 0x40 } # if int part needs to be saved at all
46 sub SAVE_DOUBLE () { 0x80 } # if double part needs to be saved at all 46 sub SAVE_DOUBLE () { 0x80 } # if double part needs to be saved at all
47 47
48 # 48 #
49 # Callback for runtime code generation 49 # Callback for runtime code generation
50 # 50 #
51 my $runtime_callback = sub { confess "set_callback not yet called" }; 51 my $runtime_callback = sub { confess "set_callback not yet called" };
52 sub set_callback (&) { $runtime_callback = shift } 52 sub set_callback (&) { $runtime_callback = shift }
53 sub runtime { &$runtime_callback(@_) } 53 sub runtime { &$runtime_callback(@_) }
54 54
55 # 55 #
56 # Methods 56 # Methods
57 # 57 #
58 58
59 # The stack holds generally only the string ($sv->save) representation of the B object,
60 # for the types sv, int, double, numeric and sometimes bool.
61 # Special subclasses keep the B obj, like Const
62
59 sub write_back { confess "stack object does not implement write_back" } 63 sub write_back { confess "stack object does not implement write_back" }
60 64
61 sub invalidate { 65 sub invalidate {
62 shift->{flags} &= ~( VALID_INT | VALID_UNSIGNED | VALID_DOUBLE ); 66 shift->{flags} &= ~( VALID_INT | VALID_UNSIGNED | VALID_DOUBLE );
63 } 67 }
64 68
65 sub invalidate_int { 69 sub invalidate_int {
66 shift->{flags} &= ~( VALID_INT | VALID_UNSIGNED ); 70 shift->{flags} &= ~( VALID_INT | VALID_UNSIGNED );
67 } 71 }
68 72
69 sub invalidate_double { 73 sub invalidate_double {
70 shift->{flags} &= ~( VALID_DOUBLE ); 74 shift->{flags} &= ~( VALID_DOUBLE );
71 } 75 }
72 76
73 sub as_sv { 77 sub as_sv {
74 my $obj = shift; 78 my $obj = shift;
75 if ( !( $obj->{flags} & VALID_SV ) ) { 79 if ( !( $obj->{flags} & VALID_SV ) ) {
76 $obj->write_back; 80 $obj->write_back;
77 $obj->{flags} |= VALID_SV; 81 $obj->{flags} |= VALID_SV;
78 } 82 }
79 return $obj->{sv}; 83 return $obj->{sv};
80 } 84 }
85
86 sub as_obj {
87 return shift->{obj};
88 }
81 89
82 sub as_int { 90 sub as_int {
83 my $obj = shift; 91 my $obj = shift;
84 if ( !( $obj->{flags} & VALID_INT ) ) { 92 if ( !( $obj->{flags} & VALID_INT ) ) {
85 $obj->load_int; 93 $obj->load_int;
86 $obj->{flags} |= VALID_INT | SAVE_INT; 94 $obj->{flags} |= VALID_INT | SAVE_INT;
87 } 95 }
88 return $obj->{iv}; 96 return $obj->{iv};
89 } 97 }
90 98
91 sub as_double { 99 sub as_double {
92 my $obj = shift; 100 my $obj = shift;
93 if ( !( $obj->{flags} & VALID_DOUBLE ) ) { 101 if ( !( $obj->{flags} & VALID_DOUBLE ) ) {
94 $obj->load_double; 102 $obj->load_double;
95 $obj->{flags} |= VALID_DOUBLE | SAVE_DOUBLE; 103 $obj->{flags} |= VALID_DOUBLE | SAVE_DOUBLE;
96 } 104 }
97 return $obj->{nv}; 105 return $obj->{nv};
98 } 106 }
99 107
100 sub as_numeric { 108 sub as_numeric {
101 my $obj = shift; 109 my $obj = shift;
102 return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double; 110 return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
103 } 111 }
104 112
105 sub as_bool { 113 sub as_bool {
106 my $obj = shift; 114 my $obj = shift;
107 if ( $obj->{flags} & VALID_INT ) { 115 if ( $obj->{flags} & VALID_INT ) {
108 return $obj->{iv}; 116 return $obj->{iv};
109 } 117 }
110 if ( $obj->{flags} & VALID_DOUBLE ) { 118 if ( $obj->{flags} & VALID_DOUBLE ) {
111 return $obj->{nv}; 119 return $obj->{nv};
112 } 120 }
113 return sprintf( "(SvTRUE(%s))", $obj->as_sv ); 121 return sprintf( "(SvTRUE(%s))", $obj->as_sv );
114 } 122 }
115 123
116 # 124 #
117 # Debugging methods 125 # Debugging methods
118 # 126 #
119 sub peek { 127 sub peek {
120 my $obj = shift; 128 my $obj = shift;
121 my $type = $obj->{type}; 129 my $type = $obj->{type};
122 my $flags = $obj->{flags}; 130 my $flags = $obj->{flags};
123 my @flags; 131 my @flags;
124 if ( $type == T_UNKNOWN ) { 132 if ( $type == T_UNKNOWN ) {
125 $type = "T_UNKNOWN"; 133 $type = "T_UNKNOWN";
126 } 134 }
127 elsif ( $type == T_INT ) { 135 elsif ( $type == T_INT ) {
128 $type = "T_INT"; 136 $type = "T_INT";
129 } 137 }
130 elsif ( $type == T_DOUBLE ) { 138 elsif ( $type == T_DOUBLE ) {
131 $type = "T_DOUBLE"; 139 $type = "T_DOUBLE";
132 } 140 }
133 else { 141 else {
134 $type = "(illegal type $type)"; 142 $type = "(illegal type $type)";
135 } 143 }
136 push( @flags, "VALID_INT" ) if $flags & VALID_INT; 144 push( @flags, "VALID_INT" ) if $flags & VALID_INT;
137 push( @flags, "VALID_DOUBLE" ) if $flags & VALID_DOUBLE; 145 push( @flags, "VALID_DOUBLE" ) if $flags & VALID_DOUBLE;
138 push( @flags, "VALID_SV" ) if $flags & VALID_SV; 146 push( @flags, "VALID_SV" ) if $flags & VALID_SV;
139 push( @flags, "REGISTER" ) if $flags & REGISTER; 147 push( @flags, "REGISTER" ) if $flags & REGISTER;
140 push( @flags, "TEMPORARY" ) if $flags & TEMPORARY; 148 push( @flags, "TEMPORARY" ) if $flags & TEMPORARY;
141 @flags = ("none") unless @flags; 149 @flags = ("none") unless @flags;
142 return sprintf( "%s type=$type flags=%s sv=$obj->{sv} iv=$obj->{iv} nv=$obj->{nv}", 150 return sprintf( "%s type=$type flags=%s sv=$obj->{sv} iv=$obj->{iv} nv=$obj->{nv}",
143 class($obj), join( "|", @flags ) ); 151 class($obj), join( "|", @flags ) );
144 } 152 }
145 153
146 sub minipeek { 154 sub minipeek {
147 my $obj = shift; 155 my $obj = shift;
148 my $type = $obj->{type}; 156 my $type = $obj->{type};
149 my $flags = $obj->{flags}; 157 my $flags = $obj->{flags};
150 if ( $type == T_INT || $flags & VALID_INT ) { 158 if ( $type == T_INT || $flags & VALID_INT ) {
151 return $obj->{iv}; 159 return $obj->{iv};
152 } 160 }
153 elsif ( $type == T_DOUBLE || $flags & VALID_DOUBLE ) { 161 elsif ( $type == T_DOUBLE || $flags & VALID_DOUBLE ) {
154 return $obj->{nv}; 162 return $obj->{nv};
155 } 163 }
156 else { 164 else {
157 return $obj->{sv}; 165 return $obj->{sv};
158 } 166 }
159 } 167 }
160 168
161 # 169 #
162 # Caller needs to ensure that set_int, set_double, 170 # Caller needs to ensure that set_int, set_double,
163 # set_numeric and set_sv are only invoked on legal lvalues. 171 # set_numeric and set_sv are only invoked on legal lvalues.
164 # 172 #
165 sub set_int { 173 sub set_int {
166 my ( $obj, $expr, $unsigned ) = @_; 174 my ( $obj, $expr, $unsigned ) = @_;
167 175
168 my $sval = B::C::ivx($expr); 176 my $sval = B::C::ivx($expr);
169 # bullshit detector for non numeric expr, expr 'lnv0 + rnv0' 177 # bullshit detector for non numeric expr, expr 'lnv0 + rnv0'
170 $sval = $expr if $sval eq '0' and $expr; 178 $sval = $expr if $sval eq '0' and $expr;
171 179
172 runtime("$obj->{iv} = $sval;"); 180 runtime("$obj->{iv} = $sval;");
173 $obj->{flags} &= ~( VALID_SV | VALID_DOUBLE ); 181 $obj->{flags} &= ~( VALID_SV | VALID_DOUBLE );
174 $obj->{flags} |= VALID_INT | SAVE_INT; 182 $obj->{flags} |= VALID_INT | SAVE_INT;
175 $obj->{flags} |= VALID_UNSIGNED if $unsigned; 183 $obj->{flags} |= VALID_UNSIGNED if $unsigned;
176 } 184 }
177 185
178 sub set_double { 186 sub set_double {
179 my ( $obj, $expr ) = @_; 187 my ( $obj, $expr ) = @_;
180 my $sval; 188 my $sval;
181 if ($expr =~ /[ a-dfzA-DF-Z]/) { # looks not like number 189 if ($expr =~ /[ a-dfzA-DF-Z]/) { # looks not like number
182 $sval = $expr; 190 $sval = $expr;
183 } else { 191 } else {
184 $sval = B::C::nvx($expr); 192 $sval = B::C::nvx($expr);
185 # non numeric expr, expr 'lnv0 + rnv0' 193 # non numeric expr, expr 'lnv0 + rnv0'
186 $sval = $expr if $sval eq '0.00' and $expr; 194 $sval = $expr if $sval eq '0.00' and $expr;
187 } 195 }
188 196
189 runtime("$obj->{nv} = $sval;"); 197 runtime("$obj->{nv} = $sval;");
190 $obj->{flags} &= ~( VALID_SV | VALID_INT ); 198 $obj->{flags} &= ~( VALID_SV | VALID_INT );
191 $obj->{flags} |= VALID_DOUBLE | SAVE_DOUBLE; 199 $obj->{flags} |= VALID_DOUBLE | SAVE_DOUBLE;
192 } 200 }
193 201
194 sub set_numeric { 202 sub set_numeric {
195 my ( $obj, $expr ) = @_; 203 my ( $obj, $expr ) = @_;
196 if ( $obj->{type} == T_INT ) { 204 if ( $obj->{type} == T_INT ) {
197 $obj->set_int($expr); 205 $obj->set_int($expr);
198 } 206 }
199 else { 207 else {
200 $obj->set_double($expr); 208 $obj->set_double($expr);
201 } 209 }
202 } 210 }
203 211
204 sub set_sv { 212 sub set_sv {
205 my ( $obj, $expr ) = @_; 213 my ( $obj, $expr ) = @_;
206 runtime("SvSetSV($obj->{sv}, $expr);"); 214 runtime("SvSetSV($obj->{sv}, $expr);");
207 $obj->invalidate; 215 $obj->invalidate;
208 $obj->{flags} |= VALID_SV; 216 $obj->{flags} |= VALID_SV;
209 } 217 }
210 218
211 # 219 #
212 # Stackobj::Padsv 220 # Stackobj::Padsv
213 # 221 #
214 222
215 @B::Stackobj::Padsv::ISA = 'B::Stackobj'; 223 @B::Stackobj::Padsv::ISA = 'B::Stackobj';
216 224
217 sub B::Stackobj::Padsv::new { 225 sub B::Stackobj::Padsv::new {
218 my ( $class, $type, $extra_flags, $ix, $iname, $dname ) = @_; 226 my ( $class, $type, $extra_flags, $ix, $iname, $dname ) = @_;
219 $extra_flags |= SAVE_INT if $extra_flags & VALID_INT; 227 $extra_flags |= SAVE_INT if $extra_flags & VALID_INT;
220 $extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE; 228 $extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE;
221 bless { 229 bless {
222 type => $type, 230 type => $type,
223 flags => VALID_SV | $extra_flags, 231 flags => VALID_SV | $extra_flags,
232 targ => $ix,
224 sv => "PL_curpad[$ix]", 233 sv => "PL_curpad[$ix]",
225 iv => "$iname", 234 iv => "$iname",
226 nv => "$dname" 235 nv => "$dname"
227 }, $class; 236 }, $class;
228 } 237 }
238
239 sub B::Stackobj::Padsv::as_obj {
240 my $obj = shift;
241 my @c = comppadlist->ARRAY;
242 my @p = $c[1]->ARRAY;
243 return $p[ $obj->{targ} ];
244 }
229 245
230 sub B::Stackobj::Padsv::load_int { 246 sub B::Stackobj::Padsv::load_int {
231 my $obj = shift; 247 my $obj = shift;
232 if ( $obj->{flags} & VALID_DOUBLE ) { 248 if ( $obj->{flags} & VALID_DOUBLE ) {
233 runtime("$obj->{iv} = $obj->{nv};"); 249 runtime("$obj->{iv} = $obj->{nv};");
234 } 250 }
235 else { 251 else {
236 runtime("$obj->{iv} = SvIV($obj->{sv});"); 252 runtime("$obj->{iv} = SvIV($obj->{sv});");
237 } 253 }
238 $obj->{flags} |= VALID_INT | SAVE_INT; 254 $obj->{flags} |= VALID_INT | SAVE_INT;
239 } 255 }
240 256
241 sub B::Stackobj::Padsv::load_double { 257 sub B::Stackobj::Padsv::load_double {
242 my $obj = shift; 258 my $obj = shift;
243 $obj->write_back; 259 $obj->write_back;
244 runtime("$obj->{nv} = SvNV($obj->{sv});"); 260 runtime("$obj->{nv} = SvNV($obj->{sv});");
245 $obj->{flags} |= VALID_DOUBLE | SAVE_DOUBLE; 261 $obj->{flags} |= VALID_DOUBLE | SAVE_DOUBLE;
246 } 262 }
247 263
248 sub B::Stackobj::Padsv::save_int { 264 sub B::Stackobj::Padsv::save_int {
249 my $obj = shift; 265 my $obj = shift;
250 return $obj->{flags} & SAVE_INT; 266 return $obj->{flags} & SAVE_INT;
251 } 267 }
252 268
253 sub B::Stackobj::Padsv::save_double { 269 sub B::Stackobj::Padsv::save_double {
254 my $obj = shift; 270 my $obj = shift;
255 return $obj->{flags} & SAVE_DOUBLE; 271 return $obj->{flags} & SAVE_DOUBLE;
256 } 272 }
257 273
258 sub B::Stackobj::Padsv::write_back { 274 sub B::Stackobj::Padsv::write_back {
259 my $obj = shift; 275 my $obj = shift;
260 my $flags = $obj->{flags}; 276 my $flags = $obj->{flags};
261 return if $flags & VALID_SV; 277 return if $flags & VALID_SV;
262 if ( $flags & VALID_INT ) { 278 if ( $flags & VALID_INT ) {
263 if ( $flags & VALID_UNSIGNED ) { 279 if ( $flags & VALID_UNSIGNED ) {
264 runtime("sv_setuv($obj->{sv}, $obj->{iv});"); 280 runtime("sv_setuv($obj->{sv}, $obj->{iv});");
265 } 281 }
266 else { 282 else {
267 runtime("sv_setiv($obj->{sv}, $obj->{iv});"); 283 runtime("sv_setiv($obj->{sv}, $obj->{iv});");
268 } 284 }
269 } 285 }
270 elsif ( $flags & VALID_DOUBLE ) { 286 elsif ( $flags & VALID_DOUBLE ) {
271 runtime("sv_setnv($obj->{sv}, $obj->{nv});"); 287 runtime("sv_setnv($obj->{sv}, $obj->{nv});");
272 } 288 }
273 else { 289 else {
274 confess "write_back failed for lexical @{[$obj->peek]}\n"; 290 confess "write_back failed for lexical @{[$obj->peek]}\n";
275 } 291 }
276 $obj->{flags} |= VALID_SV; 292 $obj->{flags} |= VALID_SV;
277 } 293 }
278 294
279 # 295 #
280 # Stackobj::Const 296 # Stackobj::Const
281 # 297 #
282 298
283 @B::Stackobj::Const::ISA = 'B::Stackobj'; 299 @B::Stackobj::Const::ISA = 'B::Stackobj';
284 300
285 sub B::Stackobj::Const::new { 301 sub B::Stackobj::Const::new {
286 my ( $class, $sv ) = @_; 302 my ( $class, $sv ) = @_;
287 my $obj = bless { 303 my $obj = bless {
288 flags => 0, 304 flags => 0,
289 sv => $sv # holds the SV object until write_back happens 305 sv => $sv, # holds the SV object until write_back happens
306 obj => $sv
290 }, $class; 307 }, $class;
291 if ( ref($sv) eq "B::SPECIAL" ) { 308 if ( ref($sv) eq "B::SPECIAL" ) {
292 $obj->{type} = T_SPECIAL; 309 $obj->{type} = T_SPECIAL;
293 } 310 }
294 else { 311 else {
295 my $svflags = $sv->FLAGS; 312 my $svflags = $sv->FLAGS;
296 if ( $svflags & SVf_IOK ) { 313 if ( $svflags & SVf_IOK ) {
297 $obj->{flags} = VALID_INT | VALID_DOUBLE; 314 $obj->{flags} = VALID_INT | VALID_DOUBLE;
298 $obj->{type} = T_INT; 315 $obj->{type} = T_INT;
299 if ( $svflags & SVf_IVisUV ) { 316 if ( $svflags & SVf_IVisUV ) {
300 $obj->{flags} |= VALID_UNSIGNED; 317 $obj->{flags} |= VALID_UNSIGNED;
301 $obj->{nv} = $obj->{iv} = $sv->UVX; 318 $obj->{nv} = $obj->{iv} = $sv->UVX;
302 } 319 }
303 else { 320 else {
304 $obj->{nv} = $obj->{iv} = $sv->IV; 321 $obj->{nv} = $obj->{iv} = $sv->IV;
305 } 322 }
306 } 323 }
307 elsif ( $svflags & SVf_NOK ) { 324 elsif ( $svflags & SVf_NOK ) {
308 $obj->{flags} = VALID_INT | VALID_DOUBLE; 325 $obj->{flags} = VALID_INT | VALID_DOUBLE;
309 $obj->{type} = T_DOUBLE; 326 $obj->{type} = T_DOUBLE;
310 $obj->{iv} = $obj->{nv} = $sv->NV; 327 $obj->{iv} = $obj->{nv} = $sv->NV;
311 } 328 }
312 else { 329 else {
313 $obj->{type} = T_UNKNOWN; 330 $obj->{type} = T_UNKNOWN;
314 } 331 }
315 } 332 }
316 return $obj; 333 return $obj;
317 } 334 }
318 335
319 sub B::Stackobj::Const::write_back { 336 sub B::Stackobj::Const::write_back {
320 my $obj = shift; 337 my $obj = shift;
321 return if $obj->{flags} & VALID_SV; 338 return if $obj->{flags} & VALID_SV;
322 339
323 # Save the SV object and replace $obj->{sv} by its C source code name 340 # Save the SV object and replace $obj->{sv} by its C source code name
324 $obj->{sv} = $obj->{sv}->save; 341 $obj->{sv} = $obj->{obj}->save;
325 $obj->{flags} |= VALID_SV | VALID_INT | VALID_DOUBLE; 342 $obj->{flags} |= VALID_SV | VALID_INT | VALID_DOUBLE;
326 } 343 }
327 344
328 sub B::Stackobj::Const::load_int { 345 sub B::Stackobj::Const::load_int {
329 my $obj = shift; 346 my $obj = shift;
330 if ( ref( $obj->{sv} ) eq "B::RV" or ($] >= 5.011 and $obj->{sv}->FLAGS & SVf_ROK)) { 347 if ( ref( $obj->{obj} ) eq "B::RV" or ($] >= 5.011 and $obj->{obj}->FLAGS & SVf_ROK)) {
331 $obj->{iv} = int( $obj->{sv}->RV->PV ); 348 $obj->{iv} = int( $obj->{obj}->RV->PV );
332 } 349 }
333 else { 350 else {
334 $obj->{iv} = int( $obj->{sv}->PV ); 351 $obj->{iv} = int( $obj->{obj}->PV );
335 } 352 }
336 $obj->{flags} |= VALID_INT; 353 $obj->{flags} |= VALID_INT;
337 } 354 }
338 355
339 sub B::Stackobj::Const::load_double { 356 sub B::Stackobj::Const::load_double {
340 my $obj = shift; 357 my $obj = shift;
341 if ( ref( $obj->{sv} ) eq "B::RV" ) { 358 if ( ref( $obj->{obj} ) eq "B::RV" ) {
342 $obj->{nv} = $obj->{sv}->RV->PV + 0.0; 359 $obj->{nv} = $obj->{obj}->RV->PV + 0.0;
343 } 360 }
344 else { 361 else {
345 $obj->{nv} = $obj->{sv}->PV + 0.0; 362 $obj->{nv} = $obj->{obj}->PV + 0.0;
346 } 363 }
347 $obj->{flags} |= VALID_DOUBLE; 364 $obj->{flags} |= VALID_DOUBLE;
348 } 365 }
349 366
350 sub B::Stackobj::Const::invalidate { } 367 sub B::Stackobj::Const::invalidate { }
351 368
352 # 369 #
353 # Stackobj::Bool 370 # Stackobj::Bool
354 # 371 #
355 372
356 @B::Stackobj::Bool::ISA = 'B::Stackobj'; 373 @B::Stackobj::Bool::ISA = 'B::Stackobj';
357 374
358 sub B::Stackobj::Bool::new { 375 sub B::Stackobj::Bool::new {
359 my ( $class, $preg ) = @_; 376 my ( $class, $preg ) = @_;
360 my $obj = bless { 377 my $obj = bless {
361 type => T_INT, 378 type => T_INT,
362 flags => VALID_INT | VALID_DOUBLE, 379 flags => VALID_INT | VALID_DOUBLE,
363 iv => $$preg, 380 iv => $$preg,
364 nv => $$preg, 381 nv => $$preg,
365 preg => $preg # this holds our ref to the pseudo-reg 382 obj => $preg # this holds our ref to the pseudo-reg
366 }, $class; 383 }, $class;
367 return $obj; 384 return $obj;
368 } 385 }
369 386
370 sub B::Stackobj::Bool::write_back { 387 sub B::Stackobj::Bool::write_back {
371 my $obj = shift; 388 my $obj = shift;
372 return if $obj->{flags} & VALID_SV; 389 return if $obj->{flags} & VALID_SV;
373 $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)"; 390 $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)";
374 $obj->{flags} |= VALID_SV; 391 $obj->{flags} |= VALID_SV;
375 } 392 }
376 393
377 # XXX Might want to handle as_double/set_double/load_double? 394 # XXX Might want to handle as_double/set_double/load_double?
378 395
379 sub B::Stackobj::Bool::invalidate { } 396 sub B::Stackobj::Bool::invalidate { }
380 397
381 1; 398 1;
382 399
383 # 400 #
384 # Stackobj::Aelem 401 # Stackobj::Aelem
385 # 402 #
386 403
387 @B::Stackobj::Aelem::ISA = 'B::Stackobj'; 404 @B::Stackobj::Aelem::ISA = 'B::Stackobj';
388 405
389 sub B::Stackobj::Aelem::new { 406 sub B::Stackobj::Aelem::new {
390 my ( $class, $av, $ix, $lvalue ) = @_; 407 my ( $class, $av, $ix, $lvalue ) = @_;
391 # TODO: check flags: OPf_MOD, DEFER, SVs_RMG
392 # check no autovivification
393 my $obj = bless { 408 my $obj = bless {
394 type => T_UNKNOWN, 409 type => T_UNKNOWN,
395 flags => VALID_INT | VALID_DOUBLE | VALID_SV, 410 flags => VALID_INT | VALID_DOUBLE | VALID_SV,
396 iv => "SvIV(AvARRAY($av)[$ix])", 411 iv => $lvalue ? "SvIVX(AvARRAY($av)[$ix])" : "SvIV(AvARRAY($av)[$ix])",
397 nv => $lvalue ? "SvNVX(AvARRAY($av)[$ix])" : "SvNV(AvARRAY($av)[$ix])", 412 nv => $lvalue ? "SvNVX(AvARRAY($av)[$ix])" : "SvNV(AvARRAY($av)[$ix])",
398 sv => "AvARRAY($av)[$ix]" 413 sv => "AvARRAY($av)[$ix]"
399 }, $class; 414 }, $class;
400 return $obj; 415 return $obj;
401 } 416 }
402 417
403 sub B::Stackobj::Aelem::write_back { } 418 sub B::Stackobj::Aelem::write_back { }
404 419
405 sub B::Stackobj::Aelem::invalidate { } 420 sub B::Stackobj::Aelem::invalidate { }
406 421
407 __END__ 422 __END__
408 423
409 =head1 NAME 424 =head1 NAME
410 425
411 B::Stackobj - Stack and type annotation helper module for the CC backend 426 B::Stackobj - Stack and type annotation helper module for the CC backend
412 427
413 =head1 SYNOPSIS 428 =head1 SYNOPSIS
414 429
415 use B::Stackobj; 430 use B::Stackobj;
416 431
417 =head1 DESCRIPTION 432 =head1 DESCRIPTION
418 433
419 A simple representation of pp stacks and lexical pads for the B::CC compiler. 434 A simple representation of pp stacks and lexical pads for the B::CC compiler.
420 All locals and function arguments get type annotated, for all B::CC ops which 435 All locals and function arguments get type annotated, for all B::CC ops which
421 can be optimized. 436 can be optimized.
422 437
423 For lexical pads (i.e. my or better our variables) we currently can force the type of 438 For lexical pads (i.e. my or better our variables) we currently can force the type of
424 variables according to a magic naming scheme in L<B::CC/load_pad>. 439 variables according to a magic naming scheme in L<B::CC/load_pad>.
425 440
426 my $<name>_i; IV integer 441 my $<name>_i; IV integer
427 my $<name>_ir; IV integer in a pseudo register 442 my $<name>_ir; IV integer in a pseudo register
428 my $<name>_d; NV double 443 my $<name>_d; NV double
429 444
430 Future ideas are B<type qualifiers> as attributes 445 Future ideas are B<type qualifiers> as attributes
431 446
432 B<double>, B<int>, B<register>, B<temp>, B<unsigned>, B<ro> 447 B<double>, B<int>, B<register>, B<temp>, B<unsigned>, B<ro>
433 448
434 such as in 449 such as in
435 450
436 our int $i : unsigned : ro; 451 our int $i : unsigned : ro;
437 our double $d; 452 our double $d;
438 453
439 Type attributes for sub definitions are not spec'ed yet. 454 Type attributes for sub definitions are not spec'ed yet.
440 L<Ctypes> attributes and objects should also be recognized, such as 455 L<Ctypes> attributes and objects should also be recognized, such as
441 C<c_int> and C<c_double>. 456 C<c_int> and C<c_double>.
442 457
443 B<my vs our>: Note that only B<our> attributes are resolved at B<compile-time>, 458 B<my vs our>: Note that only B<our> attributes are resolved at B<compile-time>,
444 B<my> attributes are resolved at B<run-time>. So the compiler will only see 459 B<my> attributes are resolved at B<run-time>. So the compiler will only see
445 type attributes for our variables. 460 type attributes for our variables.
446 461
447 See L<B::CC/load_pad> and L<types>. 462 See L<B::CC/load_pad> and L<types>.
448 463
449 TODO: Represent on this stack not only PADs,SV,IV,PV,NV,BOOL,Special 464 TODO: Represent on this stack not only PADs,SV,IV,PV,NV,BOOL,Special
450 and a SV const, but also GV,CV,RV,AV,HV, esp. AELEM and HELEM. 465 and a SV const, but also GV,CV,RV,AV,HV, esp. AELEM and HELEM.
451 Use B::Stackobj::Const. 466 Use B::Stackobj::Const.
452 467
453 =head1 AUTHOR 468 =head1 AUTHOR
454 469
455 Malcolm Beattie C<MICB at cpan.org> I<(retired)>, 470 Malcolm Beattie C<MICB at cpan.org> I<(retired)>,
456 Reini Urban C<rurban at cpan.org> 471 Reini Urban C<rurban at cpan.org>
457 472
458 =cut 473 =cut
459 474
460 # Local Variables: 475 # Local Variables:
461 # mode: cperl 476 # mode: cperl
462 # cperl-indent-level: 2 477 # cperl-indent-level: 2
463 # fill-column: 78 478 # fill-column: 78
464 # End: 479 # End:
465 # vim: expandtab shiftwidth=2: 480 # vim: expandtab shiftwidth=2:
Powered by Google Project Hosting