: maybe-compile ( word -- )
dup optimized>> [ drop ] [ queue-compile ] if ;
-SYMBOLS: +optimized+ +unoptimized+ ;
+: recompile-callers? ( word -- ? )
+ changed-effects get key? ;
-: 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 ;
+: recompile-callers ( words -- )
+ dup recompile-callers? [
+ [ usage [ word? ] filter ] [ compiled-usage keys ] bi
+ [ [ queue-compile ] each ] bi@
+ ] [ drop ] if ;
: start ( word -- )
"trace-compilation" get [ dup name>> print flush ] when
: ignore-error? ( word error -- ? )
[
{
- [ inline? ]
[ macro? ]
- [ "no-compile" word-prop ]
+ [ inline? ]
[ "special" word-prop ]
+ [ "no-compile" word-prop ]
} 1||
] [ error-type +compiler-warning+ eq? ] bi* and ;
: (fail) ( word compiled -- * )
swap
+ [ recompile-callers ]
[ compiled-unxref ]
[ compiled get set-at ]
- [ +unoptimized+ save-compiled-status ]
- tri
- return ;
+ tri return ;
: not-compiled-def ( word error -- def )
'[ _ _ not-compiled ] [ ] like ;
] each ;
: finish ( word -- )
- [ +optimized+ save-compiled-status ]
+ [ recompile-callers ]
[ compiled-unxref ]
[
- dup crossref?
- [
+ dup crossref? [
dependencies get
generic-dependencies get
compiled-xref
PRIVATE>
: define-macro ( word definition effect -- )
- real-macro-effect
- [ [ memoize-quot [ call ] append ] keep define-declared ]
- [ drop "macro" set-word-prop ]
- 3bi ;
+ real-macro-effect {
+ [ [ memoize-quot [ call ] append ] keep define-declared ]
+ [ drop "macro" set-word-prop ]
+ [ 2drop changed-effect ]
+ } 3cleave ;
SYNTAX: MACRO: (:) define-macro ;
>>def
dup crossref? [ dup xref ] when drop ;
+: changed-effect ( word -- )
+ [ dup changed-effects get set-in-unit ]
+ [ dup primitive? [ drop ] [ changed-definition ] if ] bi ;
+
: set-stack-effect ( effect word -- )
2dup "declared-effect" word-prop = [ 2drop ] [
- swap
- [ drop changed-effect ]
- [ "declared-effect" set-word-prop ]
- [ drop dup primitive? [ drop ] [ changed-definition ] if ]
+ [ nip changed-effect ]
+ [ nip subwords [ changed-effect ] each ]
+ [ swap "declared-effect" set-word-prop ]
2tri
] if ;
[ nip swap set-stack-effect ] [ drop define ] 3bi ;
: make-inline ( word -- )
- t "inline" set-word-prop ;
+ dup inline? [ drop ] [
+ [ t "inline" set-word-prop ]
+ [ changed-effect ]
+ bi
+ ] if ;
: make-recursive ( word -- )
t "recursive" set-word-prop ;