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 SVf_IOK SVf_NOK);
  20
  21 # Types
  22 sub T_UNKNOWN () { 0 }
  23 sub T_DOUBLE ()  { 1 }
  24 sub T_INT ()     { 2 }
  25 sub T_SPECIAL () { 3 }
  26
  27 # Flags
  28 sub VALID_INT ()        { 0x01 }
  29 sub VALID_DOUBLE ()     { 0x02 }
  30 sub VALID_SV ()         { 0x04 }
  31 sub REGISTER ()         { 0x08 } # no implicit write-back when calling subs
  32 sub TEMPORARY ()        { 0x10 } # no implicit write-back needed at all
  33 sub SAVE_INT ()         { 0x20 } #if int part needs to be saved at all
  34 sub SAVE_DOUBLE ()      { 0x40 } #if double part needs to be saved at all
  35
  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|SAVE_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|SAVE_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 sub as_bool {
  85         my $obj=shift;
  86         if ($obj->{flags} & VALID_INT ){
  87                 return $obj->{iv};
  88         }
  89         if ($obj->{flags} & VALID_DOUBLE ){
  90                 return $obj->{nv};
  91         }
  92         return sprintf("(SvTRUE(%s))", $obj->as_sv) ;
  93 }
  94
  95 #
  96 # Debugging methods
  97 #
  98 sub peek {
  99     my $obj = shift;
 100     my $type = $obj->{type};
 101     my $flags = $obj->{flags};
 102     my @flags;
 103     if ($type == T_UNKNOWN) {
 104         $type = "T_UNKNOWN";
 105     } elsif ($type == T_INT) {
 106         $type = "T_INT";
 107     } elsif ($type == T_DOUBLE) {
 108         $type = "T_DOUBLE";
 109     } else {
 110         $type = "(illegal type $type)";
 111     }
 112     push(@flags, "VALID_INT") if $flags & VALID_INT;
 113     push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE;
 114     push(@flags, "VALID_SV") if $flags & VALID_SV;
 115     push(@flags, "REGISTER") if $flags & REGISTER;
 116     push(@flags, "TEMPORARY") if $flags & TEMPORARY;
 117     @flags = ("none") unless @flags;
 118     return sprintf("%s type=$type flags=%s sv=$obj->{sv}",
 119                    class($obj), join("|", @flags));
 120 }
 121
 122 sub minipeek {
 123     my $obj = shift;
 124     my $type = $obj->{type};
 125     my $flags = $obj->{flags};
 126     if ($type == T_INT || $flags & VALID_INT) {
 127         return $obj->{iv};
 128     } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) {
 129         return $obj->{nv};
 130     } else {
 131         return $obj->{sv};
 132     }
 133 }
 134
 135 #
 136 # Caller needs to ensure that set_int, set_double,
 137 # set_numeric and set_sv are only invoked on legal lvalues.
 138 #
 139 sub set_int {
 140     my ($obj, $expr) = @_;
 141     runtime("$obj->{iv} = $expr;");
 142     $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
 143     $obj->{flags} |= VALID_INT|SAVE_INT;
 144 }
 145
 146 sub set_double {
 147     my ($obj, $expr) = @_;
 148     runtime("$obj->{nv} = $expr;");
 149     $obj->{flags} &= ~(VALID_SV | VALID_INT);
 150     $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
 151 }
 152
 153 sub set_numeric {
 154     my ($obj, $expr) = @_;
 155     if ($obj->{type} == T_INT) {
 156         $obj->set_int($expr);
 157     } else {
 158         $obj->set_double($expr);
 159     }
 160 }
 161
 162 sub set_sv {
 163     my ($obj, $expr) = @_;
 164     runtime("SvSetSV($obj->{sv}, $expr);");
 165     $obj->invalidate;
 166     $obj->{flags} |= VALID_SV;
 167 }
 168
 169 #
 170 # Stackobj::Padsv
 171 #
 172
 173 @B::Stackobj::Padsv::ISA = 'B::Stackobj';
 174 sub B::Stackobj::Padsv::new {
 175     my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
 176     $extra_flags |= SAVE_INT if $extra_flags & VALID_INT;
 177     $extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE;
 178     bless {
 179         type => $type,
 180         flags => VALID_SV | $extra_flags,
 181         sv => "PL_curpad[$ix]",
 182         iv => "$iname",
 183         nv => "$dname"
 184     }, $class;
 185 }
 186
 187 sub B::Stackobj::Padsv::load_int {
 188     my $obj = shift;
 189     if ($obj->{flags} & VALID_DOUBLE) {
 190         runtime("$obj->{iv} = $obj->{nv};");
 191     } else {
 192         runtime("$obj->{iv} = SvIV($obj->{sv});");
 193     }
 194     $obj->{flags} |= VALID_INT|SAVE_INT;
 195 }
 196
 197 sub B::Stackobj::Padsv::load_double {
 198     my $obj = shift;
 199     $obj->write_back;
 200     runtime("$obj->{nv} = SvNV($obj->{sv});");
 201     $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
 202 }
 203 sub B::Stackobj::Padsv::save_int {
 204     my $obj = shift;
 205     return $obj->{flags} & SAVE_INT;
 206 }
 207
 208 sub B::Stackobj::Padsv::save_double {
 209     my $obj = shift;
 210     return $obj->{flags} & SAVE_DOUBLE;
 211 }
 212
 213 sub B::Stackobj::Padsv::write_back {
 214     my $obj = shift;
 215     my $flags = $obj->{flags};
 216     return if $flags & VALID_SV;
 217     if ($flags & VALID_INT) {
 218         runtime("sv_setiv($obj->{sv}, $obj->{iv});");
 219     } elsif ($flags & VALID_DOUBLE) {
 220         runtime("sv_setnv($obj->{sv}, $obj->{nv});");
 221     } else {
 222         confess "write_back failed for lexical @{[$obj->peek]}\n";
 223     }
 224     $obj->{flags} |= VALID_SV;
 225 }
 226
 227 #
 228 # Stackobj::Const
 229 #
 230
 231 @B::Stackobj::Const::ISA = 'B::Stackobj';
 232 sub B::Stackobj::Const::new {
 233     my ($class, $sv) = @_;
 234     my $obj = bless {
 235         flags => 0,
 236         sv => $sv    # holds the SV object until write_back happens
 237     }, $class;
 238     if ( ref($sv) eq  "B::SPECIAL" ){
 239         $obj->{type}= T_SPECIAL;
 240     }else{
 241         my $svflags = $sv->FLAGS;
 242         if ($svflags & SVf_IOK) {
 243                 $obj->{flags} = VALID_INT|VALID_DOUBLE;
 244                 $obj->{type} = T_INT;
 245                 $obj->{nv} = $obj->{iv} = $sv->IV;
 246         } elsif ($svflags & SVf_NOK) {
 247                 $obj->{flags} = VALID_INT|VALID_DOUBLE;
 248                 $obj->{type} = T_DOUBLE;
 249                 $obj->{iv} = $obj->{nv} = $sv->NV;
 250         } else {
 251                 $obj->{type} = T_UNKNOWN;
 252         }
 253     }
 254     return $obj;
 255 }
 256
 257 sub B::Stackobj::Const::write_back {
 258     my $obj = shift;
 259     return if $obj->{flags} & VALID_SV;
 260     # Save the SV object and replace $obj->{sv} by its C source code name
 261     $obj->{sv} = $obj->{sv}->save;
 262     $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE;
 263 }
 264
 265 sub B::Stackobj::Const::load_int {
 266     my $obj = shift;
 267     if (ref($obj->{sv}) eq "B::RV"){
 268        $obj->{iv} = int($obj->{sv}->RV->PV);
 269     }else{
 270        $obj->{iv} = int($obj->{sv}->PV);
 271     }
 272     $obj->{flags} |= VALID_INT;
 273 }
 274
 275 sub B::Stackobj::Const::load_double {
 276     my $obj = shift;
 277     if (ref($obj->{sv}) eq "B::RV"){
 278         $obj->{nv} = $obj->{sv}->RV->PV + 0.0;
 279     }else{
 280         $obj->{nv} = $obj->{sv}->PV + 0.0;
 281     }
 282     $obj->{flags} |= VALID_DOUBLE;
 283 }
 284
 285 sub B::Stackobj::Const::invalidate {}
 286
 287 #
 288 # Stackobj::Bool
 289 #
 290
 291 @B::Stackobj::Bool::ISA = 'B::Stackobj';
 292 sub B::Stackobj::Bool::new {
 293     my ($class, $preg) = @_;
 294     my $obj = bless {
 295         type => T_INT,
 296         flags => VALID_INT|VALID_DOUBLE,
 297         iv => $$preg,
 298         nv => $$preg,
 299         preg => $preg           # this holds our ref to the pseudo-reg
 300     }, $class;
 301     return $obj;
 302 }
 303
 304 sub B::Stackobj::Bool::write_back {
 305     my $obj = shift;
 306     return if $obj->{flags} & VALID_SV;
 307     $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)";
 308     $obj->{flags} |= VALID_SV;
 309 }
 310
 311 # XXX Might want to handle as_double/set_double/load_double?
 312
 313 sub B::Stackobj::Bool::invalidate {}
 314
 315 1;
 316
 317 __END__
 318
 319 =head1 NAME
 320
 321 B::Stackobj - Helper module for CC backend
 322
 323 =head1 SYNOPSIS
 324
 325         use B::Stackobj;
 326
 327 =head1 DESCRIPTION
 328
 329 See F<ext/B/README>.
 330
 331 =head1 AUTHOR
 332
 333 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 334
 335 =cut