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