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