Make walker work better with call( and breakpoints which are nested inside combinators

basis/compiler/compiler.factor

@@ -112,19 +112,18 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
     } cond ;
 
 : optimize? ( word -- ? )
-    {
+    { [ predicate-engine-word? ] [ single-generic? ] } 1|| not ;
-        [ predicate-engine-word? ]
+
-        [ contains-breakpoints? ]
+: contains-breakpoints? ( -- ? )
-        [ single-generic? ]
+    dependencies get keys [ "break?" word-prop ] any? ;
-    } 1|| not ;
 
 : frontend ( word -- nodes )
     #! If the word contains breakpoints, don't optimize it, since
     #! the walker does not support this.
-    dup optimize?
+    dup optimize? [
-    [ [ build-tree ] [ deoptimize ] recover optimize-tree ]
+        [ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
-    [ dup def>> deoptimize-with ]
+        contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if
-    if ;
+    ] [ dup def>> deoptimize-with ] if ;
 
 : compile-dependency ( word -- )
     #! If a word calls an unoptimized word, try to compile the callee.

basis/compiler/tree/builder/builder.factor

@@ -65,5 +65,3 @@ PRIVATE>
         ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
     ] with-variable ;
 
-: contains-breakpoints? ( word -- ? )
-    def>> [ word? ] filter [ "break?" word-prop ] any? ;

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -157,11 +157,7 @@ DEFER: (flat-length)
     ] sum-outputs ;
 
 : should-inline? ( #call word -- ? )
-    {
+    dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ;
-        { [ dup contains-breakpoints? ] [ 2drop f ] }
-        { [ dup "inline" word-prop ] [ 2drop t ] }
-        [ inlining-rank 5 >= ]
-    } cond ;
 
 SYMBOL: history
 

basis/stack-checker/known-words/known-words.factor

@@ -651,7 +651,7 @@ M: object infer-call*
 
 \ become { array array } { } define-primitive
 
-\ innermost-frame-quot { callstack } { quotation } define-primitive
+\ innermost-frame-executing { callstack } { object } define-primitive
 
 \ innermost-frame-scan { callstack } { fixnum } define-primitive
 

basis/tools/continuations/continuations.factor

@@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators
 sequences math namespaces.private continuations.private
 concurrency.messaging quotations kernel.private words
 sequences.private assocs models models.arrow arrays accessors
-generic generic.single definitions make sbufs tools.crossref ;
+generic generic.single definitions make sbufs tools.crossref fry ;
 IN: tools.continuations
 
 <PRIVATE
@@ -79,21 +79,18 @@ M: object add-breakpoint ;
     (step-into-call-next-method)
 } [ t "no-compile" set-word-prop ] each >>
 
