basis/compiler/compiler.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel namespaces arrays sequences io debugger words fry
   4 compiler.units continuations vocabs assocs dlists definitions
   5 math threads graphs generic combinators deques search-deques
   6 stack-checker stack-checker.state compiler.generator
   7 compiler.errors compiler.tree.builder compiler.tree.optimizer ;
   8 IN: compiler
   9
  10 SYMBOL: +failed+
  11
  12 : ripple-up ( words -- )
  13     dup "compiled-effect" word-prop +failed+ eq?
  14     [ usage [ word? ] filter ] [ compiled-usage keys ] if
  15     [ queue-compile ] each ;
  16
  17 : ripple-up? ( word effect -- ? )
  18     #! If the word has previously been compiled and had a
  19     #! different stack effect, we have to recompile any callers.
  20     swap "compiled-effect" word-prop [ = not ] keep and ;
  21
  22 : save-effect ( word effect -- )
  23     [ dupd ripple-up? [ ripple-up ] [ drop ] if ]
  24     [ "compiled-effect" set-word-prop ]
  25     2bi ;
  26
  27 : compile-begins ( word -- )
  28     f swap compiler-error ;
  29
  30 : compile-failed ( word error -- )
  31     [ swap compiler-error ]
  32     [
  33         drop
  34         [ compiled-unxref ]
  35         [ f swap compiled get set-at ]
  36         [ +failed+ save-effect ]
  37         tri
  38     ] 2bi ;
  39
  40 : compile-succeeded ( effect word -- )
  41     [ swap save-effect ]
  42     [ compiled-unxref ]
  43     [
  44         dup crossref?
  45         [
  46             dependencies get >alist
  47             generic-dependencies get >alist
  48             compiled-xref
  49         ] [ drop ] if
  50     ] tri ;
  51
  52 : (compile) ( word -- )
  53     '[
  54         H{ } clone dependencies set
  55         H{ } clone generic-dependencies set
  56
  57         _ {
  58             [ compile-begins ]
  59             [
  60                 [ build-tree-from-word ] [ compile-failed return ] recover
  61                 optimize-tree
  62             ]
  63             [ dup generate ]
  64             [ compile-succeeded ]
  65         } cleave
  66     ] with-return ;
  67
  68 : compile-loop ( deque -- )
  69     [ (compile) yield ] slurp-deque ;
  70
  71 : decompile ( word -- )
  72     f 2array 1array t modify-code-heap ;
  73
  74 : optimized-recompile-hook ( words -- alist )
  75     [
  76         <hashed-dlist> compile-queue set
  77         H{ } clone compiled set
  78         [ queue-compile ] each
  79         compile-queue get compile-loop
  80         compiled get >alist
  81     ] with-scope ;
  82
  83 : enable-compiler ( -- )
  84     [ optimized-recompile-hook ] recompile-hook set-global ;
  85
  86 : disable-compiler ( -- )
  87     [ default-recompile-hook ] recompile-hook set-global ;
  88
  89 : recompile-all ( -- )
  90     forget-errors all-words compile ;