basis/tools/continuations/continuations.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: threads kernel namespaces continuations combinators
   4 sequences math namespaces.private continuations.private
   5 concurrency.messaging quotations kernel.private words
   6 sequences.private assocs models models.arrow arrays accessors
   7 generic generic.single definitions make sbufs tools.crossref fry ;
   8 IN: tools.continuations
   9
  10 <PRIVATE
  11
  12 : after-break ( object -- )
  13     {
  14         { [ dup continuation? ] [ (continue) ] }
  15         { [ dup not ] [ "Single stepping abandoned" rethrow ] }
  16     } cond ;
  17
  18 PRIVATE>
  19
  20 SYMBOL: break-hook
  21
  22 : break ( -- )
  23     continuation callstack >>call
  24     break-hook get call( continuation -- continuation' )
  25     after-break ;
  26
  27 \ break t "break?" set-word-prop
  28
  29 GENERIC: add-breakpoint ( quot -- quot' )
  30
  31 <PRIVATE
  32
  33 M: callable add-breakpoint
  34     dup [ break ] head? [ \ break prefix ] unless ;
  35
  36 M: array add-breakpoint
  37     [ add-breakpoint ] map ;
  38
  39 M: object add-breakpoint ;
  40
  41 : (step-into-quot) ( quot -- ) add-breakpoint call ;
  42
  43 : (step-into-dip) ( quot -- ) add-breakpoint dip ;
  44
  45 : (step-into-2dip) ( quot -- ) add-breakpoint 2dip ;
  46
  47 : (step-into-3dip) ( quot -- ) add-breakpoint 3dip ;
  48
  49 : (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
  50
  51 : (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
  52
  53 : (step-into-execute) ( word -- )
  54     {
  55         { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
  56         { [ dup single-generic? ] [ effective-method (step-into-execute) ] }
  57         { [ dup uses \ suspend swap member? ] [ execute break ] }
  58         { [ dup primitive? ] [ execute break ] }
  59         [ def>> (step-into-quot) ]
  60     } cond ;
  61
  62 \ (step-into-execute) t "step-into?" set-word-prop
  63
  64 : (step-into-continuation) ( -- )
  65     continuation callstack >>call break ;
  66
  67 : (step-into-call-next-method) ( method -- )
  68     next-method-quot (step-into-quot) ;
  69
  70 << {
  71     (step-into-quot)
  72     (step-into-dip)
  73     (step-into-2dip)
  74     (step-into-3dip)
  75     (step-into-if)
  76     (step-into-dispatch)
  77     (step-into-execute)
  78     (step-into-continuation)
  79     (step-into-call-next-method)
  80 } [ t "no-compile" set-word-prop ] each >>
  81
  82 : >innermost-frame< ( callstack -- n quot )
  83     [ innermost-frame-scan 1 + ] [ innermost-frame-executing ] bi ;
  84
  85 : (change-frame) ( callstack quot -- callstack' )
  86     [ dup innermost-frame-executing quotation? ] dip '[
  87         clone [ >innermost-frame< @ ] [ set-innermost-frame-quot ] [ ] tri
  88     ] when ; inline
  89
  90 : change-frame ( continuation quot -- continuation' )
  91     #! Applies quot to innermost call frame of the
  92     #! continuation.
  93     [ clone ] dip '[ _ (change-frame) ] change-call ; inline
  94
  95 PRIVATE>
  96
  97 : continuation-step ( continuation -- continuation' )
  98     [
  99         2dup length = [ nip [ break ] append ] [
 100             2dup nth \ break = [ nip ] [
 101                 swap 1 + cut [ break ] glue
 102             ] if
 103         ] if
 104     ] change-frame ;
 105
 106 : continuation-step-out ( continuation -- continuation' )
 107     [ nip \ break suffix ] change-frame ;
 108
 109 {
 110     { call [ (step-into-quot) ] }
 111     { dip [ (step-into-dip) ] }
 112     { 2dip [ (step-into-2dip) ] }
 113     { 3dip [ (step-into-3dip) ] }
 114     { execute [ (step-into-execute) ] }
 115     { if [ (step-into-if) ] }
 116     { dispatch [ (step-into-dispatch) ] }
 117     { continuation [ (step-into-continuation) ] }
 118     { (call-next-method) [ (step-into-call-next-method) ] }
 119 } [ "step-into" set-word-prop ] assoc-each
 120
 121 ! Never step into these words
 122 : don't-step-into ( word -- )
 123     dup '[ _ execute break ] "step-into" set-word-prop ;
 124
 125 {
 126     >n ndrop >c c>
 127     continue continue-with
 128     stop suspend (spawn)
 129 } [ don't-step-into ] each
 130
 131 \ break [ break ] "step-into" set-word-prop
 132
 133 : continuation-step-into ( continuation -- continuation' )
 134     [
 135         swap cut [
 136             swap %
 137             [ \ break , ] [
 138                 unclip {
 139                     { [ dup \ break eq? ] [ , ] }
 140                     { [ dup quotation? ] [ add-breakpoint , \ break , ] }
 141                     { [ dup array? ] [ add-breakpoint , \ break , ] }
 142                     { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
 143                     [ , \ break , ]
 144                 } cond %
 145             ] if-empty
 146         ] [ ] make
 147     ] change-frame ;
 148
 149 : continuation-current ( continuation -- obj )
 150     call>> >innermost-frame< ?nth ;