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     [ over set-where ] dip add-once ;
  22
  23 : remember-definition ( definition loc -- )
  24     new-definitions get first (remember-definition) ;
  25
  26 : remember-class ( class loc -- )
  27     [ dup new-definitions get first key? [ dup redefine-error ] when ] dip
  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 SYMBOL: remake-generics-hook
  76
  77 : dependency>= ( how1 how2 -- ? )
  78     [
  79         {
  80             called-dependency
  81             flushed-dependency
  82             inlined-dependency
  83         } index
  84     ] bi@ >= ;
  85
  86 : strongest-dependency ( how1 how2 -- how )
  87     [ called-dependency or ] bi@ [ dependency>= ] most ;
  88
  89 : weakest-dependency ( how1 how2 -- how )
  90     [ inlined-dependency or ] bi@ [ dependency>= not ] most ;
  91
  92 : compiled-usage ( word -- assoc )
  93     compiled-crossref get at ;
  94
  95 : (compiled-usages) ( word -- assoc )
  96     #! If the word is not flushable anymore, we have to recompile
  97     #! all words which flushable away a call (presumably when the
  98     #! word was still flushable). If the word is flushable, we
  99     #! don't have to recompile words that folded this away.
 100     [ compiled-usage ]
 101     [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
 102     [ dependency>= nip ] curry assoc-filter ;
 103
 104 : compiled-usages ( assoc -- assocs )
 105     [ drop word? ] assoc-filter
 106     [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
 107
 108 : compiled-generic-usage ( word -- assoc )
 109     compiled-generic-crossref get at ;
 110
 111 : (compiled-generic-usages) ( generic class -- assoc )
 112     [ compiled-generic-usage ] dip
 113     [
 114         2dup [ valid-class? ] both?
 115         [ classes-intersect? ] [ 2drop f ] if nip
 116     ] curry assoc-filter ;
 117
 118 : compiled-generic-usages ( assoc -- assocs )
 119     [ (compiled-generic-usages) ] { } assoc>map ;
 120
 121 : words-only ( assoc -- assoc' )
 122     [ drop word? ] assoc-filter ;
 123
 124 : to-recompile ( -- seq )
 125     changed-definitions get compiled-usages
 126     changed-generics get compiled-generic-usages
 127     append assoc-combine keys ;
 128
 129 : call-recompile-hook ( -- )
 130     to-recompile recompile-hook get call ;
 131
 132 : call-remake-generics-hook ( -- )
 133     remake-generics-hook get call ;
 134
 135 : call-update-tuples-hook ( -- )
 136     update-tuples-hook get call ;
 137
 138 : unxref-forgotten-definitions ( -- )
 139     forgotten-definitions get
 140     keys [ word? ] filter
 141     [ delete-compiled-xref ] each ;
 142
 143 : finish-compilation-unit ( -- )
 144     call-remake-generics-hook
 145     call-recompile-hook
 146     call-update-tuples-hook
 147     unxref-forgotten-definitions
 148     dup [ drop crossref? ] assoc-contains? modify-code-heap ;
 149
 150 : with-nested-compilation-unit ( quot -- )
 151     [
 152         H{ } clone changed-definitions set
 153         H{ } clone changed-generics set
 154         H{ } clone remake-generics set
 155         H{ } clone outdated-tuples set
 156         H{ } clone new-classes set
 157         [ finish-compilation-unit ] [ ] cleanup
 158     ] with-scope ; inline
 159
 160 : with-compilation-unit ( quot -- )
 161     [
 162         H{ } clone changed-definitions set
 163         H{ } clone changed-generics set
 164         H{ } clone remake-generics set
 165         H{ } clone forgotten-definitions set
 166         H{ } clone outdated-tuples set
 167         H{ } clone new-classes set
 168         <definitions> new-definitions set
 169         <definitions> old-definitions set
 170         [
 171             finish-compilation-unit
 172             updated-definitions
 173             notify-definition-observers
 174         ] [ ] cleanup
 175     ] with-scope ; inline
 176
 177 : compile-call ( quot -- )
 178     [ define-temp ] with-compilation-unit execute ;
 179
 180 : default-recompile-hook ( words -- alist )
 181     [ f ] { } map>assoc ;
 182
 183 recompile-hook global
 184 [ [ default-recompile-hook ] or ]
 185 change-at