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