stack-checker: do constant folding for curry and compose with constant inputs at compile time. Allows macros to expand in more cases, fixing the fry caveat found by Doug

basis/stack-checker/known-words/known-words.factor

@@ -89,44 +89,37 @@ M: composed infer-call*
 M: object infer-call*
     \ literal-expected inference-warning ;
 
-: infer-slip ( -- )
+: infer-nslip ( n -- )
-    1 infer->r infer-call 1 infer-r> ;
+    [ infer->r infer-call ] [ infer-r> ] bi ;
 
-: infer-2slip ( -- )
+: infer-slip ( -- ) 1 infer-nslip ;
-    2 infer->r infer-call 2 infer-r> ;
 
-: infer-3slip ( -- )
+: infer-2slip ( -- ) 2 infer-nslip ;
-    3 infer->r infer-call 3 infer-r> ;
 
-: infer-dip ( -- )
+: infer-3slip ( -- ) 3 infer-nslip ;
-    literals get
+
-    [ \ dip def>> infer-quot-here ]
+: infer-ndip ( word n -- )
-    [ pop 1 infer->r infer-quot-here 1 infer-r>  ]
+    [ literals get ] 2dip
+    [ '[ _ def>> infer-quot-here ] ]
+    [ '[ _ [ pop ] dip [ infer->r infer-quot-here ] [ infer-r> ] bi ] ] bi*
     if-empty ;
 
-: infer-2dip ( -- )
+: infer-dip ( -- ) \ dip 1 infer-ndip ;
-    literals get
-    [ \ 2dip def>> infer-quot-here ]
-    [ pop 2 infer->r infer-quot-here 2 infer-r>  ]
-    if-empty ;
 
-: infer-3dip ( -- )
+: infer-2dip ( -- ) \ 2dip 2 infer-ndip ;
-    literals get
-    [ \ 3dip def>> infer-quot-here ]
-    [ pop 3 infer->r infer-quot-here 3 infer-r>  ]
-    if-empty ;
 
-: infer-curry ( -- )
+: infer-3dip ( -- ) \ 3dip 3 infer-ndip ;
-    2 consume-d
-    dup first2 <curried> make-known
-    [ push-d ] [ 1array ] bi
-    \ curry #call, ;
 
-: infer-compose ( -- )
+: infer-builder ( quot word -- )
-    2 consume-d
+    [
-    dup first2 <composed> make-known
+        [ 2 consume-d ] dip
-    [ push-d ] [ 1array ] bi
+        [ dup first2 ] dip call make-known
-    \ compose #call, ;
+        [ push-d ] [ 1array ] bi
+    ] dip #call, ; inline
+
+: infer-curry ( -- ) [ <curried> ] \ curry infer-builder ;
+
+: infer-compose ( -- ) [ <composed> ] \ compose infer-builder ;
 
 : infer-execute ( -- )
     pop-literal nip

basis/stack-checker/stack-checker-docs.factor

@@ -80,13 +80,6 @@ $nl
     "[ [ 5 ] t foo ] infer."
 } ;
 
-ARTICLE: "compiler-transforms" "Compiler transforms"
-"Compiler transforms can be used to allow words to compile which would otherwise not have a stack effect, and to expand combinators into more efficient code at compile time."
-{ $subsection define-transform }
-"An example is the " { $link cond } " word. If the association list of quotations it is given is literal, the entire form is expanded into a series of nested calls to " { $link if } "."
-$nl
-"The " { $vocab-link "macros" } " vocabulary defines some nice syntax sugar which makes compiler transforms easier to work with." ;
-
 ARTICLE: "inference" "Stack effect inference"
 "The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build the high-level SSA representation on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")."
 $nl
@@ -103,7 +96,6 @@ $nl
 { $subsection "inference-recursive-combinators" }
 { $subsection "inference-branches" }
 { $subsection "inference-errors" }
-{ $subsection "compiler-transforms" }
 { $see-also "effects" } ;
 
 ABOUT: "inference"

basis/stack-checker/stack-checker-tests.factor

@@ -577,3 +577,8 @@ DEFER: eee'
 [ bogus-error ] must-infer
 
 [ [ clear ] infer. ] [ inference-error? ] must-fail-with
+
+: debugging-curry-folding ( quot -- )
+    [ debugging-curry-folding ] curry call ; inline recursive
+
+[ [ ] debugging-curry-folding ] must-infer

basis/stack-checker/transforms/transforms-docs.factor

@@ -3,12 +3,11 @@ USING: help.markup help.syntax combinators words kernel ;
 
 HELP: define-transform
 { $values { "word" word } { "quot" "a quotation taking " { $snippet "n" } " inputs from the stack and producing another quotation as output" } { "n" "a non-negative integer" } }
