core/continuations/continuations.factor

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