Better performance on array array *

1 files changed, 192 insertions, 186 deletions

diff --git a/compiler/standardClient.ey b/compiler/standardClient.ey
index c64cf2d..01e894f 100644
--- a/compiler/standardClient.ey
+++ b/compiler/standardClient.ey
@@ -665,222 +665,228 @@
     #       Take topmost type, check whether it can be found in other stacks (from top)
     #         Eliminate all matching types via function or loop creation
     { ==f
-      f sys .typed .type 7 eq { f { * }_ [ 0 ] [ 0 ] '' =f } rep
+      f sys .typed .type 7 eq { _ sys .typed .type 7 eq } { 0 } ? * { ==a
+        # this block is purely an optimization for common array-on-array invocation
+        # the other block handles this case correctly, too (but a lot slower)
+        [ a { f * }" each ]
+      } {
+        f sys .typed .type 7 eq { f { * }_ [ 0 ] [ 0 ] '' =f } rep
 
-      f sys .typed .inputs ==inputs
-      f sys .typed .outputs ==outputs
+        f sys .typed .inputs ==inputs
+        f sys .typed .outputs ==outputs
 
-      outputs len 1 gt { "multi-output function in auto-loop" die } rep
+        outputs len 1 gt { "multi-output function in auto-loop" die } rep
 
-      [ ] ==concreteArgs
-      [ ] ==viewPortOffset
+        [ ] ==concreteArgs
+        [ ] ==viewPortOffset
 
-      # Phase 1
-      0 inputs len range reverse {
-        # print "Analyzing arg: %d"
-        inputs * typeStack ==formalTypeStack
-        _ ==c typeStack ==concreteTypeStack
-        # "Type-Stack: %d" Dumper($concreteTypeStack) die
+        # Phase 1
+        0 inputs len range reverse {
+          # print "Analyzing arg: %d"
+          inputs * typeStack ==formalTypeStack
+          _ ==c typeStack ==concreteTypeStack
+          # "Type-Stack: %d" Dumper($concreteTypeStack) die
 
-        0 ==bestViewPortSize
-        concreteTypeStack len 1 add ==bestViewPortMatch
+          0 ==bestViewPortSize
+          concreteTypeStack len 1 add ==bestViewPortMatch
 
-        # "Formal Type Stack: @$formalTypeStack\n" print
-        # "       Type Stack: @$concreteTypeStack\n" print
+          # "Formal Type Stack: @$formalTypeStack\n" print
+          # "       Type Stack: @$concreteTypeStack\n" print
 
-        1 neg concreteTypeStack * isVariableType {
-          1 concreteTypeStack len 1 add range { ==viewPortSize
-            [ 0 viewPortSize range { concreteTypeStack * } each ] ==typeViewPort # explicit each here
-            # "@$formalTypeStack vs. @$concreteTypeStack\n" print
+          1 neg concreteTypeStack * isVariableType {
+            1 concreteTypeStack len 1 add range { ==viewPortSize
+              [ 0 viewPortSize range { concreteTypeStack * } each ] ==typeViewPort # explicit each here
+              # "@$formalTypeStack vs. @$concreteTypeStack\n" print
 
-            formalTypeStack concreteTypeStack typeMismatchCount ==viewPortMatch # FIXME this line seems fishy
-            viewPortMatch bestViewPortMatch lt {
-              viewPortSize =bestViewPortSize
-              viewPortMatch =bestViewPortMatch
-            } rep
-          } each
-        } {
-          concreteTypeStack len =bestViewPortSize
-          0 =bestViewPortMatch
-        } ? *
+              formalTypeStack concreteTypeStack typeMismatchCount ==viewPortMatch # FIXME this line seems fishy
+              viewPortMatch bestViewPortMatch lt {
+                viewPortSize =bestViewPortSize
+                viewPortMatch =bestViewPortMatch
+              } rep
+            } each
+          } {
+            concreteTypeStack len =bestViewPortSize
+            0 =bestViewPortMatch
+          } ? *
 
-        # convert concrete argument to exactly matching function
-        # ... which calls the concrete argument using its relevant args
-        bestViewPortMatch {
-          # if argument is concrete, but we need are construction a function overall, then concrete
-          # argument needs to be converted to a constant function in whatever domain is necessary
-          "concrete argument constant functionification needs to be implemented, mismatch: $bestViewPortMatch" die
-          { "magic goes here FIXME" die } =c
-        } {
-          # zero mismatches, can directly use concrete argument
-          [ concreteTypeStack len formalTypeStack len sub ] viewPortOffset cat =viewPortOffset
-        } ? *
+          # convert concrete argument to exactly matching function
+          # ... which calls the concrete argument using its relevant args
+          bestViewPortMatch {
+            # if argument is concrete, but we need are construction a function overall, then concrete
+            # argument needs to be converted to a constant function in whatever domain is necessary
+            "concrete argument constant functionification needs to be implemented, mismatch: $bestViewPortMatch" die
+            { "magic goes here FIXME" die } =c
+          } {
+            # zero mismatches, can directly use concrete argument
+            [ concreteTypeStack len formalTypeStack len sub ] viewPortOffset cat =viewPortOffset
+          } ? *
 
-        [ c ] concreteArgs cat =concreteArgs
-      } each
+          [ c ] concreteArgs cat =concreteArgs
+        } each
 
-      # "Viewport Offsets: @viewPortOffset\n" print
+        # "Viewport Offsets: @viewPortOffset\n" print
 
-      # Phase 2,
-      [
-        0 viewPortOffset len range { ==i
-          i concreteArgs * typeStack ==remaining
-          [ 0 i viewPortOffset * range { remaining * } each ] # explicit each here
-        } each
-      ] ==toBeAbstractedTypes
-
-      # "toBeAbstractedTypes: " dump
-      # toBeAbstractedTypes dump
-
-      [ toBeAbstractedTypes { len } each ] any not {
-        # no types need to be abstracted, function can be called
-        # "attempting to call function (w.o. abstraction)" dump
-        0 ==typeMismatch
-        0 ==mismatchIndex
-        0 concreteArgs len range reverse { ==i
-          i concreteArgs * sys .typed .type # _ dump
-          i inputs       * sys .typed .type # _ dump
-          neq typeMismatch not and { 1 =typeMismatch i =mismatchIndex } rep
-        } each
-        typeMismatch {
-          mismatchIndex concreteArgs * ==arg
-          arg sys .typed .type 9 eq { # this is a scope
-            "" ==handlingMember
-            globals { _ ==g | sys .asm .rawAddress f sys .asm .rawAddress eq {
-                mismatchIndex 9 gt { "cannot create member-fallback for argument index " dump mismatchIndex dump "" die } rep
-                arg
-                  concreteArgs len 1 sub mismatchIndex sub [
-                    "#" "#-01 " "#-021 " "#-0321 " "#-04321 " "#-054321 " "#-0654321 " "#-07654312 " "#-087654321 " "#-0987654321 "
-                  ] *
-                  g cat _ ==candidate .? { candidate =handlingMember } rep
-              } rep
-            } each
-            "" handlingMember eq { "a handling member could not be found at argument index " dump mismatchIndex dump "" die } rep
-            0 concreteArgs len range { ==i
-              i mismatchIndex neq { i concreteArgs * } rep
-            } each
-            arg handlingMember .
+        # Phase 2,
+        [
+          0 viewPortOffset len range { ==i
+            i concreteArgs * typeStack ==remaining
+            [ 0 i viewPortOffset * range { remaining * } each ] # explicit each here
+          } each
+        ] ==toBeAbstractedTypes
+
+        # "toBeAbstractedTypes: " dump
+        # toBeAbstractedTypes dump
+
+        [ toBeAbstractedTypes { len } each ] any not {
+          # no types need to be abstracted, function can be called
+          # "attempting to call function (w.o. abstraction)" dump
+          0 ==typeMismatch
+          0 ==mismatchIndex
+          0 concreteArgs len range reverse { ==i
+            i concreteArgs * sys .typed .type # _ dump
+            i inputs       * sys .typed .type # _ dump
+            neq typeMismatch not and { 1 =typeMismatch i =mismatchIndex } rep
+          } each
+          typeMismatch {
+            mismatchIndex concreteArgs * ==arg
+            arg sys .typed .type 9 eq { # this is a scope
+              "" ==handlingMember
+              globals { _ ==g | sys .asm .rawAddress f sys .asm .rawAddress eq {
+                  mismatchIndex 9 gt { "cannot create member-fallback for argument index " dump mismatchIndex dump "" die } rep
+                  arg
+                    concreteArgs len 1 sub mismatchIndex sub [
+                      "#" "#-01 " "#-021 " "#-0321 " "#-04321 " "#-054321 " "#-0654321 " "#-07654312 " "#-087654321 " "#-0987654321 "
+                    ] *
+                    g cat _ ==candidate .? { candidate =handlingMember } rep
+                } rep
+              } each
+              "" handlingMember eq { "a handling member could not be found at argument index " dump mismatchIndex dump "" die } rep
+              0 concreteArgs len range { ==i
+                i mismatchIndex neq { i concreteArgs * } rep
+              } each
+              arg handlingMember .
+            } {
+              "invalid input type at argument index " dump typeMismatch 1 sub dump "" die
+            } ? *
           } {
-            "invalid input type at argument index " dump typeMismatch 1 sub dump "" die
+            concreteArgs # _ dump
+                       _ len dearray f *
           } ? *
         } {
-          concreteArgs # _ dump
-                     _ len dearray f *
-        } ? *
-      } {
-        [ ] ==argTypes # the type stack of the new function
-        [ ] ==stageCalls # which functions to call in each stage
-        [ ] ==loops # undef for lambda abstraction, loop bound source for loops
-
-        0 toBeAbstractedTypes len range reverse { ==i
-          { i toBeAbstractedTypes * len } {
-            # TODO: create a decent shift
-            [ i toBeAbstractedTypes * reverse _ len dearray ==type ] reverse i toBeAbstractedTypes =[]
-              [ i ] ==stageCalls2
-              1 neg ==iterationSource
-              type isIterableType { i =iterationSource } rep
-
-              0 i range reverse { ==j
-                j toBeAbstractedTypes * len not not {
-                  0 j toBeAbstractedTypes * * type commonIterationType # -> <type> <any exists>
-                  { =type
-                    iterationSource 0 lt type isIterableType and { j =iterationSource } rep
-                    # TODO: create a decent shift
-                    [ j toBeAbstractedTypes * reverse _ len dearray -- ] reverse j toBeAbstractedTypes =[]
-                    [ j ] stageCalls2 cat =stageCalls2
+          [ ] ==argTypes # the type stack of the new function
+          [ ] ==stageCalls # which functions to call in each stage
+          [ ] ==loops # undef for lambda abstraction, loop bound source for loops
+
+          0 toBeAbstractedTypes len range reverse { ==i
+            { i toBeAbstractedTypes * len } {
+              # TODO: create a decent shift
+              [ i toBeAbstractedTypes * reverse _ len dearray ==type ] reverse i toBeAbstractedTypes =[]
+                [ i ] ==stageCalls2
+                1 neg ==iterationSource
+                type isIterableType { i =iterationSource } rep
+
+                0 i range reverse { ==j
+                  j toBeAbstractedTypes * len not not {
+                    0 j toBeAbstractedTypes * * type commonIterationType # -> <type> <any exists>
+                    { =type
+                      iterationSource 0 lt type isIterableType and { j =iterationSource } rep
+                      # TODO: create a decent shift
+                      [ j toBeAbstractedTypes * reverse _ len dearray -- ] reverse j toBeAbstractedTypes =[]
+                      [ j ] stageCalls2 cat =stageCalls2
+                    } rep
                   } rep
-                } rep
-              } each
+                } each
 
-              iterationSource 0 ge {
-                [ 1 neg ] argTypes cat =argTypes
-                [ iterationSource ] loops cat =loops
-              } {
-                [ type ] argTypes cat =argTypes
-                [ 1 neg ] loops cat =loops
-              } ? *
-            [ stageCalls2 ] stageCalls cat =stageCalls
-          } loop
-        } each
+                iterationSource 0 ge {
+                  [ 1 neg ] argTypes cat =argTypes
+                  [ iterationSource ] loops cat =loops
+                } {
+                  [ type ] argTypes cat =argTypes
+                  [ 1 neg ] loops cat =loops
+                } ? *
+              [ stageCalls2 ] stageCalls cat =stageCalls
+            } loop
+          } each
 
-        # "concreteArgs: " dump
-        # concreteArgs dump
-        # "stageCalls: " dump
-        # stageCalls dump
-        # "argTypes: " dump
-        # argTypes dump
-        # "loops: " dump
-        # loops dump
-
-        { ==loops ==argTypes ==stageCalls ==concreteArgs
-          stageCalls len not {
-            concreteArgs _ len dearray f
-            *
-          } {
-            [ stageCalls _ len dearray ==stage ] =stageCalls
-            [ argTypes _ len dearray ==argType ] =argTypes
-            [ loops _ len dearray ==loopIndex ] =loops
-            loopIndex 0 ge {
-              loopIndex concreteArgs * ==loopedOver
-              outputs len { loopedOver cloneForLoop } { [ ] } ? * ==results
-
-              loopedOver sys .typed .type 7 eq {
-                0 ==i 0 ==j
-                [ concreteArgs _ len dearray ] ==concreteArgsCopy
-
-                loopedOver dom { =i
-                  stage { =j
+          # "concreteArgs: " dump
+          # concreteArgs dump
+          # "stageCalls: " dump
+          # stageCalls dump
+          # "argTypes: " dump
+          # argTypes dump
+          # "loops: " dump
+          # loops dump
+
+          { ==loops ==argTypes ==stageCalls ==concreteArgs
+            stageCalls len not {
+              concreteArgs _ len dearray f
+              *
+            } {
+              [ stageCalls _ len dearray ==stage ] =stageCalls
+              [ argTypes _ len dearray ==argType ] =argTypes
+              [ loops _ len dearray ==loopIndex ] =loops
+              loopIndex 0 ge {
+                loopIndex concreteArgs * ==loopedOver
+                outputs len { loopedOver cloneForLoop } { [ ] } ? * ==results
+
+                loopedOver sys .typed .type 7 eq {
+                  0 ==i 0 ==j
+                  [ concreteArgs _ len dearray ] ==concreteArgsCopy
+
+                  loopedOver dom { =i
+                    stage { =j
+                      # TODO: think about a single function returning multiple values
+                      i j concreteArgs * * j concreteArgsCopy =[]
+                    }" each
+
+                    concreteArgsCopy stageCalls argTypes loops unravel
+                      outputs len { i results =[] }" rep
+                    # results dump
                     # TODO: think about a single function returning multiple values
-                    i j concreteArgs * * j concreteArgsCopy =[]
+                    # should be solved by producing two arrays side by side
                   }" each
+                } {
+                  loopedOver "#istart" . ==i
+
+                  { i loopedOver "#iend" . not } {
+                    [ concreteArgs _ len dearray ] ==concreteArgsCopy
+                    stage { ==j
+                      # TODO: think about a single function returning multiple values
+                      i loopedOver "#itrans" . j concreteArgs * * j concreteArgsCopy =[]
+                    } each
+
+                    concreteArgsCopy stageCalls argTypes loops unravel
+                      outputs len { i loopedOver "#itrans" . results =[] } rep
+                    # results dump
+                    # TODO: think about a single function returning multiple values
+                    # should be solved by producing two arrays side by side
 
-                  concreteArgsCopy stageCalls argTypes loops unravel
-                    outputs len { i results =[] }" rep
-                  # results dump
-                  # TODO: think about a single function returning multiple values
-                  # should be solved by producing two arrays side by side
-                }" each
-              } {
-                loopedOver "#istart" . ==i
+                    i loopedOver "#istep" . =i
+                  } loop
+                } ? *
 
-                { i loopedOver "#iend" . not } {
+                outputs len { results } rep
+                # push @$data, [\@results, ['array', '[]', [['range', 0, $#results]], [undef]]];
+                # FIXME the undef can be determined
+              } {
+                { ==v
                   [ concreteArgs _ len dearray ] ==concreteArgsCopy
-                  stage { ==j
-                    # TODO: think about a single function returning multiple values
-                    i loopedOver "#itrans" . j concreteArgs * * j concreteArgsCopy =[]
+                  stage { ==i
+                    v i concreteArgs * * i concreteArgsCopy =[]
                   } each
 
                   concreteArgsCopy stageCalls argTypes loops unravel
-                    outputs len { i loopedOver "#itrans" . results =[] } rep
-                  # results dump
-                  # TODO: think about a single function returning multiple values
-                  # should be solved by producing two arrays side by side
-
-                  i loopedOver "#istep" . =i
-                } loop
+                } # leave this on the stack
+                # push @$data, [$abstraction, ['func', 'autoabstraction of ' . $f->[1]->[1], [grep { $_ } @argTypeCopy], undef]];
+                # FIXME the undef can be determined
               } ? *
-
-              outputs len { results } rep
-              # push @$data, [\@results, ['array', '[]', [['range', 0, $#results]], [undef]]];
-              # FIXME the undef can be determined
-            } {
-              { ==v
-                [ concreteArgs _ len dearray ] ==concreteArgsCopy
-                stage { ==i
-                  v i concreteArgs * * i concreteArgsCopy =[]
-                } each
-
-                concreteArgsCopy stageCalls argTypes loops unravel
-              } # leave this on the stack
-              # push @$data, [$abstraction, ['func', 'autoabstraction of ' . $f->[1]->[1], [grep { $_ } @argTypeCopy], undef]];
-              # FIXME the undef can be determined
             } ? *
-          } ? *
-        } =*?unravel
+          } =*?unravel
 
-        concreteArgs stageCalls argTypes loops unravel
+          concreteArgs stageCalls argTypes loops unravel
 
-        # "execution complete" dump
+          # "execution complete" dump
+        } ? *
       } ? *
     } /execute sys .typed .deff
   > --