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