+: >innermost-frame< ( callstack -- n quot )
+    [ innermost-frame-scan 1 + ] [ innermost-frame-executing ] bi ;
+
+: (change-frame) ( callstack quot -- callstack' )
+    [ dup innermost-frame-executing quotation? ] dip '[
+        clone [ >innermost-frame< @ ] [ set-innermost-frame-quot ] [ ] tri
+    ] when ; inline
+
 : change-frame ( continuation quot -- continuation' )
     #! Applies quot to innermost call frame of the
     #! continuation.
-    [ clone ] dip [
+    [ clone ] dip '[ _ (change-frame) ] change-call ; inline
-        [ clone ] dip
-        [
-            [
-                [ innermost-frame-scan 1+ ]
-                [ innermost-frame-quot ] bi
-            ] dip call
-        ]
-        [ drop set-innermost-frame-quot ]
-        [ drop ]
-        2tri
-    ] curry change-call ; inline
 
 PRIVATE>
 
@@ -101,7 +98,7 @@ PRIVATE>
     [
         2dup length = [ nip [ break ] append ] [
             2dup nth \ break = [ nip ] [
-                swap 1+ cut [ break ] glue 
+                swap 1 + cut [ break ] glue 
             ] if
         ] if
     ] change-frame ;
@@ -109,7 +106,6 @@ PRIVATE>
 : continuation-step-out ( continuation -- continuation' )
     [ nip \ break suffix ] change-frame ;
 
-
 {
     { call [ (step-into-quot) ] }
     { dip [ (step-into-dip) ] }
@@ -124,7 +120,7 @@ PRIVATE>
 
 ! Never step into these words
 : don't-step-into ( word -- )
-    dup [ execute break ] curry "step-into" set-word-prop ;
+    dup '[ _ execute break ] "step-into" set-word-prop ;
 
 {
     >n ndrop >c c>
@@ -151,6 +147,4 @@ PRIVATE>
     ] change-frame ;
 
 : continuation-current ( continuation -- obj )
-    call>>
+    call>> >innermost-frame< ?nth ;
-    [ innermost-frame-scan 1+ ]
-    [ innermost-frame-quot ] bi ?nth ;

basis/tools/walker/walker-tests.factor

@@ -2,7 +2,7 @@ USING: tools.walker io io.streams.string kernel math
 math.private namespaces prettyprint sequences tools.test
 continuations math.parser threads arrays tools.walker.debug
 generic.single sequences.private kernel.private
-tools.continuations accessors words ;
+tools.continuations accessors words combinators ;
 IN: tools.walker.tests
 
 [ { } ] [
@@ -131,4 +131,18 @@ M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ;
 \ method-breakpoint-test don't-step-into
 
 [ { 3 } ]
-[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test
+[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test
+
+: case-breakpoint-test ( -- x )
+    5 { [ break 1 + ] } case ;
+
+\ case-breakpoint-test don't-step-into
+
+[ { 6 } ] [ [ case-breakpoint-test ] test-walker ] unit-test
+
+: call(-breakpoint-test ( -- x )
+    [ break 1 ] call( -- x ) 2 + ;
+
+\ call(-breakpoint-test don't-step-into
+
+[ { 3 } ] [ [ call(-breakpoint-test ] test-walker ] unit-test

core/bootstrap/primitives.factor

@@ -493,7 +493,7 @@ tuple
     { "(sleep)" "threads.private" (( us -- )) }
     { "<tuple-boa>" "classes.tuple.private" (( ... layout -- tuple )) }
     { "callstack>array" "kernel" (( callstack -- array )) }
-    { "innermost-frame-quot" "kernel.private" (( callstack -- quot )) }
+    { "innermost-frame-executing" "kernel.private" (( callstack -- obj )) }
     { "innermost-frame-scan" "kernel.private" (( callstack -- n )) }
     { "set-innermost-frame-quot" "kernel.private" (( n callstack -- )) }
     { "call-clear" "kernel" (( quot -- )) }

vm/callstack.cpp

@@ -195,9 +195,9 @@ stack_frame *innermost_stack_frame_quot(callstack *callstack)
 
 /* Some primitives implementing a limited form of callstack mutation.
 Used by the single stepper. */
-PRIMITIVE(innermost_stack_frame_quot)
+PRIMITIVE(innermost_stack_frame_executing)
 {
-	dpush(frame_executing(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
+	dpush(frame_executing(innermost_stack_frame(untag_check<callstack>(dpop()))));
 }
 
 PRIMITIVE(innermost_stack_frame_scan)

vm/callstack.hpp

@@ -22,7 +22,7 @@ cell frame_type(stack_frame *frame);
 PRIMITIVE(callstack);
 PRIMITIVE(set_callstack);
 PRIMITIVE(callstack_to_array);
-PRIMITIVE(innermost_stack_frame_quot);
+PRIMITIVE(innermost_stack_frame_executing);
 PRIMITIVE(innermost_stack_frame_scan);
 PRIMITIVE(set_innermost_stack_frame_quot);
 

vm/primitives.cpp

@@ -135,7 +135,7 @@ const primitive_type primitives[] = {
 	primitive_sleep,
 	primitive_tuple_boa,
 	primitive_callstack_to_array,
-	primitive_innermost_stack_frame_quot,
+	primitive_innermost_stack_frame_executing,
 	primitive_innermost_stack_frame_scan,
 	primitive_set_innermost_stack_frame_quot,
 	primitive_call_clear,