core/continuations/continuations.factor

   1 ! Copyright (C) 2003, 2010 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     1 context-object { vector } declare ; inline
  25
  26 : >c ( continuation -- ) catchstack* push ;
  27
  28 : c> ( -- continuation ) catchstack* pop ;
  29
  30 ! We have to defeat some optimizations to make continuations work
  31 : dummy-1 ( -- obj ) f ;
  32 : dummy-2 ( obj -- obj ) dup drop ;
  33
  34 : catchstack ( -- catchstack ) catchstack* clone ; inline
  35
  36 : set-catchstack ( catchstack -- )
  37     >vector 1 set-context-object ; inline
  38
  39 : init-catchstack ( -- ) f set-catchstack ;
  40
  41 PRIVATE>
  42
  43 TUPLE: continuation data call retain name catch ;
  44
  45 C: <continuation> continuation
  46
  47 : 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 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 4 set-special-object
  82         >continuation<
  83         set-catchstack
  84         set-namestack
  85         set-retainstack
  86         [ set-datastack drop 4 special-object f 4 set-special-object f ] dip
  87         set-callstack
  88     ] (( obj continuation -- * )) call-effect-unsafe ;
  89
  90 : continue ( continuation -- * )
  91     f swap continue-with ;
  92
  93 SYMBOL: return-continuation
  94
  95 : with-return ( quot -- )
  96     [ [ return-continuation set ] prepose callcc0 ] with-scope ; inline
  97
  98 : return ( -- * )
  99     return-continuation get continue ;
 100
 101 GENERIC: compute-restarts ( error -- seq )
 102
 103 <PRIVATE
 104
 105 : save-error ( error -- )
 106     [ error set-global ]
 107     [ compute-restarts restarts set-global ] bi ;
 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         [ original-error get-global die ] or
 118         (( error -- * )) call-effect-unsafe
 119     ] when
 120     c> continue-with ;
 121
 122 : recover ( ..a try: ( ..a -- ..b ) recovery: ( ..a error -- ..b ) -- ..b )
 123     [ [ swap >c call c> drop ] curry ] dip ifcc ; inline
 124
 125 : ignore-errors ( quot -- )
 126     [ drop ] recover ; inline
 127
 128 : cleanup ( try cleanup-always cleanup-error -- )
 129     [ compose [ dip rethrow ] curry recover ] [ drop ] 2bi call ; inline
 130
 131 ERROR: attempt-all-error ;
 132
 133 : attempt-all ( ... seq quot: ( ... elt -- ... obj ) -- ... obj )
 134     over empty? [
 135         attempt-all-error
 136     ] [
 137         [
 138             [ [ , f ] compose [ , drop t ] recover ] curry all?
 139         ] { } make last swap [ rethrow ] when
 140     ] if ; inline
 141
 142 TUPLE: condition error restarts continuation ;
 143
 144 C: <condition> condition ( error restarts cc -- condition )
 145
 146 : throw-restarts ( error restarts -- restart )
 147     [ <condition> throw ] callcc1 2nip ;
 148
 149 : rethrow-restarts ( error restarts -- restart )
 150     [ <condition> rethrow ] callcc1 2nip ;
 151
 152 : throw-continue ( error -- )
 153     { { "Continue" t } } throw-restarts drop ;
 154
 155 TUPLE: restart name obj continuation ;
 156
 157 C: <restart> restart
 158
 159 : restart ( restart -- * )
 160     [ obj>> ] [ continuation>> ] bi continue-with ;
 161
 162 M: object compute-restarts drop { } ;
 163
 164 M: condition compute-restarts
 165     [ error>> compute-restarts ]
 166     [
 167         [ restarts>> ]
 168         [ continuation>> [ <restart> ] curry ] bi
 169         { } assoc>map
 170     ] bi append ;
 171
 172 <PRIVATE
 173
 174 : init-error-handler ( -- )
 175     init-catchstack
 176     ! VM calls on error
 177     [
 178         ! 63 = self
 179         63 special-object error-thread set-global
 180         continuation error-continuation set-global
 181         [ original-error set-global ] [ rethrow ] bi
 182     ] 5 set-special-object
 183     ! VM adds this to kernel errors, so that user-space
 184     ! can identify them
 185     "kernel-error" 6 set-special-object ;
 186
 187 PRIVATE>