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