core/tools/interpreter.factor

   1 ! Copyright (C) 2004, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays errors generic io kernel kernel-internals math
   4 namespaces prettyprint sequences strings threads vectors words
   5 hashtables ;
   6 IN: interpreter
   7
   8 ! Metacircular interpreter for single-stepping
   9 SYMBOL: meta-interp
  10
  11 ! Meta-stacks;
  12 : meta-d meta-interp get continuation-data ;
  13 : push-d meta-d push ;
  14 : pop-d meta-d pop ;
  15 : peek-d meta-d peek ;
  16
  17 : meta-r meta-interp get continuation-retain ;
  18 : push-r meta-r push ;
  19 : pop-r meta-r pop ;
  20 : peek-r meta-r peek ;
  21
  22 : meta-c meta-interp get continuation-call ;
  23 : push-c meta-c push ;
  24 : pop-c meta-c pop ;
  25 : peek-c meta-c peek ;
  26
  27 ! Call frame
  28 SYMBOL: callframe
  29 SYMBOL: callframe-scan
  30 SYMBOL: callframe-end
  31
  32 ! Hook
  33 SYMBOL: break-hook
  34
  35 : meta-callframe ( -- seq )
  36     { callframe callframe-scan callframe-end } [ get ] map ;
  37
  38 : (meta-call) ( quot -- )
  39     dup callframe set
  40     length callframe-end set
  41     0 callframe-scan set ;
  42
  43 ! Callframe.
  44
  45 : break ( -- )
  46     continuation get-walker-hook
  47     [ continue-with ] [ break-hook get call ] if* ;
  48
  49 : remove-breaks \ break swap remove ;
  50
  51 : up ( -- )
  52     pop-c drop
  53     pop-c pop-c cut [ remove-breaks ] 2apply
  54     >r dup length callframe-scan set r> append
  55     dup length callframe-end set callframe set ;
  56
  57 : done-cf? ( -- ? ) callframe-scan get callframe-end get >= ;
  58
  59 : done? ( -- ? ) done-cf? meta-c empty? and ;
  60
  61 : reset-interpreter ( -- )
  62     meta-interp off f (meta-call) ;
  63
  64 : (save-callframe) ( -- )
  65     callframe get push-c
  66     callframe-scan get push-c
  67     callframe-end get push-c ;
  68
  69 : save-callframe ( -- )
  70     done-cf? [ (save-callframe) ] unless ;
  71
  72 : meta-call ( quot -- )
  73     #! Note we do tail call optimization here.
  74     save-callframe (meta-call) ;
  75
  76 : restore-normally
  77     clone meta-interp set
  78     meta-c empty? [ f (meta-call) ] [ up ] if ;
  79
  80 : restore-with
  81     first2 restore-normally push-d
  82     meta-d [ length 1- dup 1- ] keep exchange ;
  83
  84 : restore-harness ( obj -- )
  85     {
  86         { [ dup continuation? ] [ restore-normally ] }
  87         { [ dup not ] [ drop reset-interpreter ] }
  88         { [ dup length 2 = ] [ restore-with ] }
  89     } cond ;
  90
  91 : <callframe> ( quot scan -- seq )
  92     >r >quotation r> over length 3array >vector ;
  93
  94 : <breakpoint> ( break quot scan -- callframe )
  95     >r cut [ break ] swap 3append r> <callframe> ;
  96
  97 : step-to ( n -- )
  98     >r meta-c r>
  99     callframe get callframe-scan get <breakpoint>
 100     nappend
 101     [ set-walker-hook meta-interp get (continue) ] callcc1
 102     restore-harness ;
 103
 104 ! The interpreter loses object identity of the name and catch
 105 ! stacks -- they are copied after each step -- so we execute
 106 ! these atomically and don't allow stepping into these words
 107 { >n n> >c c> rethrow continue continue-with continuation
 108 (continue) (continue-with) }
 109 [ t "no-meta-word" set-word-prop ] each
 110
 111 \ call [ pop-d meta-call ] "meta-word" set-word-prop
 112 \ execute [ pop-d unit meta-call ] "meta-word" set-word-prop
 113 \ if [ pop-d pop-d pop-d [ nip ] [ drop ] if meta-call ] "meta-word" set-word-prop
 114 \ dispatch [ pop-d pop-d swap nth meta-call ] "meta-word" set-word-prop
 115
 116 ! Time travel
 117 SYMBOL: meta-history
 118
 119 : save-interp ( -- )
 120     meta-history get [
 121         [
 122             callframe [ ] change
 123             callframe-scan [ ] change
 124             callframe-end [ ] change
 125             meta-interp [ clone ] change
 126         ] make-hash swap push
 127     ] when* ;
 128
 129 : restore-interp ( ns -- )
 130     { callframe callframe-scan callframe-end }
 131     [ dup pick hash swap set ] each
 132     meta-interp swap hash clone meta-interp set ;
 133
 134 : advance ( -- ) callframe-scan inc ;
 135
 136 : (next) callframe-scan get callframe get nth ;
 137
 138 : next ( quot -- )
 139     save-interp {
 140         { [ done? ] [ drop [ ] (meta-call) ] }
 141         { [ done-cf? ] [ drop up ] }
 142         { [ >r (next) r> call ] [ ] }
 143         { [ t ] [ callframe-scan get 1+ step-to ] }
 144     } cond ; inline
 145
 146 GENERIC: (step) ( obj -- ? )
 147
 148 M: wrapper (step) advance wrapped push-d t ;
 149
 150 M: object (step) advance push-d t ;
 151
 152 M: word (step) drop f ;
 153
 154 : step ( -- ) [ (step) ] next ;
 155
 156 : (step-in) ( word -- ? )
 157     dup "meta-word" word-prop [
 158         advance call t
 159     ] [
 160         dup "no-meta-word" word-prop not over compound? and [
 161             advance word-def meta-call t
 162         ] [
 163             drop f
 164         ] if
 165     ] ?if ;
 166
 167 : step-in ( -- )
 168     [ dup word? [ (step-in) ] [ (step) ] if ] next ;
 169
 170 : step-out ( -- )
 171     save-interp callframe-end get step-to ;
 172
 173 : step-all ( -- )
 174     save-callframe meta-interp get schedule-thread ;
 175
 176 : step-back ( -- )
 177     meta-history get dup empty?
 178     [ drop ] [ pop restore-interp ] if ;