core/continuations/continuations.factor

   1 ! Copyright (C) 2003, 2011 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs classes combinators combinators.private
   4 kernel kernel.private make namespaces sequences vectors ;
   5 IN: continuations
   6
   7 : with-datastack ( stack quot -- new-stack )
   8     [
   9         [ [ get-datastack ] dip swap [ { } like set-datastack ] dip ] dip
  10         swap [ call get-datastack ] dip
  11         swap [ set-datastack ] dip
  12     ] ( stack quot -- new-stack ) call-effect-unsafe ;
  13
  14 SYMBOL: original-error
  15 SYMBOL: error
  16 SYMBOL: error-continuation
  17 SYMBOL: error-thread
  18 SYMBOL: restarts
  19
  20 SINGLETON: no-op-restart
  21
  22 <PRIVATE
  23
  24 : (get-catchstack) ( -- catchstack )
  25     CONTEXT-OBJ-CATCHSTACK context-object { vector } declare ; inline
  26
  27 ! We have to defeat some optimizations to make continuations work
  28 : dummy-1 ( -- obj ) f ;
  29 : dummy-2 ( obj -- obj ) ;
  30
  31 : get-catchstack ( -- catchstack ) (get-catchstack) clone ; inline
  32
  33 : (set-catchstack) ( catchstack -- )
  34     CONTEXT-OBJ-CATCHSTACK set-context-object ; inline
  35
  36 : set-catchstack ( catchstack -- )
  37     >vector (set-catchstack) ; inline
  38
  39 : init-catchstack ( -- )
  40     V{ } clone (set-catchstack) ;
  41
  42 PRIVATE>
  43
  44 TUPLE: continuation data call retain name catch ;
  45
  46 C: <continuation> continuation
  47
  48 : current-continuation ( -- continuation )
  49     get-datastack get-callstack get-retainstack get-namestack get-catchstack
  50     <continuation> ;
  51
  52 <PRIVATE
  53
  54 : >continuation< ( continuation -- data call retain name catch )
  55     continuation check-instance {
  56         [ data>> ] [ call>> ] [ retain>> ] [ name>> ] [ catch>> ]
  57     } cleave ; inline
  58
  59 PRIVATE>
  60
  61 : ifcc ( capture restore -- )
  62     [ dummy-1 current-continuation or* ] 2dip [ dummy-2 ] prepose if ; inline
  63
  64 : callcc0 ( quot -- ) [ drop ] ifcc ; inline
  65
  66 : callcc1 ( quot -- obj ) [ ] ifcc ; inline
  67
  68 <PRIVATE
  69
  70 : (continue) ( continuation -- * )
  71     [
  72         >continuation<
  73         set-catchstack
  74         set-namestack
  75         set-retainstack
  76         [ set-datastack ] dip
  77         set-callstack
  78     ] ( continuation -- * ) call-effect-unsafe ;
  79
  80 PRIVATE>
  81
  82 : continue-with ( obj continuation -- * )
  83     [
  84         swap OBJ-CALLCC-1 set-special-object
  85         >continuation<
  86         set-catchstack
  87         set-namestack
  88         set-retainstack
  89         [
  90             set-datastack drop
  91             OBJ-CALLCC-1 special-object
  92             f OBJ-CALLCC-1 set-special-object
  93             f
  94         ] dip
  95         set-callstack
  96     ] ( obj continuation -- * ) call-effect-unsafe ;
  97
  98 : continue ( continuation -- * )
  99     f swap continue-with ;
 100
 101 SYMBOL: return-continuation
 102
 103 : with-return ( quot -- )
 104     [ return-continuation ] dip [ with-variable ] 2curry callcc0 ; inline
 105
 106 : return ( -- * )
 107     return-continuation get continue ;
 108
 109 GENERIC: compute-restarts ( error -- seq )
 110
 111 <PRIVATE
 112
 113 : save-error ( error -- )
 114     [ error set-global ]
 115     [ compute-restarts restarts set-global ] bi ;
 116
 117 PRIVATE>
 118
 119 GENERIC: error-in-thread ( error thread -- * )
 120
 121 SYMBOL: thread-error-hook ! ( error thread -- * )
 122
 123 M: object error-in-thread
 124     thread-error-hook get-global call( error thread -- * ) ;
 125
 126 : in-callback? ( -- ? ) CONTEXT-OBJ-IN-CALLBACK-P context-object ;
 127
 128 SYMBOL: callback-error-hook ! ( error -- * )
 129
 130 : rethrow ( error -- * )
 131     dup save-error
 132     (get-catchstack) [
 133         in-callback?
 134         [ callback-error-hook get-global call( error -- * ) ]
 135         [ OBJ-CURRENT-THREAD special-object error-in-thread ]
 136         if
 137     ] [ pop continue-with ] if-empty ;
 138
 139 thread-error-hook [ [ die drop rethrow ] ] initialize
 140
 141 callback-error-hook [ [ die rethrow ] ] initialize
 142
 143 : recover ( ..a try: ( ..a -- ..b ) recovery: ( ..a error -- ..b ) -- ..b )
 144     [
 145         [
 146             [ (get-catchstack) push ] dip
 147             call
 148             (get-catchstack) pop*
 149         ] curry
 150     ] dip ifcc ; inline
 151
 152 : ignore-errors ( ... quot: ( ... -- ... ) -- ... )
 153     [ drop ] recover ; inline
 154
 155 : ignore-error ( ... quot: ( ... -- ... ) check: ( error -- ? ) -- ... )
 156     '[ dup @ [ drop ] [ rethrow ] if ] recover ; inline
 157
 158 : ignore-error/f ( ... quot: ( ... -- ... x ) check: ( error -- ? ) -- ... x/f )
 159     '[ dup @ [ drop f ] [ rethrow ] if ] recover ; inline
 160
 161 : cleanup ( try cleanup-always cleanup-error -- )
 162     [ '[ [ @ @ ] dip rethrow ] recover ] [ drop ] 2bi call ; inline
 163
 164 : finally ( try cleanup-always -- )
 165     [ ] cleanup ; inline
 166
 167 ERROR: attempt-all-error ;
 168
 169 : attempt-all ( ... seq quot: ( ... elt -- ... obj ) -- ... obj )
 170     over empty? [
 171         attempt-all-error
 172     ] [
 173         [
 174             '[ [ @ , f ] [ , drop t ] recover ] all?
 175         ] { } make last swap [ rethrow ] when
 176     ] if ; inline
 177
 178 TUPLE: condition error restarts continuation ;
 179
 180 C: <condition> condition
 181
 182 : throw-restarts ( error restarts -- restart )
 183     [ <condition> throw ] callcc1 2nip ;
 184
 185 : rethrow-restarts ( error restarts -- restart )
 186     [ <condition> rethrow ] callcc1 2nip ;
 187
 188 : throw-continue ( error -- )
 189     { { "Continue" t } } throw-restarts drop ;
 190
 191 TUPLE: restart name obj continuation ;
 192
 193 C: <restart> restart
 194
 195 : continue-restart ( restart -- * )
 196     [ obj>> ] [ continuation>> ] bi continue-with ;
 197
 198 M: object compute-restarts drop { } ;
 199
 200 M: condition compute-restarts
 201     [ error>> compute-restarts ]
 202     [
 203         [ restarts>> ]
 204         [ continuation>> [ <restart> ] curry ] bi
 205         { } assoc>map
 206     ] bi append ;
 207
 208 <PRIVATE
 209
 210 : init-error-handler ( -- )
 211     ! VM calls on error
 212     [
 213         OBJ-CURRENT-THREAD special-object error-thread set-global
 214         current-continuation error-continuation set-global
 215         [ original-error set-global ] [ rethrow ] bi
 216     ] ERROR-HANDLER-QUOT set-special-object ;
 217
 218 PRIVATE>