basis/compiler/compiler.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel namespaces arrays sequences io
   4 words fry continuations vocabs assocs dlists definitions math
   5 threads graphs generic combinators deques search-deques io
   6 stack-checker stack-checker.state stack-checker.inlining
   7 compiler.errors compiler.units compiler.tree.builder
   8 compiler.tree.optimizer compiler.cfg.builder
   9 compiler.cfg.optimizer compiler.cfg.linearization
  10 compiler.cfg.two-operand compiler.cfg.linear-scan
  11 compiler.cfg.stack-frame compiler.codegen ;
  12 IN: compiler
  13
  14 SYMBOL: compile-queue
  15 SYMBOL: compiled
  16
  17 : queue-compile ( word -- )
  18     {
  19         { [ dup "forgotten" word-prop ] [ ] }
  20         { [ dup compiled get key? ] [ ] }
  21         { [ dup inlined-block? ] [ ] }
  22         { [ dup primitive? ] [ ] }
  23         [ dup compile-queue get push-front ]
  24     } cond drop ;
  25
  26 : maybe-compile ( word -- )
  27     dup compiled>> [ drop ] [ queue-compile ] if ;
  28
  29 SYMBOL: +failed+
  30
  31 : ripple-up ( words -- )
  32     dup "compiled-effect" word-prop +failed+ eq?
  33     [ usage [ word? ] filter ] [ compiled-usage keys ] if
  34     [ queue-compile ] each ;
  35
  36 : ripple-up? ( word effect -- ? )
  37     #! If the word has previously been compiled and had a
  38     #! different stack effect, we have to recompile any callers.
  39     swap "compiled-effect" word-prop [ = not ] keep and ;
  40
  41 : save-effect ( word effect -- )
  42     [ dupd ripple-up? [ ripple-up ] [ drop ] if ]
  43     [ "compiled-effect" 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 : fail ( word error -- )
  53     [ swap compiler-error ]
  54     [
  55         drop
  56         [ compiled-unxref ]
  57         [ f swap compiled get set-at ]
  58         [ +failed+ save-effect ]
  59         tri
  60     ] 2bi
  61     return ;
  62
  63 : frontend ( word -- effect nodes )
  64     [ build-tree-from-word ] [ fail ] recover optimize-tree ;
  65
  66 ! Only switch this off for debugging.
  67 SYMBOL: compile-dependencies?
  68
  69 t compile-dependencies? set-global
  70
  71 : save-asm ( asm -- )
  72     [ [ code>> ] [ label>> ] bi compiled get set-at ]
  73     [ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ]
  74     bi ;
  75
  76 : backend ( nodes word -- )
  77     build-cfg [
  78         optimize-cfg
  79         build-mr
  80         convert-two-operand
  81         linear-scan
  82         build-stack-frame
  83         generate
  84         save-asm
  85     ] each ;
  86
  87 : finish ( effect word -- )
  88     [ swap save-effect ]
  89     [ compiled-unxref ]
  90     [
  91         dup crossref?
  92         [
  93             dependencies get
  94             generic-dependencies get
  95             compiled-xref
  96         ] [ drop ] if
  97     ] tri ;
  98
  99 : (compile) ( word -- )
 100     '[
 101         _ {
 102             [ start ]
 103             [ frontend ]
 104             [ backend ]
 105             [ finish ]
 106         } cleave
 107     ] with-return ;
 108
 109 : compile-loop ( deque -- )
 110     [ (compile) yield ] slurp-deque ;
 111
 112 : decompile ( word -- )
 113     f 2array 1array t modify-code-heap ;
 114
 115 : optimized-recompile-hook ( words -- alist )
 116     [
 117         <hashed-dlist> compile-queue set
 118         H{ } clone compiled set
 119         [ queue-compile ] each
 120         compile-queue get compile-loop
 121         compiled get >alist
 122     ] with-scope ;
 123
 124 : enable-compiler ( -- )
 125     [ optimized-recompile-hook ] recompile-hook set-global ;
 126
 127 : disable-compiler ( -- )
 128     [ default-recompile-hook ] recompile-hook set-global ;
 129
 130 : recompile-all ( -- )
 131     forget-errors all-words compile ;