diff options
Diffstat (limited to 'org.eclipse.debug.examples.core/pdavm/pda.pl')
| -rw-r--r-- | org.eclipse.debug.examples.core/pdavm/pda.pl | 678 |
1 files changed, 0 insertions, 678 deletions
diff --git a/org.eclipse.debug.examples.core/pdavm/pda.pl b/org.eclipse.debug.examples.core/pdavm/pda.pl deleted file mode 100644 index de0866eba..000000000 --- a/org.eclipse.debug.examples.core/pdavm/pda.pl +++ /dev/null @@ -1,678 +0,0 @@ -#!perl.exe - -use strict; -use warnings; -use IO::Socket; - -##################################################################### -# Copyright (c) 2005, 2008 IBM Corporation and others. -# All rights reserved. This program and the accompanying materials -# are made available under the terms of the Eclipse Public License v1.0 -# which accompanies this distribution, and is available at -# http://www.eclipse.org/legal/epl-v10.html -# -# Contributors: -# Bjorn Freeman-Benson - initial API and implementation -# Pawel Piech - WindRiver Systems - Bug 217211: PDA example debugger does not run on linux -##################################################################### - -##################################################################### -# # -# I N I T I A L I Z A T I O N A N D V A R I A B L E S # -# # -##################################################################### -# -# The push down automata stack (the data stack) -# -my @stack; -# -# Load all the code into memory -# The code is stored as an array of strings, each line of -# the source file being one entry in the array. -# -my $filename = shift; -open INFILE, $filename or die $!; -my @code = <INFILE>; -close INFILE; - -my %labels; -sub map_labels { - # - # A mapping of labels to indicies in the code array - # - %labels = ( ); - my $idx = 0; - while( $idx <= $#code ) { - if( length $code[$idx] > 0 ) { - $code[$idx] =~ /^\s*(.+?)\s*$/; - $code[$idx] = $1; - $labels{$1} = $idx if( $code[$idx] =~ /^:(\S+)/ ); - } else { - $code[$idx] = "\n"; - } - $idx ++; - } -} -map_labels(); -# -# The stack of stack frames (the control stack) -# Each stack frame is a mapping of variable names to values. -# There are a number of special variable names: -# _pc_ is the current program counter in the frame -# the pc points to the next instruction to be executed -# _func_ is the name of the function in this frame -# -my @frames; -my $currentframe; -$currentframe = { - _pc_ => 0, - _func_ => 'main' - }; - -# -# The command line argument to start a debug session. -# -my $debugflag = shift; -# -# The port to listen for debug commands on -# and the port to send debug events to -# -my $debugport; -my $debugport2; -# -# The socket to listen for debug commands on -# and the socket to send debug events on -# -my $debugsock; -my $debugsock2; -# -# An input buffer -# -my $debugbuf; -# -# Breakpoint array -# breakpoints are stored as a boolean for each line of code -# if the boolean is true, there is a breakpoint on that line -# -my @breakpoints; -# -# Mapping of debugger commands to functions that evaluate them -# -my %debug_commands = ( - clear => \&debug_clear_breakpoint, - data => \&debug_data, - drop => \&debug_drop_frame, - eval => \&debug_eval, - eventstop => \&debug_event_stop, - exit => \&debug_exit, - popdata => \&debug_pop, - pushdata => \&debug_push, - resume => \&debug_resume, - set => \&debug_set_breakpoint, - setdata => \&debug_set_data, - setvar => \&debug_set_variable, - stack => \&debug_stack, - step => \&debug_step, - stepreturn => \&debug_step_return, - suspend => \&debug_suspend, - var => \&debug_var, - watch => \&debug_watch -); - -# -# The run flag is true if the VM is running. -# If the run flag is false, the VM exits the -# next time the main instruction loop runs. -# -my $run = 1; -# -# The suspend flag is true if the VM should suspend -# running the program and just listen for debug commands. -# -my $suspend = 0; -my $started = 1; -$suspend = "client" if( $debugflag ); -# -# The step flag is used to control single-stepping. -# See the implementation of the "step" debug command. -# The stepreturn flag is used to control step-return. -# The eventstops table holds which events cause suspends and which do not. -# The watchpoints table holds watchpoint information. -# variablename_stackframedepth => N -# N = 0 is no watch -# N = 1 is read watch -# N = 2 is write watch -# N = 3 is both, etc. -# -my $step = 0; -my $stepreturn = 0; -my %eventstops = ( "unimpinstr" => 0, - "nosuchlabel" => 0, - ); -my %watchpoints = ( ); - -# -# Mapping of the names of the instructions to the functions that evaluate them -# -my %instructions = ( - add => \&add, - branch_not_zero => \&branch_not_zero, - call => \&call, - dec => \&dec, - dup => \&dup, - halt => \&halt, - output => \&output, - pop => \&ipop, - push => \&ipush, - return => \&ireturn, - var => \&var, - xyzzy => \&internal_end_eval, -); - -##################################################################### -# # -# M A I N I N T E R P R E T E R # -# # -##################################################################### -# -# Open a debug session if the command line argument is given. -# -start_debugger(); -send_debug_event( "started", 0 ); -debug_ui() if( $suspend ); -# -# The main run loop -# -while( $run ) { - check_for_breakpoint(); - debug_ui() if( $suspend ); - yield_to_debug(); - my $instruction = fetch_instruction(); - increment_pc(); - do_one_instruction($instruction); - if( $$currentframe{_pc_} > $#code ) { - $run = 0; - } elsif( $stepreturn ) { - $instruction = fetch_instruction(); - $suspend = "step" if( is_return_instruction($instruction) ); - } -} -send_debug_event( "terminated", 0 ); - -sub fetch_instruction { - my $pc = $$currentframe{_pc_}; - my $theinstruction = $code[$pc]; - return $theinstruction; -} -sub is_return_instruction { - my $theinstruction = shift; - if( $theinstruction =~ /^:/ ) { - return 0; - } elsif( $theinstruction =~ /^#/ ) { - return 0; - } else { - $theinstruction =~ /^(\S+)\s*(.*)/; - return $1 eq "return"; - } -} -sub increment_pc { - my $pc = $$currentframe{_pc_}; - $pc++; - $$currentframe{_pc_} = $pc; -} -sub decrement_pc { - my $pc = $$currentframe{_pc_}; - $pc--; - $$currentframe{_pc_} = $pc; -} -sub do_one_instruction { - my $theinstruction = shift; - if( $theinstruction =~ /^:/ ) { - # label - $suspend = "step" if( $step ); - } elsif( $theinstruction =~ /^#/ ) { - # comment - } else { - $theinstruction =~ /^(\S+)\s*(.*)/; - my $op = $1; - my $instr = $instructions{$op}; - if( $instr ) { - &$instr( $theinstruction, $2 ); - $suspend = "step" if( $step ); - } else { - send_debug_event( "unimplemented instruction $op", 1 ); - if( $eventstops{"unimpinstr"} ) { - $suspend = "event unimpinstr"; - decrement_pc(); - } - } - } -} - -##################################################################### -# # -# I N S T R U C T I O N S # -# # -##################################################################### -sub add { - my $val1 = pop @stack; - my $val2 = pop @stack; - my $val = $val1 + $val2; - push @stack, $val; -} - -sub branch_not_zero { - my $val = pop @stack; - if( $val ) { - shift; - my $label = shift; - my $dest = $labels{$label}; - if( !defined $dest ) { - send_debug_event( "no such label $label", 1 ); - if( $eventstops{"nosuchlabel"} ) { - $suspend = "event nosuchlabel"; - push @stack, $val; - decrement_pc(); - } - } else { - $$currentframe{_pc_} = $dest; - } - } -} - -sub call { - shift; - my $label = shift; - my $dest = $labels{$label}; - if( !defined $dest ) { - send_debug_event( "no such label $label", 1 ); - if( $eventstops{"nosuchlabel"} ) { - $suspend = "event nosuchlabel"; - decrement_pc(); - } - } else { - push @frames, $currentframe; - $currentframe = { - _pc_ => $dest, - _func_ => $label - }; - } -} - -sub dec { - my $val = pop @stack; - $val--; - push @stack, $val; -} - -sub dup { - my $val = pop @stack; - push @stack, $val; - push @stack, $val; -} - -sub halt { - $run = 0; -} - -sub output { - my $val = pop @stack; - print "$val\n"; -} - -sub ipop { - shift; - my $arg = shift; - if( $arg =~ /^\$(.*)/ ) { - $$currentframe{$1} = pop @stack; - my $key = "$$currentframe{_func_}\:\:$1"; - if( defined $watchpoints{$key} ) { - if( $watchpoints{$key} & 2 ) { - $suspend = "watch write $key"; - } - } - } else { - pop @stack; - } -} - -sub ipush { - shift; - my $arg = shift; - if( $arg =~ /^\$(.*)/ ) { - my $val = $$currentframe{$1}; - push @stack, $val; - my $key = "$$currentframe{_func_}\:\:$1"; - if( defined $watchpoints{$key} ) { - if( $watchpoints{$key} & 1 ) { - $suspend = "watch read $key"; - } - } - } else { - push @stack, $arg; - } -} - -sub ireturn { - $currentframe = pop @frames; -} - -sub var { - shift; - my $name = shift; - $$currentframe{$name} = 0; -} - -##################################################################### -# # -# D E B U G G E R I N T E R F A C E # -# # -##################################################################### - -sub check_for_breakpoint { - if( $debugflag ) { - my $pc = $$currentframe{_pc_}; - if( $breakpoints[$pc] ) { - $suspend = "breakpoint $pc" unless $suspend eq "eval"; - } - } -} -# -# For each instruction, we check the debug co-routine for -# control input. If there is input, we process it. -# -sub yield_to_debug { - if( $debugflag ) { - my $bytes_to_read = 1024; - my $bytes_read = sysread($debugsock, $debugbuf, $bytes_to_read); - if( defined($bytes_read) ) { - #print "read $bytes_to_read\n"; - my $rin = ''; - my $win = ''; - my $ein = ''; - vec($rin,fileno($debugsock),1) = 1; - $ein = $rin | $win; - my $debugline = $debugbuf; - while( !($debugline =~ /\n/) ) { - select($rin, undef, undef, undef); - my $bytes_to_read = 1024; - my $bytes_read = sysread($debugsock, $debugbuf, $bytes_to_read); - $debugline .= $debugbuf; - } - #print "read: $debugline"; - process_debug_command($debugline); - $debugline = ''; - } else { - # no bytes read - } - } -} - -# -# If the execution is suspended, then we go into the debug -# ui loop, reading and processing instructions. -# -sub debug_ui { - return unless( $suspend ); - my $pc = $$currentframe{_pc_}; - if (!$started) { - send_debug_event( "suspended $suspend", 0 ); - } else { - $started = 0; - } - $step = 0; - $stepreturn = 0; - my $rin = ''; - my $win = ''; - my $ein = ''; - vec($rin,fileno($debugsock),1) = 1; - $ein = $rin | $win; - my $debugline = ''; - while( $suspend ) { - select($rin, undef, undef, undef); - my $bytes_to_read = 1024; - my $bytes_read = sysread($debugsock, $debugbuf, $bytes_to_read); - $debugline .= $debugbuf; - if( $debugline =~ /\n/ ) { - #print "read: $debugline"; - process_debug_command($debugline); - $debugline = ''; - } - } - send_debug_event( "resumed step", 0 ) if( $step ); - send_debug_event( "resumed client", 0 ) unless( $step ); -} - -sub process_debug_command { - my $line = shift; - return if( length $line < 2 ); - my @words = split /\s/, $line; - my $command = lc($words[0]); - my $dfunc = $debug_commands{$words[0]}; - if( $dfunc ) { - &$dfunc( @words ); - } -} - -sub debug_clear_breakpoint { - shift; - my $line = shift; - $breakpoints[$line] = 0; - print $debugsock "ok\n"; -} -my @saved_code; -my %saved_labels; -my $saved_pc; -sub debug_eval { - shift; - my $code = shift; - my @lines = split /\|/, $code; - my $newpc = scalar @code; - @saved_code = @code; - %saved_labels = %labels; - foreach my $line ( @lines ) { - $line =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; - push @code, $line; - } - push @code, "xyzzy"; - map_labels(); - $saved_pc = $$currentframe{_pc_}; - $$currentframe{_pc_} = $newpc; - print $debugsock "ok\n"; - $suspend = 0; -} -sub internal_end_eval { - my $result = pop @stack; - @code = @saved_code; - %labels = %saved_labels; - $$currentframe{_pc_} = $saved_pc; - send_debug_event( "evalresult $result", 0 ); - $suspend = "eval"; -} - -sub debug_data { - my $result = ''; - foreach my $d ( @stack ) { - $result .= $d . '|'; - } - print $debugsock "$result\n"; -} -sub debug_drop_frame { - ireturn(); - decrement_pc(); - print $debugsock "ok\n"; - send_debug_event( "resumed drop", 0 ); - send_debug_event( "suspended drop", 0 ); -} -sub debug_event_stop { - shift; - my $event = shift; - my $bool = shift; - $eventstops{$event} = $bool; - print $debugsock "ok\n"; -} -sub debug_exit { - print $debugsock "ok\n"; - send_debug_event( "terminated", 0 ); - exit 0; -} -sub debug_pop { - pop @stack; - print $debugsock "ok\n"; -} -sub debug_push { - shift; - my $value = shift; - push @stack, $value; - print $debugsock "ok\n"; -} -sub debug_resume { - $suspend = 0; - print $debugsock "ok\n"; -} -sub debug_set_breakpoint { - shift; - my $line = shift; - $breakpoints[$line] = 1; - print $debugsock "ok\n"; -} -sub debug_set_data { - shift; - my $offset = shift; - my $value = shift; - $stack[$offset] = $value; - print $debugsock "ok\n"; -} -sub debug_set_variable { - shift; - my $sfnumber = shift; - my $var = shift; - my $value = shift; - if( $sfnumber > $#frames ) { - $$currentframe{$var} = $value; - } else { - my $theframe = $frames[$sfnumber]; - $$theframe{$var} = $value; - } - print $debugsock "ok\n"; -} -sub debug_stack { - my $result = ''; - foreach my $frame ( @frames ) { - $result .= print_frame($frame); - $result .= '#'; - } - $result .= print_frame($currentframe); - print $debugsock "$result\n"; -} -sub debug_step { - # set suspend to 0 to allow the debug loop to exit back to - # the instruction loop and thus run an instruction. However, - # we want to come back to the debug loop right away, so the - # step flag is set to true which will cause the suspend flag - # to get set to true when we get to the next instruction. - $step = 1; - $suspend = 0; - print $debugsock "ok\n"; -} -sub debug_step_return { - $stepreturn = 1; - $suspend = 0; - print $debugsock "ok\n"; -} -sub debug_suspend { - $suspend = "client"; - print $debugsock "ok\n"; -} -sub debug_var { - shift; - my $sfnumber = shift; - my $var = shift; - if( $sfnumber > $#frames ) { - print $debugsock "$$currentframe{$var}\n"; - } else { - my $theframe = $frames[$sfnumber]; - print $debugsock "$$theframe{$var}\n"; - } -} -sub debug_watch { - shift; - my $key = shift; - my $value = shift; - $watchpoints{$key} = $value; - print $debugsock "ok\n"; -} -# -# Some event has happened so notify the debugger. -# If there is no debugger, we may still want to report the -# event (such as if it is an error). -# -sub send_debug_event { - my $event = shift; - if( $debugflag ) { - print $debugsock2 "$event\n"; - } else { - my $use_stderr = shift; - print "Error: $event\n" if $use_stderr; - } -} -# -# The stack frame output is: -# frame # frame # frame ... -# where each frame is: -# filename | line number | function name | var | var | var | var ... -# -sub print_frame { - my $frame = shift; - my $result = $filename; - $result .= '|' . $$frame{_pc_}; - $result .= '|' . $$frame{_func_}; - for my $var ( keys %$frame ) { - $result .= '|' . $var unless( substr($var,0,1) eq '_'); - } - return $result; -} - -sub start_debugger { - if( defined($debugflag) ) { - if( $debugflag eq "-debug" ) { - { # make STDOUT unbuffered - my $ofh = select STDOUT; - $| = 1; - select $ofh; - } - $debugflag = 1; - $debugport = shift @ARGV; - $debugport2 = shift @ARGV; - print "-debug $debugport $debugport2\n"; - - my $mainsock = new IO::Socket::INET (LocalHost => '127.0.0.1', - LocalPort => $debugport, - Listen => 1, - Proto => 'tcp', - Reuse => 1, - ); - $debugsock = $mainsock->accept(); - - # make the socket non-blocking on windows - my $set_it = "1"; - my $ioctl_val = 0x80000000 | (4 << 16) | (ord('f') << 8) | 126; - ioctl($debugsock, $ioctl_val, $set_it); - - # make the socket non-blocking on linux - $debugsock->blocking(0); - - my $mainsock2 = new IO::Socket::INET (LocalHost => '127.0.0.1', - LocalPort => $debugport2, - Listen => 1, - Proto => 'tcp', - Reuse => 1, - ); - $debugsock2 = $mainsock2->accept(); - - print "debug connection accepted\n"; - } else { - $debugflag = 0; - } - } -} |