My favorites | Sign in
Project Home Wiki Issues Source
Repository:
Checkout   Browse   Changes   Clones  
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
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
# Stackobj.pm
#
# Copyright (c) 1996 Malcolm Beattie
# Copyright (c) 2010 Reini Urban
# Copyright (c) 2012 cPanel Inc
#
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the README file.
#
package B::Stackobj;

our $VERSION = '1.10';

use Exporter ();
@ISA = qw(Exporter);
@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED
VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
%EXPORT_TAGS = (
types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
flags => [
qw(VALID_INT VALID_DOUBLE VALID_SV
VALID_UNSIGNED REGISTER TEMPORARY)
]
);

use Carp qw(confess);
use strict;
use B qw(class SVf_IOK SVf_NOK SVf_IVisUV SVf_ROK);
use B::C qw(ivx nvx);
use Config;

# Types
sub T_UNKNOWN () { 0 }
sub T_DOUBLE () { 1 }
sub T_INT () { 2 }
sub T_SPECIAL () { 3 }

# Flags
sub VALID_INT () { 0x01 }
sub VALID_UNSIGNED () { 0x02 }
sub VALID_DOUBLE () { 0x04 }
sub VALID_SV () { 0x08 }
sub REGISTER () { 0x10 } # no implicit write-back when calling subs
sub TEMPORARY () { 0x20 } # no implicit write-back needed at all
sub SAVE_INT () { 0x40 } # if int part needs to be saved at all
sub SAVE_DOUBLE () { 0x80 } # if double part needs to be saved at all

#
# Callback for runtime code generation
#
my $runtime_callback = sub { confess "set_callback not yet called" };
sub set_callback (&) { $runtime_callback = shift }
sub runtime { &$runtime_callback(@_) }

#
# Methods
#

# The stack holds generally only the string ($sv->save) representation of the B object,
# for the types sv, int, double, numeric and sometimes bool.
# Special subclasses keep the B obj, like Const

sub write_back { confess "stack object does not implement write_back" }

sub invalidate {
shift->{flags} &= ~( VALID_INT | VALID_UNSIGNED | VALID_DOUBLE );
}

sub invalidate_int {
shift->{flags} &= ~( VALID_INT | VALID_UNSIGNED );
}

sub invalidate_double {
shift->{flags} &= ~( VALID_DOUBLE );
}

sub as_sv {
my $obj = shift;
if ( !( $obj->{flags} & VALID_SV ) ) {
$obj->write_back;
$obj->{flags} |= VALID_SV;
}
return $obj->{sv};
}

sub as_obj {
return shift->{obj};
}

sub as_int {
my $obj = shift;
if ( !( $obj->{flags} & VALID_INT ) ) {
$obj->load_int;
$obj->{flags} |= VALID_INT | SAVE_INT;
}
return $obj->{iv};
}

sub as_double {
my $obj = shift;
if ( !( $obj->{flags} & VALID_DOUBLE ) ) {
$obj->load_double;
$obj->{flags} |= VALID_DOUBLE | SAVE_DOUBLE;
}
return $obj->{nv};
}

sub as_numeric {
my $obj = shift;
return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
}

sub as_bool {
my $obj = shift;
if ( $obj->{flags} & VALID_INT ) {
return $obj->{iv};
}
if ( $obj->{flags} & VALID_DOUBLE ) {
return $obj->{nv};
}
return sprintf( "(SvTRUE(%s))", $obj->as_sv );
}

#
# Debugging methods
#
sub peek {
my $obj = shift;
my $type = $obj->{type};
my $flags = $obj->{flags};
my @flags;
if ( $type == T_UNKNOWN ) {
$type = "T_UNKNOWN";
}
elsif ( $type == T_INT ) {
$type = "T_INT";
}
elsif ( $type == T_DOUBLE ) {
$type = "T_DOUBLE";
}
else {
$type = "(illegal type $type)";
}
push( @flags, "VALID_INT" ) if $flags & VALID_INT;
push( @flags, "VALID_DOUBLE" ) if $flags & VALID_DOUBLE;
push( @flags, "VALID_SV" ) if $flags & VALID_SV;
push( @flags, "REGISTER" ) if $flags & REGISTER;
push( @flags, "TEMPORARY" ) if $flags & TEMPORARY;
@flags = ("none") unless @flags;
return sprintf( "%s type=$type flags=%s sv=$obj->{sv} iv=$obj->{iv} nv=$obj->{nv}",
class($obj), join( "|", @flags ) );
}

