improved single-stepper offers option to continue execution of stepped continuation in primary interpreter

library/bootstrap/init-stage2.factor

@@ -26,7 +26,7 @@ words ;
     garbage-collection
     run-user-init
     "shell" get shell
-    0 exit* 
+    0 exit
 ] set-boot
 
 warm-boot
@@ -66,4 +66,4 @@ unparse write " words total" print
 global [ stdio off ] bind
 
 "factor.image" save-image
-0 exit*
+0 exit

library/bootstrap/primitives.factor

@@ -59,7 +59,6 @@ vocabularies get [
     [ "str>float" "parser"                    [ [ string ] [ float ] ] ]
     [ "(unparse-float)" "unparser"            [ [ float ] [ string ] ] ]
     [ "<complex>" "math-internals"            [ [ real real ] [ number ] ] ]
-    [ "fixnum=" "math-internals"              [ [ fixnum fixnum ] [ boolean ] ] ]
     [ "fixnum+" "math-internals"              [ [ fixnum fixnum ] [ integer ] ] ]
     [ "fixnum-" "math-internals"              [ [ fixnum fixnum ] [ integer ] ] ]
     [ "fixnum*" "math-internals"              [ [ fixnum fixnum ] [ integer ] ] ]
@@ -139,7 +138,7 @@ vocabularies get [
     [ "callstack" "kernel"                    " -- cs "          ]
     [ "set-datastack" "kernel"                " ds -- "          ]
     [ "set-callstack" "kernel"                " cs -- "          ]
-    [ "exit*" "kernel"                        [ [ integer ] [ ] ] ]
+    [ "exit" "kernel"                         [ [ integer ] [ ] ] ]
     [ "client-socket" "io-internals"          [ [ string integer ] [ port port ] ] ]
     [ "server-socket" "io-internals"          [ [ integer ] [ port ] ] ]
     [ "close-port" "io-internals"             [ [ port ] [ ] ] ]

library/compiler/alien.factor

@@ -89,6 +89,10 @@ SYMBOL: alien-parameters
     length 0 node-inputs consume-d ;
 
 : alien-node ( returns params function library -- )
+    #! We should fail if the library does not exist, so that
+    #! compilation does not keep trying to compile FFI words
+    #! over and over again if the library is not loaded.
+   ! 2dup load-dll dlsym
     cons #alien-invoke dataflow,
     [ set-alien-parameters ] keep
     set-alien-returns ;

library/compiler/assembler.factor

@@ -41,3 +41,5 @@ SYMBOL: interned-literals
 
 : init-assembler ( -- )
     global [ <namespace> interned-literals set ] bind ;
+
+: w>h/h dup -16 shift HEX: ffff bitand >r HEX: ffff bitand r> ;

library/compiler/ppc/assembler.factor

@@ -4,7 +4,15 @@ IN: assembler
 USING: errors kernel math memory words ;
 
 ! See the Motorola or IBM documentation for details. The opcode
-! names are standard.
+! names are standard, and the operand order is the same as in
+! the docs, except a few differences, namely, in IBM/Motorola
+! assembler syntax, loads and stores are written like:
+!
+! stw r14,10(r15)
+!
+! In Factor, we write:
+!
+! 14 15 10 STW
 
 : insn ( operand opcode -- ) 26 shift bitor compile-cell ;
 
@@ -59,7 +67,6 @@ USING: errors kernel math memory words ;
 : STWU d-form 37 insn ;
 : CMPI d-form 11 insn ;
 
-: w>h/h dup -16 shift HEX: ffff bitand >r HEX: ffff bitand r> ;
 : LOAD32 >r w>h/h r> tuck LIS dup rot ORI ;
 
 : LOAD ( n r -- )

library/compiler/ppc/generator.factor

@@ -28,9 +28,11 @@ words ;
     REPL-DS
 ] "generator" set-word-prop
 
-! #return-to [
+#return-to [
-!     
+    0 18 LOAD32  absolute-16/16
-! ] "generator" set-word-prop
+    1 1 -16 STWU
+    18 1 20 STW
+] "generator" set-word-prop
 
 #return [ drop compile-epilogue BLR ] "generator" set-word-prop
 