-{ $description "Defines a compiler transform for the optimizing compiler. When a call to " { $snippet "word" } " is being compiled, the compiler ensures that the top " { $snippet "n" } " stack values are literal; if they are not, compilation fails. The literal values are passed to the quotation, which is expected to produce a new quotation. The call to the word is then replaced by this quotation." }
+{ $description "Defines a compiler transform for the optimizing compiler."
-{ $examples "Here is a word which pops " { $snippet "n" } " values from the stack:"
+  "When a call to " { $snippet "word" } " is being compiled, the compiler first checks that the top " { $snippet "n" } " stack values are literal, and if so, calls the quotation with those inputs at compile time. The quotation can output a new quotation, or " { $link f } "."
-{ $code ": ndrop ( n -- ) [ drop ] times ;" }
-"This word is inefficient; it does not have a static stack effect. This means that words calling " { $snippet "ndrop" } " cannot be compiled by the optimizing compiler, and additionally, a call to this word will always involve a loop with arithmetic, even if the value of " { $snippet "n" } " is known at compile time. A compiler transform can fix this:"
-{ $code "\\ ndrop [ \\ drop <repetition> >quotation ] 1 define-transform" }
-"Now, a call like " { $snippet "4 ndrop" } " is replaced with " { $snippet "drop drop drop drop" } " at compile time; the optimizer then ensures that this compiles as a single machine instruction, which is a lot cheaper than an actual call to " { $snippet "ndrop" } "."
 $nl
-"The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":"
+"If the quotation outputs " { $link f } ", or if not all inputs are literal, a call to the word is compiled as usual, or compilation fails if the word does not have a static stack effect."
+$nl
+"Otherwise, if the transform output a new quotation, the quotation replaces the word's call site." }
+{ $examples "The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":"
 { $code "\\ cond [ cond>quot ] 1 define-transform" } } ;

basis/stack-checker/transforms/transforms-tests.factor

@@ -57,3 +57,12 @@ DEFER: smart-combo ( quot -- )
 [ [ "a" "b" "c" ] very-smart-combo ] must-infer
 
 [ [ [ "a" "b" ] very-smart-combo "c" ] very-smart-combo ] must-infer
+
+! Caveat found by Doug
+DEFER: curry-folding-test ( quot -- )
+
+\ curry-folding-test [ length \ drop <repetition> >quotation ] 1 define-transform
+
+{ 3 0 } [ [ 1 2 3 ] curry-folding-test ] must-infer-as
+{ 3 0 } [ 1 [ 2 3 ] curry curry-folding-test ] must-infer-as
+{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as

basis/stack-checker/transforms/transforms.factor

@@ -24,8 +24,10 @@ IN: stack-checker.transforms
         rstate infer-quot
     ] [ word give-up-transform ] if* ;
 
+: literals? ( values -- ? ) [ literal-value? ] all? ;
+
 : (apply-transform) ( word quot n -- )
-    ensure-d dup [ known literal? ] all? [
+    ensure-d dup literals? [
         dup empty? [ dup recursive-state get ] [
             [ ]
             [ [ literal value>> ] map ]

basis/stack-checker/values/values.factor

@@ -26,27 +26,51 @@ SYMBOL: known-values
 : copy-values ( values -- values' )
     [ copy-value ] map ;
 
+GENERIC: (literal-value?) ( value -- ? )
+
+M: object (literal-value?) drop f ;
+
+GENERIC: (literal) ( value -- literal )
+
 ! Literal value
 TUPLE: literal < identity-tuple value recursion hashcode ;
 
+: literal ( value -- literal ) known (literal) ;
+
+: literal-value? ( value -- ? ) known (literal-value?) ;
+
 M: literal hashcode* nip hashcode>> ;
 
 : <literal> ( obj -- value )
     recursive-state get over hashcode \ literal boa ;
 
-GENERIC: (literal) ( value -- literal )
+M: literal (literal-value?) drop t ;
 
 M: literal (literal) ;
 
-: literal ( value -- literal )
+: curried/composed-literal ( input1 input2 quot -- literal )
-    known (literal) ;
+    [ [ literal ] bi@ ] dip
+    [ [ [ value>> ] bi@ ] dip call ] [ drop nip recursion>> ] 3bi
+    over hashcode \ literal boa ; inline
 
 ! Result of curry
 TUPLE: curried obj quot ;
 
 C: <curried> curried
 
+: >curried< ( curried -- obj quot )
+    [ obj>> ] [ quot>> ] bi ; inline
+
+M: curried (literal-value?) >curried< [ literal-value? ] both? ;
+M: curried (literal) >curried< [ curry ] curried/composed-literal ;
+
 ! Result of compose
 TUPLE: composed quot1 quot2 ;
 
 C: <composed> composed
+
+: >composed< ( composed -- quot1 quot2 )
+    [ quot1>> ] [ quot2>> ] bi ; inline
+
+M: composed (literal-value?) >composed< [ literal-value? ] both? ;
+M: composed (literal) >composed< [ compose ] curried/composed-literal ;