basis/compiler/compiler.factor

   1 ! Copyright (C) 2004, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel namespaces arrays sequences io words fry
   4 continuations vocabs assocs dlists definitions math graphs generic
   5 combinators deques search-deques macros io stack-checker call
   6 stack-checker.state stack-checker.inlining combinators.short-circuit
   7 compiler.errors compiler.units compiler.tree.builder
   8 compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
   9 compiler.cfg.linearization compiler.cfg.two-operand
  10 compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
  11 compiler.utilities ;
  12 IN: compiler
  13
  14 SYMBOL: compile-queue
  15 SYMBOL: compiled
  16
  17 : queue-compile? ( word -- ? )
  18     {
  19         [ "forgotten" word-prop ]
  20         [ compiled get key? ]
  21         [ inlined-block? ]
  22         [ primitive? ]
  23     } 1|| not ;
  24
  25 : queue-compile ( word -- )
  26     dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
  27
  28 : maybe-compile ( word -- )
  29     dup optimized>> [ drop ] [ queue-compile ] if ;
  30
  31 SYMBOLS: +optimized+ +unoptimized+ ;
  32
  33 : ripple-up ( words -- )
  34     dup "compiled-status" word-prop +unoptimized+ eq?
  35     [ usage [ word? ] filter ] [ compiled-usage keys ] if
  36     [ queue-compile ] each ;
  37
  38 : ripple-up? ( word status -- ? )
  39     swap "compiled-status" word-prop [ = not ] keep and ;
  40
  41 : save-compiled-status ( word status -- )
  42     [ dupd ripple-up? [ ripple-up ] [ drop ] if ]
  43     [ "compiled-status" set-word-prop ]
  44     2bi ;
  45
  46 : start ( word -- )
  47     "trace-compilation" get [ dup name>> print flush ] when
  48     H{ } clone dependencies set
  49     H{ } clone generic-dependencies set
  50     f swap compiler-error ;
  51
  52 : ignore-error? ( word error -- ? )
  53     [ [ inline? ] [ macro? ] bi or ]
  54     [ compiler-error-type +warning+ eq? ] bi* and ;
  55
  56 : fail ( word error -- * )
  57     [ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
  58     [
  59         drop
  60         [ compiled-unxref ]
  61         [ f swap compiled get set-at ]
  62         [ +unoptimized+ save-compiled-status ]
  63         tri
  64     ] 2bi
  65     return ;
  66
  67 : frontend ( word -- nodes )
  68     [ build-tree-from-word ] [ fail ] recover optimize-tree ;
  69
  70 ! Only switch this off for debugging.
  71 SYMBOL: compile-dependencies?
  72
  73 t compile-dependencies? set-global
  74
  75 : save-asm ( asm -- )
  76     [ [ code>> ] [ label>> ] bi compiled get set-at ]
  77     [ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ]
  78     bi ;
  79
  80 : backend ( nodes word -- )
  81     build-cfg [
  82         optimize-cfg
  83         build-mr
  84         convert-two-operand
  85         linear-scan
  86         build-stack-frame
  87         generate
  88         save-asm
  89     ] each ;
  90
  91 : finish ( word -- )
  92     [ +optimized+ save-compiled-status ]
  93     [ compiled-unxref ]
  94     [
  95         dup crossref?
  96         [
  97             dependencies get
  98             generic-dependencies get
  99             compiled-xref
 100         ] [ drop ] if
 101     ] tri ;
 102
 103 : (compile) ( word -- )
 104     '[
 105         _ {
 106             [ start ]
 107             [ frontend ]
 108             [ backend ]
 109             [ finish ]
 110         } cleave
 111     ] with-return ;
 112
 113 : compile-loop ( deque -- )
 114     [ (compile) yield-hook get call( -- ) ] slurp-deque ;
 115
 116 : decompile ( word -- )
 117     f 2array 1array modify-code-heap ;
 118
 119 : compile-call ( quot -- )
 120     [ dup infer define-temp ] with-compilation-unit execute ;
 121
 122 SINGLETON: optimizing-compiler
 123
 124 M: optimizing-compiler recompile ( words -- alist )
 125     [
 126         <hashed-dlist> compile-queue set
 127         H{ } clone compiled set
 128         [ queue-compile ] each
 129         compile-queue get compile-loop
 130         compiled get >alist
 131     ] with-scope ;
 132
 133 : enable-compiler ( -- )
 134     optimizing-compiler compiler-impl set-global ;
 135
 136 : disable-compiler ( -- )
 137     f compiler-impl set-global ;
 138
 139 : recompile-all ( -- )
 140     forget-errors all-words compile ;