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 get-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-quotation) ( 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-quotation) ;
  51
  52 : (step-into-dispatch) ( array n -- ) nth (step-into-quotation) ;
  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-quotation) ]
  61     } cond ;
  62
  63 \ (step-into-execute) t "step-into?" set-word-prop
  64
  65 : (step-into-continuation) ( -- )
  66     current-continuation get-callstack >>call break ;
  67
  68 : (step-into-call-next-method) ( method -- )
  69     next-method-quot (step-into-quotation) ;
  70
  71 << {
  72     (step-into-quotation)
  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
  89         [ >innermost-frame< @ ]
  90         [ set-innermost-frame-quotation ]
  91         [ ] tri
  92     ] when ; inline
  93
  94 : change-frame ( continuation quot -- continuation' )
  95     ! Applies quot to innermost call frame of the
  96     ! continuation.
  97     [ clone ] dip '[ _ (change-frame) ] change-call ; inline
  98
  99 PRIVATE>
 100
 101 : continuation-step ( continuation -- continuation' )
 102     [
 103         2dup length = [ nip [ break ] append ] [
 104             2dup nth \ break = [ nip ] [
 105                 swap 1 + cut [ break ] glue
 106             ] if
 107         ] if
 108     ] change-frame ;
 109
 110 : continuation-step-out ( continuation -- continuation' )
 111     [ nip \ break suffix ] change-frame ;
 112
 113 {
 114     { call [ (step-into-quotation) ] }
 115     { dip [ (step-into-dip) ] }
 116     { 2dip [ (step-into-2dip) ] }
 117     { 3dip [ (step-into-3dip) ] }
 118     { execute [ (step-into-execute) ] }
 119     { if [ (step-into-if) ] }
 120     { dispatch [ (step-into-dispatch) ] }
 121     { current-continuation [ (step-into-continuation) ] }
 122     { (call-next-method) [ (step-into-call-next-method) ] }
 123 } [ "step-into" set-word-prop ] assoc-each
 124
 125 ! Never step into these words
 126 : don't-step-into ( word -- )
 127     dup '[ _ execute break ] "step-into" set-word-prop ;
 128
 129 {
 130     >n ndrop recover
 131     continue continue-with
 132     stop suspend (spawn)
 133     set-context start-context
 134 } [ don't-step-into ] each
 135
 136 \ break [ break ] "step-into" set-word-prop
 137
 138 : continuation-step-into ( continuation -- continuation' )
 139     [
 140         swap cut [
 141             swap %
 142             [ \ break , ] [
 143                 unclip {
 144                     { [ dup \ break eq? ] [ , ] }
 145                     { [ dup quotation? ] [ add-breakpoint , \ break , ] }
 146                     { [ dup array? ] [ add-breakpoint , \ break , ] }
 147                     { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
 148                     [ , \ break , ]
 149                 } cond %
 150             ] if-empty
 151         ] [ ] make
 152     ] change-frame ;
 153
 154 : continuation-current ( continuation -- obj )
 155     call>> >innermost-frame< ?nth ;