sub minipeek {
my $obj = shift;
my $type = $obj->{type};
my $flags = $obj->{flags};
if ( $type == T_INT || $flags & VALID_INT ) {
return $obj->{iv};
}
elsif ( $type == T_DOUBLE || $flags & VALID_DOUBLE ) {
return $obj->{nv};
}
else {
return $obj->{sv};
}
}

#
# Caller needs to ensure that set_int, set_double,
# set_numeric and set_sv are only invoked on legal lvalues.
#
sub set_int {
my ( $obj, $expr, $unsigned ) = @_;
my $sval;
# bullshit detector for non numeric expr, expr 'lnv0 + rnv0'
if ($expr =~ /[ a-dfzA-DF-Z]/) { # looks not like number
$sval = $expr;
} else {
$sval = B::C::ivx($expr);
$sval = $expr if $sval eq '0' and $expr;
}

runtime("$obj->{iv} = $sval;");
$obj->{flags} &= ~( VALID_SV | VALID_DOUBLE );
$obj->{flags} |= VALID_INT | SAVE_INT;
$obj->{flags} |= VALID_UNSIGNED if $unsigned;
}

sub set_double {
my ( $obj, $expr ) = @_;
my $sval;
if ($expr =~ /[ a-dfzA-DF-Z]/) { # looks not like number
$sval = $expr;
} else {
$sval = B::C::nvx($expr);
# non numeric expr, expr 'lnv0 + rnv0'
$sval = $expr if $sval eq '0.00' and $expr;
}

runtime("$obj->{nv} = $sval;");
$obj->{flags} &= ~( VALID_SV | VALID_INT );
$obj->{flags} |= VALID_DOUBLE | SAVE_DOUBLE;
}

sub set_numeric {
my ( $obj, $expr ) = @_;
if ( $obj->{type} == T_INT ) {
$obj->set_int($expr);
}
else {
$obj->set_double($expr);
}
}

sub set_sv {
my ( $obj, $expr ) = @_;
runtime("SvSetSV($obj->{sv}, $expr);");
$obj->invalidate;
$obj->{flags} |= VALID_SV;
}

#
# Stackobj::Padsv
#

@B::Stackobj::Padsv::ISA = 'B::Stackobj';

sub B::Stackobj::Padsv::new {
my ( $class, $type, $extra_flags, $ix, $iname, $dname ) = @_;
$extra_flags |= SAVE_INT if $extra_flags & VALID_INT;
$extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE;
bless {
type => $type,
flags => VALID_SV | $extra_flags,
targ => $ix,
sv => "PL_curpad[$ix]",
iv => "$iname",
nv => "$dname"
}, $class;
}

sub B::Stackobj::Padsv::as_obj {
my $obj = shift;
my @c = comppadlist->ARRAY;
my @p = $c[1]->ARRAY;
return $p[ $obj->{targ} ];
}

sub B::Stackobj::Padsv::load_int {
my $obj = shift;
if ( $obj->{flags} & VALID_DOUBLE ) {
runtime("$obj->{iv} = $obj->{nv};");
}
else {
runtime("$obj->{iv} = SvIV($obj->{sv});");
}
$obj->{flags} |= VALID_INT | SAVE_INT;
}

sub B::Stackobj::Padsv::load_double {
my $obj = shift;
$obj->write_back;
runtime("$obj->{nv} = SvNV($obj->{sv});");
$obj->{flags} |= VALID_DOUBLE | SAVE_DOUBLE;
}

