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 sub T_SPECIAL () { 3 }
  30
  31 # Flags
  32 sub VALID_INT ()        { 0x01 }
  33 sub VALID_DOUBLE ()     { 0x02 }
  34 sub VALID_SV ()         { 0x04 }
  35 sub REGISTER ()         { 0x08 } # no implicit write-back when calling subs
  36 sub TEMPORARY ()        { 0x10 } # no implicit write-back needed at all
  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_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;
  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;
  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) = @_;
 142     runtime("$obj->{iv} = $expr;");
 143     $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
 144     $obj->{flags} |= VALID_INT;
 145 }
 146
 147 sub set_double {
 148     my ($obj, $expr) = @_;
 149     runtime("$obj->{nv} = $expr;");
 150     $obj->{flags} &= ~(VALID_SV | VALID_INT);
 151     $obj->{flags} |= VALID_DOUBLE;
 152 }
 153
 154 sub set_numeric {
 155     my ($obj, $expr) = @_;
 156     if ($obj->{type} == T_INT) {
 157         $obj->set_int($expr);
 158     } else {
 159         $obj->set_double($expr);
 160     }
 161 }
 162
 163 sub set_sv {
 164     my ($obj, $expr) = @_;
 165     runtime("SvSetSV($obj->{sv}, $expr);");
 166     $obj->invalidate;
 167     $obj->{flags} |= VALID_SV;
 168 }
 169
 170 #
 171 # Stackobj::Padsv
 172 #
 173
 174 @B::Stackobj::Padsv::ISA = 'B::Stackobj';
 175 sub B::Stackobj::Padsv::new {
 176     my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
 177     bless {
 178         type => $type,
 179         flags => VALID_SV | $extra_flags,
 180         sv => "PL_curpad[$ix]",
 181         iv => "$iname",
 182         nv => "$dname"
 183     }, $class;
 184 }
 185
 186 sub B::Stackobj::Padsv::load_int {
 187     my $obj = shift;
 188     if ($obj->{flags} & VALID_DOUBLE) {
 189         runtime("$obj->{iv} = $obj->{nv};");
 190     } else {
 191         runtime("$obj->{iv} = SvIV($obj->{sv});");
 192     }
 193     $obj->{flags} |= VALID_INT;
 194 }
 195
 196 sub B::Stackobj::Padsv::load_double {
 197     my $obj = shift;
 198     $obj->write_back;
 199     runtime("$obj->{nv} = SvNV($obj->{sv});");
 200     $obj->{flags} |= VALID_DOUBLE;
 201 }
 202
 203 sub B::Stackobj::Padsv::write_back {
 204     my $obj = shift;
 205     my $flags = $obj->{flags};
 206     return if $flags & VALID_SV;
 207     if ($flags & VALID_INT) {
 208         runtime("sv_setiv($obj->{sv}, $obj->{iv});");
 209     } elsif ($flags & VALID_DOUBLE) {
 210         runtime("sv_setnv($obj->{sv}, $obj->{nv});");
 211     } else {
 212         confess "write_back failed for lexical @{[$obj->peek]}\n";
 213     }
 214     $obj->{flags} |= VALID_SV;
 215 }
 216
 217 #
 218 # Stackobj::Const
 219 #
 220
 221 @B::Stackobj::Const::ISA = 'B::Stackobj';
 222 sub B::Stackobj::Const::new {
 223     my ($class, $sv) = @_;
 224     my $obj = bless {
 225         flags => 0,
 226         sv => $sv    # holds the SV object until write_back happens
 227     }, $class;
 228     if ( ref($sv) eq  "B::SPECIAL" ){
 229         $obj->{type}= T_SPECIAL;
 230     }else{
 231         my $svflags = $sv->FLAGS;
 232         if ($svflags & SVf_IOK) {
 233                 $obj->{flags} = VALID_INT|VALID_DOUBLE;
 234                 $obj->{type} = T_INT;
 235                 $obj->{nv} = $obj->{iv} = $sv->IV;
 236         } elsif ($svflags & SVf_NOK) {
 237                 $obj->{flags} = VALID_INT|VALID_DOUBLE;
 238                 $obj->{type} = T_DOUBLE;
 239                 $obj->{iv} = $obj->{nv} = $sv->NV;
 240         } else {
 241                 $obj->{type} = T_UNKNOWN;
 242         }
 243     }
 244     return $obj;
 245 }
 246
 247 sub B::Stackobj::Const::write_back {
 248     my $obj = shift;
 249     return if $obj->{flags} & VALID_SV;
 250     # Save the SV object and replace $obj->{sv} by its C source code name
 251     $obj->{sv} = $obj->{sv}->save;
 252     $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE;
 253 }
 254
 255 sub B::Stackobj::Const::load_int {
 256     my $obj = shift;
 257     $obj->{iv} = int($obj->{sv}->PV);
 258     $obj->{flags} |= VALID_INT;
 259 }
 260
 261 sub B::Stackobj::Const::load_double {
 262     my $obj = shift;
 263     $obj->{nv} = $obj->{sv}->PV + 0.0;
 264     $obj->{flags} |= VALID_DOUBLE;
 265 }
 266
 267 sub B::Stackobj::Const::invalidate {}
 268
 269 #
 270 # Stackobj::Bool
 271 #
 272
 273 @B::Stackobj::Bool::ISA = 'B::Stackobj';
 274 sub B::Stackobj::Bool::new {
 275     my ($class, $preg) = @_;
 276     my $obj = bless {
 277         type => T_INT,
 278         flags => VALID_INT|VALID_DOUBLE,
 279         iv => $$preg,
 280         nv => $$preg,
 281         preg => $preg           # this holds our ref to the pseudo-reg
 282     }, $class;
 283     return $obj;
 284 }
 285
 286 sub B::Stackobj::Bool::write_back {
 287     my $obj = shift;
 288     return if $obj->{flags} & VALID_SV;
 289     $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)";
 290     $obj->{flags} |= VALID_SV;
 291 }
 292
 293 # XXX Might want to handle as_double/set_double/load_double?
 294
 295 sub B::Stackobj::Bool::invalidate {}
 296
 297 1;
 298
 299 __END__
 300
 301 =head1 NAME
 302
 303 B::Stackobj - Helper module for CC backend
 304
 305 =head1 SYNOPSIS
 306
 307         use B::Stackobj;
 308
 309 =head1 DESCRIPTION
 310
 311 See F<ext/B/README>.
 312
 313 =head1 AUTHOR
 314
 315 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 316
 317 =cut