core/compiler/units/units.factor

   1 ! Copyright (C) 2008, 2009 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 classes.tuple
   6 classes.tuple.private generic source-files.errors ;
   7 IN: compiler.units
   8
   9 SYMBOL: old-definitions
  10 SYMBOL: new-definitions
  11
  12 TUPLE: redefine-error def ;
  13
  14 : redefine-error ( definition -- )
  15     \ redefine-error boa
  16     { { "Continue" t } } throw-restarts drop ;
  17
  18 : add-once ( key assoc -- )
  19     2dup key? [ over redefine-error ] when conjoin ;
  20
  21 : (remember-definition) ( definition loc assoc -- )
  22     [ over set-where ] dip add-once ;
  23
  24 : remember-definition ( definition loc -- )
  25     new-definitions get first (remember-definition) ;
  26
  27 : fake-definition ( definition -- )
  28     old-definitions get [ delete-at ] with each ;
  29
  30 : remember-class ( class loc -- )
  31     [ dup new-definitions get first key? [ dup redefine-error ] when ] dip
  32     new-definitions get second (remember-definition) ;
  33
  34 : forward-reference? ( word -- ? )
  35     dup old-definitions get assoc-stack
  36     [ new-definitions get assoc-stack not ]
  37     [ drop f ] if ;
  38
  39 SYMBOL: compiler-impl
  40
  41 HOOK: recompile compiler-impl ( words -- alist )
  42
  43 ! Non-optimizing compiler
  44 M: f recompile [ dup def>> ] { } map>assoc ;
  45
  46 : without-optimizer ( quot -- )
  47     [ f compiler-impl ] dip with-variable ; inline
  48
  49 ! Trivial compiler. We don't want to touch the code heap
  50 ! during stage1 bootstrap, it would just waste time.
  51 SINGLETON: dummy-compiler
  52
  53 M: dummy-compiler recompile drop { } ;
  54
  55 : <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
  56
  57 SYMBOL: definition-observers
  58
  59 GENERIC: definitions-changed ( assoc obj -- )
  60
  61 [ V{ } clone definition-observers set-global ]
  62 "compiler.units" add-init-hook
  63
  64 ! This goes here because vocabs cannot depend on init
  65 [ V{ } clone vocab-observers set-global ]
  66 "vocabs" add-init-hook
  67
  68 : add-definition-observer ( obj -- )
  69     definition-observers get push ;
  70
  71 : remove-definition-observer ( obj -- )
  72     definition-observers get delq ;
  73
  74 : notify-definition-observers ( assoc -- )
  75     definition-observers get
  76     [ definitions-changed ] with each ;
  77
  78 : changed-vocabs ( assoc -- vocabs )
  79     [ drop word? ] assoc-filter
  80     [ drop vocabulary>> dup [ vocab ] when dup ] assoc-map ;
  81
  82 : updated-definitions ( -- assoc )
  83     H{ } clone
  84     dup forgotten-definitions get update
  85     dup new-definitions get first update
  86     dup new-definitions get second update
  87     dup changed-definitions get update
  88     dup dup changed-vocabs update ;
  89
  90 : compile ( words -- ) recompile modify-code-heap ;
  91
  92 : index>= ( obj1 obj2 seq -- ? )
  93     [ index ] curry bi@ >= ;
  94
  95 : dependency>= ( how1 how2 -- ? )
  96     { called-dependency flushed-dependency inlined-dependency }
  97     index>= ;
  98
  99 : strongest-dependency ( how1 how2 -- how )
 100     [ called-dependency or ] bi@ [ dependency>= ] most ;
 101
 102 : weakest-dependency ( how1 how2 -- how )
 103     [ inlined-dependency or ] bi@ [ dependency>= not ] most ;
 104
 105 : compiled-usage ( word -- assoc )
 106     compiled-crossref get at ;
 107
 108 : (compiled-usages) ( word -- assoc )
 109     #! If the word is not flushable anymore, we have to recompile
 110     #! all words which flushable away a call (presumably when the
 111     #! word was still flushable). If the word is flushable, we
 112     #! don't have to recompile words that folded this away.
 113     [ compiled-usage ]
 114     [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
 115     [ dependency>= nip ] curry assoc-filter ;
 116
 117 : compiled-usages ( assoc -- assocs )
 118     [ drop word? ] assoc-filter
 119     [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
 120
 121 : compiled-generic-usage ( word -- assoc )
 122     compiled-generic-crossref get at ;
 123
 124 : (compiled-generic-usages) ( generic class -- assoc )
 125     [ compiled-generic-usage ] dip
 126     [
 127         2dup [ valid-class? ] both?
 128         [ classes-intersect? ] [ 2drop f ] if nip
 129     ] curry assoc-filter ;
 130
 131 : compiled-generic-usages ( assoc -- assocs )
 132     [ (compiled-generic-usages) ] { } assoc>map ;
 133
 134 : words-only ( assoc -- assoc' )
 135     [ drop word? ] assoc-filter ;
 136
 137 : to-recompile ( -- seq )
 138     changed-definitions get compiled-usages
 139     changed-generics get compiled-generic-usages
 140     append assoc-combine keys ;
 141
 142 : process-forgotten-definitions ( -- )
 143     forgotten-definitions get keys
 144     [ [ word? ] filter [ delete-compiled-xref ] each ]
 145     [ [ delete-definition-errors ] each ]
 146     bi ;
 147
 148 : finish-compilation-unit ( -- )
 149     remake-generics
 150     to-recompile recompile
 151     update-tuples
 152     process-forgotten-definitions
 153     modify-code-heap
 154     updated-definitions dup assoc-empty?
 155     [ drop ] [ notify-definition-observers notify-error-observers ] if ;
 156
 157 : with-nested-compilation-unit ( quot -- )
 158     [
 159         H{ } clone changed-definitions set
 160         H{ } clone changed-generics set
 161         H{ } clone changed-effects set
 162         H{ } clone outdated-generics set
 163         H{ } clone outdated-tuples set
 164         H{ } clone new-classes set
 165         [ finish-compilation-unit ] [ ] cleanup
 166     ] with-scope ; inline
 167
 168 : with-compilation-unit ( quot -- )
 169     [
 170         H{ } clone changed-definitions set
 171         H{ } clone changed-generics set
 172         H{ } clone changed-effects set
 173         H{ } clone outdated-generics set
 174         H{ } clone forgotten-definitions set
 175         H{ } clone outdated-tuples set
 176         H{ } clone new-classes set
 177         <definitions> new-definitions set
 178         <definitions> old-definitions set
 179         [ finish-compilation-unit ] [ ] cleanup
 180     ] with-scope ; inline