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 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 : dummy ( -- obj )
  23     #! Optimizing compiler assumes stack won't be messed with
  24     #! in-transit. To ensure that a value is actually reified
  25     #! on the stack, we put it in a non-inline word together
  26     #! with a declaration.
  27     f { object } declare ;
  28
  29 : init-catchstack ( -- ) V{ } clone 1 setenv ;
  30
  31 PRIVATE>
  32
  33 : catchstack ( -- catchstack ) catchstack* clone ; inline
  34
  35 : set-catchstack ( catchstack -- ) >vector 1 setenv ; inline
  36
  37 TUPLE: continuation data call retain name catch ;
  38
  39 C: <continuation> continuation
  40
  41 : continuation ( -- continuation )
  42     datastack callstack retainstack namestack catchstack
  43     <continuation> ;
  44
  45 : >continuation< ( continuation -- data call retain name catch )
  46     {
  47         [ data>>   ]
  48         [ call>>   ]
  49         [ retain>> ]
  50         [ name>>   ]
  51         [ catch>>  ]
  52     } cleave ;
  53
  54 : ifcc ( capture restore -- )
  55     #! After continuation is being captured, the stacks looks
  56     #! like:
  57     #! ( f continuation r:capture r:restore )
  58     #! so the 'capture' branch is taken.
  59     #!
  60     #! Note that the continuation itself is not captured as part
  61     #! of the datastack.
  62     #!
  63     #! BUT...
  64     #!
  65     #! After the continuation is resumed, (continue-with) pushes
  66     #! the given value together with f,
  67     #! so now, the stacks looks like:
  68     #! ( value f r:capture r:restore )
  69     #! Execution begins right after the call to 'continuation'.
  70     #! The 'restore' branch is taken.
  71     >r >r dummy continuation r> r> ?if ; inline
  72
  73 : callcc0 ( quot -- ) [ drop ] ifcc ; inline
  74
  75 : callcc1 ( quot -- obj ) [ ] ifcc ; inline
  76
  77 <PRIVATE
  78
  79 : (continue) ( continuation -- )
  80     >continuation<
  81     set-catchstack
  82     set-namestack
  83     set-retainstack
  84     >r set-datastack r>
  85     set-callstack ;
  86
  87 : (continue-with) ( obj continuation -- )
  88     swap 4 setenv
  89     >continuation<
  90     set-catchstack
  91     set-namestack
  92     set-retainstack
  93     >r set-datastack drop 4 getenv f 4 setenv f r>
  94     set-callstack ;
  95
  96 PRIVATE>
  97
  98 : continue-with ( obj continuation -- )
  99     [ (continue-with) ] 2 (throw) ;
 100
 101 : continue ( continuation -- )
 102     f swap continue-with ;
 103
 104 SYMBOL: return-continuation
 105
 106 : with-return ( quot -- )
 107     [ [ return-continuation set ] prepose callcc0 ] with-scope ; inline
 108
 109 : return ( -- )
 110     return-continuation get continue ;
 111
 112 : with-datastack ( stack quot -- newstack )
 113     [
 114         [
 115             [ [ { } like set-datastack ] dip call datastack ] dip
 116             continue-with
 117         ] 3 (throw)
 118     ] callcc1 2nip ;
 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     >r [ swap >c call c> drop ] curry r> ifcc ; inline
 142
 143 : ignore-errors ( quot -- )
 144     [ drop ] recover ; inline
 145
 146 : cleanup ( try cleanup-always cleanup-error -- )
 147     over >r compose [ dip rethrow ] curry
 148     recover r> call ; inline
 149
 150 ERROR: attempt-all-error ;
 151
 152 : attempt-all ( seq quot -- obj )
 153     over empty? [
 154         attempt-all-error
 155     ] [
 156         [
 157             [ [ , f ] compose [ , drop t ] recover ] curry all?
 158         ] { } make peek swap [ rethrow ] when
 159     ] if ; inline
 160
 161 TUPLE: condition error restarts continuation ;
 162
 163 C: <condition> condition ( error restarts cc -- condition )
 164
 165 : throw-restarts ( error restarts -- restart )
 166     [ <condition> throw ] callcc1 2nip ;
 167
 168 : rethrow-restarts ( error restarts -- restart )
 169     [ <condition> rethrow ] callcc1 2nip ;
 170
 171 TUPLE: restart name obj continuation ;
 172
 173 C: <restart> restart
 174
 175 : restart ( restart -- )
 176     [ obj>> ] [ continuation>> ] bi continue-with ;
 177
 178 M: object compute-restarts drop { } ;
 179
 180 M: condition compute-restarts
 181     [ error>> compute-restarts ]
 182     [
 183         [ restarts>> ]
 184         [ condition-continuation [ <restart> ] curry ] bi
 185         { } assoc>map
 186     ] bi append ;
 187
 188 <PRIVATE
 189
 190 : init-error-handler ( -- )
 191     V{ } clone set-catchstack
 192     ! VM calls on error
 193     [
 194         ! 63 = self
 195         63 getenv error-thread set-global
 196         continuation error-continuation set-global
 197         rethrow
 198     ] 5 setenv
 199     ! VM adds this to kernel errors, so that user-space
 200     ! can identify them
 201     "kernel-error" 6 setenv ;
 202
 203 PRIVATE>