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: c-type-word depends-on-c-type depends-on-definition ;
  44
  45 M: array depends-on-c-type
  46     [ word? ] filter [ depends-on-definition ] each ;
  47
  48 ! Generic words that the current quotation depends on
  49 SYMBOL: generic-dependencies
  50
  51 : ?class-or ( class class/f -- class' )
  52     [ class-or ] when* ;
  53
  54 : depends-on-generic ( class generic -- )
  55     generic-dependencies get dup
  56     [ [ ?class-or ] change-at ] [ 3drop ] if ;
  57
  58 ! Conditional dependencies are re-evaluated when classes change;
  59 ! if any fail, the word is recompiled
  60 SYMBOL: conditional-dependencies
  61
  62 GENERIC: satisfied? ( dependency -- ? )
  63
  64 : add-conditional-dependency ( ... class -- )
  65     boa conditional-dependencies get
  66     dup [ conjoin ] [ 2drop ] if ; inline
  67
  68 TUPLE: depends-on-class-predicate class1 class2 result ;
  69
  70 : depends-on-class-predicate ( class1 class2 result -- )
  71     \ depends-on-class-predicate add-conditional-dependency ;
  72
  73 M: depends-on-class-predicate satisfied?
  74     {
  75         [ [ class1>> classoid? ] [ class2>> classoid? ] bi and ]
  76         [ [ [ class1>> ] [ class2>> ] bi compare-classes ] [ result>> ] bi eq? ]
  77     } 1&& ;
  78
  79 TUPLE: depends-on-instance-predicate object class result ;
  80
  81 : depends-on-instance-predicate ( object class result -- )
  82     \ depends-on-instance-predicate add-conditional-dependency ;
  83
  84 M: depends-on-instance-predicate satisfied?
  85     {
  86         [ class>> classoid? ]
  87         [ [ [ object>> ] [ class>> ] bi instance? ] [ result>> ] bi eq? ]
  88     } 1&& ;
  89
  90 TUPLE: depends-on-next-method class generic next-method ;
  91
  92 : depends-on-next-method ( class generic next-method -- )
  93     over depends-on-conditionally
  94     \ depends-on-next-method add-conditional-dependency ;
  95
  96 M: depends-on-next-method satisfied?
  97     {
  98         [ class>> classoid? ]
  99         [ [ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ]
 100     } 1&& ;
 101
 102 TUPLE: depends-on-method class generic method ;
 103
 104 : depends-on-method ( class generic method -- )
 105     over depends-on-conditionally
 106     \ depends-on-method add-conditional-dependency ;
 107
 108 M: depends-on-method satisfied?
 109     {
 110         [ class>> classoid? ]
 111         [ [ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ]
 112     } 1&& ;
 113
 114 TUPLE: depends-on-tuple-layout class layout ;
 115
 116 : depends-on-tuple-layout ( class layout -- )
 117     [ drop depends-on-conditionally ]
 118     [ \ depends-on-tuple-layout add-conditional-dependency ] 2bi ;
 119
 120 M: depends-on-tuple-layout satisfied?
 121     [ class>> tuple-layout ] [ layout>> ] bi eq? ;
 122
 123 TUPLE: depends-on-flushable word ;
 124
 125 : depends-on-flushable ( word -- )
 126     [ depends-on-conditionally ]
 127     [ \ depends-on-flushable add-conditional-dependency ] bi ;
 128
 129 M: depends-on-flushable satisfied?
 130     word>> flushable? ;
 131
 132 TUPLE: depends-on-final class ;
 133
 134 : depends-on-final ( word -- )
 135     [ depends-on-conditionally ]
 136     [ \ depends-on-final add-conditional-dependency ] bi ;
 137
 138 M: depends-on-final satisfied?
 139     class>> final-class? ;
 140
 141 : init-dependencies ( -- )
 142     H{ } clone dependencies set
 143     H{ } clone generic-dependencies set
 144     H{ } clone conditional-dependencies set ;
 145
 146 : without-dependencies ( quot -- )
 147     [
 148         dependencies off
 149         generic-dependencies off
 150         conditional-dependencies off
 151         call
 152     ] with-scope ; inline