144 lines
3.7 KiB
Factor
144 lines
3.7 KiB
Factor
! Copyright (C) 2004, 2009 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors kernel namespaces arrays sequences io words fry
|
|
continuations vocabs assocs dlists definitions math graphs generic
|
|
combinators deques search-deques macros io stack-checker
|
|
stack-checker.state stack-checker.inlining combinators.short-circuit
|
|
compiler.errors compiler.units compiler.tree.builder
|
|
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
|
|
compiler.cfg.linearization compiler.cfg.two-operand
|
|
compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
|
|
compiler.utilities ;
|
|
IN: compiler
|
|
|
|
SYMBOL: compile-queue
|
|
SYMBOL: compiled
|
|
|
|
: queue-compile? ( word -- ? )
|
|
{
|
|
[ "forgotten" word-prop ]
|
|
[ compiled get key? ]
|
|
[ inlined-block? ]
|
|
[ primitive? ]
|
|
} 1|| not ;
|
|
|
|
: queue-compile ( word -- )
|
|
dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
|
|
|
|
: maybe-compile ( word -- )
|
|
dup optimized>> [ drop ] [ queue-compile ] if ;
|
|
|
|
SYMBOLS: +optimized+ +unoptimized+ ;
|
|
|
|
: ripple-up ( words -- )
|
|
dup "compiled-status" word-prop +unoptimized+ eq?
|
|
[ usage [ word? ] filter ] [ compiled-usage keys ] if
|
|
[ queue-compile ] each ;
|
|
|
|
: ripple-up? ( status word -- ? )
|
|
[
|
|
[ nip changed-effects get key? ]
|
|
[ "compiled-status" word-prop eq? not ] 2bi or
|
|
] keep "compiled-status" word-prop and ;
|
|
|
|
: save-compiled-status ( word status -- )
|
|
[ over ripple-up? [ ripple-up ] [ drop ] if ]
|
|
[ "compiled-status" set-word-prop ]
|
|
2bi ;
|
|
|
|
: start ( word -- )
|
|
"trace-compilation" get [ dup name>> print flush ] when
|
|
H{ } clone dependencies set
|
|
H{ } clone generic-dependencies set
|
|
f swap compiler-error ;
|
|
|
|
: ignore-error? ( word error -- ? )
|
|
[ [ inline? ] [ macro? ] bi or ]
|
|
[ compiler-error-type +warning+ eq? ] bi* and ;
|
|
|
|
: fail ( word error -- * )
|
|
[ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
|
|
[
|
|
drop
|
|
[ compiled-unxref ]
|
|
[ f swap compiled get set-at ]
|
|
[ +unoptimized+ save-compiled-status ]
|
|
tri
|
|
] 2bi
|
|
return ;
|
|
|
|
: frontend ( word -- nodes )
|
|
[ build-tree-from-word ] [ fail ] recover optimize-tree ;
|
|
|
|
! Only switch this off for debugging.
|
|
SYMBOL: compile-dependencies?
|
|
|
|
t compile-dependencies? set-global
|
|
|
|
: save-asm ( asm -- )
|
|
[ [ code>> ] [ label>> ] bi compiled get set-at ]
|
|
[ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ]
|
|
bi ;
|
|
|
|
: backend ( nodes word -- )
|
|
build-cfg [
|
|
optimize-cfg
|
|
build-mr
|
|
convert-two-operand
|
|
linear-scan
|
|
build-stack-frame
|
|
generate
|
|
save-asm
|
|
] each ;
|
|
|
|
: finish ( word -- )
|
|
[ +optimized+ save-compiled-status ]
|
|
[ compiled-unxref ]
|
|
[
|
|
dup crossref?
|
|
[
|
|
dependencies get
|
|
generic-dependencies get
|
|
compiled-xref
|
|
] [ drop ] if
|
|
] tri ;
|
|
|
|
: (compile) ( word -- )
|
|
'[
|
|
_ {
|
|
[ start ]
|
|
[ frontend ]
|
|
[ backend ]
|
|
[ finish ]
|
|
} cleave
|
|
] with-return ;
|
|
|
|
: compile-loop ( deque -- )
|
|
[ (compile) yield-hook get call( -- ) ] slurp-deque ;
|
|
|
|
: decompile ( word -- )
|
|
f 2array 1array modify-code-heap ;
|
|
|
|
: compile-call ( quot -- )
|
|
[ dup infer define-temp ] with-compilation-unit execute ;
|
|
|
|
SINGLETON: optimizing-compiler
|
|
|
|
M: optimizing-compiler recompile ( words -- alist )
|
|
[
|
|
<hashed-dlist> compile-queue set
|
|
H{ } clone compiled set
|
|
[ queue-compile ] each
|
|
compile-queue get compile-loop
|
|
compiled get >alist
|
|
] with-scope ;
|
|
|
|
: enable-compiler ( -- )
|
|
optimizing-compiler compiler-impl set-global ;
|
|
|
|
: disable-compiler ( -- )
|
|
f compiler-impl set-global ;
|
|
|
|
: recompile-all ( -- )
|
|
forget-errors all-words compile ;
|