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