From 46f2515ba8c0f9a3019c2c1704b9d44a62018509 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 Jan 2010 22:44:31 -0600 Subject: [PATCH 01/33] add try-find for random.windows --- core/continuations/continuations-docs.factor | 556 ++++++++++--------- core/continuations/continuations.factor | 3 + 2 files changed, 285 insertions(+), 274 deletions(-) diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 84da26a082..afe14bf5c6 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -1,274 +1,282 @@ -USING: help.markup help.syntax kernel kernel.private -continuations.private vectors arrays namespaces -assocs words quotations lexer sequences math ; -IN: continuations - -ARTICLE: "errors-restartable" "Restartable errors" -"Support for restartable errors is built on top of the basic error handling facility. The following words signals recoverable errors:" -{ $subsections - throw-restarts - rethrow-restarts -} -"The list of restarts from the most recently-thrown error is stored in a global variable:" -{ $subsections restarts } -"To invoke restarts, see " { $link "debugger" } "." ; - -ARTICLE: "errors-post-mortem" "Post-mortem error inspection" -"The most recently thrown error, together with the continuation at that point, are stored in a pair of global variables:" -{ $subsections - error - error-continuation -} -"Developer tools for inspecting these values are found in " { $link "debugger" } "." ; - -ARTICLE: "errors-anti-examples" "Common error handling pitfalls" -"When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind." -{ $heading "Anti-pattern #1: Ignoring errors" } -"The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user." -{ $heading "Anti-pattern #2: Catching errors too early" } -"A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible." -$nl -"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically." -{ $heading "Anti-pattern #3: Dropping and rethrowing" } -"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught." -{ $heading "Anti-pattern #4: Logging and rethrowing" } -"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ; - -ARTICLE: "errors" "Exception handling" -"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations." -$nl -"Two words raise an error in the innermost error handler for the current dynamic extent:" -{ $subsections - throw - rethrow -} -"Words for establishing an error handler:" -{ $subsections - cleanup - recover - ignore-errors -} -"Syntax sugar for defining errors:" -{ $subsections POSTPONE: ERROR: } -"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." -{ $subsections - "errors-restartable" - "debugger" - "errors-post-mortem" - "errors-anti-examples" -} -"When Factor encouters a critical error, it calls the following word:" -{ $subsections die } ; - -ARTICLE: "continuations.private" "Continuation implementation details" -"A continuation is simply a tuple holding the contents of the five stacks:" -{ $subsections - continuation - >continuation< -} -"The five stacks can be read and written:" -{ $subsections - datastack - set-datastack - retainstack - set-retainstack - callstack - set-callstack - namestack - set-namestack - catchstack - set-catchstack -} ; - -ARTICLE: "continuations" "Continuations" -"At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation." -$nl -"Words for working with continuations are found in the " { $vocab-link "continuations" } " vocabulary; implementation details are in " { $vocab-link "continuations.private" } "." -$nl -"Continuations can be reified with the following two words:" -{ $subsections - callcc0 - callcc1 -} -"Another two words resume continuations:" -{ $subsections - continue - continue-with -} -"Continuations as control-flow:" -{ $subsections - attempt-all - with-return -} -"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "." -{ $subsections "continuations.private" } ; - -ABOUT: "continuations" - -HELP: catchstack* -{ $values { "catchstack" "a vector of continuations" } } -{ $description "Outputs the current catchstack." } ; - -HELP: catchstack -{ $values { "catchstack" "a vector of continuations" } } -{ $description "Outputs a copy of the current catchstack." } ; - -HELP: set-catchstack -{ $values { "catchstack" "a vector of continuations" } } -{ $description "Replaces the catchstack with a copy of the given vector." } ; - -HELP: continuation -{ $values { "continuation" continuation } } -{ $description "Reifies the current continuation from the point immediately after which the caller returns." } ; - -HELP: >continuation< -{ $values { "continuation" continuation } { "data" vector } { "call" vector } { "retain" vector } { "name" vector } { "catch" vector } } -{ $description "Takes a continuation apart into its constituents." } ; - -HELP: ifcc -{ $values { "capture" { $quotation "( continuation -- )" } } { "restore" quotation } } -{ $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and "{ $snippet "restore" } " is called." } ; - -{ callcc0 continue callcc1 continue-with ifcc } related-words - -HELP: callcc0 -{ $values { "quot" { $quotation "( continuation -- )" } } } -{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue } " word resumes the continuation." } ; - -HELP: callcc1 -{ $values { "quot" { $quotation "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } } -{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ; - -HELP: continue -{ $values { "continuation" continuation } } -{ $description "Resumes a continuation reified by " { $link callcc0 } "." } ; - -HELP: continue-with -{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } } -{ $description "Resumes a continuation reified by " { $link callcc1 } ". The object will be placed on the data stack when the continuation resumes." } ; - -HELP: error -{ $description "Global variable holding most recently thrown error." } -{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ; - -HELP: error-continuation -{ $description "Global variable holding current continuation of most recently thrown error." } -{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ; - -HELP: restarts -{ $var-description "Global variable holding the set of possible restarts for the most recently thrown error." } -{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ; - -HELP: >c -{ $values { "continuation" continuation } } -{ $description "Pushes an exception handler continuation on the catch stack. The continuation must have been reified by " { $link callcc1 } "." } ; - -HELP: c> -{ $values { "continuation" continuation } } -{ $description "Pops an exception handler continuation from the catch stack." } ; - -HELP: throw -{ $values { "error" object } } -{ $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ; - -{ cleanup recover } related-words - -HELP: cleanup -{ $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } } -{ $description "Calls the " { $snippet "try" } " quotation. If no error is thrown, calls " { $snippet "cleanup-always" } " without restoring the data stack. If an error is thrown, restores the data stack, calls " { $snippet "cleanup-always" } " followed by " { $snippet "cleanup-error" } ", and rethrows the error." } ; - -HELP: recover -{ $values { "try" quotation } { "recovery" { $quotation "( error -- )" } } } -{ $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ; - -HELP: ignore-errors -{ $values { "quot" quotation } } -{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ; - -HELP: rethrow -{ $values { "error" object } } -{ $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." } -{ $notes - "This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler." -} -{ $examples - "The " { $link with-lexer } " word catches errors, annotates them with the current line and column number, and rethrows them:" - { $see with-lexer } -} ; - -HELP: throw-restarts -{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } } -{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." } -{ $examples - "Try invoking one of the two restarts which are offered after the below code throws an error:" - { $code - ": restart-test" - " \"Oops!\" { { \"One\" 1 } { \"Two\" 2 } } condition" - " \"You restarted: \" write . ;" - "restart-test" - } -} ; - -HELP: rethrow-restarts -{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } } -{ $description "Throws a restartable error using " { $link rethrow } ". Otherwise, this word is identical to " { $link throw-restarts } "." } ; - -{ throw rethrow throw-restarts rethrow-restarts } related-words - -HELP: compute-restarts -{ $values { "error" object } { "seq" "a sequence" } } -{ $description "Outputs a sequence of triples, where each triple consists of a human-readable string, an object, and a continuation. Resuming a continuation with the corresponding object restarts execution immediately after the corresponding call to " { $link condition } "." -$nl -"This word recursively travels up the delegation chain to collate restarts from nested and wrapped conditions." } ; - -HELP: save-error -{ $values { "error" "an error" } } -{ $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." } -$low-level-note ; - -HELP: with-datastack -{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } } -{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." } -{ $examples - { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } -} ; - -HELP: attempt-all -{ $values - { "seq" sequence } { "quot" quotation } - { "obj" object } } -{ $description "Applies the quotation to elements in a sequence and returns the value from the first quotation that does not throw an error. If all quotations throw an error, returns the last error thrown." } -{ $examples "The first two numbers throw, the last one doesn't:" - { $example - "USING: prettyprint continuations kernel math ;" - "{ 1 3 6 } [ dup odd? [ \"Odd\" throw ] when ] attempt-all ." - "6" } - "All quotations throw, the last exception is rethrown:" - { $example - "USING: prettyprint continuations kernel math ;" - "[ { 1 3 5 } [ dup odd? [ throw ] when ] attempt-all ] [ ] recover ." - "5" - } -} ; - -HELP: return -{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ; - -HELP: with-return -{ $values - { "quot" quotation } } -{ $description "Captures a continuation that can be reified by calling the " { $link return } " word. If so, it will resume execution immediatly after the " { $link with-return } " word. If " { $link return } " is not called, then execution proceeds as if this word were simply " { $link call } "." } -{ $examples - "Only \"Hi\" will print:" - { $example - "USING: prettyprint continuations io ;" - "[ \"Hi\" print return \"Bye\" print ] with-return" - "Hi" -} } ; - -{ return with-return } related-words - -HELP: restart -{ $values { "restart" restart } } -{ $description "Invokes a restart." } -{ $class-description "The class of restarts." } ; +USING: help.markup help.syntax kernel kernel.private +continuations.private vectors arrays namespaces +assocs words quotations lexer sequences math ; +IN: continuations + +ARTICLE: "errors-restartable" "Restartable errors" +"Support for restartable errors is built on top of the basic error handling facility. The following words signals recoverable errors:" +{ $subsections + throw-restarts + rethrow-restarts +} +"The list of restarts from the most recently-thrown error is stored in a global variable:" +{ $subsections restarts } +"To invoke restarts, see " { $link "debugger" } "." ; + +ARTICLE: "errors-post-mortem" "Post-mortem error inspection" +"The most recently thrown error, together with the continuation at that point, are stored in a pair of global variables:" +{ $subsections + error + error-continuation +} +"Developer tools for inspecting these values are found in " { $link "debugger" } "." ; + +ARTICLE: "errors-anti-examples" "Common error handling pitfalls" +"When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind." +{ $heading "Anti-pattern #1: Ignoring errors" } +"The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user." +{ $heading "Anti-pattern #2: Catching errors too early" } +"A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible." +$nl +"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically." +{ $heading "Anti-pattern #3: Dropping and rethrowing" } +"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught." +{ $heading "Anti-pattern #4: Logging and rethrowing" } +"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ; + +ARTICLE: "errors" "Exception handling" +"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations." +$nl +"Two words raise an error in the innermost error handler for the current dynamic extent:" +{ $subsections + throw + rethrow +} +"Words for establishing an error handler:" +{ $subsections + cleanup + recover + ignore-errors +} +"Word for mapping over a sequence with a quotation until an element doesn't throw an exception:" +{ $subsections + try-find +} +"Syntax sugar for defining errors:" +{ $subsections POSTPONE: ERROR: } +"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." +{ $subsections + "errors-restartable" + "debugger" + "errors-post-mortem" + "errors-anti-examples" +} +"When Factor encouters a critical error, it calls the following word:" +{ $subsections die } ; + +ARTICLE: "continuations.private" "Continuation implementation details" +"A continuation is simply a tuple holding the contents of the five stacks:" +{ $subsections + continuation + >continuation< +} +"The five stacks can be read and written:" +{ $subsections + datastack + set-datastack + retainstack + set-retainstack + callstack + set-callstack + namestack + set-namestack + catchstack + set-catchstack +} ; + +ARTICLE: "continuations" "Continuations" +"At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation." +$nl +"Words for working with continuations are found in the " { $vocab-link "continuations" } " vocabulary; implementation details are in " { $vocab-link "continuations.private" } "." +$nl +"Continuations can be reified with the following two words:" +{ $subsections + callcc0 + callcc1 +} +"Another two words resume continuations:" +{ $subsections + continue + continue-with +} +"Continuations as control-flow:" +{ $subsections + attempt-all + with-return +} +"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "." +{ $subsections "continuations.private" } ; + +ABOUT: "continuations" + +HELP: catchstack* +{ $values { "catchstack" "a vector of continuations" } } +{ $description "Outputs the current catchstack." } ; + +HELP: catchstack +{ $values { "catchstack" "a vector of continuations" } } +{ $description "Outputs a copy of the current catchstack." } ; + +HELP: set-catchstack +{ $values { "catchstack" "a vector of continuations" } } +{ $description "Replaces the catchstack with a copy of the given vector." } ; + +HELP: continuation +{ $values { "continuation" continuation } } +{ $description "Reifies the current continuation from the point immediately after which the caller returns." } ; + +HELP: >continuation< +{ $values { "continuation" continuation } { "data" vector } { "call" vector } { "retain" vector } { "name" vector } { "catch" vector } } +{ $description "Takes a continuation apart into its constituents." } ; + +HELP: ifcc +{ $values { "capture" { $quotation "( continuation -- )" } } { "restore" quotation } } +{ $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and "{ $snippet "restore" } " is called." } ; + +{ callcc0 continue callcc1 continue-with ifcc } related-words + +HELP: callcc0 +{ $values { "quot" { $quotation "( continuation -- )" } } } +{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue } " word resumes the continuation." } ; + +HELP: callcc1 +{ $values { "quot" { $quotation "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } } +{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ; + +HELP: continue +{ $values { "continuation" continuation } } +{ $description "Resumes a continuation reified by " { $link callcc0 } "." } ; + +HELP: continue-with +{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } } +{ $description "Resumes a continuation reified by " { $link callcc1 } ". The object will be placed on the data stack when the continuation resumes." } ; + +HELP: error +{ $description "Global variable holding most recently thrown error." } +{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ; + +HELP: error-continuation +{ $description "Global variable holding current continuation of most recently thrown error." } +{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ; + +HELP: restarts +{ $var-description "Global variable holding the set of possible restarts for the most recently thrown error." } +{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ; + +HELP: >c +{ $values { "continuation" continuation } } +{ $description "Pushes an exception handler continuation on the catch stack. The continuation must have been reified by " { $link callcc1 } "." } ; + +HELP: c> +{ $values { "continuation" continuation } } +{ $description "Pops an exception handler continuation from the catch stack." } ; + +HELP: throw +{ $values { "error" object } } +{ $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ; + +{ cleanup recover } related-words + +HELP: cleanup +{ $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } } +{ $description "Calls the " { $snippet "try" } " quotation. If no error is thrown, calls " { $snippet "cleanup-always" } " without restoring the data stack. If an error is thrown, restores the data stack, calls " { $snippet "cleanup-always" } " followed by " { $snippet "cleanup-error" } ", and rethrows the error." } ; + +HELP: recover +{ $values { "try" quotation } { "recovery" { $quotation "( error -- )" } } } +{ $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ; + +HELP: try-find +{ $values { "seq" sequence } { "try" quotation } { "result" "the first non-false, non-exception result of the quotation" } { "elt" "the first matching element, or " { $link f } } } +{ $description "Applies the quotation to each element of the sequence, until the quotation outputs a true value, and attempts the next element if an exception is thrown. If the quotation ever yields a result which is not " { $link f } ", then the value is output, along with the element of the sequence which yielded this." } ; + +HELP: ignore-errors +{ $values { "quot" quotation } } +{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ; + +HELP: rethrow +{ $values { "error" object } } +{ $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." } +{ $notes + "This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler." +} +{ $examples + "The " { $link with-lexer } " word catches errors, annotates them with the current line and column number, and rethrows them:" + { $see with-lexer } +} ; + +HELP: throw-restarts +{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } } +{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." } +{ $examples + "Try invoking one of the two restarts which are offered after the below code throws an error:" + { $code + ": restart-test" + " \"Oops!\" { { \"One\" 1 } { \"Two\" 2 } } condition" + " \"You restarted: \" write . ;" + "restart-test" + } +} ; + +HELP: rethrow-restarts +{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } } +{ $description "Throws a restartable error using " { $link rethrow } ". Otherwise, this word is identical to " { $link throw-restarts } "." } ; + +{ throw rethrow throw-restarts rethrow-restarts } related-words + +HELP: compute-restarts +{ $values { "error" object } { "seq" "a sequence" } } +{ $description "Outputs a sequence of triples, where each triple consists of a human-readable string, an object, and a continuation. Resuming a continuation with the corresponding object restarts execution immediately after the corresponding call to " { $link condition } "." +$nl +"This word recursively travels up the delegation chain to collate restarts from nested and wrapped conditions." } ; + +HELP: save-error +{ $values { "error" "an error" } } +{ $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." } +$low-level-note ; + +HELP: with-datastack +{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } } +{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." } +{ $examples + { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } +} ; + +HELP: attempt-all +{ $values + { "seq" sequence } { "quot" quotation } + { "obj" object } } +{ $description "Applies the quotation to elements in a sequence and returns the value from the first quotation that does not throw an error. If all quotations throw an error, returns the last error thrown." } +{ $examples "The first two numbers throw, the last one doesn't:" + { $example + "USING: prettyprint continuations kernel math ;" + "{ 1 3 6 } [ dup odd? [ \"Odd\" throw ] when ] attempt-all ." + "6" } + "All quotations throw, the last exception is rethrown:" + { $example + "USING: prettyprint continuations kernel math ;" + "[ { 1 3 5 } [ dup odd? [ throw ] when ] attempt-all ] [ ] recover ." + "5" + } +} ; + +HELP: return +{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ; + +HELP: with-return +{ $values + { "quot" quotation } } +{ $description "Captures a continuation that can be reified by calling the " { $link return } " word. If so, it will resume execution immediatly after the " { $link with-return } " word. If " { $link return } " is not called, then execution proceeds as if this word were simply " { $link call } "." } +{ $examples + "Only \"Hi\" will print:" + { $example + "USING: prettyprint continuations io ;" + "[ \"Hi\" print return \"Bye\" print ] with-return" + "Hi" +} } ; + +{ return with-return } related-words + +HELP: restart +{ $values { "restart" restart } } +{ $description "Invokes a restart." } +{ $class-description "The class of restarts." } ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index d63acae883..9feea46b84 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -128,6 +128,9 @@ SYMBOL: thread-error-hook : cleanup ( try cleanup-always cleanup-error -- ) [ compose [ dip rethrow ] curry recover ] [ drop ] 2bi call ; inline +: try-find ( seq try -- result elt ) + [ curry [ drop f ] recover ] curry map-find ; inline + ERROR: attempt-all-error ; : attempt-all ( seq quot -- obj ) From 4edc37b70ce469017cd7e37b5d1dfe4dd427aa1b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 Jan 2010 22:45:19 -0600 Subject: [PATCH 02/33] clean up random.windows init hook, and add another crypto provider --- basis/random/windows/windows.factor | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index c1d3010c0f..a10f90ddef 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -1,7 +1,8 @@ USING: accessors alien.c-types alien.data byte-arrays combinators.short-circuit continuations destructors init kernel locals namespaces random windows.advapi32 windows.errors -windows.kernel32 windows.types math.bitwise ; +windows.kernel32 windows.types math.bitwise sequences fry +literals ; IN: random.windows TUPLE: windows-rng provider type ; @@ -58,13 +59,23 @@ M: windows-rng random-bytes* ( n tuple -- bytes ) [ CryptGenRandom win32-error=0/f ] keep ] with-destructors ; -[ - MS_DEF_PROV - PROV_RSA_FULL system-random-generator set-global +ERROR: no-windows-crypto-provider ; - [ MS_STRONG_PROV PROV_RSA_FULL ] - [ drop MS_ENH_RSA_AES_PROV PROV_RSA_AES ] recover - secure-random-generator set-global +: try-crypto-providers ( seq -- windows-rng ) + [ first2 ] try-find drop + [ no-windows-crypto-provider ] unless* ; + +[ + { + ${ MS_ENHANCED_PROV PROV_RSA_FULL } + ${ MS_DEF_PROV PROV_RSA_FULL } + } try-crypto-providers + system-random-generator set-global + + { + ${ MS_STRONG_PROV PROV_RSA_FULL } + ${ MS_ENH_RSA_AES_PROV PROV_RSA_AES } + } try-crypto-providers secure-random-generator set-global ] "random.windows" add-startup-hook [ From 88e20af800eb35af39b266bb54e3787d390b2d1a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 Jan 2010 23:12:31 -0600 Subject: [PATCH 03/33] add some unit tests for try-find --- core/continuations/continuations-tests.factor | 228 +++++++++--------- 1 file changed, 120 insertions(+), 108 deletions(-) diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 988be0dd88..5ee61f84d8 100644 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -1,108 +1,120 @@ -USING: kernel math namespaces io tools.test sequences vectors -continuations debugger parser memory arrays words -kernel.private accessors eval ; -IN: continuations.tests - -: (callcc1-test) ( n obj -- n' obj ) - [ 1 - dup ] dip ?push - over 0 = [ "test-cc" get continue-with ] when - (callcc1-test) ; - -: callcc1-test ( x -- list ) - [ - "test-cc" set V{ } clone (callcc1-test) - ] callcc1 nip ; - -: callcc-namespace-test ( -- ? ) - [ - "test-cc" set - 5 "x" set - [ - 6 "x" set "test-cc" get continue - ] with-scope - ] callcc0 "x" get 5 = ; - -[ t ] [ 10 callcc1-test 10 iota reverse >vector = ] unit-test -[ t ] [ callcc-namespace-test ] unit-test - -[ 5 throw ] [ 5 = ] must-fail-with - -[ t ] [ - [ "Hello" throw ] ignore-errors - error get-global - "Hello" = -] unit-test - -"!!! The following error is part of the test" print - -[ ] [ [ 6 [ 12 [ "2 car" ] ] ] print-error ] unit-test - -"!!! The following error is part of the test" print - -[ ] [ [ [ "2 car" ] eval ] try ] unit-test - -[ f throw ] must-fail - -! Weird PowerPC bug. -[ ] [ - [ "4" throw ] ignore-errors - gc - gc -] unit-test - -! ! See how well callstack overflow is handled -! [ clear drop ] must-fail -! -! : callstack-overflow callstack-overflow f ; -! [ callstack-overflow ] must-fail - -: don't-compile-me ( -- ) ; -: foo ( -- ) callstack "c" set don't-compile-me ; -: bar ( -- a b ) 1 foo 2 ; - -<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >> - -[ 1 2 ] [ bar ] unit-test - -[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test - -[ 1 ] [ "c" get innermost-frame-scan ] unit-test - -SYMBOL: always-counter -SYMBOL: error-counter - -[ - 0 always-counter set - 0 error-counter set - - [ ] [ always-counter inc ] [ error-counter inc ] cleanup - - [ 1 ] [ always-counter get ] unit-test - [ 0 ] [ error-counter get ] unit-test - - [ - [ "a" throw ] - [ always-counter inc ] - [ error-counter inc ] cleanup - ] [ "a" = ] must-fail-with - - [ 2 ] [ always-counter get ] unit-test - [ 1 ] [ error-counter get ] unit-test - - [ - [ ] - [ always-counter inc "a" throw ] - [ error-counter inc ] cleanup - ] [ "a" = ] must-fail-with - - [ 3 ] [ always-counter get ] unit-test - [ 1 ] [ error-counter get ] unit-test -] with-scope - -[ ] [ [ return ] with-return ] unit-test - -[ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with - -[ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test - -[ with-datastack ] must-infer +USING: kernel math namespaces io tools.test sequences vectors +continuations debugger parser memory arrays words +kernel.private accessors eval ; +IN: continuations.tests + +: (callcc1-test) ( n obj -- n' obj ) + [ 1 - dup ] dip ?push + over 0 = [ "test-cc" get continue-with ] when + (callcc1-test) ; + +: callcc1-test ( x -- list ) + [ + "test-cc" set V{ } clone (callcc1-test) + ] callcc1 nip ; + +: callcc-namespace-test ( -- ? ) + [ + "test-cc" set + 5 "x" set + [ + 6 "x" set "test-cc" get continue + ] with-scope + ] callcc0 "x" get 5 = ; + +[ t ] [ 10 callcc1-test 10 iota reverse >vector = ] unit-test +[ t ] [ callcc-namespace-test ] unit-test + +[ 5 throw ] [ 5 = ] must-fail-with + +[ t ] [ + [ "Hello" throw ] ignore-errors + error get-global + "Hello" = +] unit-test + +"!!! The following error is part of the test" print + +[ ] [ [ 6 [ 12 [ "2 car" ] ] ] print-error ] unit-test + +"!!! The following error is part of the test" print + +[ ] [ [ [ "2 car" ] eval ] try ] unit-test + +[ f throw ] must-fail + +! Weird PowerPC bug. +[ ] [ + [ "4" throw ] ignore-errors + gc + gc +] unit-test + +! ! See how well callstack overflow is handled +! [ clear drop ] must-fail +! +! : callstack-overflow callstack-overflow f ; +! [ callstack-overflow ] must-fail + +: don't-compile-me ( -- ) ; +: foo ( -- ) callstack "c" set don't-compile-me ; +: bar ( -- a b ) 1 foo 2 ; + +<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >> + +[ 1 2 ] [ bar ] unit-test + +[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test + +[ 1 ] [ "c" get innermost-frame-scan ] unit-test + +SYMBOL: always-counter +SYMBOL: error-counter + +[ + 0 always-counter set + 0 error-counter set + + [ ] [ always-counter inc ] [ error-counter inc ] cleanup + + [ 1 ] [ always-counter get ] unit-test + [ 0 ] [ error-counter get ] unit-test + + [ + [ "a" throw ] + [ always-counter inc ] + [ error-counter inc ] cleanup + ] [ "a" = ] must-fail-with + + [ 2 ] [ always-counter get ] unit-test + [ 1 ] [ error-counter get ] unit-test + + [ + [ ] + [ always-counter inc "a" throw ] + [ error-counter inc ] cleanup + ] [ "a" = ] must-fail-with + + [ 3 ] [ always-counter get ] unit-test + [ 1 ] [ error-counter get ] unit-test +] with-scope + +[ ] [ [ return ] with-return ] unit-test + +[ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with + +[ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test + +[ with-datastack ] must-infer + +[ { t 1 } ] +[ { 1 1 } [ odd? ] try-find 2array ] unit-test + +[ { 9 3 } ] +[ { 3 3 } [ sq ] try-find 2array ] unit-test + +[ { f f } ] +[ { 1 1 } [ even? ] try-find 2array ] unit-test + +[ { f f } ] +[ { 1 1 } [ "error" throw ] try-find 2array ] unit-test From 9a8bd2678654a78e4f06155a45fadaf714996edd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 Jan 2010 20:56:10 -0600 Subject: [PATCH 04/33] Remove an iota from images.jpeg --- basis/images/jpeg/jpeg.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index a7f08504bb..db30faee33 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -287,7 +287,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; : decode-macroblock ( -- blocks ) jpeg> components>> [ - [ mb-dim first2 * iota ] + [ mb-dim first2 * ] [ [ decode-block ] curry replicate ] bi ] map concat ; From 1f76ab2d45b4243846600f66fc55197ba43ec71c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 Jan 2010 23:28:11 -0600 Subject: [PATCH 05/33] try-find is just attempt-all. oops --- basis/random/windows/windows.factor | 6 +++--- core/continuations/continuations-docs.factor | 8 -------- core/continuations/continuations-tests.factor | 12 ------------ core/continuations/continuations.factor | 3 --- 4 files changed, 3 insertions(+), 26 deletions(-) diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index a10f90ddef..30b169bfed 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -59,11 +59,11 @@ M: windows-rng random-bytes* ( n tuple -- bytes ) [ CryptGenRandom win32-error=0/f ] keep ] with-destructors ; -ERROR: no-windows-crypto-provider ; +ERROR: no-windows-crypto-provider error ; : try-crypto-providers ( seq -- windows-rng ) - [ first2 ] try-find drop - [ no-windows-crypto-provider ] unless* ; + [ first2 ] attempt-all + dup windows-rng? [ no-windows-crypto-provider ] unless ; [ { diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index afe14bf5c6..ac33eee2c5 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -48,10 +48,6 @@ $nl recover ignore-errors } -"Word for mapping over a sequence with a quotation until an element doesn't throw an exception:" -{ $subsections - try-find -} "Syntax sugar for defining errors:" { $subsections POSTPONE: ERROR: } "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." @@ -185,10 +181,6 @@ HELP: recover { $values { "try" quotation } { "recovery" { $quotation "( error -- )" } } } { $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ; -HELP: try-find -{ $values { "seq" sequence } { "try" quotation } { "result" "the first non-false, non-exception result of the quotation" } { "elt" "the first matching element, or " { $link f } } } -{ $description "Applies the quotation to each element of the sequence, until the quotation outputs a true value, and attempts the next element if an exception is thrown. If the quotation ever yields a result which is not " { $link f } ", then the value is output, along with the element of the sequence which yielded this." } ; - HELP: ignore-errors { $values { "quot" quotation } } { $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ; diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 5ee61f84d8..0d2880edde 100644 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -106,15 +106,3 @@ SYMBOL: error-counter [ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test [ with-datastack ] must-infer - -[ { t 1 } ] -[ { 1 1 } [ odd? ] try-find 2array ] unit-test - -[ { 9 3 } ] -[ { 3 3 } [ sq ] try-find 2array ] unit-test - -[ { f f } ] -[ { 1 1 } [ even? ] try-find 2array ] unit-test - -[ { f f } ] -[ { 1 1 } [ "error" throw ] try-find 2array ] unit-test diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 9feea46b84..d63acae883 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -128,9 +128,6 @@ SYMBOL: thread-error-hook : cleanup ( try cleanup-always cleanup-error -- ) [ compose [ dip rethrow ] curry recover ] [ drop ] 2bi call ; inline -: try-find ( seq try -- result elt ) - [ curry [ drop f ] recover ] curry map-find ; inline - ERROR: attempt-all-error ; : attempt-all ( seq quot -- obj ) From e8dfc2207385d57e0175012453c3951475728f1a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 28 Jan 2010 21:48:41 -0800 Subject: [PATCH 06/33] gpu.shaders: don't attempt to bind vertex attributes that don't exist in the compiled shader --- extra/gpu/shaders/shaders.factor | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor index 2c321fe559..890bb06a1f 100644 --- a/extra/gpu/shaders/shaders.factor +++ b/extra/gpu/shaders/shaders.factor @@ -128,6 +128,20 @@ TR: hyphens>underscores "-" "_" ; [ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ] } 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ; +:: (bind-float-vertex-attribute) ( program-instance ptr name dim gl-type normalize? stride offset -- ) + program-instance name attribute-index :> idx + idx 0 >= [ + idx glEnableVertexAttribArray + idx dim gl-type normalize? stride offset ptr glVertexAttribPointer + ] when ; inline + +:: (bind-int-vertex-attribute) ( program-instance ptr name dim gl-type stride offset -- ) + program-instance name attribute-index :> idx + idx 0 >= [ + idx glEnableVertexAttribArray + idx dim gl-type stride offset ptr glVertexAttribIPointer + ] when ; inline + :: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot ) vertex-attribute name>> hyphens>underscores :> name vertex-attribute component-type>> :> type @@ -141,23 +155,9 @@ TR: hyphens>underscores "-" "_" ; { [ name not ] [ [ 2drop ] ] } { [ type unnormalized-integer-components? ] - [ - { - name attribute-index [ glEnableVertexAttribArray ] keep - dim gl-type stride offset - } >quotation :> dip-block - - { dip-block dip glVertexAttribIPointer } >quotation - ] + [ { name dim gl-type stride offset (bind-int-vertex-attribute) } >quotation ] } - [ - { - name attribute-index [ glEnableVertexAttribArray ] keep - dim gl-type normalize? stride offset - } >quotation :> dip-block - - { dip-block dip glVertexAttribPointer } >quotation - ] + [ { name dim gl-type normalize? stride offset (bind-float-vertex-attribute) } >quotation ] } cond ; :: [bind-vertex-format] ( vertex-attributes -- quot ) From d3db7e0225547fffa60d21be4cffde7238d7b115 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Jan 2010 13:47:06 -0600 Subject: [PATCH 07/33] Add mnapply, smart-apply. Docs incoming soon --- basis/combinators/smart/smart-tests.factor | 6 +++++- basis/combinators/smart/smart.factor | 3 +++ basis/generalizations/generalizations-tests.factor | 5 +++++ basis/generalizations/generalizations.factor | 4 ++++ 4 files changed, 17 insertions(+), 1 deletion(-) diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index afafd174d3..11624dcf10 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test combinators.smart math kernel accessors ; +USING: accessors arrays combinators.smart kernel math +tools.test ; IN: combinators.smart.tests : test-bi ( -- 9 11 ) @@ -59,3 +60,6 @@ IN: combinators.smart.tests [ 7 ] [ 10 3 smart-if-test ] unit-test [ 16 ] [ 25 41 smart-if-test ] unit-test + +[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 3 smart-apply ] unit-test +[ { 1 2 3 } { 4 5 6 } ] [ 1 2 3 4 5 6 [ 3array ] 2 smart-apply ] unit-test diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index 05185fec2e..3ad5b6c7ee 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -51,3 +51,6 @@ MACRO: nullary ( quot -- quot' ) MACRO: smart-if ( pred true false -- ) '[ _ preserving _ _ if ] ; + +MACRO: smart-apply ( quot n -- ) + [ dup inputs ] dip '[ _ _ mnapply ] ; diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 0c35f15714..84b6565de1 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -108,3 +108,8 @@ IN: generalizations.tests 2 1 0 -1 [ + ] [ - ] [ * ] [ / ] 4 spread-curry 4 spread* ] unit-test +[ { 1 2 } { 3 4 } { 5 6 } ] +[ 1 2 3 4 5 6 [ 2array ] 2 3 mnapply ] unit-test + +[ { 1 2 3 } { 4 5 6 } ] +[ 1 2 3 4 5 6 [ 3array ] 3 2 mnapply ] unit-test diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 6c8a0b5fde..667cff7b8a 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -124,6 +124,10 @@ MACRO: cleave* ( n -- ) MACRO: mnswap ( m n -- ) 1 + '[ _ -nrot ] swap '[ _ _ napply ] ; +MACRO: mnapply ( quot m n -- ) + swap + [ swap '[ _ ] replicate ] dip '[ _ _ nspread ] ; + MACRO: nweave ( n -- ) [ dup iota [ '[ _ _ mnswap ] ] with map ] keep '[ _ _ ncleave ] ; From af41dc61691893ef53b89bd9d8a3b42c450ed136 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 20 Jan 2010 20:26:47 +1300 Subject: [PATCH 08/33] Trying to fix mixin semantics --- basis/grouping/grouping.factor | 8 +++++--- core/classes/algebra/algebra-tests.factor | 18 +++++++++++------- core/classes/algebra/algebra.factor | 17 +++++++++-------- core/classes/intersection/intersection.factor | 5 ++++- core/classes/mixin/mixin-tests.factor | 4 ++-- core/classes/mixin/mixin.factor | 19 +++++++++---------- core/classes/union/union.factor | 5 ++++- 7 files changed, 44 insertions(+), 32 deletions(-) diff --git a/basis/grouping/grouping.factor b/basis/grouping/grouping.factor index 8a39a5d5cf..8364144694 100644 --- a/basis/grouping/grouping.factor +++ b/basis/grouping/grouping.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2009 Slava Pestov. +! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.order strings arrays vectors sequences sequences.private accessors fry ; @@ -20,14 +20,16 @@ M: chunking-seq set-nth group@ 0 swap copy ; M: chunking-seq like drop { } like ; inline -INSTANCE: chunking-seq sequence - MIXIN: subseq-chunking +INSTANCE: subseq-chunking sequence + M: subseq-chunking nth group@ subseq ; inline MIXIN: slice-chunking +INSTANCE: slice-chunking sequence + M: slice-chunking nth group@ ; inline M: slice-chunking nth-unsafe group@ slice boa ; inline diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 11cb11d334..39b1a2d4e7 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -79,9 +79,9 @@ INSTANCE: union-with-one-member mixin-with-one-member [ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test -[ t ] [ growable tuple sequence class-and class<= ] unit-test +[ f ] [ growable tuple sequence class-and class<= ] unit-test -[ t ] [ growable assoc class-and tuple class<= ] unit-test +[ f ] [ growable assoc class-and tuple class<= ] unit-test [ t ] [ object \ f \ f class-not class-or class<= ] unit-test @@ -130,6 +130,11 @@ INSTANCE: union-with-one-member mixin-with-one-member [ t ] [ a union-with-one-member class<= ] unit-test [ f ] [ union-with-one-member class-not integer class<= ] unit-test +MIXIN: empty-mixin + +[ f ] [ empty-mixin class-not null class<= ] unit-test +[ f ] [ empty-mixin null class<= ] unit-test + ! class-and : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ; @@ -146,8 +151,6 @@ INSTANCE: union-with-one-member mixin-with-one-member [ t ] [ slice reversed null class-and* ] unit-test [ t ] [ \ f class-not \ f null class-and* ] unit-test -[ t ] [ vector virtual-sequence null class-and* ] unit-test - [ t ] [ vector array class-not vector class-and* ] unit-test ! class-or @@ -160,7 +163,8 @@ INSTANCE: union-with-one-member mixin-with-one-member ! classes-intersect? [ t ] [ both tuple classes-intersect? ] unit-test -[ f ] [ vector virtual-sequence classes-intersect? ] unit-test + +[ t ] [ vector virtual-sequence classes-intersect? ] unit-test [ t ] [ number vector class-or sequence classes-intersect? ] unit-test @@ -188,11 +192,11 @@ INSTANCE: union-with-one-member mixin-with-one-member [ t ] [ union-with-one-member object classes-intersect? ] unit-test [ t ] [ a mixin-with-one-member classes-intersect? ] unit-test -[ f ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test +[ t ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test [ t ] [ object mixin-with-one-member classes-intersect? ] unit-test [ t ] [ mixin-with-one-member a classes-intersect? ] unit-test -[ f ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test +[ t ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test [ t ] [ mixin-with-one-member object classes-intersect? ] unit-test ! class= diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index e98470cd83..5e29de464c 100644 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel classes combinators accessors sequences arrays vectors assocs namespaces words sorting layouts math hashtables @@ -34,12 +34,9 @@ DEFER: (class-or) GENERIC: (flatten-class) ( class -- ) -: normalize-class ( class -- class' ) - { - { [ dup members ] [ members normalize-class ] } - { [ dup participants ] [ participants normalize-class ] } - [ ] - } cond ; +GENERIC: normalize-class ( class -- class' ) + +M: object normalize-class ; PRIVATE> @@ -93,6 +90,9 @@ M: word valid-class? drop f ; : left-anonymous-union<= ( first second -- ? ) [ members>> ] dip [ class<= ] curry all? ; +: right-union<= ( first second -- ? ) + members [ class<= ] with any? ; + : right-anonymous-union<= ( first second -- ? ) members>> [ class<= ] with any? ; @@ -117,7 +117,7 @@ M: word valid-class? drop f ; [ class-not normalize-class ] map ] } - [ ] + [ drop object ] } cond ; : left-anonymous-complement<= ( first second -- ? ) @@ -147,6 +147,7 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; { [ over anonymous-union? ] [ left-anonymous-union<= ] } { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] } { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] } + { [ dup members ] [ right-union<= ] } { [ dup anonymous-union? ] [ right-anonymous-union<= ] } { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] } { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index 36514f3cb2..6eb9f57823 100644 --- a/core/classes/intersection/intersection.factor +++ b/core/classes/intersection/intersection.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words accessors sequences kernel assocs combinators classes classes.algebra classes.algebra.private classes.builtin @@ -33,6 +33,9 @@ M: intersection-class rank-class drop 2 ; M: intersection-class instance? "participants" word-prop [ instance? ] with all? ; +M: intersection-class normalize-class + participants normalize-class ; + M: intersection-class (flatten-class) participants (flatten-class) ; diff --git a/core/classes/mixin/mixin-tests.factor b/core/classes/mixin/mixin-tests.factor index a9a7952c51..d174bb55ad 100644 --- a/core/classes/mixin/mixin-tests.factor +++ b/core/classes/mixin/mixin-tests.factor @@ -38,8 +38,8 @@ MIXIN: mx1 INSTANCE: integer mx1 [ t ] [ integer mx1 class<= ] unit-test -[ t ] [ mx1 integer class<= ] unit-test -[ t ] [ mx1 number class<= ] unit-test +[ f ] [ mx1 integer class<= ] unit-test +[ f ] [ mx1 number class<= ] unit-test "IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval( -- ) diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 6514f36074..8a7599205d 100644 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -1,11 +1,17 @@ -! Copyright (C) 2004, 2009 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes classes.union words kernel sequences -definitions combinators arrays assocs generic accessors ; +USING: classes classes.algebra classes.algebra.private +classes.union words kernel sequences definitions combinators +arrays assocs generic accessors ; IN: classes.mixin PREDICATE: mixin-class < union-class "mixin" word-prop ; +M: mixin-class normalize-class ; + +M: mixin-class (classes-intersect?) + members [ classes-intersect? ] with any? ; + M: mixin-class reset-class [ call-next-method ] [ { "mixin" } reset-props ] bi ; @@ -53,13 +59,6 @@ TUPLE: check-mixin-class class ; GENERIC# add-mixin-instance 1 ( class mixin -- ) M: class add-mixin-instance - #! Note: we call update-classes on the new member, not the - #! mixin. This ensures that we only have to update the - #! methods whose specializer intersects the new member, not - #! the entire mixin (since the other mixin members are not - #! affected at all). Also, all usages of the mixin will get - #! updated by transitivity; the mixins usages appear in - #! class-usages of the member, now that it's been added. [ 2drop ] [ [ (add-mixin-instance) ] 2keep [ nip ] [ [ new-class? ] either? ] 2bi diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 4615d316ac..6774848677 100644 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words sequences kernel assocs combinators classes classes.algebra classes.algebra.private namespaces arrays math @@ -34,5 +34,8 @@ M: union-class rank-class drop 2 ; M: union-class instance? "members" word-prop [ instance? ] with any? ; +M: union-class normalize-class + members normalize-class ; + M: union-class (flatten-class) members (flatten-class) ; From d58f73453f963333cdb89dd7bc62f6e0dcd3e38f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 20 Jan 2010 20:27:10 +1300 Subject: [PATCH 09/33] Add test case for mixin bug Doug found, seems to be fixed now --- basis/compiler/tests/redefine18.factor | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 basis/compiler/tests/redefine18.factor diff --git a/basis/compiler/tests/redefine18.factor b/basis/compiler/tests/redefine18.factor new file mode 100644 index 0000000000..efa9c6ce87 --- /dev/null +++ b/basis/compiler/tests/redefine18.factor @@ -0,0 +1,25 @@ +USING: kernel tools.test eval words ; +IN: compiler.tests.redefine18 + +! Mixin bug found by Doug + +GENERIC: g1 ( a -- b ) +GENERIC: g2 ( a -- b ) + +MIXIN: c +SINGLETON: a +INSTANCE: a c + +M: c g1 g2 ; +M: a g2 drop a ; + +MIXIN: d +INSTANCE: d c + +M: d g2 drop d ; + +[ ] [ "IN: compiler.tests.redefine18 SINGLETON: b INSTANCE: b d" eval( -- ) ] unit-test + +[ d ] [ "b" "compiler.tests.redefine18" lookup g1 ] unit-test + +[ ] [ "IN: compiler.tests.redefine18 FORGET: b" eval( -- ) ] unit-test From e6d1388dcc7f99decb672d004f2c7a15a42238ac Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Jan 2010 00:44:34 +1300 Subject: [PATCH 10/33] Clean up class algebra a bit, and change mixins to recompile less, taking advantage of new semantics --- core/bootstrap/primitives.factor | 3 ++ core/classes/algebra/algebra-tests.factor | 6 ++-- core/classes/builtin/builtin.factor | 7 +---- core/classes/intersection/intersection.factor | 14 +++++---- core/classes/mixin/mixin.factor | 29 ++++++++----------- core/classes/predicate/predicate.factor | 6 +++- core/classes/singleton/singleton.factor | 9 ++++-- core/classes/tuple/tuple-docs.factor | 3 +- core/classes/union/union.factor | 4 +++ 9 files changed, 45 insertions(+), 36 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 67107c8c9a..ecf66834ce 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -126,6 +126,9 @@ call( -- ) prepare-slots make-slots 1 finalize-slots [ "slots" set-word-prop ] [ define-accessors ] 2bi ; +: define-builtin-predicate ( class -- ) + dup class>type [ eq? ] curry [ tag ] prepend define-predicate ; + : define-builtin ( symbol slotspec -- ) [ [ define-builtin-predicate ] keep ] dip define-builtin-slots ; diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 39b1a2d4e7..fcce372fe8 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -164,7 +164,7 @@ MIXIN: empty-mixin ! classes-intersect? [ t ] [ both tuple classes-intersect? ] unit-test -[ t ] [ vector virtual-sequence classes-intersect? ] unit-test +[ f ] [ vector virtual-sequence classes-intersect? ] unit-test [ t ] [ number vector class-or sequence classes-intersect? ] unit-test @@ -192,11 +192,11 @@ MIXIN: empty-mixin [ t ] [ union-with-one-member object classes-intersect? ] unit-test [ t ] [ a mixin-with-one-member classes-intersect? ] unit-test -[ t ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test +[ f ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test [ t ] [ object mixin-with-one-member classes-intersect? ] unit-test [ t ] [ mixin-with-one-member a classes-intersect? ] unit-test -[ t ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test +[ f ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test [ t ] [ mixin-with-one-member object classes-intersect? ] unit-test ! class= diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index 028225ec49..fd14a64e35 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors classes classes.algebra classes.algebra.private words kernel kernel.private namespaces sequences math @@ -20,11 +20,6 @@ M: object class tag type>class ; inline M: builtin-class rank-class drop 0 ; -GENERIC: define-builtin-predicate ( class -- ) - -M: builtin-class define-builtin-predicate - dup class>type [ eq? ] curry [ tag ] prepend define-predicate ; - M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ; M: builtin-class (flatten-class) dup set ; diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index 6eb9f57823..242f099ea0 100644 --- a/core/classes/intersection/intersection.factor +++ b/core/classes/intersection/intersection.factor @@ -8,6 +8,8 @@ IN: classes.intersection PREDICATE: intersection-class < class "metaclass" word-prop intersection-class eq? ; + + +: define-intersection-class ( class participants -- ) + [ [ f f ] dip intersection-class define-class ] + [ drop update-classes ] + 2bi ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 8a7599205d..3a6670a4f7 100644 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes classes.algebra classes.algebra.private -classes.union words kernel sequences definitions combinators -arrays assocs generic accessors ; +classes.union classes.union.private words kernel sequences +definitions combinators arrays assocs generic accessors ; IN: classes.mixin PREDICATE: mixin-class < union-class "mixin" word-prop ; @@ -46,40 +46,35 @@ TUPLE: check-mixin-class class ; [ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi swap redefine-mixin-class ; inline -: update-classes/new ( mixin -- ) +: update-mixin-class ( member mixin -- ) class-usages + [ update-methods ] [ [ update-class ] each ] - [ implementors [ remake-generic ] each ] bi ; + [ implementors [ remake-generic ] each ] + tri ; : (add-mixin-instance) ( class mixin -- ) [ [ suffix ] change-mixin-class ] [ [ f ] 2dip "instances" word-prop set-at ] - 2bi ; + [ update-mixin-class ] + 2tri ; GENERIC# add-mixin-instance 1 ( class mixin -- ) M: class add-mixin-instance - [ 2drop ] [ - [ (add-mixin-instance) ] 2keep - [ nip ] [ [ new-class? ] either? ] 2bi - [ update-classes/new ] [ update-classes ] if - ] if-mixin-member? ; + [ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ; : (remove-mixin-instance) ( class mixin -- ) [ [ swap remove ] change-mixin-class ] [ "instances" word-prop delete-at ] - 2bi ; + [ update-mixin-class ] + 2tri ; : remove-mixin-instance ( class mixin -- ) #! The order of the three clauses is important here. The last #! one must come after the other two so that the entries it #! adds to changed-generics are not overwritten. - [ - [ (remove-mixin-instance) ] - [ nip update-classes ] - [ class-usages update-methods ] - 2tri - ] [ 2drop ] if-mixin-member? ; + [ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ; M: mixin-class class-forgotten remove-mixin-instance ; diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index eab2746dea..c0dfb4efa0 100644 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2009 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes classes.algebra classes.algebra.private kernel namespaces make words sequences quotations arrays kernel.private @@ -8,6 +8,8 @@ IN: classes.predicate PREDICATE: predicate-class < class "metaclass" word-prop predicate-class eq? ; + + : define-predicate-class ( class superclass definition -- ) [ drop f f predicate-class define-class ] [ nip "predicate-definition" set-word-prop ] diff --git a/core/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor index e1caf4f46b..02ca405145 100644 --- a/core/classes/singleton/singleton.factor +++ b/core/classes/singleton/singleton.factor @@ -1,11 +1,16 @@ -! Copyright (C) 2008, 2009 Doug Coleman, Slava Pestov. +! Copyright (C) 2008, 2010 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes classes.algebra classes.algebra.private -classes.predicate kernel sequences words ; +classes.predicate classes.predicate.private kernel sequences +words ; IN: classes.singleton + + PREDICATE: singleton-class < predicate-class [ "predicate-definition" word-prop ] [ singleton-predicate-quot ] diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 45d3931448..4dcbf86280 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -348,8 +348,7 @@ HELP: tuple-class HELP: tuple= { $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } } -{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." } -{ $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ; +{ $description "Checks if two tuples have equal slot values. This is the default behavior of " { $link = } " on tuples, unless the tuple class subclasses " { $link identity-tuple } " or implements a method on " { $link equal? } ". In cases where equality has been redefined, this word can be used to get the default semantics if needed." } ; HELP: tuple { $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class." diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 6774848677..9540b0be86 100644 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -8,6 +8,8 @@ IN: classes.union PREDICATE: union-class < class "metaclass" word-prop union-class eq? ; + + : define-union-class ( class members -- ) [ (define-union-class) ] [ drop update-classes ] 2bi ; From 066bf9a42f14af2e716334413a546656e9dc82f0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Jan 2010 02:36:20 +1300 Subject: [PATCH 11/33] classes.algebra: couple more tests --- core/classes/algebra/algebra-tests.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index fcce372fe8..cd7eb83c24 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -135,6 +135,9 @@ MIXIN: empty-mixin [ f ] [ empty-mixin class-not null class<= ] unit-test [ f ] [ empty-mixin null class<= ] unit-test +[ t ] [ array sequence vector class-not class-and class<= ] unit-test +[ f ] [ vector sequence vector class-not class-and class<= ] unit-test + ! class-and : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ; From 830e25c70b7d6a63be5e9f97986600c21692cedb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Jan 2010 04:23:20 +1300 Subject: [PATCH 12/33] More changes so that mixins trigger even less recompilation --- basis/compiler/compiler.factor | 16 ++++---- basis/compiler/crossref/crossref.factor | 12 +----- core/classes/classes.factor | 39 ++++++++++--------- core/classes/mixin/mixin.factor | 50 ++++++++++++++----------- core/classes/union/union.factor | 11 ++++-- core/compiler/units/units.factor | 26 ++++++++----- core/definitions/definitions.factor | 12 +----- core/generic/generic.factor | 16 ++------ 8 files changed, 85 insertions(+), 97 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index bf9b049127..70a0676863 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -3,18 +3,16 @@ USING: accessors kernel namespaces arrays sequences io words fry continuations vocabs assocs dlists definitions math graphs generic generic.single combinators deques search-deques macros -source-files.errors combinators.short-circuit +source-files.errors combinators.short-circuit classes.algebra stack-checker stack-checker.dependencies stack-checker.inlining stack-checker.errors -compiler.errors compiler.units compiler.utilities +compiler.errors compiler.units compiler.utilities compiler.crossref compiler.tree.builder compiler.tree.optimizer -compiler.crossref - compiler.cfg compiler.cfg.builder compiler.cfg.optimizer @@ -183,6 +181,12 @@ t compile-dependencies? set-global SINGLETON: optimizing-compiler +M: optimizing-compiler update-call-sites ( class generic -- words ) + #! Words containing call sites with inferred type 'class' + #! which inlined a method on 'generic' + compiled-generic-usage swap + '[ nip _ classes-intersect? ] assoc-filter keys ; + M: optimizing-compiler recompile ( words -- alist ) [ compile-queue set @@ -197,9 +201,7 @@ M: optimizing-compiler recompile ( words -- alist ) "--- compile done" compiler-message ; M: optimizing-compiler to-recompile ( -- words ) - changed-definitions get compiled-usages - changed-generics get compiled-generic-usages - append assoc-combine keys ; + changed-definitions get compiled-usages assoc-combine keys ; M: optimizing-compiler process-forgotten-words [ delete-compiled-xref ] each ; diff --git a/basis/compiler/crossref/crossref.factor b/basis/compiler/crossref/crossref.factor index e6ef5cf17c..e216a1f147 100644 --- a/basis/compiler/crossref/crossref.factor +++ b/basis/compiler/crossref/crossref.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs classes.algebra compiler.units definitions graphs grouping kernel namespaces sequences words @@ -32,16 +32,6 @@ compiled-generic-crossref [ H{ } clone ] initialize : compiled-generic-usage ( word -- assoc ) compiled-generic-crossref get at ; -: (compiled-generic-usages) ( generic class -- assoc ) - [ compiled-generic-usage ] dip - [ - 2dup [ valid-class? ] both? - [ classes-intersect? ] [ 2drop f ] if nip - ] curry assoc-filter ; - -: compiled-generic-usages ( assoc -- assocs ) - [ (compiled-generic-usages) ] { } assoc>map ; - : (compiled-xref) ( word dependencies word-prop variable -- ) [ [ concat ] dip set-word-prop ] [ get add-vertex* ] bi-curry* 2bi ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index f009368420..656037c739 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2009 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions assocs kernel kernel.private slots.private namespaces make sequences strings words words.symbol @@ -133,19 +133,24 @@ M: sequence implementors [ implementors ] gather ; dup deferred? [ define-symbol ] [ drop ] if ; : (define-class) ( word props -- ) + reset-caches + [ drop update-map- ] [ - { - [ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ] - [ reset-class ] - [ ?define-symbol ] - [ changed-definition ] - [ ] - } cleave - ] dip [ assoc-union ] curry change-props - dup predicate-word - [ 1quotation "predicate" set-word-prop ] - [ swap "predicating" set-word-prop ] - [ drop t "class" set-word-prop ] + [ + { + [ dup class? [ drop ] [ implementors-map+ ] if ] + [ reset-class ] + [ ?define-symbol ] + [ ] + } cleave + ] dip [ assoc-union ] curry change-props + dup predicate-word + [ 1quotation "predicate" set-word-prop ] + [ swap "predicating" set-word-prop ] + [ drop t "class" set-word-prop ] + 2tri + ] + [ drop update-map+ ] 2tri ; PRIVATE> @@ -161,13 +166,7 @@ GENERIC: update-methods ( class seq -- ) [ nip [ update-class ] each ] [ update-methods ] 2bi ; : define-class ( word superclass members participants metaclass -- ) - #! If it was already a class, update methods after. - reset-caches - make-class-props - [ drop update-map- ] - [ (define-class) ] - [ drop update-map+ ] - 2tri ; + make-class-props [ (define-class) ] [ drop changed-definition ] 2bi ; : forget-predicate ( class -- ) dup "predicate" word-prop diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 3a6670a4f7..cc67a75407 100644 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -26,10 +26,12 @@ M: mixin-class rank-class drop 3 ; dup mixin-class? [ drop ] [ - [ { } redefine-mixin-class ] - [ H{ } clone "instances" set-word-prop ] - [ update-classes ] - tri + { + [ { } redefine-mixin-class ] + [ H{ } clone "instances" set-word-prop ] + [ changed-definition ] + [ update-classes ] + } cleave ] if ; TUPLE: check-mixin-class class ; @@ -46,18 +48,18 @@ TUPLE: check-mixin-class class ; [ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi swap redefine-mixin-class ; inline -: update-mixin-class ( member mixin -- ) - class-usages - [ update-methods ] - [ [ update-class ] each ] - [ implementors [ remake-generic ] each ] - tri ; - : (add-mixin-instance) ( class mixin -- ) - [ [ suffix ] change-mixin-class ] - [ [ f ] 2dip "instances" word-prop set-at ] - [ update-mixin-class ] - 2tri ; + #! Call update-methods before adding the member: + #! - Call sites of generics specializing on 'mixin' + #! where the inferred type is 'class' are updated, + #! - Call sites where the inferred type is a subtype + #! of 'mixin' disjoint from 'class' are not updated + dup class-usages { + [ nip update-methods ] + [ drop [ suffix ] change-mixin-class ] + [ drop [ f ] 2dip "instances" word-prop set-at ] + [ 2nip [ update-class ] each ] + } 3cleave ; GENERIC# add-mixin-instance 1 ( class mixin -- ) @@ -65,15 +67,19 @@ M: class add-mixin-instance [ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ; : (remove-mixin-instance) ( class mixin -- ) - [ [ swap remove ] change-mixin-class ] - [ "instances" word-prop delete-at ] - [ update-mixin-class ] - 2tri ; + #! Call update-methods after removing the member: + #! - Call sites of generics specializing on 'mixin' + #! where the inferred type is 'class' are updated, + #! - Call sites where the inferred type is a subtype + #! of 'mixin' disjoint from 'class' are not updated + dup class-usages { + [ drop [ swap remove ] change-mixin-class ] + [ drop "instances" word-prop delete-at ] + [ 2nip [ update-class ] each ] + [ nip update-methods ] + } 3cleave ; : remove-mixin-instance ( class mixin -- ) - #! The order of the three clauses is important here. The last - #! one must come after the other two so that the entries it - #! adds to changed-generics are not overwritten. [ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ; M: mixin-class class-forgotten remove-mixin-instance ; diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 9540b0be86..94013c32d9 100644 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words sequences kernel assocs combinators classes -classes.algebra classes.algebra.private namespaces arrays math -quotations ; +classes.private classes.algebra classes.algebra.private +namespaces arrays math quotations definitions ; IN: classes.union PREDICATE: union-class < class @@ -26,12 +26,15 @@ PREDICATE: union-class < class M: union-class update-class define-union-predicate ; : (define-union-class) ( class members -- ) - f swap f union-class define-class ; + f swap f union-class make-class-props (define-class) ; PRIVATE> : define-union-class ( class members -- ) - [ (define-union-class) ] [ drop update-classes ] 2bi ; + [ (define-union-class) ] + [ drop changed-definition ] + [ drop update-classes ] + 2tri ; M: union-class rank-class drop 2 ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 87a25f2af7..3d0cd7bb97 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel continuations assocs namespaces sequences words vocabs definitions hashtables init sets @@ -43,6 +43,16 @@ PRIVATE> SYMBOL: compiler-impl +HOOK: update-call-sites compiler-impl ( class generic -- words ) + +M: generic update-generic ( class generic -- ) + [ update-call-sites [ changed-definition ] each ] + [ remake-generic drop ] + 2bi ; + +M: sequence update-methods ( class seq -- ) + implementors [ update-generic ] with each ; + HOOK: recompile compiler-impl ( words -- alist ) HOOK: to-recompile compiler-impl ( -- words ) @@ -52,12 +62,14 @@ HOOK: process-forgotten-words compiler-impl ( words -- ) : compile ( words -- ) recompile modify-code-heap ; ! Non-optimizing compiler -M: f recompile - [ dup def>> ] { } map>assoc ; +M: f update-call-sites + 2drop { } ; M: f to-recompile - changed-definitions get [ drop word? ] assoc-filter - changed-generics get assoc-union keys ; + changed-definitions get [ drop word? ] assoc-filter keys ; + +M: f recompile + [ dup def>> ] { } map>assoc ; M: f process-forgotten-words drop ; @@ -148,25 +160,21 @@ PRIVATE> : with-nested-compilation-unit ( quot -- ) [ H{ } clone changed-definitions set - H{ } clone changed-generics set H{ } clone changed-effects set H{ } clone outdated-generics set H{ } clone outdated-tuples set H{ } clone new-words set - H{ } clone new-classes set [ finish-compilation-unit ] [ ] cleanup ] with-scope ; inline : with-compilation-unit ( quot -- ) [ H{ } clone changed-definitions set - H{ } clone changed-generics set H{ } clone changed-effects set H{ } clone outdated-generics set H{ } clone forgotten-definitions set H{ } clone outdated-tuples set H{ } clone new-words set - H{ } clone new-classes set new-definitions set old-definitions set [ finish-compilation-unit ] [ ] cleanup diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 597b195c36..71d6797abd 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2009 Slava Pestov. +! Copyright (C) 2006, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences namespaces assocs math accessors ; IN: definitions @@ -17,26 +17,16 @@ SYMBOL: changed-definitions SYMBOL: changed-effects -SYMBOL: changed-generics - SYMBOL: outdated-generics SYMBOL: new-words -SYMBOL: new-classes - : new-word ( word -- ) dup new-words get set-in-unit ; : new-word? ( word -- ? ) new-words get key? ; -: new-class ( word -- ) - dup new-classes get set-in-unit ; - -: new-class? ( word -- ? ) - new-classes get key? ; - GENERIC: where ( defspec -- loc ) M: object where drop f ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index cea3643473..517ccd4775 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -87,21 +87,16 @@ TUPLE: check-method class generic ; \ check-method boa throw ] unless ; inline -: changed-generic ( class generic -- ) - changed-generics get - [ [ [ class-or ] when* ] change-at ] [ no-compilation-unit ] if* ; - : remake-generic ( generic -- ) dup outdated-generics get set-in-unit ; : remake-generics ( -- ) outdated-generics get keys [ generic? ] filter [ make-generic ] each ; +GENERIC: update-generic ( class generic -- ) + : with-methods ( class generic quot -- ) - [ drop changed-generic ] - [ [ "methods" word-prop ] dip call ] - [ drop remake-generic drop ] - 3tri ; inline + [ "methods" word-prop ] prepose [ update-generic ] 2bi ; inline : method-word-name ( class generic -- string ) [ name>> ] bi@ "=>" glue ; @@ -174,11 +169,6 @@ M: method-body forget* [ call-next-method ] bi ] if ; -M: sequence update-methods ( class seq -- ) - implementors [ - [ changed-generic ] [ remake-generic drop ] 2bi - ] with each ; - : define-generic ( word combination effect -- ) [ nip swap set-stack-effect ] [ From 8b19b56a1c871773ae09e2eecd933593673ef3e6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Jan 2010 04:32:31 +1300 Subject: [PATCH 13/33] classes.mixin: privacy please --- core/classes/mixin/mixin.factor | 52 +++++++++++++++++++-------------- 1 file changed, 30 insertions(+), 22 deletions(-) diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index cc67a75407..44e66dd79c 100644 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -17,23 +17,6 @@ M: mixin-class reset-class M: mixin-class rank-class drop 3 ; -: redefine-mixin-class ( class members -- ) - [ (define-union-class) ] - [ drop t "mixin" set-word-prop ] - 2bi ; - -: define-mixin-class ( class -- ) - dup mixin-class? [ - drop - ] [ - { - [ { } redefine-mixin-class ] - [ H{ } clone "instances" set-word-prop ] - [ changed-definition ] - [ update-classes ] - } cleave - ] if ; - TUPLE: check-mixin-class class ; : check-mixin-class ( mixin -- mixin ) @@ -41,6 +24,13 @@ TUPLE: check-mixin-class class ; \ check-mixin-class boa throw ] unless ; + + +GENERIC# add-mixin-instance 1 ( class mixin -- ) + +M: class add-mixin-instance + [ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ; + : remove-mixin-instance ( class mixin -- ) [ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ; M: mixin-class class-forgotten remove-mixin-instance ; +: define-mixin-class ( class -- ) + dup mixin-class? [ + drop + ] [ + { + [ { } redefine-mixin-class ] + [ H{ } clone "instances" set-word-prop ] + [ changed-definition ] + [ update-classes ] + } cleave + ] if ; + ! Definition protocol implementation ensures that removing an ! INSTANCE: declaration from a source file updates the mixin. TUPLE: mixin-instance class mixin ; C: mixin-instance +mixin-instance< ( mixin-instance -- class mixin ) [ class>> ] [ mixin>> ] bi ; inline +PRIVATE> + M: mixin-instance where >mixin-instance< "instances" word-prop at ; M: mixin-instance set-where >mixin-instance< "instances" word-prop set-at ; From 34287fd9d68fd573c6aa921aa0babda9de6c4834 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Jan 2010 04:33:58 +1300 Subject: [PATCH 14/33] Minor documentation updates --- core/classes/tuple/tuple-docs.factor | 2 ++ core/kernel/kernel-docs.factor | 3 +++ 2 files changed, 5 insertions(+) diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 4dcbf86280..48b95bec48 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -202,6 +202,8 @@ ARTICLE: "tuple-introspection" "Tuple introspection" } "Tuple classes can also be defined at run time:" { $subsections define-tuple-class } +"Tuples can be compared for slot equality even if the tuple class overrides " { $link equal? } ":" +{ $subsections tuple= } { $see-also "slots" "mirrors" } ; ARTICLE: "tuple-examples" "Tuple examples" diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 7c80990d7a..99fa21133d 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -672,6 +672,9 @@ HELP: object HELP: null { $class-description "The canonical empty class with no instances." +} +{ $notes + "Unlike " { $snippet "null" } " in Java or " { $snippet "NULL" } " in C++, this is not a value signifying empty, or nothing. Use " { $link f } " for this purpose." } ; HELP: most From 238ec94e06c1502de6c8141e8b646bda861b278d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Jan 2010 05:02:07 +1300 Subject: [PATCH 15/33] tools.deploy.shaker: don't strip "mixin" word prop --- basis/tools/deploy/shaker/shaker.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 71191d0fe6..e4e11a3135 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -159,7 +159,6 @@ IN: tools.deploy.shaker "members" "memo-quot" "methods" - "mixin" "method-class" "method-generic" "modular-arithmetic" From bd479db2f8eea8b3aa7e7c801a802eb8457dd640 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Jan 2010 07:55:42 +1300 Subject: [PATCH 16/33] Fix regression when forgetting classes --- basis/compiler/compiler.factor | 6 ++++-- core/classes/algebra/algebra.factor | 11 +++++------ 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 70a0676863..7fc171859c 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -184,8 +184,10 @@ SINGLETON: optimizing-compiler M: optimizing-compiler update-call-sites ( class generic -- words ) #! Words containing call sites with inferred type 'class' #! which inlined a method on 'generic' - compiled-generic-usage swap - '[ nip _ classes-intersect? ] assoc-filter keys ; + compiled-generic-usage swap '[ + nip dup forgotten-class? + [ drop f ] [ _ classes-intersect? ] if + ] assoc-filter keys ; M: optimizing-compiler recompile ( words -- alist ) [ diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 5e29de464c..fe02e6b583 100644 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -40,13 +40,12 @@ M: object normalize-class ; PRIVATE> -GENERIC: valid-class? ( obj -- ? ) +GENERIC: forgotten-class? ( obj -- ? ) -M: class valid-class? drop t ; -M: anonymous-union valid-class? members>> [ valid-class? ] all? ; -M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ; -M: anonymous-complement valid-class? class>> valid-class? ; -M: word valid-class? drop f ; +M: word forgotten-class? "forgotten" word-prop ; +M: anonymous-union forgotten-class? members>> [ forgotten-class? ] any? ; +M: anonymous-intersection forgotten-class? participants>> [ forgotten-class? ] any? ; +M: anonymous-complement forgotten-class? class>> forgotten-class? ; : class<= ( first second -- ? ) class<=-cache get [ (class<=) ] 2cache ; From 4f68808a7242fa7dc8c28ffb5acb844fdbd6bc9d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Jan 2010 08:00:36 +1300 Subject: [PATCH 17/33] Rename predicate-word to create-predicate-word and add a new predicate-word word --- core/classes/classes.factor | 10 ++++++---- core/classes/parser/parser.factor | 4 ++-- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 656037c739..e4301f6bae 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -37,9 +37,12 @@ PREDICATE: class < word "class" word-prop ; : classes ( -- seq ) implementors-map get keys ; -: predicate-word ( word -- predicate ) +: create-predicate-word ( word -- predicate ) [ name>> "?" append ] [ vocabulary>> ] bi create ; +: predicate-word ( word -- predicate ) + "predicate" word-prop first ; + PREDICATE: predicate < word "predicating" word-prop >boolean ; M: predicate forget* @@ -49,8 +52,7 @@ M: predicate reset-word [ call-next-method ] [ f "predicating" set-word-prop ] bi ; : define-predicate ( class quot -- ) - [ "predicate" word-prop first ] dip - (( object -- ? )) define-declared ; + [ predicate-word ] dip (( object -- ? )) define-declared ; : superclass ( class -- super ) #! Output f for non-classes to work with algebra code @@ -144,7 +146,7 @@ M: sequence implementors [ implementors ] gather ; [ ] } cleave ] dip [ assoc-union ] curry change-props - dup predicate-word + dup create-predicate-word [ 1quotation "predicate" set-word-prop ] [ swap "predicating" set-word-prop ] [ drop t "class" set-word-prop ] diff --git a/core/classes/parser/parser.factor b/core/classes/parser/parser.factor index 0697537d12..8233d8cff3 100644 --- a/core/classes/parser/parser.factor +++ b/core/classes/parser/parser.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser vocabs.parser words kernel classes compiler.units lexer ; IN: classes.parser @@ -9,7 +9,7 @@ IN: classes.parser : create-class-in ( string -- word ) current-vocab create dup save-class-location - dup predicate-word dup set-word save-location ; + dup create-predicate-word dup set-word save-location ; : CREATE-CLASS ( -- word ) scan create-class-in ; From f031a970843cbde66829271b5843d94c36ca8115 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Jan 2010 10:25:53 +1300 Subject: [PATCH 18/33] Work in progress: record constant-folds of predicate words, and call-next-method invocations, in the same way that method inlining are recorded, for greater recompilation accuracy --- basis/compiler/tests/redefine10.factor | 58 +++++++++++++++++-- basis/compiler/tests/redefine19.factor | 23 ++++++++ basis/compiler/tests/redefine20.factor | 23 ++++++++ basis/compiler/tree/cleanup/cleanup.factor | 18 ++++-- .../dependencies/dependencies.factor | 8 +-- .../transforms/transforms.factor | 2 +- core/compiler/units/units.factor | 8 ++- 7 files changed, 123 insertions(+), 17 deletions(-) create mode 100644 basis/compiler/tests/redefine19.factor create mode 100644 basis/compiler/tests/redefine20.factor diff --git a/basis/compiler/tests/redefine10.factor b/basis/compiler/tests/redefine10.factor index 768b926389..e8d9a22e97 100644 --- a/basis/compiler/tests/redefine10.factor +++ b/basis/compiler/tests/redefine10.factor @@ -1,19 +1,39 @@ -USING: eval tools.test compiler.units vocabs words kernel ; +USING: eval tools.test compiler.units vocabs words kernel +definitions sequences ; IN: compiler.tests.redefine10 -! Mixin redefinition did not recompile all necessary words. - -[ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test +! Mixin redefinition should update predicate call sites [ ] [ "USING: kernel math classes ; IN: compiler.tests.redefine10 MIXIN: my-mixin INSTANCE: fixnum my-mixin - : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;" + : my-inline-1 ( a -- b ) dup my-mixin instance? [ 1 + ] when ; + : my-inline-2 ( a -- b ) dup my-mixin? [ 1 + ] when ; + : my-inline-3 ( a -- b ) dup my-mixin? [ float? ] [ drop f ] if ; + : my-inline-4 ( a -- b ) dup float? [ my-mixin? ] [ drop f ] if ; + : my-inline-5 ( a -- b ) dup my-mixin? [ fixnum? ] [ drop f ] if ; + : my-inline-6 ( a -- b ) dup fixnum? [ my-mixin? ] [ drop f ] if ;" eval( -- ) ] unit-test +[ f ] [ + 5 "my-inline-3" "compiler.tests.redefine10" lookup execute +] unit-test + +[ f ] [ + 5 "my-inline-4" "compiler.tests.redefine10" lookup execute +] unit-test + +[ t ] [ + 5 "my-inline-5" "compiler.tests.redefine10" lookup execute +] unit-test + +[ t ] [ + 5 "my-inline-6" "compiler.tests.redefine10" lookup execute +] unit-test + [ ] [ "USE: math IN: compiler.tests.redefine10 @@ -22,5 +42,31 @@ IN: compiler.tests.redefine10 ] unit-test [ 2.0 ] [ - 1.0 "my-inline" "compiler.tests.redefine10" lookup execute + 1.0 "my-inline-1" "compiler.tests.redefine10" lookup execute ] unit-test + +[ 2.0 ] [ + 1.0 "my-inline-2" "compiler.tests.redefine10" lookup execute +] unit-test + +[ t ] [ + 1.0 "my-inline-3" "compiler.tests.redefine10" lookup execute +] unit-test + +[ t ] [ + 1.0 "my-inline-4" "compiler.tests.redefine10" lookup execute +] unit-test + +[ f ] [ + 1.0 "my-inline-5" "compiler.tests.redefine10" lookup execute +] unit-test + +[ f ] [ + 1.0 "my-inline-6" "compiler.tests.redefine10" lookup execute +] unit-test + +[ + { + "my-mixin" "my-inline-1" "my-inline-2" + } [ "compiler.tests.redefine10" lookup forget ] each +] with-compilation-unit diff --git a/basis/compiler/tests/redefine19.factor b/basis/compiler/tests/redefine19.factor new file mode 100644 index 0000000000..c9f741b5c5 --- /dev/null +++ b/basis/compiler/tests/redefine19.factor @@ -0,0 +1,23 @@ +USING: kernel classes.mixin compiler.units tools.test generic ; +IN: compiler.tests.redefine19 + +GENERIC: g ( a -- b ) + +MIXIN: m1 M: m1 g drop 1 ; +MIXIN: m2 M: m2 g drop 2 ; + +TUPLE: c ; + +INSTANCE: c m2 + +: foo ( -- b ) c new g ; + +[ 2 ] [ foo ] unit-test + +[ ] [ [ c m1 add-mixin-instance ] with-compilation-unit ] unit-test + +[ { m2 m1 } ] [ \ g order ] unit-test + +[ 1 ] [ foo ] unit-test + +[ ] [ [ c m1 remove-mixin-instance ] with-compilation-unit ] unit-test diff --git a/basis/compiler/tests/redefine20.factor b/basis/compiler/tests/redefine20.factor new file mode 100644 index 0000000000..43045e26e9 --- /dev/null +++ b/basis/compiler/tests/redefine20.factor @@ -0,0 +1,23 @@ +IN: compiler.tests.redefine20 +USING: kernel sequences compiler.units definitions classes.mixin +tools.test ; + +GENERIC: cnm-recompile-test ( a -- b ) + +M: object cnm-recompile-test drop object ; + +M: sequence cnm-recompile-test drop sequence ; + +TUPLE: funny ; + +M: funny cnm-recompile-test call-next-method ; + +[ object ] [ funny new cnm-recompile-test ] unit-test + +[ ] [ [ funny sequence add-mixin-instance ] with-compilation-unit ] unit-test + +[ sequence ] [ funny new cnm-recompile-test ] unit-test + +[ ] [ [ funny sequence remove-mixin-instance ] with-compilation-unit ] unit-test + +[ object ] [ funny new cnm-recompile-test ] unit-test diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index ec819d0eac..a2481a84e3 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -36,24 +36,34 @@ GENERIC: cleanup* ( node -- node/nodes ) #! do it since the logic is a bit more involved [ cleanup* ] map-flat ; +! Constant folding : cleanup-folding? ( #call -- ? ) node-output-infos [ f ] [ [ literal?>> ] all? ] if-empty ; -: cleanup-folding ( #call -- nodes ) +: (cleanup-folding) ( #call -- nodes ) #! Replace a #call having a known result with a #drop of its #! inputs followed by #push nodes for the outputs. - [ word>> inlined-dependency depends-on ] [ [ node-output-infos ] [ out-d>> ] bi [ [ literal>> ] dip #push ] 2map ] [ in-d>> #drop ] - tri prefix ; + bi prefix ; +: record-folding ( #call -- ) + dup word>> predicate? + [ [ node-input-infos first class>> ] [ word>> ] bi depends-on-generic ] + [ word>> inlined-dependency depends-on ] + if ; + +: cleanup-folding ( #call -- nodes ) + [ (cleanup-folding) ] [ record-folding ] bi ; + +! Method inlining : add-method-dependency ( #call -- ) dup method>> word? [ - [ word>> ] [ class>> ] bi depends-on-generic + [ class>> ] [ word>> ] bi depends-on-generic ] [ drop ] if ; : cleanup-inlining ( #call -- nodes ) diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index f0c77b8398..d3cda71478 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -29,9 +29,9 @@ SYMBOLS: inlined-dependency flushed-dependency called-dependency ; ! Generic words that the current quotation depends on SYMBOL: generic-dependencies -: ?class-or ( class/f class -- class' ) - swap [ class-or ] when* ; +: ?class-or ( class class/f -- class' ) + [ class-or ] when* ; -: depends-on-generic ( generic class -- ) +: depends-on-generic ( class generic -- ) generic-dependencies get dup - [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ; + [ [ ?class-or ] change-at ] [ 3drop ] if ; diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 3fdf29b85e..853bf3911c 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -128,7 +128,7 @@ IN: stack-checker.transforms [ [ "method-class" word-prop ] [ "method-generic" word-prop ] bi - [ inlined-dependency depends-on ] bi@ + depends-on-generic ] [ [ next-method-quot ] [ '[ _ no-next-method ] ] bi or diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 3d0cd7bb97..b2926dfb4d 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -45,13 +45,17 @@ SYMBOL: compiler-impl HOOK: update-call-sites compiler-impl ( class generic -- words ) +: changed-call-sites ( class generic -- ) + update-call-sites [ changed-definition ] each ; + M: generic update-generic ( class generic -- ) - [ update-call-sites [ changed-definition ] each ] + [ changed-call-sites ] [ remake-generic drop ] 2bi ; M: sequence update-methods ( class seq -- ) - implementors [ update-generic ] with each ; + [ [ predicate-word changed-call-sites ] with each ] + [ implementors [ update-generic ] with each ] 2bi ; HOOK: recompile compiler-impl ( words -- alist ) From ab428fc2597d4eb5073bba48eb3e4eb8cd88c5cf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Jan 2010 12:06:28 +1300 Subject: [PATCH 19/33] Code cleanups --- basis/compiler/crossref/crossref.factor | 8 +- basis/compiler/tests/redefine10.factor | 123 ++++++++++++--------- basis/compiler/tree/builder/builder.factor | 22 ++-- basis/hints/hints.factor | 7 +- 4 files changed, 81 insertions(+), 79 deletions(-) diff --git a/basis/compiler/crossref/crossref.factor b/basis/compiler/crossref/crossref.factor index e216a1f147..bd6e25999a 100644 --- a/basis/compiler/crossref/crossref.factor +++ b/basis/compiler/crossref/crossref.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs classes.algebra compiler.units definitions graphs -grouping kernel namespaces sequences words +grouping kernel namespaces sequences words fry stack-checker.dependencies ; IN: compiler.crossref @@ -23,7 +23,7 @@ compiled-generic-crossref [ H{ } clone ] initialize #! don't have to recompile words that folded this away. [ compiled-usage ] [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi - [ dependency>= nip ] curry assoc-filter ; + '[ nip _ dependency>= ] assoc-filter ; : compiled-usages ( seq -- assocs ) [ drop word? ] assoc-filter @@ -42,8 +42,8 @@ compiled-generic-crossref [ H{ } clone ] initialize bi-curry* bi ; : (compiled-unxref) ( word word-prop variable -- ) - [ [ [ dupd word-prop 2 ] dip get remove-vertex* ] 2curry ] - [ drop [ remove-word-prop ] curry ] + [ '[ dup _ word-prop 2 _ get remove-vertex* ] ] + [ drop '[ _ remove-word-prop ] ] 2bi bi ; : compiled-unxref ( word -- ) diff --git a/basis/compiler/tests/redefine10.factor b/basis/compiler/tests/redefine10.factor index e8d9a22e97..c23ce8cd8b 100644 --- a/basis/compiler/tests/redefine10.factor +++ b/basis/compiler/tests/redefine10.factor @@ -1,72 +1,85 @@ USING: eval tools.test compiler.units vocabs words kernel -definitions sequences ; +definitions sequences math classes classes.mixin kernel.private ; IN: compiler.tests.redefine10 ! Mixin redefinition should update predicate call sites -[ ] [ - "USING: kernel math classes ; - IN: compiler.tests.redefine10 - MIXIN: my-mixin - INSTANCE: fixnum my-mixin - : my-inline-1 ( a -- b ) dup my-mixin instance? [ 1 + ] when ; - : my-inline-2 ( a -- b ) dup my-mixin? [ 1 + ] when ; - : my-inline-3 ( a -- b ) dup my-mixin? [ float? ] [ drop f ] if ; - : my-inline-4 ( a -- b ) dup float? [ my-mixin? ] [ drop f ] if ; - : my-inline-5 ( a -- b ) dup my-mixin? [ fixnum? ] [ drop f ] if ; - : my-inline-6 ( a -- b ) dup fixnum? [ my-mixin? ] [ drop f ] if ;" - eval( -- ) -] unit-test +MIXIN: my-mixin +INSTANCE: fixnum my-mixin +: my-inline-1 ( a -- b ) dup my-mixin instance? [ 1 + ] when ; +: my-inline-2 ( a -- b ) dup my-mixin? [ 1 + ] when ; +: my-inline-3 ( a -- b ) dup my-mixin? [ float? ] [ drop f ] if ; +: my-inline-4 ( a -- b ) dup float? [ my-mixin? ] [ drop f ] if ; +: my-inline-5 ( a -- b ) dup my-mixin? [ fixnum? ] [ drop f ] if ; +: my-inline-6 ( a -- b ) dup fixnum? [ my-mixin? ] [ drop f ] if ; -[ f ] [ - 5 "my-inline-3" "compiler.tests.redefine10" lookup execute -] unit-test +GENERIC: fake-float? ( obj -- ? ) -[ f ] [ - 5 "my-inline-4" "compiler.tests.redefine10" lookup execute -] unit-test +M: float fake-float? drop t ; +M: object fake-float? drop f ; -[ t ] [ - 5 "my-inline-5" "compiler.tests.redefine10" lookup execute -] unit-test +: my-fake-inline-3 ( a -- b ) dup my-mixin? [ fake-float? ] [ drop f ] if ; -[ t ] [ - 5 "my-inline-6" "compiler.tests.redefine10" lookup execute -] unit-test +: my-baked-inline-3 ( a -- b ) { my-mixin } declare fake-float? ; -[ ] [ - "USE: math - IN: compiler.tests.redefine10 - INSTANCE: float my-mixin" - eval( -- ) -] unit-test +[ f ] [ 5 my-inline-3 ] unit-test -[ 2.0 ] [ - 1.0 "my-inline-1" "compiler.tests.redefine10" lookup execute -] unit-test +[ f ] [ 5 my-fake-inline-3 ] unit-test -[ 2.0 ] [ - 1.0 "my-inline-2" "compiler.tests.redefine10" lookup execute -] unit-test +[ f ] [ 5 my-baked-inline-3 ] unit-test -[ t ] [ - 1.0 "my-inline-3" "compiler.tests.redefine10" lookup execute -] unit-test +[ f ] [ 5 my-inline-4 ] unit-test -[ t ] [ - 1.0 "my-inline-4" "compiler.tests.redefine10" lookup execute -] unit-test +[ t ] [ 5 my-inline-5 ] unit-test -[ f ] [ - 1.0 "my-inline-5" "compiler.tests.redefine10" lookup execute -] unit-test +[ t ] [ 5 my-inline-6 ] unit-test -[ f ] [ - 1.0 "my-inline-6" "compiler.tests.redefine10" lookup execute -] unit-test +[ ] [ [ float my-mixin add-mixin-instance ] with-compilation-unit ] unit-test -[ - { - "my-mixin" "my-inline-1" "my-inline-2" - } [ "compiler.tests.redefine10" lookup forget ] each -] with-compilation-unit +[ 2.0 ] [ 1.0 my-inline-1 ] unit-test + +[ 2.0 ] [ 1.0 my-inline-2 ] unit-test + +[ t ] [ 1.0 my-inline-3 ] unit-test + +[ t ] [ 1.0 my-fake-inline-3 ] unit-test + +[ t ] [ 1.0 my-baked-inline-3 ] unit-test + +[ t ] [ 1.0 my-inline-4 ] unit-test + +[ f ] [ 1.0 my-inline-5 ] unit-test + +[ f ] [ 1.0 my-inline-6 ] unit-test + +[ ] [ [ fixnum my-mixin remove-mixin-instance ] with-compilation-unit ] unit-test + +[ f ] [ 5 my-inline-3 ] unit-test + +[ f ] [ 5 my-fake-inline-3 ] unit-test + +[ f ] [ 5 my-baked-inline-3 ] unit-test + +[ f ] [ 5 my-inline-4 ] unit-test + +[ f ] [ 5 my-inline-5 ] unit-test + +[ f ] [ 5 my-inline-6 ] unit-test + +[ ] [ [ float my-mixin remove-mixin-instance ] with-compilation-unit ] unit-test + +[ 1.0 ] [ 1.0 my-inline-1 ] unit-test + +[ 1.0 ] [ 1.0 my-inline-2 ] unit-test + +[ f ] [ 1.0 my-inline-3 ] unit-test + +[ f ] [ 1.0 my-fake-inline-3 ] unit-test + +[ f ] [ 1.0 my-baked-inline-3 ] unit-test + +[ f ] [ 1.0 my-inline-4 ] unit-test + +[ f ] [ 1.0 my-inline-5 ] unit-test + +[ f ] [ 1.0 my-inline-6 ] unit-test diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 8eb66fde1f..024a7bacca 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -50,17 +50,11 @@ PRIVATE> [ f ] dip build-tree-with ; :: build-sub-tree ( in-d out-d word/quot -- nodes/f ) - #! We don't want methods on mixins to have a declaration for that mixin. - #! This slows down compiler.tree.propagation.inlining since then every - #! inlined usage of a method has an inline-dependency on the mixin, and - #! not the more specific type at the call site. - f specialize-method? [ - [ - in-d word/quot build-tree-with unclip-last in-d>> :> in-d' - { - { [ dup not ] [ ] } - { [ dup ends-with-terminate? ] [ out-d [ f swap #push ] map append ] } - [ in-d' out-d [ [ length ] bi@ assert= ] [ #copy suffix ] 2bi ] - } cond - ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover - ] with-variable ; \ No newline at end of file + [ + in-d word/quot build-tree-with unclip-last in-d>> :> in-d' + { + { [ dup not ] [ ] } + { [ dup ends-with-terminate? ] [ out-d [ f swap #push ] map append ] } + [ in-d' out-d [ [ length ] bi@ assert= ] [ #copy suffix ] 2bi ] + } cond + ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ; \ No newline at end of file diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index e4bbb3459e..7a3fa323d2 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -41,18 +41,13 @@ M: object specializer-declaration class ; : specialize-quot ( quot specializer -- quot' ) [ drop ] [ specializer-cases ] 2bi alist>quot ; -! compiler.tree.propagation.inlining sets this to f -SYMBOL: specialize-method? - -t specialize-method? set-global - : method-declaration ( method -- quot ) [ "method-generic" word-prop dispatch# object ] [ "method-class" word-prop ] bi prefix [ declare ] curry [ ] like ; : specialize-method ( quot method -- quot' ) - [ specialize-method? get [ method-declaration prepend ] [ drop ] if ] + [ method-declaration prepend ] [ "method-generic" word-prop ] bi specializer [ specialize-quot ] when* ; From 29fc287618cc786888bacac5996f78ccb9b59f27 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 28 Jan 2010 00:46:40 +1300 Subject: [PATCH 20/33] classes.tuple: documentation fix --- core/classes/tuple/tuple-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 48b95bec48..e57b3deafc 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -200,10 +200,10 @@ ARTICLE: "tuple-introspection" "Tuple introspection" tuple>array tuple-slots } -"Tuple classes can also be defined at run time:" -{ $subsections define-tuple-class } "Tuples can be compared for slot equality even if the tuple class overrides " { $link equal? } ":" { $subsections tuple= } +"Tuple classes can also be defined at run time:" +{ $subsections define-tuple-class } { $see-also "slots" "mirrors" } ; ARTICLE: "tuple-examples" "Tuple examples" From 817bc02392dd2e3f7e6fdfbc6e35475a52e0edeb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 29 Jan 2010 20:15:19 +1300 Subject: [PATCH 21/33] compiler.tree.propagation.call-effect: clear out dependency tracking variables to ensure that infer calls made by call( as part of the compile process doesn't pollute the dependencies of the word being compiled --- .../tree/propagation/call-effect/call-effect.factor | 13 +++++++++---- .../stack-checker/dependencies/dependencies.factor | 7 +++++++ 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor index 04320ee792..0feeb211a0 100644 --- a/basis/compiler/tree/propagation/call-effect/call-effect.factor +++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor @@ -2,14 +2,19 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators combinators.private effects fry kernel kernel.private make sequences continuations -quotations words math stack-checker combinators.short-circuit -stack-checker.transforms compiler.tree.propagation.info +quotations words math stack-checker stack-checker.dependencies +combinators.short-circuit stack-checker.transforms +compiler.tree.propagation.info compiler.tree.propagation.inlining compiler.units ; IN: compiler.tree.propagation.call-effect ! call( and execute( have complex expansions. -! call( uses the following strategy: +! If the input quotation is a literal, or built up from curry and +! compose with terminal quotations literal, it is inlined at the +! call site. + +! For dynamic call sites, call( uses the following strategy: ! - Inline caching. If the quotation is the same as last time, just call it unsafely ! - Effect inference. Infer quotation's effect, caching it in the cached-effect slot, ! and compare it with declaration. If matches, call it unsafely. @@ -58,7 +63,7 @@ M: compose cached-effect [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ; : safe-infer ( quot -- effect ) - [ infer ] [ 2drop +unknown+ ] recover ; + [ [ infer ] [ 2drop +unknown+ ] recover ] without-dependencies ; : cached-effect-valid? ( quot -- ? ) cache-counter>> effect-counter eq? ; inline diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index d3cda71478..74cc5f32d4 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -35,3 +35,10 @@ SYMBOL: generic-dependencies : depends-on-generic ( class generic -- ) generic-dependencies get dup [ [ ?class-or ] change-at ] [ 3drop ] if ; + +: without-dependencies ( quot -- ) + [ + dependencies off + generic-dependencies off + call + ] with-scope ; inline From c02704685721f3f35ef3a56afe59cba79622a273 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 29 Jan 2010 21:40:09 +1300 Subject: [PATCH 22/33] New 'conditional dependency' mechanism for more accurate recording of recompilation information --- basis/compiler/compiler.factor | 15 +++--- basis/compiler/crossref/crossref.factor | 23 +++++++-- basis/compiler/tests/redefine10.factor | 2 - basis/compiler/tree/cleanup/cleanup.factor | 25 +++++++--- .../tree/dead-code/simple/simple.factor | 8 --- .../known-words/known-words.factor | 2 +- .../tree/propagation/simple/simple.factor | 7 +-- .../propagation/transforms/transforms.factor | 2 +- .../dependencies/dependencies.factor | 49 +++++++++++++++++-- .../transforms/transforms.factor | 2 +- basis/tools/deploy/shaker/shaker.factor | 3 +- core/classes/classes.factor | 2 + core/classes/mixin/mixin.factor | 13 +++-- core/classes/tuple/tuple.factor | 2 +- core/classes/union/union.factor | 2 +- core/compiler/units/units.factor | 3 ++ core/definitions/definitions.factor | 5 ++ core/generic/generic.factor | 3 ++ core/words/words.factor | 4 ++ 19 files changed, 122 insertions(+), 50 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 7fc171859c..90197b207c 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -49,8 +49,7 @@ SYMBOL: compiled : start ( word -- ) dup name>> compiler-message - H{ } clone dependencies set - H{ } clone generic-dependencies set + init-dependencies clear-compiler-error ; GENERIC: no-compile? ( word -- ? ) @@ -86,15 +85,15 @@ M: word combinator? inline? ; [ compiled-unxref ] [ dup crossref? [ - dependencies get - generic-dependencies get - compiled-xref + [ dependencies get generic-dependencies get compiled-xref ] + [ conditional-dependencies get save-conditional-dependencies ] + bi ] [ drop ] if ] tri ; : deoptimize-with ( word def -- * ) #! If the word failed to infer, compile it with the - #! non-optimizing compiler. + #! non-optimizing compiler. swap [ finish ] [ compiled get set-at ] bi return ; : not-compiled-def ( word error -- def ) @@ -203,7 +202,9 @@ M: optimizing-compiler recompile ( words -- alist ) "--- compile done" compiler-message ; M: optimizing-compiler to-recompile ( -- words ) - changed-definitions get compiled-usages assoc-combine keys ; + changed-definitions get compiled-usages + changed-classes get outdated-class-usages + append assoc-combine keys ; M: optimizing-compiler process-forgotten-words [ delete-compiled-xref ] each ; diff --git a/basis/compiler/crossref/crossref.factor b/basis/compiler/crossref/crossref.factor index bd6e25999a..b7a48a9d51 100644 --- a/basis/compiler/crossref/crossref.factor +++ b/basis/compiler/crossref/crossref.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs classes.algebra compiler.units definitions graphs -grouping kernel namespaces sequences words fry +USING: arrays assocs classes.algebra compiler.units definitions +graphs grouping kernel namespaces sequences words fry stack-checker.dependencies ; IN: compiler.crossref @@ -25,10 +25,21 @@ compiled-generic-crossref [ H{ } clone ] initialize [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi '[ nip _ dependency>= ] assoc-filter ; -: compiled-usages ( seq -- assocs ) +: compiled-usages ( assoc -- assocs ) [ drop word? ] assoc-filter [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ; +: dependencies-satisfied? ( word -- ? ) + "conditional-dependencies" word-prop [ satisfied? ] all? ; + +: outdated-class-usages ( assoc -- assocs ) + [ + drop + compiled-usage + [ nip class-dependency dependency>= ] assoc-filter + [ drop dependencies-satisfied? not ] assoc-filter + ] { } assoc>map ; + : compiled-generic-usage ( word -- assoc ) compiled-generic-crossref get at ; @@ -49,10 +60,14 @@ compiled-generic-crossref [ H{ } clone ] initialize : compiled-unxref ( word -- ) [ "compiled-uses" compiled-crossref (compiled-unxref) ] [ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ] - bi ; + [ f "conditional-dependencies" set-word-prop ] + tri ; : delete-compiled-xref ( word -- ) [ compiled-unxref ] [ compiled-crossref get delete-at ] [ compiled-generic-crossref get delete-at ] tri ; + +: save-conditional-dependencies ( word deps -- ) + >array f like "conditional-dependencies" set-word-prop ; diff --git a/basis/compiler/tests/redefine10.factor b/basis/compiler/tests/redefine10.factor index c23ce8cd8b..c9e1dc9af8 100644 --- a/basis/compiler/tests/redefine10.factor +++ b/basis/compiler/tests/redefine10.factor @@ -76,8 +76,6 @@ M: object fake-float? drop f ; [ f ] [ 1.0 my-fake-inline-3 ] unit-test -[ f ] [ 1.0 my-baked-inline-3 ] unit-test - [ f ] [ 1.0 my-inline-4 ] unit-test [ f ] [ 1.0 my-inline-5 ] unit-test diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index a2481a84e3..74353df483 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences combinators fry classes.algebra namespaces assocs words math math.private @@ -51,9 +51,15 @@ GENERIC: cleanup* ( node -- node/nodes ) [ in-d>> #drop ] bi prefix ; +: record-predicate-folding ( #call -- ) + [ node-input-infos first class>> ] + [ word>> "predicating" word-prop ] + [ node-output-infos first literal>> ] tri + [ depends-on-class<= ] [ depends-on-classes-disjoint ] if ; + : record-folding ( #call -- ) dup word>> predicate? - [ [ node-input-infos first class>> ] [ word>> ] bi depends-on-generic ] + [ record-predicate-folding ] [ word>> inlined-dependency depends-on ] if ; @@ -63,15 +69,18 @@ GENERIC: cleanup* ( node -- node/nodes ) ! Method inlining : add-method-dependency ( #call -- ) dup method>> word? [ - [ class>> ] [ word>> ] bi depends-on-generic + [ [ class>> ] [ word>> ] bi depends-on-generic ] + [ [ class>> ] [ word>> ] [ method>> ] tri depends-on-method ] + bi ] [ drop ] if ; +: record-inlining ( #call -- ) + dup method>> + [ add-method-dependency ] + [ word>> inlined-dependency depends-on ] if ; + : cleanup-inlining ( #call -- nodes ) - [ - dup method>> - [ add-method-dependency ] - [ word>> inlined-dependency depends-on ] if - ] [ body>> cleanup ] bi ; + [ record-inlining ] [ body>> cleanup ] bi ; ! Removing overflow checks : (remove-overflow-check?) ( #call -- ? ) diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor index 77523568d7..0856920679 100644 --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/basis/compiler/tree/dead-code/simple/simple.factor @@ -9,14 +9,6 @@ compiler.tree.propagation.info compiler.tree.dead-code.liveness ; IN: compiler.tree.dead-code.simple -GENERIC: flushable? ( word -- ? ) - -M: predicate flushable? drop t ; - -M: word flushable? "flushable" word-prop ; - -M: method-body flushable? "method-generic" word-prop flushable? ; - : flushable-call? ( #call -- ? ) dup word>> dup flushable? [ "input-classes" word-prop dup [ diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 6aacbc57da..2a84d41f3c 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -318,7 +318,7 @@ generic-comparison-ops [ dup literal>> class? [ literal>> - [ inlined-dependency depends-on ] + [ class-dependency depends-on ] [ predicate-output-infos ] bi ] [ 2drop object-info ] if diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 225f10d342..8df6621dc2 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -36,7 +36,7 @@ M: #declare propagate-before #! classes mentioned in the declaration are redefined, since #! now we're making assumptions but their definitions. declaration>> [ - [ inlined-dependency depends-on ] + [ class-dependency depends-on ] [ swap refine-value-info ] bi ] assoc-each ; @@ -110,8 +110,9 @@ M: #declare propagate-before #! is redefined, since now we're making assumptions but the #! class definition itself. [ in-d>> first value-info ] - [ "predicating" word-prop dup inlined-dependency depends-on ] bi* - predicate-output-infos 1array ; + [ "predicating" word-prop ] bi* + [ nip class-dependency depends-on ] + [ predicate-output-infos 1array ] 2bi ; : default-output-value-infos ( #call word -- infos ) "default-output-classes" word-prop diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 63c0aea13e..f387b2b1df 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -163,7 +163,7 @@ ERROR: bad-partial-eval quot word ; : inline-new ( class -- quot/f ) dup tuple-class? [ - dup inlined-dependency depends-on + dup class-dependency depends-on [ all-slots [ initial>> literalize ] map ] [ tuple-layout '[ _ ] ] bi append >quotation diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index 74cc5f32d4..838a97a944 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -1,19 +1,19 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs classes.algebra fry kernel math namespaces -sequences words ; +USING: assocs accessors classes.algebra fry generic kernel math +namespaces sequences words ; IN: stack-checker.dependencies ! Words that the current quotation depends on SYMBOL: dependencies -SYMBOLS: inlined-dependency flushed-dependency called-dependency ; +SYMBOLS: inlined-dependency class-dependency flushed-dependency called-dependency ; : index>= ( obj1 obj2 seq -- ? ) [ index ] curry bi@ >= ; : dependency>= ( how1 how2 -- ? ) - { called-dependency flushed-dependency inlined-dependency } + { called-dependency class-dependency flushed-dependency inlined-dependency } index>= ; : strongest-dependency ( how1 how2 -- how ) @@ -36,6 +36,45 @@ SYMBOL: generic-dependencies generic-dependencies get dup [ [ ?class-or ] change-at ] [ 3drop ] if ; +! Conditional dependencies are re-evaluated when classes change; +! if any fail, the word is recompiled +SYMBOL: conditional-dependencies + +GENERIC: satisfied? ( dependency -- ? ) + +: conditional-dependency ( ... class -- ) + boa conditional-dependencies get + dup [ push ] [ 2drop ] if ; inline + +TUPLE: depends-on-class<= class1 class2 ; + +: depends-on-class<= ( class1 class2 -- ) + \ depends-on-class<= conditional-dependency ; + +M: depends-on-class<= satisfied? + [ class1>> ] [ class2>> ] bi class<= ; + +TUPLE: depends-on-classes-disjoint class1 class2 ; + +: depends-on-classes-disjoint ( class1 class2 -- ) + \ depends-on-classes-disjoint conditional-dependency ; + +M: depends-on-classes-disjoint satisfied? + [ class1>> ] [ class2>> ] bi classes-intersect? not ; + +TUPLE: depends-on-method class generic method ; + +: depends-on-method ( class generic method -- ) + \ depends-on-method conditional-dependency ; + +M: depends-on-method satisfied? + [ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ; + +: init-dependencies ( -- ) + H{ } clone dependencies set + H{ } clone generic-dependencies set + V{ } clone conditional-dependencies set ; + : without-dependencies ( quot -- ) [ dependencies off diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 853bf3911c..8610bbf66a 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -140,7 +140,7 @@ IN: stack-checker.transforms ! Constructors \ boa [ dup tuple-class? [ - dup inlined-dependency depends-on + dup class-dependency depends-on [ "boa-check" word-prop [ ] or ] [ tuple-layout '[ _ ] ] bi append diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index e4e11a3135..c2db471a23 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2009 Slava Pestov. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays accessors io.backend io.streams.c init fry namespaces math make assocs kernel parser parser.notes lexer @@ -128,6 +128,7 @@ IN: tools.deploy.shaker "combination" "compiled-generic-uses" "compiled-uses" + "conditional-dependencies" "constant" "constraints" "custom-inlining" diff --git a/core/classes/classes.factor b/core/classes/classes.factor index e4301f6bae..34e65e54db 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -45,6 +45,8 @@ PREDICATE: class < word "class" word-prop ; PREDICATE: predicate < word "predicating" word-prop >boolean ; +M: predicate flushable? drop t ; + M: predicate forget* [ call-next-method ] [ f "predicating" set-word-prop ] bi ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 44e66dd79c..16e4ff124e 100644 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -28,8 +28,9 @@ TUPLE: check-mixin-class class ; : redefine-mixin-class ( class members -- ) [ (define-union-class) ] + [ drop changed-class ] [ drop t "mixin" set-word-prop ] - 2bi ; + 2tri ; : if-mixin-member? ( class mixin true false -- ) [ check-mixin-class 2dup members member-eq? ] 2dip if ; inline @@ -80,12 +81,10 @@ M: mixin-class class-forgotten remove-mixin-instance ; dup mixin-class? [ drop ] [ - { - [ { } redefine-mixin-class ] - [ H{ } clone "instances" set-word-prop ] - [ changed-definition ] - [ update-classes ] - } cleave + [ { } redefine-mixin-class ] + [ H{ } clone "instances" set-word-prop ] + [ update-classes ] + tri ] if ; ! Definition protocol implementation ensures that removing an diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index d5ae145203..12d90e036b 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -223,7 +223,7 @@ M: tuple-class update-class 2drop [ [ update-tuples-after ] - [ changed-definition ] + [ changed-class ] bi ] each-subclass ] diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 94013c32d9..44a1c22774 100644 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -32,7 +32,7 @@ PRIVATE> : define-union-class ( class members -- ) [ (define-union-class) ] - [ drop changed-definition ] + [ drop changed-class ] [ drop update-classes ] 2tri ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index b2926dfb4d..40cb235e8a 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -124,6 +124,7 @@ M: object bump-effect-counter* drop f ; dup new-definitions get first update dup new-definitions get second update dup changed-definitions get update + dup changed-classes get update dup dup changed-vocabs update ; : process-forgotten-definitions ( -- ) @@ -164,6 +165,7 @@ PRIVATE> : with-nested-compilation-unit ( quot -- ) [ H{ } clone changed-definitions set + H{ } clone changed-classes set H{ } clone changed-effects set H{ } clone outdated-generics set H{ } clone outdated-tuples set @@ -174,6 +176,7 @@ PRIVATE> : with-compilation-unit ( quot -- ) [ H{ } clone changed-definitions set + H{ } clone changed-classes set H{ } clone changed-effects set H{ } clone outdated-generics set H{ } clone forgotten-definitions set diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 71d6797abd..7110e27e04 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -15,6 +15,11 @@ SYMBOL: changed-definitions : changed-definition ( defspec -- ) dup changed-definitions get set-in-unit ; +SYMBOL: changed-classes + +: changed-class ( class -- ) + dup changed-classes get set-in-unit ; + SYMBOL: changed-effects SYMBOL: outdated-generics diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 517ccd4775..62ff40acfc 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -104,6 +104,9 @@ GENERIC: update-generic ( class generic -- ) PREDICATE: method-body < word "method-generic" word-prop >boolean ; +M: method-body flushable? + "method-generic" word-prop flushable? ; + M: method-body stack-effect "method-generic" word-prop stack-effect ; diff --git a/core/words/words.factor b/core/words/words.factor index cd1b4f4455..106cca29fa 100644 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -182,6 +182,10 @@ M: parsing-word definer drop \ SYNTAX: \ ; ; : deprecated? ( obj -- ? ) dup word? [ "deprecated" word-prop ] [ drop f ] if ; +GENERIC: flushable? ( word -- ? ) + +M: word flushable? "flushable" word-prop ; + ! Definition protocol M: word where "loc" word-prop ; From 26f311279cf42f955b7f6e1061c842ba603b05f6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 29 Jan 2010 21:53:14 +1300 Subject: [PATCH 23/33] Re-defining a tuple class now invalidates cached quotation stack effects --- basis/compiler/crossref/crossref.factor | 2 +- .../call-effect/call-effect-tests.factor | 13 +++++++++++++ .../propagation/known-words/known-words.factor | 2 +- .../compiler/tree/propagation/simple/simple.factor | 4 ++-- .../tree/propagation/transforms/transforms.factor | 2 +- .../stack-checker/dependencies/dependencies.factor | 12 ++++++------ basis/stack-checker/transforms/transforms.factor | 2 +- core/compiler/units/units.factor | 14 +++++++------- 8 files changed, 32 insertions(+), 19 deletions(-) diff --git a/basis/compiler/crossref/crossref.factor b/basis/compiler/crossref/crossref.factor index b7a48a9d51..72e2c07c34 100644 --- a/basis/compiler/crossref/crossref.factor +++ b/basis/compiler/crossref/crossref.factor @@ -36,7 +36,7 @@ compiled-generic-crossref [ H{ } clone ] initialize [ drop compiled-usage - [ nip class-dependency dependency>= ] assoc-filter + [ nip conditional-dependency dependency>= ] assoc-filter [ drop dependencies-satisfied? not ] assoc-filter ] { } assoc>map ; diff --git a/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor b/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor index 4a543fb87a..4b524fd0d4 100644 --- a/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor +++ b/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor @@ -79,3 +79,16 @@ TUPLE: a-tuple x ; [ ] [ "IN: compiler.tree.propagation.call-effect.tests USE: math : call(-redefine-test ( a -- c ) 1 + ;" eval( -- ) ] unit-test [ 1 3 test-quotatation inline-cache-invalidation-test ] [ T{ wrong-values f (( a b -- c )) } = ] must-fail-with + +! See if redefining a tuple class bumps effect counter +TUPLE: my-tuple a b c ; + +: my-quot ( -- quot ) [ my-tuple boa ] ; + +: my-word ( a b c q -- result ) call( a b c -- result ) ; + +[ T{ my-tuple f 1 2 3 } ] [ 1 2 3 my-quot my-word ] unit-test + +[ ] [ "IN: compiler.tree.propagation.call-effect.tests TUPLE: my-tuple a b ;" eval( -- ) ] unit-test + +[ 1 2 3 my-quot my-word ] [ wrong-values? ] must-fail-with diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 2a84d41f3c..252c5d892b 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -318,7 +318,7 @@ generic-comparison-ops [ dup literal>> class? [ literal>> - [ class-dependency depends-on ] + [ conditional-dependency depends-on ] [ predicate-output-infos ] bi ] [ 2drop object-info ] if diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 8df6621dc2..da973e785c 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -36,7 +36,7 @@ M: #declare propagate-before #! classes mentioned in the declaration are redefined, since #! now we're making assumptions but their definitions. declaration>> [ - [ class-dependency depends-on ] + [ conditional-dependency depends-on ] [ swap refine-value-info ] bi ] assoc-each ; @@ -111,7 +111,7 @@ M: #declare propagate-before #! class definition itself. [ in-d>> first value-info ] [ "predicating" word-prop ] bi* - [ nip class-dependency depends-on ] + [ nip conditional-dependency depends-on ] [ predicate-output-infos 1array ] 2bi ; : default-output-value-infos ( #call word -- infos ) diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index f387b2b1df..414c553290 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -163,7 +163,7 @@ ERROR: bad-partial-eval quot word ; : inline-new ( class -- quot/f ) dup tuple-class? [ - dup class-dependency depends-on + dup conditional-dependency depends-on [ all-slots [ initial>> literalize ] map ] [ tuple-layout '[ _ ] ] bi append >quotation diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index 838a97a944..97c151ac9d 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -7,13 +7,13 @@ IN: stack-checker.dependencies ! Words that the current quotation depends on SYMBOL: dependencies -SYMBOLS: inlined-dependency class-dependency flushed-dependency called-dependency ; +SYMBOLS: inlined-dependency conditional-dependency flushed-dependency called-dependency ; : index>= ( obj1 obj2 seq -- ? ) [ index ] curry bi@ >= ; : dependency>= ( how1 how2 -- ? ) - { called-dependency class-dependency flushed-dependency inlined-dependency } + { called-dependency conditional-dependency flushed-dependency inlined-dependency } index>= ; : strongest-dependency ( how1 how2 -- how ) @@ -42,14 +42,14 @@ SYMBOL: conditional-dependencies GENERIC: satisfied? ( dependency -- ? ) -: conditional-dependency ( ... class -- ) +: add-conditional-dependency ( ... class -- ) boa conditional-dependencies get dup [ push ] [ 2drop ] if ; inline TUPLE: depends-on-class<= class1 class2 ; : depends-on-class<= ( class1 class2 -- ) - \ depends-on-class<= conditional-dependency ; + \ depends-on-class<= add-conditional-dependency ; M: depends-on-class<= satisfied? [ class1>> ] [ class2>> ] bi class<= ; @@ -57,7 +57,7 @@ M: depends-on-class<= satisfied? TUPLE: depends-on-classes-disjoint class1 class2 ; : depends-on-classes-disjoint ( class1 class2 -- ) - \ depends-on-classes-disjoint conditional-dependency ; + \ depends-on-classes-disjoint add-conditional-dependency ; M: depends-on-classes-disjoint satisfied? [ class1>> ] [ class2>> ] bi classes-intersect? not ; @@ -65,7 +65,7 @@ M: depends-on-classes-disjoint satisfied? TUPLE: depends-on-method class generic method ; : depends-on-method ( class generic method -- ) - \ depends-on-method conditional-dependency ; + \ depends-on-method add-conditional-dependency ; M: depends-on-method satisfied? [ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ; diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 8610bbf66a..5426ac9e19 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -140,7 +140,7 @@ IN: stack-checker.transforms ! Constructors \ boa [ dup tuple-class? [ - dup class-dependency depends-on + dup conditional-dependency depends-on [ "boa-check" word-prop [ ] or ] [ tuple-layout '[ _ ] ] bi append diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 40cb235e8a..21ab578ccc 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -54,8 +54,7 @@ M: generic update-generic ( class generic -- ) 2bi ; M: sequence update-methods ( class seq -- ) - [ [ predicate-word changed-call-sites ] with each ] - [ implementors [ update-generic ] with each ] 2bi ; + implementors [ update-generic ] with each ; HOOK: recompile compiler-impl ( words -- alist ) @@ -108,9 +107,9 @@ GENERIC: definitions-changed ( assoc obj -- ) ! inline caching : effect-counter ( -- n ) 47 special-object ; inline -GENERIC: bump-effect-counter* ( defspec -- ? ) +GENERIC: always-bump-effect-counter? ( defspec -- ? ) -M: object bump-effect-counter* drop f ; +M: object always-bump-effect-counter? drop f ; Date: Fri, 29 Jan 2010 22:29:55 +1300 Subject: [PATCH 24/33] Add some utility words to stack-checker.dependencies in preparation for a refactoring --- basis/compiler/compiler.factor | 6 +++--- basis/compiler/tree/cleanup/cleanup.factor | 4 ++-- .../tree/propagation/known-words/known-words.factor | 2 +- basis/compiler/tree/propagation/simple/simple.factor | 4 ++-- .../tree/propagation/transforms/transforms.factor | 4 ++-- basis/stack-checker/backend/backend.factor | 2 +- basis/stack-checker/dependencies/dependencies.factor | 9 +++++++++ basis/stack-checker/inlining/inlining.factor | 2 +- basis/stack-checker/known-words/known-words.factor | 2 +- basis/stack-checker/transforms/transforms.factor | 2 +- 10 files changed, 23 insertions(+), 14 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 90197b207c..2bdff71781 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -38,9 +38,9 @@ SYMBOL: compiled : recompile-callers? ( word -- ? ) changed-effects get key? ; -: recompile-callers ( words -- ) - #! If a word's stack effect changed, recompile all words that - #! have compiled calls to it. +: recompile-callers ( word -- ) + #! If a word's stack effect changed, recompile all words + #! that have compiled calls to it. dup recompile-callers? [ compiled-usage keys [ queue-compile ] each ] [ drop ] if ; diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index 74353df483..b19c99c360 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -60,7 +60,7 @@ GENERIC: cleanup* ( node -- node/nodes ) : record-folding ( #call -- ) dup word>> predicate? [ record-predicate-folding ] - [ word>> inlined-dependency depends-on ] + [ word>> depends-on-definition ] if ; : cleanup-folding ( #call -- nodes ) @@ -77,7 +77,7 @@ GENERIC: cleanup* ( node -- node/nodes ) : record-inlining ( #call -- ) dup method>> [ add-method-dependency ] - [ word>> inlined-dependency depends-on ] if ; + [ word>> depends-on-definition ] if ; : cleanup-inlining ( #call -- nodes ) [ record-inlining ] [ body>> cleanup ] bi ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 252c5d892b..55629507ab 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -318,7 +318,7 @@ generic-comparison-ops [ dup literal>> class? [ literal>> - [ conditional-dependency depends-on ] + [ depends-on-conditionally ] [ predicate-output-infos ] bi ] [ 2drop object-info ] if diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index da973e785c..ccfd6ffabd 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -36,7 +36,7 @@ M: #declare propagate-before #! classes mentioned in the declaration are redefined, since #! now we're making assumptions but their definitions. declaration>> [ - [ conditional-dependency depends-on ] + [ depends-on-conditionally ] [ swap refine-value-info ] bi ] assoc-each ; @@ -111,7 +111,7 @@ M: #declare propagate-before #! class definition itself. [ in-d>> first value-info ] [ "predicating" word-prop ] bi* - [ nip conditional-dependency depends-on ] + [ nip depends-on-conditionally ] [ predicate-output-infos 1array ] 2bi ; : default-output-value-infos ( #call word -- infos ) diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 414c553290..3f6a200534 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -163,7 +163,7 @@ ERROR: bad-partial-eval quot word ; : inline-new ( class -- quot/f ) dup tuple-class? [ - dup conditional-dependency depends-on + dup depends-on-conditionally [ all-slots [ initial>> literalize ] map ] [ tuple-layout '[ _ ] ] bi append >quotation @@ -293,6 +293,6 @@ CONSTANT: lookup-table-at-max 256 ! calls when a C type is redefined \ heap-size [ dup word? [ - [ inlined-dependency depends-on ] [ heap-size '[ _ ] ] bi + [ depends-on-definition ] [ heap-size '[ _ ] ] bi ] [ drop f ] if ] 1 define-partial-eval diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index b2a99f0731..8de930a6cd 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -74,7 +74,7 @@ GENERIC: apply-object ( obj -- ) M: wrapper apply-object wrapped>> - [ dup word? [ called-dependency depends-on ] [ drop ] if ] + [ dup word? [ depends-on-effect ] [ drop ] if ] [ push-literal ] bi ; diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index 97c151ac9d..004c1dd07d 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -26,6 +26,15 @@ SYMBOLS: inlined-dependency conditional-dependency flushed-dependency called-dep ] [ 3drop ] if ] if ; +: depends-on-effect ( word -- ) + called-dependency depends-on ; + +: depends-on-definition ( word -- ) + inlined-dependency depends-on ; + +: depends-on-conditionally ( word -- ) + conditional-dependency depends-on ; + ! Generic words that the current quotation depends on SYMBOL: generic-dependencies diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index 20d61b9c37..4197aa00a2 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -140,7 +140,7 @@ SYMBOL: enter-out : inline-word ( word -- ) commit-literals - [ inlined-dependency depends-on ] + [ depends-on-definition ] [ dup inline-recursive-label [ call-recursive-inline-word diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 6ac668b031..966a273f20 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -273,7 +273,7 @@ M: bad-executable summary \ clear t "no-compile" set-word-prop : non-inline-word ( word -- ) - dup called-dependency depends-on + dup depends-on-effect { { [ dup "shuffle" word-prop ] [ infer-shuffle-word ] } { [ dup "special" word-prop ] [ infer-special ] } diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 5426ac9e19..bb68a3f5c9 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -140,7 +140,7 @@ IN: stack-checker.transforms ! Constructors \ boa [ dup tuple-class? [ - dup conditional-dependency depends-on + dup depends-on-conditionally [ "boa-check" word-prop [ ] or ] [ tuple-layout '[ _ ] ] bi append From 09ead56652e4e7b20adcb3ba1c5d67bc093faa63 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 30 Jan 2010 02:58:39 +1300 Subject: [PATCH 25/33] Re-work flushed dependencies into new compiler cross-referencing framework --- basis/compiler/compiler.factor | 2 +- basis/compiler/crossref/crossref.factor | 10 ++-------- basis/compiler/tree/dead-code/simple/simple.factor | 2 +- basis/macros/macros.factor | 2 +- .../dependencies/dependencies-tests.factor | 7 ------- basis/stack-checker/dependencies/dependencies.factor | 9 +++++++++ core/classes/mixin/mixin.factor | 2 +- core/classes/tuple/tuple.factor | 2 +- core/classes/union/union.factor | 2 +- core/compiler/units/units.factor | 8 ++++---- core/definitions/definitions.factor | 6 +++--- core/words/words.factor | 9 +++++---- 12 files changed, 29 insertions(+), 32 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 2bdff71781..cce33c2f8d 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -203,7 +203,7 @@ M: optimizing-compiler recompile ( words -- alist ) M: optimizing-compiler to-recompile ( -- words ) changed-definitions get compiled-usages - changed-classes get outdated-class-usages + maybe-changed get outdated-conditional-usages append assoc-combine keys ; M: optimizing-compiler process-forgotten-words diff --git a/basis/compiler/crossref/crossref.factor b/basis/compiler/crossref/crossref.factor index 72e2c07c34..d0595f53b6 100644 --- a/basis/compiler/crossref/crossref.factor +++ b/basis/compiler/crossref/crossref.factor @@ -17,13 +17,7 @@ compiled-generic-crossref [ H{ } clone ] initialize compiled-crossref get at ; : (compiled-usages) ( word -- assoc ) - #! If the word is not flushable anymore, we have to recompile - #! all words which flushable away a call (presumably when the - #! word was still flushable). If the word is flushable, we - #! don't have to recompile words that folded this away. - [ compiled-usage ] - [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi - '[ nip _ dependency>= ] assoc-filter ; + compiled-usage [ nip inlined-dependency dependency>= ] assoc-filter ; : compiled-usages ( assoc -- assocs ) [ drop word? ] assoc-filter @@ -32,7 +26,7 @@ compiled-generic-crossref [ H{ } clone ] initialize : dependencies-satisfied? ( word -- ? ) "conditional-dependencies" word-prop [ satisfied? ] all? ; -: outdated-class-usages ( assoc -- assocs ) +: outdated-conditional-usages ( assoc -- assocs ) [ drop compiled-usage diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor index 0856920679..5582f4dc6f 100644 --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/basis/compiler/tree/dead-code/simple/simple.factor @@ -90,7 +90,7 @@ M: #push remove-dead-code* ] [ drop f ] if ; : remove-flushable-call ( #call -- node ) - [ word>> flushed-dependency depends-on ] + [ word>> depends-on-flushable ] [ in-d>> #drop remove-dead-code* ] bi ; diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 29c4fb6093..46fd1ce748 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -32,4 +32,4 @@ M: macro definition "macro" word-prop ; M: macro reset-word [ call-next-method ] [ f "macro" set-word-prop ] bi ; -M: macro bump-effect-counter* drop t ; +M: macro always-bump-effect-counter? drop t ; diff --git a/basis/stack-checker/dependencies/dependencies-tests.factor b/basis/stack-checker/dependencies/dependencies-tests.factor index 9bcec64033..2b6686e247 100644 --- a/basis/stack-checker/dependencies/dependencies-tests.factor +++ b/basis/stack-checker/dependencies/dependencies-tests.factor @@ -28,10 +28,3 @@ SYMBOL: b b inlined-dependency depends-on ] computing-dependencies ] unit-test - -[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test -[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test -[ inlined-dependency ] [ flushed-dependency inlined-dependency strongest-dependency ] unit-test -[ inlined-dependency ] [ called-dependency inlined-dependency strongest-dependency ] unit-test -[ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test -[ called-dependency ] [ called-dependency f strongest-dependency ] unit-test diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index 004c1dd07d..865fedebca 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -79,6 +79,15 @@ TUPLE: depends-on-method class generic method ; M: depends-on-method satisfied? [ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ; +TUPLE: depends-on-flushable word ; + +: depends-on-flushable ( word -- ) + [ depends-on-conditionally ] + [ \ depends-on-flushable add-conditional-dependency ] bi ; + +M: depends-on-flushable satisfied? + word>> flushable? ; + : init-dependencies ( -- ) H{ } clone dependencies set H{ } clone generic-dependencies set diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 16e4ff124e..8a48a25160 100644 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -28,7 +28,7 @@ TUPLE: check-mixin-class class ; : redefine-mixin-class ( class members -- ) [ (define-union-class) ] - [ drop changed-class ] + [ drop changed-conditionally ] [ drop t "mixin" set-word-prop ] 2tri ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 12d90e036b..620c65c865 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -223,7 +223,7 @@ M: tuple-class update-class 2drop [ [ update-tuples-after ] - [ changed-class ] + [ changed-conditionally ] bi ] each-subclass ] diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 44a1c22774..518ba37d7c 100644 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -32,7 +32,7 @@ PRIVATE> : define-union-class ( class members -- ) [ (define-union-class) ] - [ drop changed-class ] + [ drop changed-conditionally ] [ drop update-classes ] 2tri ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 21ab578ccc..386d5750bf 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -123,7 +123,7 @@ M: object always-bump-effect-counter? drop f ; dup new-definitions get first update dup new-definitions get second update dup changed-definitions get update - dup changed-classes get update + dup maybe-changed get update dup dup changed-vocabs update ; : process-forgotten-definitions ( -- ) @@ -134,7 +134,7 @@ M: object always-bump-effect-counter? drop f ; : bump-effect-counter? ( -- ? ) changed-effects get - changed-classes get + maybe-changed get changed-definitions get [ drop always-bump-effect-counter? ] assoc-filter 3array assoc-combine new-words get assoc-diff assoc-empty? not ; @@ -165,7 +165,7 @@ PRIVATE> : with-nested-compilation-unit ( quot -- ) [ H{ } clone changed-definitions set - H{ } clone changed-classes set + H{ } clone maybe-changed set H{ } clone changed-effects set H{ } clone outdated-generics set H{ } clone outdated-tuples set @@ -176,7 +176,7 @@ PRIVATE> : with-compilation-unit ( quot -- ) [ H{ } clone changed-definitions set - H{ } clone changed-classes set + H{ } clone maybe-changed set H{ } clone changed-effects set H{ } clone outdated-generics set H{ } clone forgotten-definitions set diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 7110e27e04..e255b161ee 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -15,10 +15,10 @@ SYMBOL: changed-definitions : changed-definition ( defspec -- ) dup changed-definitions get set-in-unit ; -SYMBOL: changed-classes +SYMBOL: maybe-changed -: changed-class ( class -- ) - dup changed-classes get set-in-unit ; +: changed-conditionally ( class -- ) + dup maybe-changed get set-in-unit ; SYMBOL: changed-effects diff --git a/core/words/words.factor b/core/words/words.factor index 106cca29fa..4fe00d1edf 100644 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -110,9 +110,14 @@ M: word make-inline : define-inline ( word def effect -- ) [ define-declared ] [ 2drop make-inline ] 3bi ; +GENERIC: flushable? ( word -- ? ) + +M: word flushable? "flushable" word-prop ; + GENERIC: reset-word ( word -- ) M: word reset-word + dup flushable? [ dup changed-conditionally ] when { "unannotated-def" "parsing" "inline" "recursive" "foldable" "flushable" "reading" "writing" "reader" @@ -182,10 +187,6 @@ M: parsing-word definer drop \ SYNTAX: \ ; ; : deprecated? ( obj -- ? ) dup word? [ "deprecated" word-prop ] [ drop f ] if ; -GENERIC: flushable? ( word -- ? ) - -M: word flushable? "flushable" word-prop ; - ! Definition protocol M: word where "loc" word-prop ; From 6cc68e889e38f8511696210e60f2d284a109928b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 30 Jan 2010 03:04:51 +1300 Subject: [PATCH 26/33] stack-checker.dependencies: add tuple layout dependencies for use by 'new' and 'boa' --- .../tree/propagation/transforms/transforms.factor | 10 ++++++---- basis/stack-checker/dependencies/dependencies.factor | 10 ++++++++++ basis/stack-checker/transforms/transforms.factor | 8 ++++---- 3 files changed, 20 insertions(+), 8 deletions(-) diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 3f6a200534..e95c6c4a49 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -163,10 +163,12 @@ ERROR: bad-partial-eval quot word ; : inline-new ( class -- quot/f ) dup tuple-class? [ - dup depends-on-conditionally - [ all-slots [ initial>> literalize ] map ] - [ tuple-layout '[ _ ] ] - bi append >quotation + dup tuple-layout + [ depends-on-tuple-layout ] + [ drop all-slots [ initial>> literalize ] [ ] map-as ] + [ nip ] + 2tri + '[ @ _ ] ] [ drop f ] if ; \ new [ inline-new ] 1 define-partial-eval diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index 865fedebca..4932d51de9 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs accessors classes.algebra fry generic kernel math namespaces sequences words ; +FROM: classes.tuple.private => tuple-layout ; IN: stack-checker.dependencies ! Words that the current quotation depends on @@ -79,6 +80,15 @@ TUPLE: depends-on-method class generic method ; M: depends-on-method satisfied? [ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ; +TUPLE: depends-on-tuple-layout class layout ; + +: depends-on-tuple-layout ( class layout -- ) + [ drop depends-on-conditionally ] + [ \ depends-on-tuple-layout add-conditional-dependency ] 2bi ; + +M: depends-on-tuple-layout satisfied? + [ class>> tuple-layout ] [ layout>> ] bi eq? ; + TUPLE: depends-on-flushable word ; : depends-on-flushable ( word -- ) diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index bb68a3f5c9..8afb5290de 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -140,10 +140,10 @@ IN: stack-checker.transforms ! Constructors \ boa [ dup tuple-class? [ - dup depends-on-conditionally - [ "boa-check" word-prop [ ] or ] - [ tuple-layout '[ _ ] ] - bi append + dup tuple-layout + [ depends-on-tuple-layout ] + [ [ "boa-check" word-prop [ ] or ] dip ] 2bi + '[ @ _ ] ] [ drop f ] if ] 1 define-transform From a13c2fb856e9a56f78aad2cb15864ca5044e70b7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 30 Jan 2010 03:12:29 +1300 Subject: [PATCH 27/33] compiler.crosssref: rename word property --- basis/compiler/crossref/crossref.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/compiler/crossref/crossref.factor b/basis/compiler/crossref/crossref.factor index d0595f53b6..b919c26184 100644 --- a/basis/compiler/crossref/crossref.factor +++ b/basis/compiler/crossref/crossref.factor @@ -24,7 +24,7 @@ compiled-generic-crossref [ H{ } clone ] initialize [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ; : dependencies-satisfied? ( word -- ? ) - "conditional-dependencies" word-prop [ satisfied? ] all? ; + "dependency-checks" word-prop [ satisfied? ] all? ; : outdated-conditional-usages ( assoc -- assocs ) [ @@ -54,7 +54,7 @@ compiled-generic-crossref [ H{ } clone ] initialize : compiled-unxref ( word -- ) [ "compiled-uses" compiled-crossref (compiled-unxref) ] [ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ] - [ f "conditional-dependencies" set-word-prop ] + [ f "dependency-checks" set-word-prop ] tri ; : delete-compiled-xref ( word -- ) @@ -64,4 +64,4 @@ compiled-generic-crossref [ H{ } clone ] initialize tri ; : save-conditional-dependencies ( word deps -- ) - >array f like "conditional-dependencies" set-word-prop ; + >array f like "dependency-checks" set-word-prop ; From c438e84bd038a058203d1c9e3df84f113565757d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 30 Jan 2010 04:12:09 +1300 Subject: [PATCH 28/33] compiler.crossref: add next-method dependency --- .../dependencies/dependencies.factor | 10 ++++++++++ basis/stack-checker/transforms/transforms.factor | 16 ++++++++-------- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index 4932d51de9..5a5cbcbd6f 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -72,9 +72,19 @@ TUPLE: depends-on-classes-disjoint class1 class2 ; M: depends-on-classes-disjoint satisfied? [ class1>> ] [ class2>> ] bi classes-intersect? not ; +TUPLE: depends-on-next-method class generic next-method ; + +: depends-on-next-method ( class generic next-method -- ) + over depends-on-conditionally + \ depends-on-next-method add-conditional-dependency ; + +M: depends-on-next-method satisfied? + [ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ; + TUPLE: depends-on-method class generic method ; : depends-on-method ( class generic method -- ) + over depends-on-conditionally \ depends-on-method add-conditional-dependency ; M: depends-on-method satisfied? diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 8afb5290de..cf32792a2e 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -124,15 +124,15 @@ IN: stack-checker.transforms \ 3|| t "no-compile" set-word-prop +: add-next-method-dependency ( method -- ) + [ "method-class" word-prop ] + [ "method-generic" word-prop ] bi + 2dup next-method + depends-on-next-method ; + \ (call-next-method) [ - [ - [ "method-class" word-prop ] - [ "method-generic" word-prop ] bi - depends-on-generic - ] [ - [ next-method-quot ] - [ '[ _ no-next-method ] ] bi or - ] bi + [ add-next-method-dependency ] + [ [ next-method-quot ] [ '[ _ no-next-method ] ] bi or ] bi ] 1 define-transform \ (call-next-method) t "no-compile" set-word-prop From 015a9d365decaeae4db30db34ef98454e45534d3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 30 Jan 2010 05:09:49 +1300 Subject: [PATCH 29/33] compiler.crossref: memoize dependency evaluation --- basis/compiler/crossref/crossref.factor | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/basis/compiler/crossref/crossref.factor b/basis/compiler/crossref/crossref.factor index b919c26184..67c5a6f1ea 100644 --- a/basis/compiler/crossref/crossref.factor +++ b/basis/compiler/crossref/crossref.factor @@ -23,15 +23,16 @@ compiled-generic-crossref [ H{ } clone ] initialize [ drop word? ] assoc-filter [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ; -: dependencies-satisfied? ( word -- ? ) - "dependency-checks" word-prop [ satisfied? ] all? ; +: dependencies-satisfied? ( word cache -- ? ) + [ "dependency-checks" word-prop ] dip + '[ _ [ satisfied? ] cache ] all? ; : outdated-conditional-usages ( assoc -- assocs ) - [ + H{ } clone '[ drop compiled-usage [ nip conditional-dependency dependency>= ] assoc-filter - [ drop dependencies-satisfied? not ] assoc-filter + [ drop _ dependencies-satisfied? not ] assoc-filter ] { } assoc>map ; : compiled-generic-usage ( word -- assoc ) From 7189342c199fef071f4285707b36c7849f9634b0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 30 Jan 2010 05:10:10 +1300 Subject: [PATCH 30/33] compiler.units: fix call-next-method call site recompilation --- core/compiler/units/units.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 386d5750bf..9fe13ba3ed 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -51,7 +51,8 @@ HOOK: update-call-sites compiler-impl ( class generic -- words ) M: generic update-generic ( class generic -- ) [ changed-call-sites ] [ remake-generic drop ] - 2bi ; + [ changed-conditionally drop ] + 2tri ; M: sequence update-methods ( class seq -- ) implementors [ update-generic ] with each ; From fa4f7d8ccf1df58bc20d470a9cf61f74ccd0f763 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 30 Jan 2010 05:28:55 +1300 Subject: [PATCH 31/33] Clean up some code in preparation for a refactoring --- basis/compiler/compiler.factor | 2 +- basis/compiler/crossref/crossref.factor | 14 +++++---- .../dependencies/dependencies-tests.factor | 29 ------------------- .../dependencies/dependencies.factor | 14 ++++----- basis/tools/profiler/profiler.factor | 2 +- 5 files changed, 17 insertions(+), 44 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index cce33c2f8d..0fb9231666 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -42,7 +42,7 @@ SYMBOL: compiled #! If a word's stack effect changed, recompile all words #! that have compiled calls to it. dup recompile-callers? - [ compiled-usage keys [ queue-compile ] each ] [ drop ] if ; + [ effect-dependencies-of keys [ queue-compile ] each ] [ drop ] if ; : compiler-message ( string -- ) "trace-compilation" get [ global [ print flush ] bind ] [ drop ] if ; diff --git a/basis/compiler/crossref/crossref.factor b/basis/compiler/crossref/crossref.factor index 67c5a6f1ea..518b05d89d 100644 --- a/basis/compiler/crossref/crossref.factor +++ b/basis/compiler/crossref/crossref.factor @@ -13,15 +13,18 @@ SYMBOL: compiled-generic-crossref compiled-generic-crossref [ H{ } clone ] initialize -: compiled-usage ( word -- assoc ) +: effect-dependencies-of ( word -- assoc ) compiled-crossref get at ; -: (compiled-usages) ( word -- assoc ) - compiled-usage [ nip inlined-dependency dependency>= ] assoc-filter ; +: definition-dependencies-of ( word -- assoc ) + effect-dependencies-of [ nip definition-dependency dependency>= ] assoc-filter ; + +: conditional-dependencies-of ( word -- assoc ) + effect-dependencies-of [ nip conditional-dependency dependency>= ] assoc-filter ; : compiled-usages ( assoc -- assocs ) [ drop word? ] assoc-filter - [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ; + [ [ drop definition-dependencies-of ] { } assoc>map ] keep suffix ; : dependencies-satisfied? ( word cache -- ? ) [ "dependency-checks" word-prop ] dip @@ -30,8 +33,7 @@ compiled-generic-crossref [ H{ } clone ] initialize : outdated-conditional-usages ( assoc -- assocs ) H{ } clone '[ drop - compiled-usage - [ nip conditional-dependency dependency>= ] assoc-filter + conditional-dependencies-of [ drop _ dependencies-satisfied? not ] assoc-filter ] { } assoc>map ; diff --git a/basis/stack-checker/dependencies/dependencies-tests.factor b/basis/stack-checker/dependencies/dependencies-tests.factor index 2b6686e247..8b13789179 100644 --- a/basis/stack-checker/dependencies/dependencies-tests.factor +++ b/basis/stack-checker/dependencies/dependencies-tests.factor @@ -1,30 +1 @@ -IN: stack-checker.dependencies.tests -USING: tools.test stack-checker.dependencies words kernel namespaces -definitions ; -: computing-dependencies ( quot -- dependencies ) - H{ } clone [ dependencies rot with-variable ] keep ; - inline - -SYMBOL: a -SYMBOL: b - -[ ] [ a called-dependency depends-on ] unit-test - -[ H{ { a called-dependency } } ] [ - [ a called-dependency depends-on ] computing-dependencies -] unit-test - -[ H{ { a called-dependency } { b inlined-dependency } } ] [ - [ - a called-dependency depends-on b inlined-dependency depends-on - ] computing-dependencies -] unit-test - -[ H{ { a inlined-dependency } { b inlined-dependency } } ] [ - [ - a inlined-dependency depends-on - a called-dependency depends-on - b inlined-dependency depends-on - ] computing-dependencies -] unit-test diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index 5a5cbcbd6f..a2ae1f1bc9 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -8,17 +8,17 @@ IN: stack-checker.dependencies ! Words that the current quotation depends on SYMBOL: dependencies -SYMBOLS: inlined-dependency conditional-dependency flushed-dependency called-dependency ; +SYMBOLS: effect-dependency conditional-dependency definition-dependency ; : index>= ( obj1 obj2 seq -- ? ) [ index ] curry bi@ >= ; : dependency>= ( how1 how2 -- ? ) - { called-dependency conditional-dependency flushed-dependency inlined-dependency } + { effect-dependency conditional-dependency definition-dependency } index>= ; : strongest-dependency ( how1 how2 -- how ) - [ called-dependency or ] bi@ [ dependency>= ] most ; + [ effect-dependency or ] bi@ [ dependency>= ] most ; : depends-on ( word how -- ) over primitive? [ 2drop ] [ @@ -28,14 +28,14 @@ SYMBOLS: inlined-dependency conditional-dependency flushed-dependency called-dep ] if ; : depends-on-effect ( word -- ) - called-dependency depends-on ; - -: depends-on-definition ( word -- ) - inlined-dependency depends-on ; + effect-dependency depends-on ; : depends-on-conditionally ( word -- ) conditional-dependency depends-on ; +: depends-on-definition ( word -- ) + definition-dependency depends-on ; + ! Generic words that the current quotation depends on SYMBOL: generic-dependencies diff --git a/basis/tools/profiler/profiler.factor b/basis/tools/profiler/profiler.factor index 8279a90514..76d62cec3a 100644 --- a/basis/tools/profiler/profiler.factor +++ b/basis/tools/profiler/profiler.factor @@ -40,7 +40,7 @@ IN: tools.profiler : profiler-usage ( word -- words ) [ smart-usage [ word? ] filter ] [ compiled-generic-usage keys ] - [ compiled-usage keys ] + [ effect-dependencies-of keys ] tri 3append prune ; : usage-counters ( word -- alist ) From ea9dbf2ea1e4a2e19ee5a0e51ed8d732e6645c66 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 30 Jan 2010 09:28:33 +1300 Subject: [PATCH 32/33] compiler.crossref: more space-efficient storage of dependency information --- basis/compiler/crossref/crossref.factor | 73 +++++++++++++++---- .../dependencies/dependencies.factor | 7 +- 2 files changed, 61 insertions(+), 19 deletions(-) diff --git a/basis/compiler/crossref/crossref.factor b/basis/compiler/crossref/crossref.factor index 518b05d89d..2e30e942d9 100644 --- a/basis/compiler/crossref/crossref.factor +++ b/basis/compiler/crossref/crossref.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes.algebra compiler.units definitions graphs grouping kernel namespaces sequences words fry -stack-checker.dependencies ; +stack-checker.dependencies combinators ; IN: compiler.crossref SYMBOL: compiled-crossref @@ -40,25 +40,66 @@ compiled-generic-crossref [ H{ } clone ] initialize : compiled-generic-usage ( word -- assoc ) compiled-generic-crossref get at ; -: (compiled-xref) ( word dependencies word-prop variable -- ) - [ [ concat ] dip set-word-prop ] [ get add-vertex* ] bi-curry* 2bi ; +: only-xref ( assoc -- assoc' ) + [ drop crossref? ] { } assoc-filter-as ; + +: set-compiled-generic-uses ( word alist -- ) + concat f like "compiled-generic-uses" set-word-prop ; + +: split-dependencies ( assoc -- effect-deps cond-deps def-deps ) + [ nip effect-dependency eq? ] assoc-partition + [ nip conditional-dependency eq? ] assoc-partition ; + +: (store-dependencies) ( word assoc prop -- ) + [ keys f like ] dip set-word-prop ; + +: store-dependencies ( word assoc -- ) + split-dependencies + "effect-dependencies" "definition-dependencies" "conditional-dependencies" + [ (store-dependencies) ] tri-curry@ tri-curry* tri ; + +: (compiled-xref) ( word dependencies generic-dependencies -- ) + compiled-crossref compiled-generic-crossref + [ get add-vertex* ] bi-curry@ bi-curry* bi ; : compiled-xref ( word dependencies generic-dependencies -- ) - [ [ drop crossref? ] { } assoc-filter-as ] bi@ - [ "compiled-uses" compiled-crossref (compiled-xref) ] - [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ] - bi-curry* bi ; + [ only-xref ] bi@ + [ nip set-compiled-generic-uses ] + [ drop store-dependencies ] + [ (compiled-xref) ] + 3tri ; -: (compiled-unxref) ( word word-prop variable -- ) - [ '[ dup _ word-prop 2 _ get remove-vertex* ] ] - [ drop '[ _ remove-word-prop ] ] - 2bi bi ; +: set-at-each ( keys assoc value -- ) + '[ _ [ _ ] 2dip set-at ] each ; + +: join-dependencies ( effect-deps cond-deps def-deps -- assoc ) + H{ } clone [ + [ effect-dependency set-at-each ] + [ conditional-dependency set-at-each ] + [ definition-dependency set-at-each ] tri-curry tri* + ] keep ; + +: load-dependencies ( word -- assoc ) + [ "effect-dependencies" word-prop ] + [ "definition-dependencies" word-prop ] + [ "conditional-dependencies" word-prop ] tri + join-dependencies ; + +: (compiled-unxref) ( word dependencies variable -- ) + get remove-vertex* ; + +: compiled-generic-uses ( word -- alist ) + "compiled-generic-uses" word-prop 2 ; : compiled-unxref ( word -- ) - [ "compiled-uses" compiled-crossref (compiled-unxref) ] - [ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ] - [ f "dependency-checks" set-word-prop ] - tri ; + { + [ dup load-dependencies compiled-crossref (compiled-unxref) ] + [ dup compiled-generic-uses compiled-generic-crossref (compiled-unxref) ] + [ "effect-dependencies" remove-word-prop ] + [ "definition-dependencies" remove-word-prop ] + [ "conditional-dependencies" remove-word-prop ] + [ "compiled-generic-uses" remove-word-prop ] + } cleave ; : delete-compiled-xref ( word -- ) [ compiled-unxref ] @@ -67,4 +108,4 @@ compiled-generic-crossref [ H{ } clone ] initialize tri ; : save-conditional-dependencies ( word deps -- ) - >array f like "dependency-checks" set-word-prop ; + keys f like "dependency-checks" set-word-prop ; diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index a2ae1f1bc9..6fa2ae4eab 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs accessors classes.algebra fry generic kernel math -namespaces sequences words ; +namespaces sequences words sets ; FROM: classes.tuple.private => tuple-layout ; IN: stack-checker.dependencies @@ -54,7 +54,7 @@ GENERIC: satisfied? ( dependency -- ? ) : add-conditional-dependency ( ... class -- ) boa conditional-dependencies get - dup [ push ] [ 2drop ] if ; inline + dup [ conjoin ] [ 2drop ] if ; inline TUPLE: depends-on-class<= class1 class2 ; @@ -111,11 +111,12 @@ M: depends-on-flushable satisfied? : init-dependencies ( -- ) H{ } clone dependencies set H{ } clone generic-dependencies set - V{ } clone conditional-dependencies set ; + H{ } clone conditional-dependencies set ; : without-dependencies ( quot -- ) [ dependencies off generic-dependencies off + conditional-dependencies off call ] with-scope ; inline From 36618bc46ec7f68f539a4bae17d13d6fa8081106 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 30 Jan 2010 10:53:42 +1300 Subject: [PATCH 33/33] typed: update for dependency changes --- basis/typed/typed.factor | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/basis/typed/typed.factor b/basis/typed/typed.factor index 0b3ac9d5f8..e71196e3ee 100644 --- a/basis/typed/typed.factor +++ b/basis/typed/typed.factor @@ -4,6 +4,7 @@ combinators.short-circuit definitions effects fry hints math kernel kernel.private namespaces parser quotations sequences slots words locals locals.parser macros stack-checker.dependencies ; +FROM: classes.tuple.private => tuple-layout ; IN: typed ERROR: type-mismatch-error word expected-types ; @@ -31,6 +32,7 @@ PREDICATE: typed-word < word "typed-word" word-prop ; : (unboxer) ( type -- quot ) dup unboxable-tuple-class? [ + dup dup tuple-layout depends-on-tuple-layout all-slots [ [ name>> reader-word 1quotation ] [ class>> (unboxer) ] bi compose @@ -49,7 +51,10 @@ PREDICATE: typed-word < word "typed-word" word-prop ; : (unboxed-types) ( type -- types ) dup unboxable-tuple-class? - [ all-slots [ class>> (unboxed-types) ] map concat ] + [ + dup dup tuple-layout depends-on-tuple-layout + all-slots [ class>> (unboxed-types) ] map concat + ] [ 1array ] if ; : unboxed-types ( types -- types' ) @@ -75,7 +80,12 @@ DEFER: make-boxer : boxer ( type -- quot ) dup unboxable-tuple-class? - [ [ all-slots [ class>> ] map make-boxer ] [ [ boa ] curry ] bi compose ] + [ + dup dup tuple-layout depends-on-tuple-layout + [ all-slots [ class>> ] map make-boxer ] + [ [ boa ] curry ] + bi compose + ] [ drop [ ] ] if ; : make-boxer ( types -- quot ) @@ -84,18 +94,15 @@ DEFER: make-boxer ! defining typed words -: (depends-on) ( types -- types ) - dup [ inlined-dependency depends-on ] each ; inline - MACRO: (typed) ( word def effect -- quot ) [ swap ] dip [ - nip effect-in-types (depends-on) swap + nip effect-in-types swap [ [ unboxed-types ] [ make-boxer ] bi ] dip '[ _ declare @ @ ] ] [ - effect-out-types (depends-on) + effect-out-types dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if ] 2bi ; @@ -118,9 +125,9 @@ M: typed-gensym crossref? [ 2nip ] 3tri define-declared ; MACRO: typed ( quot word effect -- quot' ) - [ effect-in-types (depends-on) dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ] + [ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ] [ - nip effect-out-types (depends-on) dup typed-stack-effect? + nip effect-out-types dup typed-stack-effect? [ [ unboxed-types ] [ make-boxer ] bi '[ @ _ declare @ ] ] [ drop ] if ] 2bi ;