basis/tools/continuations/continuations.factor

   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
  10
  11 <PRIVATE
  12
  13 : after-break ( object -- )
  14     {
  15         { [ dup continuation? ] [ (continue) ] }
  16         { [ dup not ] [ "Single stepping abandoned" rethrow ] }
  17     } cond ;
  18
  19 PRIVATE>
  20
  21 SYMBOL: break-hook
  22
  23 : break ( -- )
  24     current-continuation callstack >>call
  25     break-hook get call( continuation -- continuation' )
  26     after-break ;
  27
  28 \ break t "break?" set-word-prop
  29
  30 GENERIC: add-breakpoint ( quot -- quot' )
  31
  32 <PRIVATE
  33
  34 M: callable add-breakpoint
  35     dup [ break ] head? [ \ break prefix ] unless ;
  36
  37 M: array add-breakpoint
  38     [ add-breakpoint ] map ;
  39
  40 M: object add-breakpoint ;
  41
  42 : (step-into-quot) ( quot -- ) add-breakpoint call ;
  43
  44 : (step-into-dip) ( quot -- ) add-breakpoint dip ;
  45
  46 : (step-into-2dip) ( quot -- ) add-breakpoint 2dip ;
  47
  48 : (step-into-3dip) ( quot -- ) add-breakpoint 3dip ;
  49
  50 : (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
  51
  52 : (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
  53
  54 : (step-into-execute) ( word -- )
  55     {
  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) ]
  61     } cond ;
  62
  63 \ (step-into-execute) t "step-into?" set-word-prop
  64
  65 : (step-into-continuation) ( -- )
  66     current-continuation callstack >>call break ;
  67
  68 : (step-into-call-next-method) ( method -- )
  69     next-method-quot (step-into-quot) ;
  70
  71 << {
  72     (step-into-quot)
  73     (step-into-dip)
  74     (step-into-2dip)
  75     (step-into-3dip)
  76     (step-into-if)
  77     (step-into-dispatch)
  78     (step-into-execute)
  79     (step-into-continuation)
  80     (step-into-call-next-method)
  81 } [ t "no-compile" set-word-prop ] each >>
  82
  83 : >innermost-frame< ( callstack -- n quot )
  84     [ innermost-frame-scan 1 + ] [ innermost-frame-executing ] bi ;
  85
  86 : (change-frame) ( callstack quot -- callstack' )
  87     [ dup innermost-frame-executing quotation? ] dip '[
  88         clone [ >innermost-frame< @ ] [ set-innermost-frame-quot ] [ ] tri
  89     ] when ; inline
  90
  91 : change-frame ( continuation quot -- continuation' )
  92     #! Applies quot to innermost call frame of the
  93     #! continuation.
  94     [ clone ] dip '[ _ (change-frame) ] change-call ; inline
  95
  96 PRIVATE>
  97
  98 : continuation-step ( continuation -- continuation' )
  99     [
 100         2dup length = [ nip [ break ] append ] [
 101             2dup nth \ break = [ nip ] [
 102                 swap 1 + cut [ break ] glue
 103             ] if
 104         ] if
 105     ] change-frame ;
 106
 107 : continuation-step-out ( continuation -- continuation' )
 108     [ nip \ break suffix ] change-frame ;
 109
 110 {
 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     { current-continuation [ (step-into-continuation) ] }
 119     { (call-next-method) [ (step-into-call-next-method) ] }
 120 } [ "step-into" set-word-prop ] assoc-each
 121
 122 ! Never step into these words
 123 : don't-step-into ( word -- )
 124     dup '[ _ execute break ] "step-into" set-word-prop ;
 125
 126 {
 127     >n ndrop recover
 128     continue continue-with
 129     stop suspend (spawn)
 130     set-context start-context
 131 } [ don't-step-into ] each
 132
 133 \ break [ break ] "step-into" set-word-prop
 134
 135 : continuation-step-into ( continuation -- continuation' )
 136     [
 137         swap cut [
 138             swap %
 139             [ \ break , ] [
 140                 unclip {
 141                     { [ dup \ break eq? ] [ , ] }
 142                     { [ dup quotation? ] [ add-breakpoint , \ break , ] }
 143                     { [ dup array? ] [ add-breakpoint , \ break , ] }
 144                     { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
 145                     [ , \ break , ]
 146                 } cond %
 147             ] if-empty
 148         ] [ ] make
 149     ] change-frame ;
 150
 151 : continuation-current ( continuation -- obj )
 152     call>> >innermost-frame< ?nth ;