core/continuations/continuations.factor

   1 ! Copyright (C) 2003, 2008 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 accessors ;
   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 getenv { 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 : init-catchstack ( -- ) V{ } clone 1 setenv ;
  27
  28 PRIVATE>
  29
  30 : catchstack ( -- catchstack ) catchstack* clone ; inline
  31
  32 : set-catchstack ( catchstack -- ) >vector 1 setenv ; inline
  33
  34 TUPLE: continuation data call retain name catch ;
  35
  36 C: <continuation> continuation
  37
  38 : continuation ( -- continuation )
  39     datastack callstack retainstack namestack catchstack
  40     <continuation> ;
  41
  42 : >continuation< ( continuation -- data call retain name catch )
  43     {
  44         [ data>>   ]
  45         [ call>>   ]
  46         [ retain>> ]
  47         [ name>>   ]
  48         [ catch>>  ]
  49     } cleave ;
  50
  51 : ifcc ( capture restore -- )
  52     #! After continuation is being captured, the stacks looks
  53     #! like:
  54     #! ( f continuation r:capture r:restore )
  55     #! so the 'capture' branch is taken.
  56     #!
  57     #! Note that the continuation itself is not captured as part
  58     #! of the datastack.
  59     #!
  60     #! BUT...
  61     #!
  62     #! After the continuation is resumed, (continue-with) pushes
  63     #! the given value together with f,
  64     #! so now, the stacks looks like:
  65     #! ( value f r:capture r:restore )
  66     #! Execution begins right after the call to 'continuation'.
  67     #! The 'restore' branch is taken.
  68     [ dummy-1 continuation ] 2dip [ dummy-2 ] prepose ?if ; inline
  69
  70 : callcc0 ( quot -- ) [ drop ] ifcc ; inline
  71
  72 : callcc1 ( quot -- obj ) [ ] ifcc ; inline
  73
  74 <PRIVATE
  75
  76 : (continue) ( continuation -- )
  77     >continuation<
  78     set-catchstack
  79     set-namestack
  80     set-retainstack
  81     [ set-datastack ] dip
  82     set-callstack ;
  83
  84 : (continue-with) ( obj continuation -- )
  85     swap 4 setenv
  86     >continuation<
  87     set-catchstack
  88     set-namestack
  89     set-retainstack
  90     [ set-datastack drop 4 getenv f 4 setenv f ] dip
  91     set-callstack ;
  92
  93 PRIVATE>
  94
  95 : continue-with ( obj continuation -- * )
  96     [ (continue-with) ] 2 (throw) ;
  97
  98 : continue ( continuation -- * )
  99     f swap continue-with ;
 100
 101 SYMBOL: return-continuation
 102
 103 : with-return ( quot -- )
 104     [ [ return-continuation set ] prepose callcc0 ] with-scope ; inline
 105
 106 : return ( -- * )
 107     return-continuation get continue ;
 108
 109 : with-datastack ( stack quot -- newstack )
 110     [
 111         [
 112             [ [ { } like set-datastack ] dip call datastack ] dip
 113             continue-with
 114         ] 3 (throw)
 115     ] callcc1 2nip ;
 116
 117 : assert-depth ( quot -- )
 118     { } swap with-datastack { } assert= ; inline
 119
 120 GENERIC: compute-restarts ( error -- seq )
 121
 122 <PRIVATE
 123
 124 : save-error ( error -- )
 125     dup error set-global
 126     compute-restarts restarts set-global ;
 127
 128 PRIVATE>
 129
 130 SYMBOL: thread-error-hook
 131
 132 : rethrow ( error -- * )
 133     dup save-error
 134     catchstack* empty? [
 135         thread-error-hook get-global
 136         [ 1 (throw) ] [ die ] if*
 137     ] when
 138     c> continue-with ;
 139
 140 : recover ( try recovery -- )
 141     [ [ swap >c call c> drop ] curry ] dip ifcc ; inline
 142
 143 : ignore-errors ( quot -- )
 144     [ drop ] recover ; inline
 145
 146 : cleanup ( try cleanup-always cleanup-error -- )
 147     [ compose [ dip rethrow ] curry recover ] [ drop ] 2bi call ; inline
 148
 149 ERROR: attempt-all-error ;
 150
 151 : attempt-all ( seq quot -- obj )
 152     over empty? [
 153         attempt-all-error
 154     ] [
 155         [
 156             [ [ , f ] compose [ , drop t ] recover ] curry all?
 157         ] { } make peek swap [ rethrow ] when
 158     ] if ; inline
 159
 160 : retry ( quot: ( -- ? )  n -- ) swap [ drop ] prepose attempt-all ; 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 TUPLE: restart name obj continuation ;
 173
 174 C: <restart> restart
 175
 176 : restart ( restart -- * )
 177     [ obj>> ] [ continuation>> ] bi continue-with ;
 178
 179 M: object compute-restarts drop { } ;
 180
 181 M: condition compute-restarts
 182     [ error>> compute-restarts ]
 183     [
 184         [ restarts>> ]
 185         [ continuation>> [ <restart> ] curry ] bi
 186         { } assoc>map
 187     ] bi append ;
 188
 189 <PRIVATE
 190
 191 : init-error-handler ( -- )
 192     V{ } clone set-catchstack
 193     ! VM calls on error
 194     [
 195         ! 63 = self
 196         63 getenv error-thread set-global
 197         continuation error-continuation set-global
 198         rethrow
 199     ] 5 setenv
 200     ! VM adds this to kernel errors, so that user-space
 201     ! can identify them
 202     "kernel-error" 6 setenv ;
 203
 204 PRIVATE>