core/continuations/continuations.factor

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