generalizing the optimization

compile.rkt

@@ -446,7 +446,58 @@
    (KernelPrimitiveName App CompileTimeEnvironment Target Linkage -> InstructionSequence))
 ;; This is a special case of application, where the operator is statically
 ;; known to be in the set of hardcoded primitives.
+;;
+;; There's a special case optimization we can perform: we can avoid touching
+;; the stack for constant arguments; rather than allocate (length (App-operands exp))
+;; stack slots, we can do less than that.
+;;
+;; We have to be sensitive to mutation.
 (define (compile-kernel-primitive-application kernel-op exp cenv target linkage)
+  (cond
+    ;; If all the arguments are primitive enough (all constants, localrefs, or toplevelrefs),
+    ;; then application requires no stack space at all, and application is especially simple.
+    [(andmap (lambda (op) 
+               ;; TODO: as long as the operand contains no applications?
+               (or (Constant? op)
+                   (ToplevelRef? op)
+                   (LocalRef? op)))
+             (App-operands exp))
+     (let* ([n (length (App-operands exp))]
+            
+            [operand-knowledge
+             (map (lambda: ([arg : Expression])
+                           (extract-static-knowledge 
+                            arg 
+                            (extend-compile-time-environment/scratch-space 
+                             cenv n)))
+                  (App-operands exp))]
+            
+            [typechecks?
+             (map (lambda: ([dom : OperandDomain]
+                            [known : CompileTimeEnvironmentEntry])
+                           (not (redundant-check? dom known)))
+                  (kernel-primitive-expected-operand-types kernel-op n)
+                  operand-knowledge)]
+            
+            [expected-operand-types
+             (kernel-primitive-expected-operand-types kernel-op n)]
+            [operand-poss
+             (simple-operands->opargs (map (lambda: ([op : Expression])
+                                               (adjust-expression-depth op n n))
+                                             (App-operands exp)))])
+       (end-with-linkage
+        linkage cenv
+        (make-instruction-sequence
+         `(,(make-AssignPrimOpStatement
+             target
+             (make-CallKernelPrimitiveProcedure 
+              kernel-op 
+              operand-poss
+              expected-operand-types
+              typechecks?))))))]
+    
+    [else
+     ;; Otherwise, we can split the operands into two categories: constants, and the rest.
      (let*-values ([(n) 
                     (length (App-operands exp))]
                    
@@ -454,7 +505,8 @@
                     (kernel-primitive-expected-operand-types kernel-op n)]
                    
                    [(constant-operands rest-operands)
-                 (split-operands-by-constant-or-stack-references (App-operands exp))]
+                    (split-operands-by-constant-or-stack-references 
+                     (App-operands exp))]
                    
                    ;; here, we rewrite the stack references so they assume no scratch space
                    ;; used by the constant operands.
@@ -505,7 +557,7 @@
                                                        0))))]
                    
                    [(constant-operand-poss)
-                 (constant-operands->opargs constant-operands)]
+                    (simple-operands->opargs constant-operands)]
                    
                    [(rest-operand-poss)
                     (build-list (length rest-operands)
@@ -518,9 +570,6 @@
                                          (compile operand extended-cenv target next-linkage))
                                 rest-operands
                                 rest-operand-poss))])
-    ;; There's a special case optimization we can perform: we can avoid touching
-    ;; the stack for constant arguments; rather than allocate (length (App-operands exp))
-    ;; stack slots, we can do less than that.
        
        (end-with-linkage
         linkage cenv
@@ -529,13 +578,13 @@
          rest-operand-code
          (make-instruction-sequence
           `(,(make-AssignPrimOpStatement
-           target
+              (adjust-target-depth target (length rest-operands))
               (make-CallKernelPrimitiveProcedure 
                kernel-op 
                (append constant-operand-poss rest-operand-poss)
                expected-operand-types
                typechecks?))))
-      stack-popping-code))))
+         stack-popping-code)))]))
 
 
 
@@ -549,11 +598,9 @@
       (error 'ensure-simple-expression)))
 
 
-(: constant-operands->opargs ((Listof (U Constant LocalRef ToplevelRef)) 
+(: simple-operands->opargs ((Listof Expression) -> (Listof OpArg)))
-                              -> 
-                              (Listof OpArg)))
 ;; Produces a list of OpArgs if all the operands are particularly simple, and false therwise.
-(define (constant-operands->opargs rands)
+(define (simple-operands->opargs rands)
   (map (lambda: ([e : Expression])
                 (cond
                   [(Constant? e)
@@ -594,7 +641,8 @@
 
 
 (: split-operands-by-constant-or-stack-references 
-   ((Listof Expression) -> (values (Listof (U Constant LocalRef ToplevelRef))
+   ((Listof Expression)  -> 
+                         (values (Listof (U Constant LocalRef ToplevelRef))
                                  (Listof Expression))))
 ;; Splits off the list of operations into two: a prefix of constant
 ;; or simple expressions, and the remainder.
@@ -607,8 +655,12 @@
                (values (reverse constants) empty)]
               [else (let ([e (first rands)])
                       (if (or (Constant? e)
-                              (LocalRef? e)
+                              (and (LocalRef? e) (not (LocalRef-unbox? e))) 
-                              (ToplevelRef? e))
+                              #;(and (ToplevelRef? e)
+                                     (let ([prefix (ensure-prefix 
+                                                    (list-ref cenv (ToplevelRef-depth e)))])
+                                       (ModuleVariable? 
+                                        (list-ref prefix (ToplevelRef-pos e))))))
                           (loop (rest rands) (cons e constants))
                           (values (reverse constants) rands)))])))