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 combinators combinators.private kernel
   4 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 : 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 ) 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 ERROR: not-a-continuation object ;
  53
  54 : >continuation< ( continuation -- data call retain name catch )
  55     dup continuation? [ not-a-continuation ] unless
  56     { [ data>> ] [ call>> ] [ retain>> ] [ name>> ] [ catch>> ] } cleave ; inline
  57
  58 PRIVATE>
  59
  60 : ifcc ( capture restore -- )
  61     [ dummy-1 current-continuation ] 2dip [ dummy-2 ] prepose ?if ; inline
  62
  63 : callcc0 ( quot -- ) [ drop ] ifcc ; inline
  64
  65 : callcc1 ( quot -- obj ) [ ] ifcc ; inline
  66
  67 <PRIVATE
  68
  69 : (continue) ( continuation -- * )
  70     [
  71         >continuation<
  72         set-catchstack
  73         set-namestack
  74         set-retainstack
  75         [ set-datastack ] dip
  76         set-callstack
  77     ] ( continuation -- * ) call-effect-unsafe ;
  78
  79 PRIVATE>
  80
  81 : continue-with ( obj continuation -- * )
  82     [
  83         swap OBJ-CALLCC-1 set-special-object
  84         >continuation<
  85         set-catchstack
  86         set-namestack
  87         set-retainstack
  88         [
  89             set-datastack drop
  90             OBJ-CALLCC-1 special-object
  91             f OBJ-CALLCC-1 set-special-object
  92             f
  93         ] dip
  94         set-callstack
  95     ] ( obj continuation -- * ) call-effect-unsafe ;
  96
  97 : continue ( continuation -- * )
  98     f swap continue-with ;
  99
 100 SYMBOL: return-continuation
 101
 102 : with-return ( quot -- )
 103     [ return-continuation ] dip [ with-variable ] 2curry callcc0 ; inline
 104
 105 : return ( -- * )
 106     return-continuation get continue ;
 107
 108 GENERIC: compute-restarts ( error -- seq )
 109
 110 <PRIVATE
 111
 112 : save-error ( error -- )
 113     [ error set-global ]
 114     [ compute-restarts restarts set-global ] bi ;
 115
 116 PRIVATE>
 117
 118 GENERIC: error-in-thread ( error thread -- * )
 119
 120 SYMBOL: thread-error-hook ! ( error thread -- )
 121
 122 thread-error-hook [ [ die ] ] initialize
 123
 124 M: object error-in-thread ( error thread -- * )
 125     thread-error-hook get-global call( error thread -- * ) ;
 126
 127 : in-callback? ( -- ? ) CONTEXT-OBJ-IN-CALLBACK-P context-object ;
 128
 129 SYMBOL: callback-error-hook ! ( error -- * )
 130
 131 callback-error-hook [ [ die ] ] initialize
 132
 133 : rethrow ( error -- * )
 134     dup save-error
 135     catchstack* [
 136         in-callback?
 137         [ callback-error-hook get-global call( error -- * ) ]
 138         [ OBJ-CURRENT-THREAD special-object error-in-thread ]
 139         if
 140     ] [ pop continue-with ] if-empty ;
 141
 142 : recover ( ..a try: ( ..a -- ..b ) recovery: ( ..a error -- ..b ) -- ..b )
 143     [
 144         [
 145             [ catchstack* push ] dip
 146             call
 147             catchstack* pop*
 148         ] curry
 149     ] dip ifcc ; inline
 150
 151 : ignore-errors ( quot -- )
 152     [ drop ] recover ; inline
 153
 154 : cleanup ( try cleanup-always cleanup-error -- )
 155     [ compose [ dip rethrow ] curry recover ] [ drop ] 2bi call ; inline
 156
 157 ERROR: attempt-all-error ;
 158
 159 : attempt-all ( ... seq quot: ( ... elt -- ... obj ) -- ... obj )
 160     over empty? [
 161         attempt-all-error
 162     ] [
 163         [
 164             [ [ , f ] compose [ , drop t ] recover ] curry all?
 165         ] { } make last swap [ rethrow ] when
 166     ] if ; inline
 167
 168 TUPLE: condition error restarts continuation ;
 169
 170 C: <condition> condition
 171
 172 : throw-restarts ( error restarts -- restart )
 173     [ <condition> throw ] callcc1 2nip ;
 174
 175 : rethrow-restarts ( error restarts -- restart )
 176     [ <condition> rethrow ] callcc1 2nip ;
 177
 178 : throw-continue ( error -- )
 179     { { "Continue" t } } throw-restarts drop ;
 180
 181 TUPLE: restart name obj continuation ;
 182
 183 C: <restart> restart
 184
 185 : continue-restart ( restart -- * )
 186     [ obj>> ] [ continuation>> ] bi continue-with ;
 187
 188 M: object compute-restarts drop { } ;
 189
 190 M: condition compute-restarts
 191     [ error>> compute-restarts ]
 192     [
 193         [ restarts>> ]
 194         [ continuation>> [ <restart> ] curry ] bi
 195         { } assoc>map
 196     ] bi append ;
 197
 198 <PRIVATE
 199
 200 : init-error-handler ( -- )
 201     init-catchstack
 202     ! VM calls on error
 203     [
 204         OBJ-CURRENT-THREAD special-object error-thread set-global
 205         current-continuation error-continuation set-global
 206         [ original-error set-global ] [ rethrow ] bi
 207     ] ERROR-HANDLER-QUOT set-special-object
 208     ! VM adds this to kernel errors, so that user-space
 209     ! can identify them
 210     "kernel-error" OBJ-ERROR set-special-object ;
 211
 212 PRIVATE>