core/compiler/units/units.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays kernel continuations assocs namespaces
   4 sequences words vocabs definitions hashtables init sets
   5 math math.order classes classes.algebra ;
   6 IN: compiler.units
   7
   8 SYMBOL: old-definitions
   9 SYMBOL: new-definitions
  10
  11 TUPLE: redefine-error def ;
  12
  13 : redefine-error ( definition -- )
  14     \ redefine-error boa
  15     { { "Continue" t } } throw-restarts drop ;
  16
  17 : add-once ( key assoc -- )
  18     2dup key? [ over redefine-error ] when conjoin ;
  19
  20 : (remember-definition) ( definition loc assoc -- )
  21     >r over set-where r> add-once ;
  22
  23 : remember-definition ( definition loc -- )
  24     new-definitions get first (remember-definition) ;
  25
  26 : remember-class ( class loc -- )
  27     over new-definitions get first key? [ dup redefine-error ] when
  28     new-definitions get second (remember-definition) ;
  29
  30 : forward-reference? ( word -- ? )
  31     dup old-definitions get assoc-stack
  32     [ new-definitions get assoc-stack not ]
  33     [ drop f ] if ;
  34
  35 SYMBOL: recompile-hook
  36
  37 : <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
  38
  39 SYMBOL: definition-observers
  40
  41 GENERIC: definitions-changed ( assoc obj -- )
  42
  43 [ V{ } clone definition-observers set-global ]
  44 "compiler.units" add-init-hook
  45
  46 : add-definition-observer ( obj -- )
  47     definition-observers get push ;
  48
  49 : remove-definition-observer ( obj -- )
  50     definition-observers get delete ;
  51
  52 : notify-definition-observers ( assoc -- )
  53     definition-observers get
  54     [ definitions-changed ] with each ;
  55
  56 : changed-vocabs ( assoc -- vocabs )
  57     [ drop word? ] assoc-filter
  58     [ drop vocabulary>> dup [ vocab ] when dup ] assoc-map ;
  59
  60 : updated-definitions ( -- assoc )
  61     H{ } clone
  62     dup forgotten-definitions get update
  63     dup new-definitions get first update
  64     dup new-definitions get second update
  65     dup changed-definitions get update
  66     dup dup changed-vocabs update ;
  67
  68 : compile ( words -- )
  69     recompile-hook get call
  70     dup [ drop crossref? ] assoc-contains?
  71     modify-code-heap ;
  72
  73 SYMBOL: outdated-tuples
  74 SYMBOL: update-tuples-hook
  75
  76 : dependency>= ( how1 how2 -- ? )
  77     [
  78         {
  79             called-dependency
  80             flushed-dependency
  81             inlined-dependency
  82         } index
  83     ] bi@ >= ;
  84
  85 : strongest-dependency ( how1 how2 -- how )
  86     [ called-dependency or ] bi@ [ dependency>= ] most ;
  87
  88 : weakest-dependency ( how1 how2 -- how )
  89     [ inlined-dependency or ] bi@ [ dependency>= not ] most ;
  90
  91 : compiled-usage ( word -- assoc )
  92     compiled-crossref get at ;
  93
  94 : (compiled-usages) ( word -- assoc )
  95     #! If the word is not flushable anymore, we have to recompile
  96     #! all words which flushable away a call (presumably when the
  97     #! word was still flushable). If the word is flushable, we
  98     #! don't have to recompile words that folded this away.
  99     [ compiled-usage ]
 100     [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
 101     [ dependency>= nip ] curry assoc-filter ;
 102
 103 : compiled-usages ( assoc -- assocs )
 104     [ drop word? ] assoc-filter
 105     [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
 106
 107 : compiled-generic-usage ( word -- assoc )
 108     compiled-generic-crossref get at ;
 109
 110 : (compiled-generic-usages) ( generic class -- assoc )
 111     dup class? [
 112         [ compiled-generic-usage ] dip
 113         [ classes-intersect? nip ] curry assoc-filter
 114     ] [ 2drop f ] if ;
 115
 116 : compiled-generic-usages ( assoc -- assocs )
 117     [ (compiled-generic-usages) ] { } assoc>map ;
 118
 119 : words-only ( assoc -- assoc' )
 120     [ drop word? ] assoc-filter ;
 121
 122 : to-recompile ( -- seq )
 123     changed-definitions get compiled-usages
 124     changed-generics get compiled-generic-usages
 125     append assoc-combine keys ;
 126
 127 : call-recompile-hook ( -- )
 128     to-recompile recompile-hook get call ;
 129
 130 : call-update-tuples-hook ( -- )
 131     update-tuples-hook get call ;
 132
 133 : unxref-forgotten-definitions ( -- )
 134     forgotten-definitions get
 135     keys [ word? ] filter
 136     [ delete-compiled-xref ] each ;
 137
 138 : finish-compilation-unit ( -- )
 139     call-recompile-hook
 140     call-update-tuples-hook
 141     unxref-forgotten-definitions
 142     dup [ drop crossref? ] assoc-contains? modify-code-heap ;
 143
 144 : with-nested-compilation-unit ( quot -- )
 145     [
 146         H{ } clone changed-definitions set
 147         H{ } clone changed-generics set
 148         H{ } clone outdated-tuples set
 149         H{ } clone new-classes set
 150         [ finish-compilation-unit ] [ ] cleanup
 151     ] with-scope ; inline
 152
 153 : with-compilation-unit ( quot -- )
 154     [
 155         H{ } clone changed-definitions set
 156         H{ } clone changed-generics set
 157         H{ } clone forgotten-definitions set
 158         H{ } clone outdated-tuples set
 159         H{ } clone new-classes set
 160         <definitions> new-definitions set
 161         <definitions> old-definitions set
 162         [
 163             finish-compilation-unit
 164             updated-definitions
 165             notify-definition-observers
 166         ] [ ] cleanup
 167     ] with-scope ; inline
 168
 169 : compile-call ( quot -- )
 170     [ define-temp ] with-compilation-unit execute ;
 171
 172 : default-recompile-hook ( words -- alist )
 173     [ f ] { } map>assoc ;
 174
 175 recompile-hook global
 176 [ [ default-recompile-hook ] or ]
 177 change-at