core/compiler/units/units.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel continuations assocs namespaces
   4 sequences words vocabs definitions hashtables init sets ;
   5 IN: compiler.units
   6
   7 SYMBOL: old-definitions
   8 SYMBOL: new-definitions
   9
  10 TUPLE: redefine-error def ;
  11
  12 : redefine-error ( definition -- )
  13     \ redefine-error boa
  14     { { "Continue" t } } throw-restarts drop ;
  15
  16 : add-once ( key assoc -- )
  17     2dup key? [ over redefine-error ] when conjoin ;
  18
  19 : (remember-definition) ( definition loc assoc -- )
  20     >r over set-where r> add-once ;
  21
  22 : remember-definition ( definition loc -- )
  23     new-definitions get first (remember-definition) ;
  24
  25 : remember-class ( class loc -- )
  26     over new-definitions get first key? [ dup redefine-error ] when
  27     new-definitions get second (remember-definition) ;
  28
  29 : forward-reference? ( word -- ? )
  30     dup old-definitions get assoc-stack
  31     [ new-definitions get assoc-stack not ]
  32     [ drop f ] if ;
  33
  34 SYMBOL: recompile-hook
  35
  36 : <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
  37
  38 SYMBOL: definition-observers
  39
  40 GENERIC: definitions-changed ( assoc obj -- )
  41
  42 [ V{ } clone definition-observers set-global ]
  43 "compiler.units" add-init-hook
  44
  45 : add-definition-observer ( obj -- )
  46     definition-observers get push ;
  47
  48 : remove-definition-observer ( obj -- )
  49     definition-observers get delete ;
  50
  51 : notify-definition-observers ( assoc -- )
  52     definition-observers get
  53     [ definitions-changed ] with each ;
  54
  55 : changed-vocabs ( assoc -- vocabs )
  56     [ drop word? ] assoc-filter
  57     [ drop vocabulary>> dup [ vocab ] when dup ] assoc-map ;
  58
  59 : updated-definitions ( -- assoc )
  60     H{ } clone
  61     dup forgotten-definitions get update
  62     dup new-definitions get first update
  63     dup new-definitions get second update
  64     dup changed-definitions get update
  65     dup dup changed-vocabs update ;
  66
  67 : compile ( words -- )
  68     recompile-hook get call
  69     dup [ drop crossref? ] assoc-contains?
  70     modify-code-heap ;
  71
  72 SYMBOL: outdated-tuples
  73 SYMBOL: update-tuples-hook
  74
  75 : call-recompile-hook ( -- )
  76     changed-definitions get [ drop word? ] assoc-filter
  77     compiled-usages recompile-hook get call ;
  78
  79 : call-update-tuples-hook ( -- )
  80     update-tuples-hook get call ;
  81
  82 : unxref-forgotten-definitions ( -- )
  83     forgotten-definitions get
  84     keys [ word? ] filter
  85     [ delete-compiled-xref ] each ;
  86
  87 : finish-compilation-unit ( -- )
  88     call-recompile-hook
  89     call-update-tuples-hook
  90     unxref-forgotten-definitions
  91     dup [ drop crossref? ] assoc-contains? modify-code-heap ;
  92
  93 : with-nested-compilation-unit ( quot -- )
  94     [
  95         H{ } clone changed-definitions set
  96         H{ } clone outdated-tuples set
  97         [ finish-compilation-unit ] [ ] cleanup
  98     ] with-scope ; inline
  99
 100 : with-compilation-unit ( quot -- )
 101     [
 102         H{ } clone changed-definitions set
 103         H{ } clone forgotten-definitions set
 104         H{ } clone outdated-tuples set
 105         H{ } clone new-classes set
 106         <definitions> new-definitions set
 107         <definitions> old-definitions set
 108         [
 109             finish-compilation-unit
 110             updated-definitions
 111             notify-definition-observers
 112         ] [ ] cleanup
 113     ] with-scope ; inline
 114
 115 : compile-call ( quot -- )
 116     [ define-temp ] with-compilation-unit execute ;
 117
 118 : default-recompile-hook ( words -- alist )
 119     [ f ] { } map>assoc ;
 120
 121 recompile-hook global
 122 [ [ default-recompile-hook ] or ]
 123 change-at