library/compiler/simplifier.factor

@@ -150,7 +150,7 @@ SYMBOL: simplifying
 
 #target-label [
     [ #jump-label #target-label double-jump ]
-    [ #jump #target double-jump ]
+!   [ #jump #target double-jump ]
 ] "simplifiers" set-word-prop
 
 #jump [ [ dead-code ] ] "simplifiers" set-word-prop

library/compiler/xt.factor

@@ -90,15 +90,16 @@ M: relative fixup ( relative -- )
 TUPLE: absolute word where ;
 
 C: absolute ( word -- )
-    dup f rel-word
     [ set-absolute-word ] keep
     [ just-compiled swap set-absolute-where ] keep ;
 
-: absolute ( word -- ) <absolute> deferred-xts cons@ ;
+: absolute ( word -- )
+    dup f rel-word <absolute> deferred-xts cons@ ;
+
+: >absolute dup absolute-word compiled-xt swap absolute-where ;
 
 M: absolute fixup ( absolute -- )
-    dup absolute-word compiled-xt
+    >absolute set-compiled-cell ;
-    swap absolute-where set-compiled-cell ;
 
 ! Fixups where the address is inside a bitfield in the
 ! instruction.
@@ -117,11 +118,28 @@ C: relative-bitfld ( word mask -- )
     BIN: 1111111111111100 <relative-bitfld>
     deferred-xts cons@ ;
 
+: or-compiled ( n off -- )
+    [ compiled-cell bitor ] keep set-compiled-cell ;
+
 M: relative-bitfld fixup
     dup relative-fixup over relative-bitfld-mask bitand
     swap relative-where
-    [ compiled-cell bitor ] keep
+    or-compiled ;
-    set-compiled-cell ;
+
+! Fixup where the address is split between two PowerPC D-form
+! instructions (low 16 bits of each instruction is the literal).
+TUPLE: absolute-16/16 ;
+
+C: absolute-16/16 ( word -- )
+    [ >r <absolute> r> set-delegate ] keep ;
+
+: fixup-16/16 ( xt where -- )
+    >r w>h/h r> tuck 4 - or-compiled or-compiled ;
+
+M: absolute-16/16 fixup ( absolute -- ) >absolute fixup-16/16 ;
+
+: absolute-16/16 ( word -- )
+    <absolute-16/16> deferred-xts cons@ ;
 
 : compiling? ( word -- ? )
     #! A word that is compiling or already compiled will not be

library/math/integer.factor

@@ -28,7 +28,11 @@ USING: errors generic kernel math ;
         2dup gcd tuck /i >r /i r> fraction>
     ] ifte ; inline
 
-M: fixnum number= fixnum= ;
+M: fixnum number=
+    #! Fixnums are immediate values, so equality testing is
+    #! trivial.
+    eq? ;
+
 M: fixnum < fixnum< ;
 M: fixnum <= fixnum<= ;
 M: fixnum > fixnum> ;

library/test/interpreter.factor

@@ -1,4 +1,5 @@
 IN: scratchpad
+USE: vectors
 USE: interpreter
 USE: test
 USE: namespaces
@@ -9,6 +10,9 @@ USE: math-internals
 USE: lists
 USE: kernel
 
+: done-cf? ( -- ? ) meta-cf get not ;
+: done? ( -- ? ) done-cf? meta-r get vector-length 0 = and ;
+
 : interpret ( quot -- )
     #! The quotation is called with each word as its executed.
     done? [ drop ] [ [ next swap call ] keep interpret ] ifte ;

library/tools/interpreter.factor

@@ -22,12 +22,16 @@ SYMBOL: meta-c
 ! Call frame
 SYMBOL: meta-cf
 
+! Currently executing word.
+SYMBOL: meta-executing
+
 : init-interpreter ( -- )
     10 <vector> meta-r set
     10 <vector> meta-d set
     namestack meta-n set
     f meta-c set
-    f meta-cf set ;
+    f meta-cf set
+    f meta-executing set ;
 
 : copy-interpreter ( -- )
     #! Copy interpreter state from containing namespaces.
@@ -36,11 +40,8 @@ SYMBOL: meta-cf
     meta-n [ ] change
     meta-c [ ] change ;
 
-: done-cf? ( -- ? ) meta-cf get not ;
-: done? ( -- ? ) done-cf? meta-r get vector-length 0 = and ;
-
 ! Callframe.
-: up ( -- ) pop-r meta-cf set ;
+: up ( -- ) pop-r meta-cf set  pop-r drop ;
 
 : next ( -- obj )
     meta-cf get [ meta-cf [ uncons ] change ] [ up next ] ifte ;
@@ -55,13 +56,19 @@ SYMBOL: meta-cf
 
 : meta-call ( quot -- )
     #! Note we do tail call optimization here.
-    meta-cf [ [ push-r ] when* ] change ;
+    meta-cf [
+        [ meta-executing get push-r  push-r ] when*
+    ] change ;
 
 : meta-word ( word -- )
     dup "meta-word" word-prop [
         call
     ] [
-        dup compound? [ word-def meta-call ] [ host-word ] ifte
+        dup compound? [
+            dup word-def meta-call  meta-executing set
+        ] [
+            host-word
+        ] ifte
     ] ?ifte ;
 
 : do ( obj -- ) dup word? [ meta-word ] [ push-d ] ifte ;

library/tools/listener.factor

@@ -20,7 +20,7 @@ global [
     ! over to the input
     " " write flush ;
 
-: exit ( -- )
+: bye ( -- )
     #! Exit the current listener.
     quit-flag on ;
 
@@ -45,7 +45,7 @@ global [
 : listen ( -- )
     #! Wait for user input, and execute.
     listener-prompt get prompt.
-    [ read-multiline [ call ] [ exit ] ifte ] try ;
+    [ read-multiline [ call ] [ bye ] ifte ] try ;
 
 : listener ( -- )
     #! Run a listener loop that executes user input.
@@ -53,50 +53,11 @@ global [
 
 : print-banner ( -- )
     "Factor " write version write
-    " (OS: " write os write
+    " :: http://factor.sourceforge.net :: " write
-    " CPU: " write cpu write
+    os write
-    ")" print
+    "/" write cpu print
-    "Copyright (C) 2003, 2005 Slava Pestov" print
+    "(C) 2003, 2005 Slava Pestov, Chris Double, Mackenzie Straight" print ;
-    "Copyright (C) 2004, 2005 Chris Double" print
-    "Copyright (C) 2004, 2005 Mackenzie Straight" print
-    "Type ``exit'' to exit, ``help'' for help." print
-    terpri
-    room.
-    terpri ;
-
-: help ( -- )
-    "SESSION:" print
-    "\"foo.image\" save-image   -- save heap to a file" print
-    "room.                    -- show memory usage" print
-    "heap-stats.              -- memory allocation breakdown" print
-    "garbage-collection       -- force a GC" print
-    "exit                     -- exit interpreter" print
-    terpri
-    "WORDS:" print
-    "vocabs.                  -- list vocabularies" print 
-    "\"math\" words.            -- list the math vocabulary" print
-    "\"str\" apropos.           -- list all words containing str" print
-    "\\ neg see                -- show word definition" print
-    "\\ car usages.            -- list all words invoking car" print
-    terpri
-    "STACKS:" print
-    ".s .r .n .c              -- show contents of the 4 stacks" print
-    "clear                    -- clear datastack" print
-    terpri
-    "OBJECTS:" print
-    "global describe          -- list global variables." print
-    "\"foo\" get .              -- print a variable value." print
-    ".                        -- print top of stack." print
-    terpri
-    "PROFILER:                [ ... ] call-profile" print
-    "                         [ ... ] allot-profile" print
-    "TRACE:                   [ ... ] trace" print
-    "SINGLE STEP:             [ ... ] walk" print
-    terpri
-    "HTTP SERVER:             USE: httpd 8888 httpd" print
-    "TELNET SERVER:           USE: telnetd 9999 telnetd" print ;
 
 IN: shells
 
-: tty
+: tty print-banner listener ;
-    print-banner listener ;

library/tools/walker.factor

@@ -9,8 +9,9 @@ stdio strings vectors words ;
     meta-d get {.} ;
 
 : &r
-    #! Print stepper call stack.
+    #! Print stepper call stack, as well as the currently
-    meta-r get {.} meta-cf get . ;
+    #! executing quotation.
+    meta-cf get . meta-executing get . meta-r get {.} ;
 
 : &n
     #! Print stepper name stack.
@@ -24,27 +25,25 @@ stdio strings vectors words ;
     #! Get stepper variable value.
     meta-n get (get) ;
 
-: stack-report ( -- )
+: report ( -- ) meta-cf get . ;
-    meta-r get vector-length "=" fill write
-    meta-d get vector-length "-" fill write ;
-
-: not-done ( quot -- )
-    done? [
-        stack-report "Stepper is done." print drop
-    ] [
-        call
-    ] ifte ;
-
-: report ( -- )
-    stack-report meta-cf get . ;
 
 : step
     #! Step over current word.
-    [ next do-1 report ] not-done ;
+    next do-1 report ;
 
 : into
     #! Step into current word.
-    [ next do report ] not-done ;
+    next do report ;
+
+: continue
+    #! Continue executing the single-stepped continuation in the
+    #! primary interpreter.
+    meta-d get set-datastack
+    meta-c get set-catchstack
+    meta-cf get
+    meta-r get
+    meta-n get set-namestack
+    set-callstack call ;
 
 : walk-banner ( -- )
     [ &s &r &n &c ] [ prettyprint-word " " write ] each
@@ -53,17 +52,22 @@ stdio strings vectors words ;
     " ( var -- value ) inspects the stepper namestack." print
     \ step prettyprint-word " -- single step over" print
     \ into prettyprint-word " -- single step into" print
-    \ exit prettyprint-word " -- exit single-stepper" print
+    \ continue prettyprint-word " -- continue execution" print
+    \ bye prettyprint-word " -- exit single-stepper" print
     report ;
 
 : walk-listener walk-banner "walk" listener-prompt set listener ;
 
+: init-walk ( quot callstack namestack -- )
+    init-interpreter
+    meta-n set
+    meta-r set
+    meta-cf set
+    datastack meta-d set ;
+
 : walk ( quot -- )
     #! Single-step through execution of a quotation.
-    [
+    callstack namestack [
-        init-interpreter
+        init-walk
-        meta-cf set
-        datastack meta-d set
         walk-listener
-        meta-d get
+    ] with-scope ;
-    ] with-scope set-datastack ;

native/error.c

@@ -25,8 +25,8 @@ void early_error(CELL error)
 		/* Crash at startup */
 		fprintf(stderr,"Error during startup: ");
 		print_obj(error);
-		dump_stacks();
 		fprintf(stderr,"\n");
+		dump_stacks();
 		fflush(stderr);
 		exit(1);
 	}

native/fixnum.c

@@ -32,13 +32,6 @@ void primitive_to_fixnum(void)
 	drepl(tag_fixnum(to_fixnum(dpeek())));
 }
 
-void primitive_fixnum_eq(void)
-{
-	F_FIXNUM y = untag_fixnum_fast(dpop());
-	F_FIXNUM x = untag_fixnum_fast(dpop());
-	box_boolean(x == y);
-}
-
 void primitive_fixnum_add(void)
 {
 	F_FIXNUM y = untag_fixnum_fast(dpop());

native/fixnum.h

@@ -11,7 +11,6 @@ INLINE CELL tag_fixnum(F_FIXNUM untagged)
 F_FIXNUM to_fixnum(CELL tagged);
 void primitive_to_fixnum(void);
 
-void primitive_fixnum_eq(void);
 void primitive_fixnum_add(void);
 void primitive_fixnum_subtract(void);
 void primitive_fixnum_multiply(void);

native/primitives.c

@@ -31,7 +31,6 @@ void* primitives[] = {
 	primitive_str_to_float,
 	primitive_float_to_str,
 	primitive_from_rect,
-	primitive_fixnum_eq,
 	primitive_fixnum_add,
 	primitive_fixnum_subtract,
 	primitive_fixnum_multiply,