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