sub B::Stackobj::Padsv::save_int {
my $obj = shift;
return $obj->{flags} & SAVE_INT;
}

sub B::Stackobj::Padsv::save_double {
my $obj = shift;
return $obj->{flags} & SAVE_DOUBLE;
}

sub B::Stackobj::Padsv::write_back {
my $obj = shift;
my $flags = $obj->{flags};
return if $flags & VALID_SV;
if ( $flags & VALID_INT ) {
if ( $flags & VALID_UNSIGNED ) {
runtime("sv_setuv($obj->{sv}, $obj->{iv});");
}
else {
runtime("sv_setiv($obj->{sv}, $obj->{iv});");
}
}
elsif ( $flags & VALID_DOUBLE ) {
runtime("sv_setnv($obj->{sv}, $obj->{nv});");
}
else {
confess "write_back failed for lexical @{[$obj->peek]}\n";
}
$obj->{flags} |= VALID_SV;
}

#
# Stackobj::Const
#

@B::Stackobj::Const::ISA = 'B::Stackobj';

sub B::Stackobj::Const::new {
my ( $class, $sv ) = @_;
my $obj = bless {
flags => 0,
sv => $sv, # holds the SV object until write_back happens
obj => $sv
}, $class;
if ( ref($sv) eq "B::SPECIAL" ) {
$obj->{type} = T_SPECIAL;
}
else {
my $svflags = $sv->FLAGS;
if ( $svflags & SVf_IOK ) {
$obj->{flags} = VALID_INT | VALID_DOUBLE;
$obj->{type} = T_INT;
if ( $svflags & SVf_IVisUV ) {
$obj->{flags} |= VALID_UNSIGNED;
$obj->{nv} = $obj->{iv} = $sv->UVX;
}
else {
$obj->{nv} = $obj->{iv} = $sv->IV;
}
}
elsif ( $svflags & SVf_NOK ) {
$obj->{flags} = VALID_INT | VALID_DOUBLE;
$obj->{type} = T_DOUBLE;
$obj->{iv} = $obj->{nv} = $sv->NV;
}
else {
$obj->{type} = T_UNKNOWN;
}
}
return $obj;
}

sub B::Stackobj::Const::write_back {
my $obj = shift;
return if $obj->{flags} & VALID_SV;

# Save the SV object and replace $obj->{sv} by its C source code name
$obj->{sv} = $obj->{obj}->save;
$obj->{flags} |= VALID_SV | VALID_INT | VALID_DOUBLE;
}

sub B::Stackobj::Const::load_int {
my $obj = shift;
if ( ref( $obj->{obj} ) eq "B::RV" or ($] >= 5.011 and $obj->{obj}->FLAGS & SVf_ROK)) {
$obj->{iv} = int( $obj->{obj}->RV->PV );
}
else {
$obj->{iv} = int( $obj->{obj}->PV );
}
$obj->{flags} |= VALID_INT;
}

sub B::Stackobj::Const::load_double {
my $obj = shift;
if ( ref( $obj->{obj} ) eq "B::RV" ) {
$obj->{nv} = $obj->{obj}->RV->PV + 0.0;
}
else {
$obj->{nv} = $obj->{obj}->PV + 0.0;
}
$obj->{flags} |= VALID_DOUBLE;
}

sub B::Stackobj::Const::invalidate { }

#
# Stackobj::Bool
#
;
@B::Stackobj::Bool::ISA = 'B::Stackobj';

sub B::Stackobj::Bool::new {
my ( $class, $preg ) = @_;
my $obj = bless {
type => T_INT,
flags => VALID_INT | VALID_DOUBLE,
iv => $$preg,
nv => $$preg,
obj => $preg # this holds our ref to the pseudo-reg
}, $class;
return $obj;
}

sub B::Stackobj::Bool::write_back {
my $obj = shift;
return if $obj->{flags} & VALID_SV;
$obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)";
$obj->{flags} |= VALID_SV;
}

# XXX Might want to handle as_double/set_double/load_double?

