basis/stack-checker/dependencies/dependencies.factor

   1 ! Copyright (C) 2009, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types arrays assocs classes
   4 classes.algebra classes.tuple combinators.short-circuit fry
   5 generic kernel math namespaces sequences sets words ;
   6 FROM: classes.tuple.private => tuple-layout ;
   7 FROM: namespaces => set ;
   8 IN: stack-checker.dependencies
   9
  10 ! Words that the current quotation depends on
  11 SYMBOL: dependencies
  12
  13 SYMBOLS: effect-dependency conditional-dependency definition-dependency ;
  14
  15 : index>= ( obj1 obj2 seq -- ? )
  16     [ index ] curry bi@ >= ;
  17
  18 : dependency>= ( how1 how2 -- ? )
  19     {
  20         effect-dependency
  21         conditional-dependency
  22         definition-dependency
  23     } index>= ;
  24
  25 : strongest-dependency ( how1 how2 -- how )
  26     [ effect-dependency or ] bi@ [ dependency>= ] most ;
  27
  28 : depends-on ( word how -- )
  29     over primitive? [ 2drop ] [
  30         dependencies get dup [
  31             swap '[ _ strongest-dependency ] change-at
  32         ] [ 3drop ] if
  33     ] if ;
  34
  35 : add-depends-on-effect ( word -- )
  36     effect-dependency depends-on ;
  37
  38 : add-depends-on-conditionally ( word -- )
  39     conditional-dependency depends-on ;
  40
  41 : add-depends-on-definition ( word -- )
  42     definition-dependency depends-on ;
  43
  44 GENERIC: add-depends-on-c-type ( c-type -- )
  45
  46 M: void add-depends-on-c-type drop ;
  47
  48 M: c-type-word add-depends-on-c-type add-depends-on-definition ;
  49
  50 M: array add-depends-on-c-type
  51     [ word? ] filter [ add-depends-on-definition ] each ;
  52
  53 M: pointer add-depends-on-c-type
  54     to>> add-depends-on-c-type ;
  55
  56 ! Generic words that the current quotation depends on
  57 SYMBOL: generic-dependencies
  58
  59 : ?class-or ( class class/f -- class' )
  60     [ class-or ] when* ;
  61
  62 : add-depends-on-generic ( class generic -- )
  63     generic-dependencies get
  64     [ [ ?class-or ] change-at ] [ 2drop ] if* ;
  65
  66 ! Conditional dependencies are re-evaluated when classes change;
  67 ! if any fail, the word is recompiled
  68 SYMBOL: conditional-dependencies
  69
  70 GENERIC: satisfied? ( dependency -- ? )
  71
  72 : add-conditional-dependency ( ... class -- )
  73     boa conditional-dependencies get
  74     [ adjoin ] [ drop ] if* ; inline
  75
  76 TUPLE: depends-on-class-predicate class1 class2 result ;
  77
  78 : add-depends-on-class-predicate ( class1 class2 result -- )
  79     \ depends-on-class-predicate add-conditional-dependency ;
  80
  81 M: depends-on-class-predicate satisfied?
  82     {
  83         [ class1>> valid-classoid? ]
  84         [ class2>> valid-classoid? ]
  85         [ [ [ class1>> ] [ class2>> ] bi evaluate-class-predicate ] [ result>> ] bi eq? ]
  86     } 1&& ;
  87
  88 TUPLE: depends-on-instance-predicate object class result ;
  89
  90 : add-depends-on-instance-predicate ( object class result -- )
  91     \ depends-on-instance-predicate add-conditional-dependency ;
  92
  93 M: depends-on-instance-predicate satisfied?
  94     {
  95         [ class>> valid-classoid? ]
  96         [ [ [ object>> ] [ class>> ] bi instance? ] [ result>> ] bi eq? ]
  97     } 1&& ;
  98
  99 TUPLE: depends-on-next-method class generic next-method ;
 100
 101 : add-depends-on-next-method ( class generic next-method -- )
 102     over add-depends-on-conditionally
 103     \ depends-on-next-method add-conditional-dependency ;
 104
 105 M: depends-on-next-method satisfied?
 106     {
 107         [ class>> valid-classoid? ]
 108         [ [ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ]
 109     } 1&& ;
 110
 111 TUPLE: depends-on-method class generic method ;
 112
 113 : add-depends-on-method ( class generic method -- )
 114     over add-depends-on-conditionally
 115     \ depends-on-method add-conditional-dependency ;
 116
 117 M: depends-on-method satisfied?
 118     {
 119         [ class>> classoid? ]
 120         [ [ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ]
 121     } 1&& ;
 122
 123 TUPLE: depends-on-tuple-layout class layout ;
 124
 125 : add-depends-on-tuple-layout ( class layout -- )
 126     [ drop add-depends-on-conditionally ]
 127     [ \ depends-on-tuple-layout add-conditional-dependency ] 2bi ;
 128
 129 M: depends-on-tuple-layout satisfied?
 130     [ class>> tuple-layout ] [ layout>> ] bi eq? ;
 131
 132 TUPLE: depends-on-flushable word ;
 133
 134 : add-depends-on-flushable ( word -- )
 135     [ add-depends-on-conditionally ]
 136     [ \ depends-on-flushable add-conditional-dependency ] bi ;
 137
 138 M: depends-on-flushable satisfied?
 139     word>> flushable? ;
 140
 141 TUPLE: depends-on-final class ;
 142
 143 : add-depends-on-final ( word -- )
 144     [ add-depends-on-conditionally ]
 145     [ \ depends-on-final add-conditional-dependency ] bi ;
 146
 147 M: depends-on-final satisfied?
 148     class>> { [ class? ] [ final-class? ] } 1&& ;
 149
 150 : init-dependencies ( -- )
 151     H{ } clone dependencies set
 152     H{ } clone generic-dependencies set
 153     HS{ } clone conditional-dependencies set ;
 154
 155 : without-dependencies ( quot -- )
 156     [
 157         dependencies off
 158         generic-dependencies off
 159         conditional-dependencies off
 160         call
 161     ] with-scope ; inline