| … | |
… | |
| 25 | immensely, but rarely cause bugs). |
25 | immensely, but rarely cause bugs). |
| 26 | |
26 | |
| 27 | Usage is very easy, just C<use Faster> and every function called from then |
27 | Usage is very easy, just C<use Faster> and every function called from then |
| 28 | on will be compiled. |
28 | on will be compiled. |
| 29 | |
29 | |
| 30 | Right now, Faster will leave ltos of F<*.c>, F<*.o> and F<*.so> files in |
30 | Right now, Faster will leave lots of F<*.c>, F<*.o> and F<*.so> files in |
| 31 | F</tmp>, and it will even create those temporary files in an insecure |
31 | F</tmp>, and it will even create those temporary files in an insecure |
| 32 | manner, so watch out. |
32 | manner, so watch out. |
| 33 | |
33 | |
| 34 | =over 4 |
34 | =over 4 |
| 35 | |
35 | |
| … | |
… | |
| 38 | package Faster; |
38 | package Faster; |
| 39 | |
39 | |
| 40 | use strict; |
40 | use strict; |
| 41 | use Config; |
41 | use Config; |
| 42 | use B (); |
42 | use B (); |
| 43 | use Digest::MD5 (); |
43 | #use Digest::MD5 (); |
| 44 | use DynaLoader (); |
44 | use DynaLoader (); |
| 45 | |
45 | |
| 46 | BEGIN { |
46 | BEGIN { |
| 47 | our $VERSION = '0.01'; |
47 | our $VERSION = '0.01'; |
| 48 | |
48 | |
| … | |
… | |
| 58 | |
58 | |
| 59 | # we don't need no steenking PIC on x86 |
59 | # we don't need no steenking PIC on x86 |
| 60 | $COMPILE =~ s/-f(?:PIC|pic)//g |
60 | $COMPILE =~ s/-f(?:PIC|pic)//g |
| 61 | if $Config{archname} =~ /^(i[3456]86)-/; |
61 | if $Config{archname} =~ /^(i[3456]86)-/; |
| 62 | |
62 | |
| 63 | my $opt_assert = 1; |
63 | my $opt_assert = 0; |
| 64 | |
64 | |
| 65 | our $source; |
65 | our $source; |
| 66 | |
66 | |
| 67 | our @ops; |
67 | our @ops; |
| 68 | our $op; |
68 | our $op; |
| … | |
… | |
| 135 | unstack noasync |
135 | unstack noasync |
| 136 | leaveloop noasync |
136 | leaveloop noasync |
| 137 | aelem noasync |
137 | aelem noasync |
| 138 | aelemfast noasync |
138 | aelemfast noasync |
| 139 | helem noasync |
139 | helem noasync |
|
|
140 | delete noasync |
|
|
141 | exists noasync |
| 140 | pushre noasync |
142 | pushre noasync |
| 141 | subst noasync |
143 | subst noasync |
| 142 | const noasync extend=1 |
144 | const noasync extend=1 |
| 143 | list noasync |
145 | list noasync |
| 144 | join noasync |
146 | join noasync |
| … | |
… | |
| 548 | #warn $source; |
550 | #warn $source; |
| 549 | |
551 | |
| 550 | $source |
552 | $source |
| 551 | } |
553 | } |
| 552 | |
554 | |
|
|
555 | my $uid = "aaaaaaa0"; |
|
|
556 | |
| 553 | sub source2ptr { |
557 | sub source2ptr { |
| 554 | my ($source) = @_; |
558 | my (@source) = @_; |
| 555 | |
559 | |
| 556 | my $md5 = Digest::MD5::md5_hex $source; |
560 | my $stem = "/tmp/Faster-$$-" . $uid++; |
| 557 | $source =~ s/%%%FUNC%%%/Faster_$md5/; |
|
|
| 558 | |
561 | |
| 559 | my $stem = "/tmp/$md5"; |
|
|
| 560 | |
|
|
| 561 | unless (-e "$stem$_so") { |
|
|
| 562 | open FILE, ">:raw", "$stem.c"; |
562 | open FILE, ">:raw", "$stem.c"; |
| 563 | print FILE <<EOF; |
563 | print FILE <<EOF; |
| 564 | #define PERL_NO_GET_CONTEXT |
564 | #define PERL_NO_GET_CONTEXT |
| 565 | |
565 | |
| 566 | #include <assert.h> |
566 | #include <assert.h> |
| 567 | |
567 | |
| 568 | #include "EXTERN.h" |
568 | #include "EXTERN.h" |
| 569 | #include "perl.h" |
569 | #include "perl.h" |
| 570 | #include "XSUB.h" |
570 | #include "XSUB.h" |
| 571 | |
571 | |
| 572 | #define RUNOPS_TILL(op) \\ |
572 | #define RUNOPS_TILL(op) \\ |
| 573 | while (nextop != (op)) \\ |
573 | while (nextop != (op)) \\ |
| 574 | { \\ |
574 | { \\ |
| 575 | PERL_ASYNC_CHECK (); \\ |
575 | PERL_ASYNC_CHECK (); \\ |
| 576 | PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ |
576 | PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ |
| 577 | } |
577 | } |
| 578 | |
578 | |
| 579 | EOF |
579 | EOF |
|
|
580 | for (@source) { |
|
|
581 | my $func = $uid++; |
|
|
582 | $_ =~ s/%%%FUNC%%%/$func/g; |
| 580 | print FILE $source; |
583 | print FILE $_; |
| 581 | close FILE; |
584 | $_ = $func; |
| 582 | system "$COMPILE -o $stem$_o $stem.c"; |
|
|
| 583 | system "$LINK -o $stem$_so $stem$_o $LIBS"; |
|
|
| 584 | } |
585 | } |
| 585 | |
586 | |
| 586 | # warn $source; |
587 | close FILE; |
|
|
588 | system "$COMPILE -o $stem$_o $stem.c"; |
|
|
589 | #d#unlink "$stem.c"; |
|
|
590 | system "$LINK -o $stem$_so $stem$_o $LIBS"; |
|
|
591 | unlink "$stem$_o"; |
|
|
592 | |
| 587 | my $so = DynaLoader::dl_load_file "$stem$_so" |
593 | my $so = DynaLoader::dl_load_file "$stem$_so" |
| 588 | or die "$stem$_so: $!"; |
594 | or die "$stem$_so: $!"; |
| 589 | |
595 | |
| 590 | DynaLoader::dl_find_symbol $so, "Faster_$md5" |
596 | #unlink "$stem$_so"; |
| 591 | or die "Faster_$md5: $!" |
597 | |
|
|
598 | map +(DynaLoader::dl_find_symbol $so, $_), @source |
| 592 | } |
599 | } |
|
|
600 | |
|
|
601 | my %ignore; |
| 593 | |
602 | |
| 594 | sub entersub { |
603 | sub entersub { |
| 595 | my ($cv) = @_; |
604 | my ($cv) = @_; |
| 596 | |
605 | |
| 597 | # always compile the whole stash |
606 | my $pkg = $cv->STASH->NAME; |
| 598 | # my @stash = $cv->STASH->ARRAY; |
607 | |
| 599 | # warn join ":", @stash; |
608 | return if $ignore{$pkg}; |
| 600 | # exit; |
609 | |
|
|
610 | warn "compiling ", $cv->STASH->NAME;#d# |
| 601 | |
611 | |
| 602 | eval { |
612 | eval { |
| 603 | my $source = cv2c $cv; |
613 | my @cv; |
|
|
614 | my @cv_source; |
| 604 | |
615 | |
|
|
616 | # always compile the whole stash |
|
|
617 | my %stash = $cv->STASH->ARRAY; |
|
|
618 | while (my ($k, $v) = each %stash) { |
|
|
619 | $v->isa (B::GV::) |
|
|
620 | or next; |
|
|
621 | |
|
|
622 | my $cv = $v->CV; |
|
|
623 | |
|
|
624 | if ($cv->isa (B::CV::) |
|
|
625 | && ${$cv->START} |
|
|
626 | && $cv->START->name ne "null") { |
|
|
627 | push @cv, $cv; |
|
|
628 | push @cv_source, cv2c $cv; |
|
|
629 | } |
|
|
630 | } |
|
|
631 | |
| 605 | my $ptr = source2ptr $source; |
632 | my @ptr = source2ptr @cv_source; |
| 606 | |
633 | |
|
|
634 | for (0 .. $#cv) { |
| 607 | patch_cv $cv, $ptr; |
635 | patch_cv $cv[$_], $ptr[$_]; |
|
|
636 | } |
| 608 | }; |
637 | }; |
| 609 | |
638 | |
| 610 | warn $@ if $@; |
639 | if ($@) { |
|
|
640 | $ignore{$pkg}++; |
|
|
641 | warn $@; |
|
|
642 | } |
| 611 | } |
643 | } |
| 612 | |
644 | |
| 613 | hook_entersub; |
645 | hook_entersub; |
| 614 | |
646 | |
| 615 | 1; |
647 | 1; |
| … | |
… | |
| 621 | Perl will check much less often for asynchronous signals in |
653 | Perl will check much less often for asynchronous signals in |
| 622 | Faster-compiled code. It tries to check on every function call, loop |
654 | Faster-compiled code. It tries to check on every function call, loop |
| 623 | iteration and every I/O operator, though. |
655 | iteration and every I/O operator, though. |
| 624 | |
656 | |
| 625 | The following things will disable Faster. If you manage to enable them at |
657 | The following things will disable Faster. If you manage to enable them at |
| 626 | runtime, bad things will happen. |
658 | runtime, bad things will happen. Enabling them at startup will be fine, |
|
|
659 | though. |
| 627 | |
660 | |
| 628 | enabled tainting |
661 | enabled tainting |
| 629 | enabled debugging |
662 | enabled debugging |
| 630 | |
663 | |
| 631 | This will dramatically reduce Faster's performance: |
664 | Thread-enabled builds of perl will dramatically reduce Faster's |
|
|
665 | performance, but you don't care about speed if you enable threads anyway. |
| 632 | |
666 | |
| 633 | threads (but you don't care about speed if you use threads anyway) |
|
|
| 634 | |
|
|
| 635 | These constructs will force the use of the interpreter as soon as they are |
667 | These constructs will force the use of the interpreter for the currently |
| 636 | being executed, for the rest of the currently executed: |
668 | executed function as soon as they are being encountered during execution. |
| 637 | |
669 | |
| 638 | .., ... (flipflop operators) |
|
|
| 639 | goto |
670 | goto |
| 640 | next, redo (but not well-behaved last's) |
671 | next, redo (but not well-behaved last's) |
| 641 | eval |
672 | eval |
| 642 | require |
673 | require |
| 643 | any use of formats |
674 | any use of formats |
|
|
675 | .., ... (flipflop operators) |
| 644 | |
676 | |
| 645 | =head1 AUTHOR |
677 | =head1 AUTHOR |
| 646 | |
678 | |
| 647 | Marc Lehmann <schmorp@schmorp.de> |
679 | Marc Lehmann <schmorp@schmorp.de> |
| 648 | http://home.schmorp.de/ |
680 | http://home.schmorp.de/ |
