core/continuations/continuations.factor

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