basis/compiler/compiler.factor

   1 ! Copyright (C) 2004, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs classes.algebra combinators
   4 combinators.short-circuit compiler.cfg compiler.cfg.builder
   5 compiler.cfg.builder.alien compiler.cfg.finalization
   6 compiler.cfg.optimizer compiler.codegen compiler.crossref
   7 compiler.errors compiler.tree.builder compiler.tree.optimizer
   8 compiler.units compiler.utilities continuations definitions fry
   9 generic generic.single io kernel macros make namespaces
  10 sequences sets stack-checker.dependencies stack-checker.errors
  11 stack-checker.inlining vocabs.loader words ;
  12 IN: compiler
  13
  14 SYMBOL: compiled
  15
  16 : compile? ( word -- ? )
  17     ! Don't attempt to compile certain words.
  18     {
  19         [ "forgotten" word-prop ]
  20         [ inlined-block? ]
  21     } 1|| not ;
  22
  23 : compiler-message ( string -- )
  24     "trace-compilation" get [ [ print flush ] with-global ] [ drop ] if ;
  25
  26 : start ( word -- )
  27     dup name>> compiler-message
  28     init-dependencies
  29     clear-compiler-error ;
  30
  31 GENERIC: no-compile? ( word -- ? )
  32
  33 M: method no-compile? "method-generic" word-prop no-compile? ;
  34
  35 M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
  36
  37 M: word no-compile?
  38     { [ macro? ] [ "special" word-prop ] [ "no-compile" word-prop ] } 1|| ;
  39
  40 GENERIC: combinator? ( word -- ? )
  41
  42 M: method combinator? "method-generic" word-prop combinator? ;
  43
  44 M: predicate-engine-word combinator? "owner-generic" word-prop combinator? ;
  45
  46 M: word combinator? inline? ;
  47
  48 : ignore-error? ( word error -- ? )
  49     ! Ignore some errors on inline combinators, macros, and special
  50     ! words such as 'call'.
  51     {
  52         [ drop no-compile? ]
  53         [ [ combinator? ] [ unknown-macro-input? ] bi* and ]
  54     } 2|| ;
  55
  56 : finish ( word -- )
  57     ! Recompile callers if the word's stack effect changed, then
  58     ! save the word's dependencies so that if they change, the
  59     ! word can get recompiled too.
  60     [ compiled-unxref ]
  61     [
  62         dup crossref? [
  63             [ dependencies get generic-dependencies get compiled-xref ]
  64             [ conditional-dependencies get set-dependency-checks ]
  65             bi
  66         ] [ drop ] if
  67     ] bi ;
  68
  69 : deoptimize-with ( word def -- * )
  70     ! If the word failed to infer, compile it with the
  71     ! non-optimizing compiler.
  72     swap [ finish ] [ compiled get set-at ] bi return ;
  73
  74 : not-compiled-def ( word error -- def )
  75     '[ _ _ not-compiled ] [ ] like ;
  76
  77 : deoptimize* ( word -- * )
  78     dup def>> deoptimize-with ;
  79
  80 : ignore-error ( word error -- * )
  81     drop [ clear-compiler-error ] [ deoptimize* ] bi ;
  82
  83 : remember-error ( word error -- * )
  84     [ swap <compiler-error> save-compiler-error ]
  85     [ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ]
  86     2bi ;
  87
  88 : deoptimize ( word error -- * )
  89     ! If the error is ignorable, compile the word with the
  90     ! non-optimizing compiler, using its definition. Otherwise,
  91     ! if the compiler error is not ignorable, use a dummy
  92     ! definition from 'not-compiled-def' which throws an error.
  93     {
  94         { [ dup inference-error? not ] [ rethrow ] }
  95         { [ 2dup ignore-error? ] [ ignore-error ] }
  96         [ remember-error ]
  97     } cond ;
  98
  99 : optimize? ( word -- ? )
 100     {
 101         [ single-generic? ]
 102         [ primitive? ]
 103     } 1|| not ;
 104
 105 : contains-breakpoints? ( -- ? )
 106     dependencies get keys [ "break?" word-prop ] any? ;
 107
 108 : frontend ( word -- tree )
 109     ! If the word contains breakpoints, don't optimize it, since
 110     ! the walker does not support this.
 111     dup optimize? [
 112         [ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
 113         contains-breakpoints? [ nip deoptimize* ] [ drop ] if
 114     ] [ deoptimize* ] if ;
 115
 116 : backend ( tree word -- )
 117     build-cfg [
 118         [
 119             [ optimize-cfg ]
 120             [ finalize-cfg ]
 121             [ [ generate ] [ label>> ] bi compiled get set-at ]
 122             tri
 123         ] with-cfg
 124     ] each ;
 125
 126 : compile-word ( word -- )
 127     ! We return early if the word has breakpoints or if it
 128     ! failed to infer.
 129     '[
 130         _ {
 131             [ start ]
 132             [ frontend ]
 133             [ backend ]
 134             [ finish ]
 135         } cleave
 136     ] with-return ;
 137
 138 SINGLETON: optimizing-compiler
 139
 140 M: optimizing-compiler update-call-sites ( class generic -- words )
 141     ! Words containing call sites with inferred type 'class'
 142     ! which inlined a method on 'generic'
 143     generic-call-sites-of keys swap '[
 144         _ 2dup [ valid-classoid? ] both?
 145         [ classes-intersect? ] [ 2drop f ] if
 146     ] filter ;
 147
 148 M: optimizing-compiler recompile ( words -- alist )
 149     H{ } clone compiled [
 150         [ compile? ] filter
 151         [ compile-word yield-hook get call( -- ) ] each
 152         compiled get >alist
 153     ] with-variable
 154     "--- compile done" compiler-message ;
 155
 156 M: optimizing-compiler to-recompile ( -- words )
 157     [
 158         changed-effects get new-words get diff
 159         outdated-effect-usages %
 160
 161         changed-definitions get new-words get diff
 162         outdated-definition-usages %
 163
 164         maybe-changed get new-words get diff
 165         outdated-conditional-usages %
 166
 167         changed-definitions get members [ word? ] filter dup zip ,
 168     ] { } make assoc-combine keys ;
 169
 170 M: optimizing-compiler process-forgotten-words
 171     [ delete-compiled-xref ] each ;
 172
 173 : with-optimizer ( quot -- )
 174     [ optimizing-compiler compiler-impl ] dip with-variable ; inline
 175
 176 : enable-optimizer ( -- )
 177     optimizing-compiler compiler-impl set-global ;
 178
 179 : disable-optimizer ( -- )
 180     f compiler-impl set-global ;
 181
 182 { "threads" "compiler" } "compiler.threads" require-when