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