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