basis/stack-checker/state/state.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: assocs namespaces sequences kernel definitions math
   4 effects accessors words fry classes.algebra stack-checker.errors
   5 compiler.units ;
   6 IN: stack-checker.state
   7
   8 : <value> ( -- value ) \ <value> counter ;
   9
  10 SYMBOL: known-values
  11
  12 : known ( value -- known ) known-values get at ;
  13
  14 : set-known ( known value -- )
  15     over [ known-values get set-at ] [ 2drop ] if ;
  16
  17 : make-known ( known -- value )
  18     <value> [ set-known ] keep ;
  19
  20 : copy-value ( value -- value' )
  21     known make-known ;
  22
  23 : copy-values ( values -- values' )
  24     [ copy-value ] map ;
  25
  26 ! Literal value
  27 TUPLE: literal < identity-tuple value recursion ;
  28
  29 : <literal> ( obj -- value )
  30     recursive-state get \ literal boa ;
  31
  32 : literal ( value -- literal )
  33     known dup literal?
  34     [  \ literal-expected inference-warning ] unless ;
  35
  36 ! Result of curry
  37 TUPLE: curried obj quot ;
  38
  39 C: <curried> curried
  40
  41 ! Result of compose
  42 TUPLE: composed quot1 quot2 ;
  43
  44 C: <composed> composed
  45
  46 ! Did the current control-flow path throw an error?
  47 SYMBOL: terminated?
  48
  49 ! Number of inputs current word expects from the stack
  50 SYMBOL: d-in
  51
  52 ! Compile-time data stack
  53 SYMBOL: meta-d
  54
  55 ! Compile-time retain stack
  56 SYMBOL: meta-r
  57
  58 : current-stack-height ( -- n ) meta-d get length d-in get - ;
  59
  60 : current-effect ( -- effect )
  61     d-in get
  62     meta-d get length <effect>
  63     terminated? get >>terminated? ;
  64
  65 : init-inference ( -- )
  66     terminated? off
  67     V{ } clone meta-d set
  68     V{ } clone meta-r set
  69     0 d-in set ;
  70
  71 : init-known-values ( -- )
  72     H{ } clone known-values set ;
  73
  74 : recursive-label ( word -- label/f )
  75     recursive-state get at ;
  76
  77 : local-recursive-state ( -- assoc )
  78     recursive-state get dup keys
  79     [ dup word? [ inline? ] when not ] find drop
  80     [ head-slice ] when* ;
  81
  82 : inline-recursive-label ( word -- label/f )
  83     local-recursive-state at ;
  84
  85 : recursive-quotation? ( quot -- ? )
  86     local-recursive-state [ first eq? ] with contains? ;
  87
  88 ! Words that the current quotation depends on
  89 SYMBOL: dependencies
  90
  91 : depends-on ( word how -- )
  92     over primitive? [ 2drop ] [
  93         dependencies get dup [
  94             swap '[ _ strongest-dependency ] change-at
  95         ] [ 3drop ] if
  96     ] if ;
  97
  98 ! Generic words that the current quotation depends on
  99 SYMBOL: generic-dependencies
 100
 101 : depends-on-generic ( generic class -- )
 102     generic-dependencies get dup
 103     [ swap '[ null or _ class-or ] change-at ] [ 3drop ] if ;
 104
 105 ! Words we've inferred the stack effect of, for rollback
 106 SYMBOL: recorded