ext/B/B/Stackobj.pm

   1 #      Stackobj.pm
   2 #
   3 #      Copyright (c) 1996 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::Stackobj;
   9 use Exporter ();
  10 @ISA = qw(Exporter);
  11 @EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT
  12                 VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
  13 %EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
  14                 flags => [qw(VALID_INT VALID_DOUBLE VALID_SV
  15                              REGISTER TEMPORARY)]);
  16
  17 use Carp qw(confess);
  18 use strict;
  19 use B qw(class);
  20
  21 # Perl internal constants that I should probably define elsewhere.
  22 sub SVf_IOK () { 0x10000 }
  23 sub SVf_NOK () { 0x20000 }
  24
  25 # Types
  26 sub T_UNKNOWN () { 0 }
  27 sub T_DOUBLE ()  { 1 }
  28 sub T_INT ()     { 2 }
  29
  30 # Flags
  31 sub VALID_INT ()        { 0x01 }
  32 sub VALID_DOUBLE ()     { 0x02 }
  33 sub VALID_SV ()         { 0x04 }
  34 sub REGISTER ()         { 0x08 } # no implicit write-back when calling subs
  35 sub TEMPORARY ()        { 0x10 } # no implicit write-back needed at all
  36
  37 #
  38 # Callback for runtime code generation
  39 #
  40 my $runtime_callback = sub { confess "set_callback not yet called" };
  41 sub set_callback (&) { $runtime_callback = shift }
  42 sub runtime { &$runtime_callback(@_) }
  43
  44 #
  45 # Methods
  46 #
  47
  48 sub write_back { confess "stack object does not implement write_back" }
  49
  50 sub invalidate { shift->{flags} &= ~(VALID_INT | VALID_DOUBLE) }
  51
  52 sub as_sv {
  53     my $obj = shift;
  54     if (!($obj->{flags} & VALID_SV)) {
  55         $obj->write_back;
  56         $obj->{flags} |= VALID_SV;
  57     }
  58     return $obj->{sv};
  59 }
  60
  61 sub as_int {
  62     my $obj = shift;
  63     if (!($obj->{flags} & VALID_INT)) {
  64         $obj->load_int;
  65         $obj->{flags} |= VALID_INT;
  66     }
  67     return $obj->{iv};
  68 }
  69
  70 sub as_double {
  71     my $obj = shift;
  72     if (!($obj->{flags} & VALID_DOUBLE)) {
  73         $obj->load_double;
  74         $obj->{flags} |= VALID_DOUBLE;
  75     }
  76     return $obj->{nv};
  77 }
  78
  79 sub as_numeric {
  80     my $obj = shift;
  81     return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
  82 }
  83
  84 #
  85 # Debugging methods
  86 #
  87 sub peek {
  88     my $obj = shift;
  89     my $type = $obj->{type};
  90     my $flags = $obj->{flags};
  91     my @flags;
  92     if ($type == T_UNKNOWN) {
  93         $type = "T_UNKNOWN";
  94     } elsif ($type == T_INT) {
  95         $type = "T_INT";
  96     } elsif ($type == T_DOUBLE) {
  97         $type = "T_DOUBLE";
  98     } else {
  99         $type = "(illegal type $type)";
 100     }
 101     push(@flags, "VALID_INT") if $flags & VALID_INT;
 102     push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE;
 103     push(@flags, "VALID_SV") if $flags & VALID_SV;
 104     push(@flags, "REGISTER") if $flags & REGISTER;
 105     push(@flags, "TEMPORARY") if $flags & TEMPORARY;
 106     @flags = ("none") unless @flags;
 107     return sprintf("%s type=$type flags=%s sv=$obj->{sv}",
 108                    class($obj), join("|", @flags));
 109 }
 110
 111 sub minipeek {
 112     my $obj = shift;
 113     my $type = $obj->{type};
 114     my $flags = $obj->{flags};
 115     if ($type == T_INT || $flags & VALID_INT) {
 116         return $obj->{iv};
 117     } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) {
 118         return $obj->{nv};
 119     } else {
 120         return $obj->{sv};
 121     }
 122 }
 123
 124 #
 125 # Caller needs to ensure that set_int, set_double,
 126 # set_numeric and set_sv are only invoked on legal lvalues.
 127 #
 128 sub set_int {
 129     my ($obj, $expr) = @_;
 130     runtime("$obj->{iv} = $expr;");
 131     $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
 132     $obj->{flags} |= VALID_INT;
 133 }
 134
 135 sub set_double {
 136     my ($obj, $expr) = @_;
 137     runtime("$obj->{nv} = $expr;");
 138     $obj->{flags} &= ~(VALID_SV | VALID_INT);
 139     $obj->{flags} |= VALID_DOUBLE;
 140 }
 141
 142 sub set_numeric {
 143     my ($obj, $expr) = @_;
 144     if ($obj->{type} == T_INT) {
 145         $obj->set_int($expr);
 146     } else {
 147         $obj->set_double($expr);
 148     }
 149 }
 150
 151 sub set_sv {
 152     my ($obj, $expr) = @_;
 153     runtime("SvSetSV($obj->{sv}, $expr);");
 154     $obj->invalidate;
 155     $obj->{flags} |= VALID_SV;
 156 }
 157
 158 #
 159 # Stackobj::Padsv
 160 #
 161
 162 @B::Stackobj::Padsv::ISA = 'B::Stackobj';
 163 sub B::Stackobj::Padsv::new {
 164     my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
 165     bless {
 166         type => $type,
 167         flags => VALID_SV | $extra_flags,
 168         sv => "PL_curpad[$ix]",
 169         iv => "$iname",
 170         nv => "$dname"
 171     }, $class;
 172 }
 173
 174 sub B::Stackobj::Padsv::load_int {
 175     my $obj = shift;
 176     if ($obj->{flags} & VALID_DOUBLE) {
 177         runtime("$obj->{iv} = $obj->{nv};");
 178     } else {
 179         runtime("$obj->{iv} = SvIV($obj->{sv});");
 180     }
 181     $obj->{flags} |= VALID_INT;
 182 }
 183
 184 sub B::Stackobj::Padsv::load_double {
 185     my $obj = shift;
 186     $obj->write_back;
 187     runtime("$obj->{nv} = SvNV($obj->{sv});");
 188     $obj->{flags} |= VALID_DOUBLE;
 189 }
 190
 191 sub B::Stackobj::Padsv::write_back {
 192     my $obj = shift;
 193     my $flags = $obj->{flags};
 194     return if $flags & VALID_SV;
 195     if ($flags & VALID_INT) {
 196         runtime("sv_setiv($obj->{sv}, $obj->{iv});");
 197     } elsif ($flags & VALID_DOUBLE) {
 198         runtime("sv_setnv($obj->{sv}, $obj->{nv});");
 199     } else {
 200         confess "write_back failed for lexical @{[$obj->peek]}\n";
 201     }
 202     $obj->{flags} |= VALID_SV;
 203 }
 204
 205 #
 206 # Stackobj::Const
 207 #
 208
 209 @B::Stackobj::Const::ISA = 'B::Stackobj';
 210 sub B::Stackobj::Const::new {
 211     my ($class, $sv) = @_;
 212     my $obj = bless {
 213         flags => 0,
 214         sv => $sv    # holds the SV object until write_back happens
 215     }, $class;
 216     my $svflags = $sv->FLAGS;
 217     if ($svflags & SVf_IOK) {
 218         $obj->{flags} = VALID_INT|VALID_DOUBLE;
 219         $obj->{type} = T_INT;
 220         $obj->{nv} = $obj->{iv} = $sv->IV;
 221     } elsif ($svflags & SVf_NOK) {
 222         $obj->{flags} = VALID_INT|VALID_DOUBLE;
 223         $obj->{type} = T_DOUBLE;
 224         $obj->{iv} = $obj->{nv} = $sv->NV;
 225     } else {
 226         $obj->{type} = T_UNKNOWN;
 227     }
 228     return $obj;
 229 }
 230
 231 sub B::Stackobj::Const::write_back {
 232     my $obj = shift;
 233     return if $obj->{flags} & VALID_SV;
 234     # Save the SV object and replace $obj->{sv} by its C source code name
 235     $obj->{sv} = $obj->{sv}->save;
 236     $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE;
 237 }
 238
 239 sub B::Stackobj::Const::load_int {
 240     my $obj = shift;
 241     $obj->{iv} = int($obj->{sv}->PV);
 242     $obj->{flags} |= VALID_INT;
 243 }
 244
 245 sub B::Stackobj::Const::load_double {
 246     my $obj = shift;
 247     $obj->{nv} = $obj->{sv}->PV + 0.0;
 248     $obj->{flags} |= VALID_DOUBLE;
 249 }
 250
 251 sub B::Stackobj::Const::invalidate {}
 252
 253 #
 254 # Stackobj::Bool
 255 #
 256
 257 @B::Stackobj::Bool::ISA = 'B::Stackobj';
 258 sub B::Stackobj::Bool::new {
 259     my ($class, $preg) = @_;
 260     my $obj = bless {
 261         type => T_INT,
 262         flags => VALID_INT|VALID_DOUBLE,
 263         iv => $$preg,
 264         nv => $$preg,
 265         preg => $preg           # this holds our ref to the pseudo-reg
 266     }, $class;
 267     return $obj;
 268 }
 269
 270 sub B::Stackobj::Bool::write_back {
 271     my $obj = shift;
 272     return if $obj->{flags} & VALID_SV;
 273     $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)";
 274     $obj->{flags} |= VALID_SV;
 275 }
 276
 277 # XXX Might want to handle as_double/set_double/load_double?
 278
 279 sub B::Stackobj::Bool::invalidate {}
 280
 281 1;
 282
 283 __END__
 284
 285 =head1 NAME
 286
 287 B::Stackobj - Helper module for CC backend
 288
 289 =head1 SYNOPSIS
 290
 291         use B::Stackobj;
 292
 293 =head1 DESCRIPTION
 294
 295 See F<ext/B/README>.
 296
 297 =head1 AUTHOR
 298
 299 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 300
 301 =cut