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