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