1 ! Copyright (C) 2009, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: threads threads.private kernel namespaces continuations
4 combinators sequences math namespaces.private
5 continuations.private concurrency.messaging quotations
6 kernel.private words sequences.private assocs models
7 models.arrow arrays accessors generic generic.single definitions
8 make sbufs tools.crossref fry ;
9 IN: tools.continuations
13 : after-break ( object -- )
15 { [ dup continuation? ] [ (continue) ] }
16 { [ dup not ] [ "Single stepping abandoned" rethrow ] }
24 current-continuation callstack >>call
25 break-hook get call( continuation -- continuation' )
28 \ break t "break?" set-word-prop
30 GENERIC: add-breakpoint ( quot -- quot' )
34 M: callable add-breakpoint
35 dup [ break ] head? [ \ break prefix ] unless ;
37 M: array add-breakpoint
38 [ add-breakpoint ] map ;
40 M: object add-breakpoint ;
42 : (step-into-quot) ( quot -- ) add-breakpoint call ;
44 : (step-into-dip) ( quot -- ) add-breakpoint dip ;
46 : (step-into-2dip) ( quot -- ) add-breakpoint 2dip ;
48 : (step-into-3dip) ( quot -- ) add-breakpoint 3dip ;
50 : (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
52 : (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
54 : (step-into-execute) ( word -- )
56 { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
57 { [ dup single-generic? ] [ effective-method (step-into-execute) ] }
58 { [ dup uses \ suspend swap member? ] [ execute break ] }
59 { [ dup primitive? ] [ execute break ] }
60 [ def>> (step-into-quot) ]
63 \ (step-into-execute) t "step-into?" set-word-prop
65 : (step-into-continuation) ( -- )
66 current-continuation callstack >>call break ;
68 : (step-into-call-next-method) ( method -- )
69 next-method-quot (step-into-quot) ;
79 (step-into-continuation)
80 (step-into-call-next-method)
81 } [ t "no-compile" set-word-prop ] each >>
83 : >innermost-frame< ( callstack -- n quot )
84 [ innermost-frame-scan 1 + ] [ innermost-frame-executing ] bi ;
86 : (change-frame) ( callstack quot -- callstack' )
87 [ dup innermost-frame-executing quotation? ] dip '[
88 clone [ >innermost-frame< @ ] [ set-innermost-frame-quot ] [ ] tri
91 : change-frame ( continuation quot -- continuation' )
92 #! Applies quot to innermost call frame of the
94 [ clone ] dip '[ _ (change-frame) ] change-call ; inline
98 : continuation-step ( continuation -- continuation' )
100 2dup length = [ nip [ break ] append ] [
101 2dup nth \ break = [ nip ] [
102 swap 1 + cut [ break ] glue
107 : continuation-step-out ( continuation -- continuation' )
108 [ nip \ break suffix ] change-frame ;
111 { call [ (step-into-quot) ] }
112 { dip [ (step-into-dip) ] }
113 { 2dip [ (step-into-2dip) ] }
114 { 3dip [ (step-into-3dip) ] }
115 { execute [ (step-into-execute) ] }
116 { if [ (step-into-if) ] }
117 { dispatch [ (step-into-dispatch) ] }
118 { continuation [ (step-into-continuation) ] }
119 { (call-next-method) [ (step-into-call-next-method) ] }
120 } [ "step-into" set-word-prop ] assoc-each
122 ! Never step into these words
123 : don't-step-into ( word -- )
124 dup '[ _ execute break ] "step-into" set-word-prop ;
128 continue continue-with
130 set-context start-context
131 } [ don't-step-into ] each
133 \ break [ break ] "step-into" set-word-prop
135 : continuation-step-into ( continuation -- continuation' )
141 { [ dup \ break eq? ] [ , ] }
142 { [ dup quotation? ] [ add-breakpoint , \ break , ] }
143 { [ dup array? ] [ add-breakpoint , \ break , ] }
144 { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
151 : continuation-current ( continuation -- obj )
152 call>> >innermost-frame< ?nth ;