projects / OpenSPARC-T2-DV / blame
| Commit | Line | Data |
|---|---|---|
| 86530b38 AT |
1 | # Bytecode.pm |
| 2 | # | |
| 3 | # Copyright (c) 1996-1998 Malcolm Beattie | |
| 4 | # | |
| 5 | # You may distribute under the terms of either the GNU General Public | |
| 6 | # License or the Artistic License, as specified in the README file. | |
| 7 | # | |
| 8 | package B::Bytecode; | |
| 9 | ||
| 10 | our $VERSION = '1.00'; | |
| 11 | ||
| 12 | use strict; | |
| 13 | use Carp; | |
| 14 | use B qw(main_cv main_root main_start comppadlist | |
| 15 | class peekop walkoptree svref_2object cstring walksymtable | |
| 16 | init_av begin_av end_av | |
| 17 | SVf_POK SVp_POK SVf_IOK SVp_IOK SVf_NOK SVp_NOK | |
| 18 | SVf_READONLY GVf_IMPORTED_AV GVf_IMPORTED_CV GVf_IMPORTED_HV | |
| 19 | GVf_IMPORTED_SV SVTYPEMASK | |
| 20 | ); | |
| 21 | use B::Asmdata qw(@optype @specialsv_name); | |
| 22 | use B::Assembler qw(newasm endasm assemble); | |
| 23 | ||
| 24 | my %optype_enum; | |
| 25 | my $i; | |
| 26 | for ($i = 0; $i < @optype; $i++) { | |
| 27 | $optype_enum{$optype[$i]} = $i; | |
| 28 | } | |
| 29 | ||
| 30 | # Following is SVf_POK|SVp_POK | |
| 31 | # XXX Shouldn't be hardwired | |
| 32 | sub POK () { SVf_POK|SVp_POK } | |
| 33 | ||
| 34 | # Following is SVf_IOK|SVp_IOK | |
| 35 | # XXX Shouldn't be hardwired | |
| 36 | sub IOK () { SVf_IOK|SVp_IOK } | |
| 37 | ||
| 38 | # Following is SVf_NOK|SVp_NOK | |
| 39 | # XXX Shouldn't be hardwired | |
| 40 | sub NOK () { SVf_NOK|SVp_NOK } | |
| 41 | ||
| 42 | # nonexistant flags (see B::GV::bytecode for usage) | |
| 43 | sub GVf_IMPORTED_IO () { 0; } | |
| 44 | sub GVf_IMPORTED_FORM () { 0; } | |
| 45 | ||
| 46 | my ($verbose, $no_assemble, $debug_bc, $debug_cv); | |
| 47 | my @packages; # list of packages to compile | |
| 48 | ||
| 49 | sub asm (@) { # print replacement that knows about assembling | |
| 50 | if ($no_assemble) { | |
| 51 | print @_; | |
| 52 | } else { | |
| 53 | my $buf = join '', @_; | |
| 54 | assemble($_) for (split /\n/, $buf); | |
| 55 | } | |
| 56 | } | |
| 57 | ||
| 58 | sub asmf (@) { # printf replacement that knows about assembling | |
| 59 | if ($no_assemble) { | |
| 60 | printf shift(), @_; | |
| 61 | } else { | |
| 62 | my $format = shift; | |
| 63 | my $buf = sprintf $format, @_; | |
| 64 | assemble($_) for (split /\n/, $buf); | |
| 65 | } | |
| 66 | } | |
| 67 | ||
| 68 | # Optimisation options. On the command line, use hyphens instead of | |
| 69 | # underscores for compatibility with gcc-style options. We use | |
| 70 | # underscores here because they are OK in (strict) barewords. | |
| 71 | my ($compress_nullops, $omit_seq, $bypass_nullops); | |
| 72 | my %optimise = (compress_nullops => \$compress_nullops, | |
| 73 | omit_sequence_numbers => \$omit_seq, | |
| 74 | bypass_nullops => \$bypass_nullops); | |
| 75 | ||
| 76 | my $strip_syntree; # this is left here in case stripping the | |
| 77 | # syntree ever becomes safe again | |
| 78 | # -- BKS, June 2000 | |
| 79 | ||
| 80 | my $nextix = 0; | |
| 81 | my %symtable; # maps object addresses to object indices. | |
| 82 | # Filled in at allocation (newsv/newop) time. | |
| 83 | ||
| 84 | my %saved; # maps object addresses (for SVish classes) to "saved yet?" | |
| 85 | # flag. Set at FOO::bytecode time usually by SV::bytecode. | |
| 86 | # Manipulated via saved(), mark_saved(), unmark_saved(). | |
| 87 | ||
| 88 | my %strtable; # maps shared strings to object indices | |
| 89 | # Filled in at allocation (pvix) time | |
| 90 | ||
| 91 | my $svix = -1; # we keep track of when the sv register contains an element | |
| 92 | # of the object table to avoid unnecessary repeated | |
| 93 | # consecutive ldsv instructions. | |
| 94 | ||
| 95 | my $opix = -1; # Ditto for the op register. | |
| 96 | ||
| 97 | sub ldsv { | |
| 98 | my $ix = shift; | |
| 99 | if ($ix != $svix) { | |
| 100 | asm "ldsv $ix\n"; | |
| 101 | $svix = $ix; | |
| 102 | } | |
| 103 | } | |
| 104 | ||
| 105 | sub stsv { | |
| 106 | my $ix = shift; | |
| 107 | asm "stsv $ix\n"; | |
| 108 | $svix = $ix; | |
| 109 | } | |
| 110 | ||
| 111 | sub set_svix { | |
| 112 | $svix = shift; | |
| 113 | } | |
| 114 | ||
| 115 | sub ldop { | |
| 116 | my $ix = shift; | |
| 117 | if ($ix != $opix) { | |
| 118 | asm "ldop $ix\n"; | |
| 119 | $opix = $ix; | |
| 120 | } | |
| 121 | } | |
| 122 | ||
| 123 | sub stop { | |
| 124 | my $ix = shift; | |
| 125 | asm "stop $ix\n"; | |
| 126 | $opix = $ix; | |
| 127 | } | |
| 128 | ||
| 129 | sub set_opix { | |
| 130 | $opix = shift; | |
| 131 | } | |
| 132 | ||
| 133 | sub pvstring { | |
| 134 | my $str = shift; | |
| 135 | if (defined($str)) { | |
| 136 | return cstring($str . "\0"); | |
| 137 | } else { | |
| 138 | return '""'; | |
| 139 | } | |
| 140 | } | |
| 141 | ||
| 142 | sub nv { | |
| 143 | # print full precision | |
| 144 | my $str = sprintf "%.40f", $_[0]; | |
| 145 | $str =~ s/0+$//; # remove trailing zeros | |
| 146 | $str =~ s/\.$/.0/; | |
| 147 | return $str; | |
| 148 | } | |
| 149 | ||
| 150 | sub saved { $saved{${$_[0]}} } | |
| 151 | sub mark_saved { $saved{${$_[0]}} = 1 } | |
| 152 | sub unmark_saved { $saved{${$_[0]}} = 0 } | |
| 153 | ||
| 154 | sub debug { $debug_bc = shift } | |
| 155 | ||
| 156 | sub pvix { # save a shared PV (mainly for COPs) | |
| 157 | return $strtable{$_[0]} if defined($strtable{$_[0]}); | |
| 158 | asmf "newpv %s\n", pvstring($_[0]); | |
| 159 | my $ix = $nextix++; | |
| 160 | $strtable{$_[0]} = $ix; | |
| 161 | asmf "stpv %d\n", $ix; | |
| 162 | return $ix; | |
| 163 | } | |
| 164 | ||
| 165 | sub B::OBJECT::nyi { | |
| 166 | my $obj = shift; | |
| 167 | warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n", | |
| 168 | class($obj), $$obj); | |
| 169 | } | |
| 170 | ||
| 171 | # | |
| 172 | # objix may stomp on the op register (for op objects) | |
| 173 | # or the sv register (for SV objects) | |
| 174 | # | |
| 175 | sub B::OBJECT::objix { | |
| 176 | my $obj = shift; | |
| 177 | my $ix = $symtable{$$obj}; | |
| 178 | if (defined($ix)) { | |
| 179 | return $ix; | |
| 180 | } else { | |
| 181 | $obj->newix($nextix); | |
| 182 | return $symtable{$$obj} = $nextix++; | |
| 183 | } | |
| 184 | } | |
| 185 | ||
| 186 | sub B::SV::newix { | |
| 187 | my ($sv, $ix) = @_; | |
| 188 | asmf "newsv %d\t# %s\n", $sv->FLAGS & SVTYPEMASK, class($sv); | |
| 189 | stsv($ix); | |
| 190 | } | |
| 191 | ||
| 192 | sub B::GV::newix { | |
| 193 | my ($gv, $ix) = @_; | |
| 194 | my $gvname = $gv->NAME; | |
| 195 | my $name = cstring($gv->STASH->NAME . "::" . $gvname); | |
| 196 | asm "gv_fetchpv $name\n"; | |
| 197 | stsv($ix); | |
| 198 | } | |
| 199 | ||
| 200 | sub B::HV::newix { | |
| 201 | my ($hv, $ix) = @_; | |
| 202 | my $name = $hv->NAME; | |
| 203 | if ($name) { | |
| 204 | # It's a stash | |
| 205 | asmf "gv_stashpv %s\n", cstring($name); | |
| 206 | stsv($ix); | |
| 207 | } else { | |
| 208 | # It's an ordinary HV. Fall back to ordinary newix method | |
| 209 | $hv->B::SV::newix($ix); | |
| 210 | } | |
| 211 | } | |
| 212 | ||
| 213 | sub B::SPECIAL::newix { | |
| 214 | my ($sv, $ix) = @_; | |
| 215 | # Special case. $$sv is not the address of the SV but an | |
| 216 | # index into svspecialsv_list. | |
| 217 | asmf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv]; | |
| 218 | stsv($ix); | |
| 219 | } | |
| 220 | ||
| 221 | sub B::OP::newix { | |
| 222 | my ($op, $ix) = @_; | |
| 223 | my $class = class($op); | |
| 224 | my $typenum = $optype_enum{$class}; | |
| 225 | croak("OP::newix: can't understand class $class") unless defined($typenum); | |
| 226 | asm "newop $typenum\t# $class\n"; | |
| 227 | stop($ix); | |
| 228 | } | |
| 229 | ||
| 230 | sub B::OP::walkoptree_debug { | |
| 231 | my $op = shift; | |
| 232 | warn(sprintf("walkoptree: %s\n", peekop($op))); | |
| 233 | } | |
| 234 | ||
| 235 | sub B::OP::bytecode { | |
| 236 | my $op = shift; | |
| 237 | my $next = $op->next; | |
| 238 | my $nextix; | |
| 239 | my $sibix = $op->sibling->objix unless $strip_syntree; | |
| 240 | my $ix = $op->objix; | |
| 241 | my $type = $op->type; | |
| 242 | ||
| 243 | if ($bypass_nullops) { | |
| 244 | $next = $next->next while $$next && $next->type == 0; | |
| 245 | } | |
| 246 | $nextix = $next->objix; | |
| 247 | ||
| 248 | asmf "# %s\n", peekop($op) if $debug_bc; | |
| 249 | ldop($ix); | |
| 250 | asm "op_next $nextix\n"; | |
| 251 | asm "op_sibling $sibix\n" unless $strip_syntree; | |
| 252 | asmf "op_type %s\t# %d\n", "pp_" . $op->name, $type; | |
| 253 | asmf("op_seq %d\n", $op->seq) unless $omit_seq; | |
| 254 | if ($type || !$compress_nullops) { | |
| 255 | asmf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n", | |
| 256 | $op->targ, $op->flags, $op->private; | |
| 257 | } | |
| 258 | } | |
| 259 | ||
| 260 | sub B::UNOP::bytecode { | |
| 261 | my $op = shift; | |
| 262 | my $firstix = $op->first->objix unless $strip_syntree; | |
| 263 | $op->B::OP::bytecode; | |
| 264 | if (($op->type || !$compress_nullops) && !$strip_syntree) { | |
| 265 | asm "op_first $firstix\n"; | |
| 266 | } | |
| 267 | } | |
| 268 | ||
| 269 | sub B::LOGOP::bytecode { | |
| 270 | my $op = shift; | |
| 271 | my $otherix = $op->other->objix; | |
| 272 | $op->B::UNOP::bytecode; | |
| 273 | asm "op_other $otherix\n"; | |
| 274 | } | |
| 275 | ||
| 276 | sub B::SVOP::bytecode { | |
| 277 | my $op = shift; | |
| 278 | my $sv = $op->sv; | |
| 279 | my $svix = $sv->objix; | |
| 280 | $op->B::OP::bytecode; | |
| 281 | asm "op_sv $svix\n"; | |
| 282 | $sv->bytecode; | |
| 283 | } | |
| 284 | ||
| 285 | sub B::PADOP::bytecode { | |
| 286 | my $op = shift; | |
| 287 | my $padix = $op->padix; | |
| 288 | $op->B::OP::bytecode; | |
| 289 | asm "op_padix $padix\n"; | |
| 290 | } | |
| 291 | ||
| 292 | sub B::PVOP::bytecode { | |
| 293 | my $op = shift; | |
| 294 | my $pv = $op->pv; | |
| 295 | $op->B::OP::bytecode; | |
| 296 | # | |
| 297 | # This would be easy except that OP_TRANS uses a PVOP to store an | |
| 298 | # endian-dependent array of 256 shorts instead of a plain string. | |
| 299 | # | |
| 300 | if ($op->name eq "trans") { | |
| 301 | my @shorts = unpack("s256", $pv); # assembler handles endianness | |
| 302 | asm "op_pv_tr ", join(",", @shorts), "\n"; | |
| 303 | } else { | |
| 304 | asmf "newpv %s\nop_pv\n", pvstring($pv); | |
| 305 | } | |
| 306 | } | |
| 307 | ||
| 308 | sub B::BINOP::bytecode { | |
| 309 | my $op = shift; | |
| 310 | my $lastix = $op->last->objix unless $strip_syntree; | |
| 311 | $op->B::UNOP::bytecode; | |
| 312 | if (($op->type || !$compress_nullops) && !$strip_syntree) { | |
| 313 | asm "op_last $lastix\n"; | |
| 314 | } | |
| 315 | } | |
| 316 | ||
| 317 | sub B::LOOP::bytecode { | |
| 318 | my $op = shift; | |
| 319 | my $redoopix = $op->redoop->objix; | |
| 320 | my $nextopix = $op->nextop->objix; | |
| 321 | my $lastopix = $op->lastop->objix; | |
| 322 | $op->B::LISTOP::bytecode; | |
| 323 | asm "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n"; | |
| 324 | } | |
| 325 | ||
| 326 | sub B::COP::bytecode { | |
| 327 | my $op = shift; | |
| 328 | my $file = $op->file; | |
| 329 | my $line = $op->line; | |
| 330 | if ($debug_bc) { # do this early to aid debugging | |
| 331 | asmf "# line %s:%d\n", $file, $line; | |
| 332 | } | |
| 333 | my $stashpv = $op->stashpv; | |
| 334 | my $warnings = $op->warnings; | |
| 335 | my $warningsix = $warnings->objix; | |
| 336 | my $labelix = pvix($op->label); | |
| 337 | my $stashix = pvix($stashpv); | |
| 338 | my $fileix = pvix($file); | |
| 339 | $warnings->bytecode; | |
| 340 | $op->B::OP::bytecode; | |
| 341 | asmf <<"EOT", $labelix, $stashix, $op->cop_seq, $fileix, $op->arybase; | |
| 342 | cop_label %d | |
| 343 | cop_stashpv %d | |
| 344 | cop_seq %d | |
| 345 | cop_file %d | |
| 346 | cop_arybase %d | |
| 347 | cop_line $line | |
| 348 | cop_warnings $warningsix | |
| 349 | EOT | |
| 350 | } | |
| 351 | ||
| 352 | sub B::PMOP::bytecode { | |
| 353 | my $op = shift; | |
| 354 | my $replroot = $op->pmreplroot; | |
| 355 | my $replrootix = $replroot->objix; | |
| 356 | my $replstartix = $op->pmreplstart->objix; | |
| 357 | my $opname = $op->name; | |
| 358 | # pmnext is corrupt in some PMOPs (see misc.t for example) | |
| 359 | #my $pmnextix = $op->pmnext->objix; | |
| 360 | ||
| 361 | if ($$replroot) { | |
| 362 | # OP_PUSHRE (a mutated version of OP_MATCH for the regexp | |
| 363 | # argument to a split) stores a GV in op_pmreplroot instead | |
| 364 | # of a substitution syntax tree. We don't want to walk that... | |
| 365 | if ($opname eq "pushre") { | |
| 366 | $replroot->bytecode; | |
| 367 | } else { | |
| 368 | walkoptree($replroot, "bytecode"); | |
| 369 | } | |
| 370 | } | |
| 371 | $op->B::LISTOP::bytecode; | |
| 372 | if ($opname eq "pushre") { | |
| 373 | asmf "op_pmreplrootgv $replrootix\n"; | |
| 374 | } else { | |
| 375 | asm "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n"; | |
| 376 | } | |
| 377 | my $re = pvstring($op->precomp); | |
| 378 | # op_pmnext omitted since a perl bug means it's sometime corrupt | |
| 379 | asmf <<"EOT", $op->pmflags, $op->pmpermflags; | |
| 380 | op_pmflags 0x%x | |
| 381 | op_pmpermflags 0x%x | |
| 382 | newpv $re | |
| 383 | pregcomp | |
| 384 | EOT | |
| 385 | } | |
| 386 | ||
| 387 | sub B::SV::bytecode { | |
| 388 | my $sv = shift; | |
| 389 | return if saved($sv); | |
| 390 | my $ix = $sv->objix; | |
| 391 | my $refcnt = $sv->REFCNT; | |
| 392 | my $flags = sprintf("0x%x", $sv->FLAGS); | |
| 393 | ldsv($ix); | |
| 394 | asm "sv_refcnt $refcnt\nsv_flags $flags\n"; | |
| 395 | mark_saved($sv); | |
| 396 | } | |
| 397 | ||
| 398 | sub B::PV::bytecode { | |
| 399 | my $sv = shift; | |
| 400 | return if saved($sv); | |
| 401 | $sv->B::SV::bytecode; | |
| 402 | asmf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK; | |
| 403 | } | |
| 404 | ||
| 405 | sub B::IV::bytecode { | |
| 406 | my $sv = shift; | |
| 407 | return if saved($sv); | |
| 408 | my $iv = $sv->IVX; | |
| 409 | $sv->B::SV::bytecode; | |
| 410 | asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32" if $sv->FLAGS & IOK; # could be PVNV | |
| 411 | } | |
| 412 | ||
| 413 | sub B::NV::bytecode { | |
| 414 | my $sv = shift; | |
| 415 | return if saved($sv); | |
| 416 | $sv->B::SV::bytecode; | |
| 417 | asmf "xnv %s\n", nv($sv->NVX); | |
| 418 | } | |
| 419 | ||
| 420 | sub B::RV::bytecode { | |
| 421 | my $sv = shift; | |
| 422 | return if saved($sv); | |
| 423 | my $rv = $sv->RV; | |
| 424 | my $rvix = $rv->objix; | |
| 425 | $rv->bytecode; | |
| 426 | $sv->B::SV::bytecode; | |
| 427 | asm "xrv $rvix\n"; | |
| 428 | } | |
| 429 | ||
| 430 | sub B::PVIV::bytecode { | |
| 431 | my $sv = shift; | |
| 432 | return if saved($sv); | |
| 433 | my $iv = $sv->IVX; | |
| 434 | $sv->B::PV::bytecode; | |
| 435 | asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; | |
| 436 | } | |
| 437 | ||
| 438 | sub B::PVNV::bytecode { | |
| 439 | my $sv = shift; | |
| 440 | my $flag = shift || 0; | |
| 441 | # The $flag argument is passed through PVMG::bytecode by BM::bytecode | |
| 442 | # and AV::bytecode and indicates special handling. $flag = 1 is used by | |
| 443 | # BM::bytecode and means that we should ensure we save the whole B-M | |
| 444 | # table. It consists of 257 bytes (256 char array plus a final \0) | |
| 445 | # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected | |
| 446 | # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only | |
| 447 | # call SV::bytecode instead of saving PV and calling NV::bytecode since | |
| 448 | # PV/NV/IV stuff is different for AVs. | |
| 449 | return if saved($sv); | |
| 450 | if ($flag == 2) { | |
| 451 | $sv->B::SV::bytecode; | |
| 452 | } else { | |
| 453 | my $pv = $sv->PV; | |
| 454 | $sv->B::IV::bytecode; | |
| 455 | asmf "xnv %s\n", nv($sv->NVX); | |
| 456 | if ($flag == 1) { | |
| 457 | $pv .= "\0" . $sv->TABLE; | |
| 458 | asmf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257; | |
| 459 | } else { | |
| 460 | asmf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK; | |
| 461 | } | |
| 462 | } | |
| 463 | } | |
| 464 | ||
| 465 | sub B::PVMG::bytecode { | |
| 466 | my ($sv, $flag) = @_; | |
| 467 | # See B::PVNV::bytecode for an explanation of $flag. | |
| 468 | return if saved($sv); | |
| 469 | # XXX We assume SvSTASH is already saved and don't save it later ourselves | |
| 470 | my $stashix = $sv->SvSTASH->objix; | |
| 471 | my @mgchain = $sv->MAGIC; | |
| 472 | my (@mgobjix, $mg); | |
| 473 | # | |
| 474 | # We need to traverse the magic chain and get objix for each OBJ | |
| 475 | # field *before* we do B::PVNV::bytecode since objix overwrites | |
| 476 | # the sv register. However, we need to write the magic-saving | |
| 477 | # bytecode *after* B::PVNV::bytecode since sv isn't initialised | |
| 478 | # to refer to $sv until then. | |
| 479 | # | |
| 480 | @mgobjix = map($_->OBJ->objix, @mgchain); | |
| 481 | $sv->B::PVNV::bytecode($flag); | |
| 482 | asm "xmg_stash $stashix\n"; | |
| 483 | foreach $mg (@mgchain) { | |
| 484 | asmf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n", | |
| 485 | cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR); | |
| 486 | } | |
| 487 | } | |
| 488 | ||
| 489 | sub B::PVLV::bytecode { | |
| 490 | my $sv = shift; | |
| 491 | return if saved($sv); | |
| 492 | $sv->B::PVMG::bytecode; | |
| 493 | asmf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE); | |
| 494 | xlv_targoff %d | |
| 495 | xlv_targlen %d | |
| 496 | xlv_type %s | |
| 497 | EOT | |
| 498 | } | |
| 499 | ||
| 500 | sub B::BM::bytecode { | |
| 501 | my $sv = shift; | |
| 502 | return if saved($sv); | |
| 503 | # See PVNV::bytecode for an explanation of what the argument does | |
| 504 | $sv->B::PVMG::bytecode(1); | |
| 505 | asmf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n", | |
| 506 | $sv->USEFUL, $sv->PREVIOUS, $sv->RARE; | |
| 507 | } | |
| 508 | ||
| 509 | sub empty_gv { # is a GV empty except for imported stuff? | |
| 510 | my $gv = shift; | |
| 511 | ||
| 512 | return 0 if ($gv->SV->FLAGS & SVTYPEMASK); # sv not SVt_NULL | |
| 513 | my @subfield_names = qw(AV HV CV FORM IO); | |
| 514 | @subfield_names = grep {; | |
| 515 | no strict 'refs'; | |
| 516 | !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->()) && ${$gv->$_()}; | |
| 517 | } @subfield_names; | |
| 518 | return scalar @subfield_names; | |
| 519 | } | |
| 520 | ||
| 521 | sub B::GV::bytecode { | |
| 522 | my $gv = shift; | |
| 523 | return if saved($gv); | |
| 524 | return unless grep { $_ eq $gv->STASH->NAME; } @packages; | |
| 525 | return if $gv->NAME =~ m/^\(/; # ignore overloads - they'll be rebuilt | |
| 526 | my $ix = $gv->objix; | |
| 527 | mark_saved($gv); | |
| 528 | ldsv($ix); | |
| 529 | asmf <<"EOT", $gv->FLAGS, $gv->GvFLAGS; | |
| 530 | sv_flags 0x%x | |
| 531 | xgv_flags 0x%x | |
| 532 | EOT | |
| 533 | my $refcnt = $gv->REFCNT; | |
| 534 | asmf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1; | |
| 535 | return if $gv->is_empty; | |
| 536 | asmf <<"EOT", $gv->LINE, pvix($gv->FILE); | |
| 537 | gp_line %d | |
| 538 | gp_file %d | |
| 539 | EOT | |
| 540 | my $gvname = $gv->NAME; | |
| 541 | my $name = cstring($gv->STASH->NAME . "::" . $gvname); | |
| 542 | my $egv = $gv->EGV; | |
| 543 | my $egvix = $egv->objix; | |
| 544 | my $gvrefcnt = $gv->GvREFCNT; | |
| 545 | asmf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1; | |
| 546 | if ($gvrefcnt > 1 && $ix != $egvix) { | |
| 547 | asm "gp_share $egvix\n"; | |
| 548 | } else { | |
| 549 | if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) { | |
| 550 | my $i; | |
| 551 | my @subfield_names = qw(SV AV HV CV FORM IO); | |
| 552 | @subfield_names = grep {; | |
| 553 | no strict 'refs'; | |
| 554 | !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->()); | |
| 555 | } @subfield_names; | |
| 556 | my @subfields = map($gv->$_(), @subfield_names); | |
| 557 | my @ixes = map($_->objix, @subfields); | |
| 558 | # Reset sv register for $gv | |
| 559 | ldsv($ix); | |
| 560 | for ($i = 0; $i < @ixes; $i++) { | |
| 561 | asmf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; | |
| 562 | } | |
| 563 | # Now save all the subfields | |
| 564 | my $sv; | |
| 565 | foreach $sv (@subfields) { | |
| 566 | $sv->bytecode; | |
| 567 | } | |
| 568 | } | |
| 569 | } | |
| 570 | } | |
| 571 | ||
| 572 | sub B::HV::bytecode { | |
| 573 | my $hv = shift; | |
| 574 | return if saved($hv); | |
| 575 | mark_saved($hv); | |
| 576 | my $name = $hv->NAME; | |
| 577 | my $ix = $hv->objix; | |
| 578 | if (!$name) { | |
| 579 | # It's an ordinary HV. Stashes have NAME set and need no further | |
| 580 | # saving beyond the gv_stashpv that $hv->objix already ensures. | |
| 581 | my @contents = $hv->ARRAY; | |
| 582 | my ($i, @ixes); | |
| 583 | for ($i = 1; $i < @contents; $i += 2) { | |
| 584 | push(@ixes, $contents[$i]->objix); | |
| 585 | } | |
| 586 | for ($i = 1; $i < @contents; $i += 2) { | |
| 587 | $contents[$i]->bytecode; | |
| 588 | } | |
| 589 | ldsv($ix); | |
| 590 | for ($i = 0; $i < @contents; $i += 2) { | |
| 591 | asmf("newpv %s\nhv_store %d\n", | |
| 592 | pvstring($contents[$i]), $ixes[$i / 2]); | |
| 593 | } | |
| 594 | asmf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS; | |
| 595 | } | |
| 596 | } | |
| 597 | ||
| 598 | sub B::AV::bytecode { | |
| 599 | my $av = shift; | |
| 600 | return if saved($av); | |
| 601 | my $ix = $av->objix; | |
| 602 | my $fill = $av->FILL; | |
| 603 | my $max = $av->MAX; | |
| 604 | my (@array, @ixes); | |
| 605 | if ($fill > -1) { | |
| 606 | @array = $av->ARRAY; | |
| 607 | @ixes = map($_->objix, @array); | |
| 608 | my $sv; | |
| 609 | foreach $sv (@array) { | |
| 610 | $sv->bytecode; | |
| 611 | } | |
| 612 | } | |
| 613 | # See PVNV::bytecode for the meaning of the flag argument of 2. | |
| 614 | $av->B::PVMG::bytecode(2); | |
| 615 | # Recover sv register and set AvMAX and AvFILL to -1 (since we | |
| 616 | # create an AV with NEWSV and SvUPGRADE rather than doing newAV | |
| 617 | # which is what sets AvMAX and AvFILL. | |
| 618 | ldsv($ix); | |
| 619 | asmf "sv_flags 0x%x\n", $av->FLAGS & ~SVf_READONLY; # SvREADONLY_off($av) in case PADCONST | |
| 620 | asmf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS; | |
| 621 | if ($fill > -1) { | |
| 622 | my $elix; | |
| 623 | foreach $elix (@ixes) { | |
| 624 | asm "av_push $elix\n"; | |
| 625 | } | |
| 626 | } else { | |
| 627 | if ($max > -1) { | |
| 628 | asm "av_extend $max\n"; | |
| 629 | } | |
| 630 | } | |
| 631 | asmf "sv_flags 0x%x\n", $av->FLAGS; # restore flags from above | |
| 632 | } | |
| 633 | ||
| 634 | sub B::CV::bytecode { | |
| 635 | my $cv = shift; | |
| 636 | return if saved($cv); | |
| 637 | return if ${$cv->GV} && ($cv->GV->GvFLAGS & GVf_IMPORTED_CV); | |
| 638 | my $fileix = pvix($cv->FILE); | |
| 639 | my $ix = $cv->objix; | |
| 640 | $cv->B::PVMG::bytecode; | |
| 641 | my $i; | |
| 642 | my @subfield_names = qw(ROOT START STASH GV PADLIST OUTSIDE); | |
| 643 | my @subfields = map($cv->$_(), @subfield_names); | |
| 644 | my @ixes = map($_->objix, @subfields); | |
| 645 | # Save OP tree from CvROOT (first element of @subfields) | |
| 646 | my $root = shift @subfields; | |
| 647 | if ($$root) { | |
| 648 | walkoptree($root, "bytecode"); | |
| 649 | } | |
| 650 | # Reset sv register for $cv (since above ->objix calls stomped on it) | |
| 651 | ldsv($ix); | |
| 652 | for ($i = 0; $i < @ixes; $i++) { | |
| 653 | asmf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; | |
| 654 | } | |
| 655 | asmf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS; | |
| 656 | asmf "xcv_file %d\n", $fileix; | |
| 657 | # Now save all the subfields (except for CvROOT which was handled | |
| 658 | # above) and CvSTART (now the initial element of @subfields). | |
| 659 | shift @subfields; # bye-bye CvSTART | |
| 660 | my $sv; | |
| 661 | foreach $sv (@subfields) { | |
| 662 | $sv->bytecode; | |
| 663 | } | |
| 664 | } | |
| 665 | ||
| 666 | sub B::IO::bytecode { | |
| 667 | my $io = shift; | |
| 668 | return if saved($io); | |
| 669 | my $ix = $io->objix; | |
| 670 | my $top_gv = $io->TOP_GV; | |
| 671 | my $top_gvix = $top_gv->objix; | |
| 672 | my $fmt_gv = $io->FMT_GV; | |
| 673 | my $fmt_gvix = $fmt_gv->objix; | |
| 674 | my $bottom_gv = $io->BOTTOM_GV; | |
| 675 | my $bottom_gvix = $bottom_gv->objix; | |
| 676 | ||
| 677 | $io->B::PVMG::bytecode; | |
| 678 | ldsv($ix); | |
| 679 | asm "xio_top_gv $top_gvix\n"; | |
| 680 | asm "xio_fmt_gv $fmt_gvix\n"; | |
| 681 | asm "xio_bottom_gv $bottom_gvix\n"; | |
| 682 | my $field; | |
| 683 | foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) { | |
| 684 | asmf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field); | |
| 685 | } | |
| 686 | foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) { | |
| 687 | asmf "xio_%s %d\n", lc($field), $io->$field(); | |
| 688 | } | |
| 689 | asmf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS; | |
| 690 | $top_gv->bytecode; | |
| 691 | $fmt_gv->bytecode; | |
| 692 | $bottom_gv->bytecode; | |
| 693 | } | |
| 694 | ||
| 695 | sub B::SPECIAL::bytecode { | |
| 696 | # nothing extra needs doing | |
| 697 | } | |
| 698 | ||
| 699 | sub bytecompile_object { | |
| 700 | for my $sv (@_) { | |
| 701 | svref_2object($sv)->bytecode; | |
| 702 | } | |
| 703 | } | |
| 704 | ||
| 705 | sub B::GV::bytecodecv { | |
| 706 | my $gv = shift; | |
| 707 | my $cv = $gv->CV; | |
| 708 | if ($$cv && !saved($cv) && !($gv->FLAGS & GVf_IMPORTED_CV)) { | |
| 709 | if ($debug_cv) { | |
| 710 | warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", | |
| 711 | $gv->STASH->NAME, $gv->NAME, $$cv, $$gv); | |
| 712 | } | |
| 713 | $gv->bytecode; | |
| 714 | } | |
| 715 | } | |
| 716 | ||
| 717 | sub save_call_queues { | |
| 718 | if (begin_av()->isa("B::AV")) { # this is just to save 'use Foo;' calls | |
| 719 | for my $cv (begin_av()->ARRAY) { | |
| 720 | next unless grep { $_ eq $cv->STASH->NAME; } @packages; | |
| 721 | my $op = $cv->START; | |
| 722 | OPLOOP: | |
| 723 | while ($$op) { | |
| 724 | if ($op->name eq 'require') { # save any BEGIN that does a require | |
| 725 | $cv->bytecode; | |
| 726 | asmf "push_begin %d\n", $cv->objix; | |
| 727 | last OPLOOP; | |
| 728 | } | |
| 729 | $op = $op->next; | |
| 730 | } | |
| 731 | } | |
| 732 | } | |
| 733 | if (init_av()->isa("B::AV")) { | |
| 734 | for my $cv (init_av()->ARRAY) { | |
| 735 | next unless grep { $_ eq $cv->STASH->NAME; } @packages; | |
| 736 | $cv->bytecode; | |
| 737 | asmf "push_init %d\n", $cv->objix; | |
| 738 | } | |
| 739 | } | |
| 740 | if (end_av()->isa("B::AV")) { | |
| 741 | for my $cv (end_av()->ARRAY) { | |
| 742 | next unless grep { $_ eq $cv->STASH->NAME; } @packages; | |
| 743 | $cv->bytecode; | |
| 744 | asmf "push_end %d\n", $cv->objix; | |
| 745 | } | |
| 746 | } | |
| 747 | } | |
| 748 | ||
| 749 | sub symwalk { | |
| 750 | no strict 'refs'; | |
| 751 | my $ok = 1 if grep { (my $name = $_[0]) =~ s/::$//; $_ eq $name;} @packages; | |
| 752 | if (grep { /^$_[0]/; } @packages) { | |
| 753 | walksymtable(\%{"$_[0]"}, "bytecodecv", \&symwalk, $_[0]); | |
| 754 | } | |
| 755 | warn "considering $_[0] ... " . ($ok ? "accepted\n" : "rejected\n") | |
| 756 | if $debug_bc; | |
| 757 | $ok; | |
| 758 | } | |
| 759 | ||
| 760 | sub bytecompile_main { | |
| 761 | my $curpad = (comppadlist->ARRAY)[1]; | |
| 762 | my $curpadix = $curpad->objix; | |
| 763 | $curpad->bytecode; | |
| 764 | save_call_queues(); | |
| 765 | walkoptree(main_root, "bytecode") unless ref(main_root) eq "B::NULL"; | |
| 766 | warn "done main program, now walking symbol table\n" if $debug_bc; | |
| 767 | if (@packages) { | |
| 768 | no strict qw(refs); | |
| 769 | walksymtable(\%{"main::"}, "bytecodecv", \&symwalk); | |
| 770 | } else { | |
| 771 | die "No packages requested for compilation!\n"; | |
| 772 | } | |
| 773 | asmf "main_root %d\n", main_root->objix; | |
| 774 | asmf "main_start %d\n", main_start->objix; | |
| 775 | asmf "curpad $curpadix\n"; | |
| 776 | # XXX Do min_intro_pending and max_intro_pending matter? | |
| 777 | } | |
| 778 | ||
| 779 | sub compile { | |
| 780 | my @options = @_; | |
| 781 | my ($option, $opt, $arg); | |
| 782 | open(OUT, ">&STDOUT"); | |
| 783 | binmode OUT; | |
| 784 | select OUT; | |
| 785 | OPTION: | |
| 786 | while ($option = shift @options) { | |
| 787 | if ($option =~ /^-(.)(.*)/) { | |
| 788 | $opt = $1; | |
| 789 | $arg = $2; | |
| 790 | } else { | |
| 791 | unshift @options, $option; | |
| 792 | last OPTION; | |
| 793 | } | |
| 794 | if ($opt eq "-" && $arg eq "-") { | |
| 795 | shift @options; | |
| 796 | last OPTION; | |
| 797 | } elsif ($opt eq "o") { | |
| 798 | $arg ||= shift @options; | |
| 799 | open(OUT, ">$arg") or return "$arg: $!\n"; | |
| 800 | binmode OUT; | |
| 801 | } elsif ($opt eq "a") { | |
| 802 | $arg ||= shift @options; | |
| 803 | open(OUT, ">>$arg") or return "$arg: $!\n"; | |
| 804 | binmode OUT; | |
| 805 | } elsif ($opt eq "D") { | |
| 806 | $arg ||= shift @options; | |
| 807 | foreach $arg (split(//, $arg)) { | |
| 808 | if ($arg eq "b") { | |
| 809 | $| = 1; | |
| 810 | debug(1); | |
| 811 | } elsif ($arg eq "o") { | |
| 812 | B->debug(1); | |
| 813 | } elsif ($arg eq "a") { | |
| 814 | B::Assembler::debug(1); | |
| 815 | } elsif ($arg eq "C") { | |
| 816 | $debug_cv = 1; | |
| 817 | } | |
| 818 | } | |
| 819 | } elsif ($opt eq "v") { | |
| 820 | $verbose = 1; | |
| 821 | } elsif ($opt eq "S") { | |
| 822 | $no_assemble = 1; | |
| 823 | } elsif ($opt eq "f") { | |
| 824 | $arg ||= shift @options; | |
| 825 | my $value = $arg !~ s/^no-//; | |
| 826 | $arg =~ s/-/_/g; | |
| 827 | my $ref = $optimise{$arg}; | |
| 828 | if (defined($ref)) { | |
| 829 | $$ref = $value; | |
| 830 | } else { | |
| 831 | warn qq(ignoring unknown optimisation option "$arg"\n); | |
| 832 | } | |
| 833 | } elsif ($opt eq "O") { | |
| 834 | $arg = 1 if $arg eq ""; | |
| 835 | my $ref; | |
| 836 | foreach $ref (values %optimise) { | |
| 837 | $$ref = 0; | |
| 838 | } | |
| 839 | if ($arg >= 2) { | |
| 840 | $bypass_nullops = 1; | |
| 841 | } | |
| 842 | if ($arg >= 1) { | |
| 843 | $compress_nullops = 1; | |
| 844 | $omit_seq = 1; | |
| 845 | } | |
| 846 | } elsif ($opt eq "u") { | |
| 847 | $arg ||= shift @options; | |
| 848 | push @packages, $arg; | |
| 849 | } else { | |
| 850 | warn qq(ignoring unknown option "$opt$arg"\n); | |
| 851 | } | |
| 852 | } | |
| 853 | if (! @packages) { | |
| 854 | warn "No package specified for compilation, assuming main::\n"; | |
| 855 | @packages = qw(main); | |
| 856 | } | |
| 857 | if (@options) { | |
| 858 | die "Extraneous options left on B::Bytecode commandline: @options\n"; | |
| 859 | } else { | |
| 860 | return sub { | |
| 861 | newasm(\&apr) unless $no_assemble; | |
| 862 | bytecompile_main(); | |
| 863 | endasm() unless $no_assemble; | |
| 864 | }; | |
| 865 | } | |
| 866 | } | |
| 867 | ||
| 868 | sub apr { print @_; } | |
| 869 | ||
| 870 | 1; | |
| 871 | ||
| 872 | __END__ | |
| 873 | ||
| 874 | =head1 NAME | |
| 875 | ||
| 876 | B::Bytecode - Perl compiler's bytecode backend | |
| 877 | ||
| 878 | =head1 SYNOPSIS | |
| 879 | ||
| 880 | perl -MO=Bytecode[,OPTIONS] foo.pl | |
| 881 | ||
| 882 | =head1 DESCRIPTION | |
| 883 | ||
| 884 | This compiler backend takes Perl source and generates a | |
| 885 | platform-independent bytecode encapsulating code to load the | |
| 886 | internal structures perl uses to run your program. When the | |
| 887 | generated bytecode is loaded in, your program is ready to run, | |
| 888 | reducing the time which perl would have taken to load and parse | |
| 889 | your program into its internal semi-compiled form. That means that | |
| 890 | compiling with this backend will not help improve the runtime | |
| 891 | execution speed of your program but may improve the start-up time. | |
| 892 | Depending on the environment in which your program runs this may | |
| 893 | or may not be a help. | |
| 894 | ||
| 895 | The resulting bytecode can be run with a special byteperl executable | |
| 896 | or (for non-main programs) be loaded via the C<byteload_fh> function | |
| 897 | in the F<B> module. | |
| 898 | ||
| 899 | =head1 OPTIONS | |
| 900 | ||
| 901 | If there are any non-option arguments, they are taken to be names of | |
| 902 | objects to be saved (probably doesn't work properly yet). Without | |
| 903 | extra arguments, it saves the main program. | |
| 904 | ||
| 905 | =over 4 | |
| 906 | ||
| 907 | =item B<-ofilename> | |
| 908 | ||
| 909 | Output to filename instead of STDOUT. | |
| 910 | ||
| 911 | =item B<-afilename> | |
| 912 | ||
| 913 | Append output to filename. | |
| 914 | ||
| 915 | =item B<--> | |
| 916 | ||
| 917 | Force end of options. | |
| 918 | ||
| 919 | =item B<-f> | |
| 920 | ||
| 921 | Force optimisations on or off one at a time. Each can be preceded | |
| 922 | by B<no-> to turn the option off (e.g. B<-fno-compress-nullops>). | |
| 923 | ||
| 924 | =item B<-fcompress-nullops> | |
| 925 | ||
| 926 | Only fills in the necessary fields of ops which have | |
| 927 | been optimised away by perl's internal compiler. | |
| 928 | ||
| 929 | =item B<-fomit-sequence-numbers> | |
| 930 | ||
| 931 | Leaves out code to fill in the op_seq field of all ops | |
| 932 | which is only used by perl's internal compiler. | |
| 933 | ||
| 934 | =item B<-fbypass-nullops> | |
| 935 | ||
| 936 | If op->op_next ever points to a NULLOP, replaces the op_next field | |
| 937 | with the first non-NULLOP in the path of execution. | |
| 938 | ||
| 939 | =item B<-On> | |
| 940 | ||
| 941 | Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. | |
| 942 | B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>. | |
| 943 | B<-O2> adds B<-fbypass-nullops>. | |
| 944 | ||
| 945 | =item B<-D> | |
| 946 | ||
| 947 | Debug options (concatenated or separate flags like C<perl -D>). | |
| 948 | ||
| 949 | =item B<-Do> | |
| 950 | ||
| 951 | Prints each OP as it's processed. | |
| 952 | ||
| 953 | =item B<-Db> | |
| 954 | ||
| 955 | Print debugging information about bytecompiler progress. | |
| 956 | ||
| 957 | =item B<-Da> | |
| 958 | ||
| 959 | Tells the (bytecode) assembler to include source assembler lines | |
| 960 | in its output as bytecode comments. | |
| 961 | ||
| 962 | =item B<-DC> | |
| 963 | ||
| 964 | Prints each CV taken from the final symbol tree walk. | |
| 965 | ||
| 966 | =item B<-S> | |
| 967 | ||
| 968 | Output (bytecode) assembler source rather than piping it | |
| 969 | through the assembler and outputting bytecode. | |
| 970 | ||
| 971 | =item B<-upackage> | |
| 972 | ||
| 973 | Stores package in the output. | |
| 974 | ||
| 975 | =back | |
| 976 | ||
| 977 | =head1 EXAMPLES | |
| 978 | ||
| 979 | perl -MO=Bytecode,-O6,-ofoo.plc,-umain foo.pl | |
| 980 | ||
| 981 | perl -MO=Bytecode,-S,-umain foo.pl > foo.S | |
| 982 | assemble foo.S > foo.plc | |
| 983 | ||
| 984 | Note that C<assemble> lives in the C<B> subdirectory of your perl | |
| 985 | library directory. The utility called perlcc may also be used to | |
| 986 | help make use of this compiler. | |
| 987 | ||
| 988 | perl -MO=Bytecode,-uFoo,-oFoo.pmc Foo.pm | |
| 989 | ||
| 990 | =head1 BUGS | |
| 991 | ||
| 992 | Output is still huge and there are still occasional crashes during | |
| 993 | either compilation or ByteLoading. Current status: experimental. | |
| 994 | ||
| 995 | =head1 AUTHORS | |
| 996 | ||
| 997 | Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> | |
| 998 | Benjamin Stuhl, C<sho_pi@hotmail.com> | |
| 999 | ||
| 1000 | =cut |