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