core/continuations/continuations.factor

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