sub B::Stackobj::Bool::invalidate { }

#
# Stackobj::Aelem
#

@B::Stackobj::Aelem::ISA = 'B::Stackobj';

sub B::Stackobj::Aelem::new {
my ( $class, $av, $ix, $lvalue ) = @_;
my $sv;
# pop ix before av
if ($av eq 'POPs' and $ix eq 'POPi') {
$sv = "({ oldsave = SvIVX(POPs); AvARRAY(POPs)[oldsave]; })";
} else {
$sv = "AvARRAY($av)[$ix]";
}
my $obj = bless {
type => T_UNKNOWN,
flags => VALID_INT | VALID_DOUBLE | VALID_SV,
iv => "SvIVX($sv)",
nv => "SvNVX($sv)",
sv => "$sv",
lvalue => $lvalue,
}, $class;
return $obj;
}

sub B::Stackobj::Aelem::write_back {
my $obj = shift;
$obj->{flags} |= VALID_SV | VALID_INT | VALID_DOUBLE;
}

sub B::Stackobj::Aelem::invalidate { }

1;

__END__

=head1 NAME

B::Stackobj - Stack and type annotation helper module for the CC backend

=head1 SYNOPSIS

use B::Stackobj;

=head1 DESCRIPTION

A simple representation of pp stacks and lexical pads for the B::CC compiler.
All locals and function arguments get type annotated, for all B::CC ops which
can be optimized.

For lexical pads (i.e. my or better our variables) we currently can force the type of
variables according to a magic naming scheme in L<B::CC/load_pad>.

my $<name>_i; IV integer
my $<name>_ir; IV integer in a pseudo register
my $<name>_d; NV double

Future ideas are B<type qualifiers> as attributes

B<double>, B<int>, B<register>, B<temp>, B<unsigned>, B<ro>

such as in

our int $i : unsigned : ro;
our double $d;

Type attributes for sub definitions are not spec'ed yet.
L<Ctypes> attributes and objects should also be recognized, such as
C<c_int> and C<c_double>.

B<my vs our>: Note that only B<our> attributes are resolved at B<compile-time>,
B<my> attributes are resolved at B<run-time>. So the compiler will only see
type attributes for our variables.

See L<B::CC/load_pad> and L<types>.

TODO: Represent on this stack not only PADs,SV,IV,PV,NV,BOOL,Special
and a SV const, but also GV,CV,RV,AV,HV, esp. AELEM and HELEM.
Use B::Stackobj::Const.

=head1 AUTHOR

Malcolm Beattie C<MICB at cpan.org> I<(retired)>,
Reini Urban C<rurban at cpan.org>

=cut

# Local Variables:
# mode: cperl
# cperl-indent-level: 2
# fill-column: 78
# End:
# vim: expandtab shiftwidth=2:

Change log

d6185482ae29 by Reini Urban <rur...@cpanel.net> on Oct 17, 2012   Diff
CC, C: protect from some compiler warnings
for uninitialized vars

perl5.14.3-nt -Mblib -MO=CC,-fno-destruct
,-fno-magic,-fno-taint,-Uwarnings,-UB,-UCa
rp,-DspCG,-v,-otakfp.perl.c
../shootout/bench/takfp/takfp.perl
Go to: 
Project members, sign in to write a code review

Older revisions

06d5b7bd0c9a by Reini Urban <rur...@cpanel.net> on Oct 11, 2012   Diff
CC: simplify B::Stackobj::Aelem::new

We need to pop ix before av, but
detect that now in the constructor
9024278287e1 by Reini Urban <rur...@cpanel.net> on Oct 9, 2012   Diff
CC: check AvARRAY(POPs)[POPi]
0076fb5bf0fb by Reini Urban <rur...@cpanel.net> on Oct 9, 2012   Diff
CC: optimize aelem, add -fno-
autovivify, add Stackobj::as_obj

On known stack elements aelem can now
be as fast as aelemfast.
...
All revisions of this file

File info

Size: 11580 bytes, 495 lines
Powered by Google Project Hosting