adding type checks

assemble-helpers.rkt

@@ -0,0 +1,123 @@
+#lang typed/racket/base
+
+(require "il-structs.rkt"
+         "lexical-structs.rkt"
+         racket/list)
+
+(provide assemble-oparg
+         assemble-target
+         assemble-const
+         assemble-lexical-reference
+         assemble-prefix-reference
+         assemble-whole-prefix-reference
+         assemble-reg
+         assemble-label
+         assemble-input)
+
+
+(: assemble-oparg (OpArg -> String))
+(define (assemble-oparg v)
+  (cond 
+    [(Reg? v)
+     (assemble-reg v)]
+    [(Label? v)
+     (assemble-label v)]
+    [(Const? v)
+     (assemble-const v)]
+    [(EnvLexicalReference? v)
+     (assemble-lexical-reference v)]
+    [(EnvPrefixReference? v)
+     (assemble-prefix-reference v)]
+    [(EnvWholePrefixReference? v)
+     (assemble-whole-prefix-reference v)]))
+
+
+
+
+(: assemble-target (Target -> String))
+(define (assemble-target target)
+  (cond
+    [(eq? target 'proc)
+     "MACHINE.proc"]
+    [(eq? target 'val)
+     "MACHINE.val"]
+    [(EnvLexicalReference? target)
+     (assemble-lexical-reference target)]
+    [(EnvPrefixReference? target)
+     (assemble-prefix-reference target)]
+    [(PrimitivesReference? target)
+     (format "Primitives[~s]" (symbol->string (PrimitivesReference-name target)))]))
+
+
+
+;; fixme: use js->string
+(: assemble-const (Const -> String))
+(define (assemble-const stmt)
+  (let: loop : String ([val : Any (Const-const stmt)])
+        (cond [(symbol? val)
+               (format "~s" (symbol->string val))]
+              [(pair? val)
+               (format "[~a, ~a]" 
+                       (loop (car val))
+                       (loop (cdr val)))]
+              [(boolean? val)
+               (if val "true" "false")]
+              [(void? val)
+               "null"]
+              [(empty? val)
+               (format "Primitives.null")]
+              [(number? val)
+               (format "(~s)" val)]
+              [else
+               (format "~s" val)])))
+
+
+
+
+(: assemble-lexical-reference (EnvLexicalReference -> String))
+(define (assemble-lexical-reference a-lex-ref)
+  (if (EnvLexicalReference-unbox? a-lex-ref)
+      (format "MACHINE.env[MACHINE.env.length - 1 - ~a][0]"
+              (EnvLexicalReference-depth a-lex-ref))
+      (format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
+              (EnvLexicalReference-depth a-lex-ref))))
+
+(: assemble-prefix-reference (EnvPrefixReference -> String))
+(define (assemble-prefix-reference a-ref)
+  (format "MACHINE.env[MACHINE.env.length - 1 - ~a][~a]"
+          (EnvPrefixReference-depth a-ref)
+          (EnvPrefixReference-pos a-ref)))
+
+(: assemble-whole-prefix-reference (EnvWholePrefixReference -> String))
+(define (assemble-whole-prefix-reference a-prefix-ref)
+  (format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
+          (EnvWholePrefixReference-depth a-prefix-ref)))
+
+
+(: assemble-reg (Reg -> String))
+(define (assemble-reg a-reg)
+  (string-append "MACHINE." (symbol->string (Reg-name a-reg))))
+
+
+
+(: assemble-label (Label -> String))
+(define (assemble-label a-label)
+  (symbol->string (Label-name a-label)))
+
+
+
+(: assemble-input (OpArg -> String))
+(define (assemble-input an-input)
+  (cond
+    [(Reg? an-input)
+     (assemble-reg an-input)]
+    [(Const? an-input)
+     (assemble-const an-input)]
+    [(Label? an-input)
+     (assemble-label an-input)]
+    [(EnvLexicalReference? an-input)
+     (assemble-lexical-reference an-input)]
+    [(EnvPrefixReference? an-input)
+     (assemble-prefix-reference an-input)]
+    [(EnvWholePrefixReference? an-input)
+     (assemble-whole-prefix-reference an-input)]))

assemble-open-coded.rkt

@@ -0,0 +1,225 @@
+#lang typed/racket/base
+
+(require "il-structs.rkt"
+         "lexical-structs.rkt"
+         "assemble-helpers.rkt"
+         racket/string
+         racket/list)
+
+(provide open-code-kernel-primitive-procedure)
+
+
+
+(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String))
+(define (open-code-kernel-primitive-procedure op)
+  (let: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)]
+         [rand-knowledge : (Listof CompileTimeEnvironmentEntry)
+                        (CallKernelPrimitiveProcedure-operands-knowledge op)]
+         [rand-vals : (Listof String) (map assemble-input (CallKernelPrimitiveProcedure-operands op))])
+        (case operator
+          
+          [(+)
+           (let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
+                                                          rand-vals 
+                                                          rand-knowledge)])
+                 (cond [(empty? rand-vals)
+                        "0"]
+                       [else
+                        (string-append "(" (string-join checked-rands " + ") ")")]))]
+          
+          [(-)
+           (let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
+                                                          rand-vals 
+                                                          rand-knowledge)])
+             (cond [(empty? rand-vals)
+                    (error '- "Expects at least 1 argument, given 0")]
+                   [(empty? (rest rand-vals))
+                    (format "(-(~a))" (first rand-vals))]
+                   [else
+                    (string-append "(" (string-join checked-rands "-") ")")]))]
+
+          [(*)
+           (let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
+                                                          rand-vals 
+                                                          rand-knowledge)])
+             (cond [(empty? rand-vals)
+                    "1"]
+                   [else
+                    (string-append "(" (string-join checked-rands "*") ")")]))]
+
+          [(/)
+           (let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
+                                                          rand-vals 
+                                                          rand-knowledge)])
+             (cond [(empty? rand-vals)
+                    (error '/ "Expects at least 1 argument, given 0")]
+                   [else
+                    (string-append "(" (string-join checked-rands "/") ")")]))]
+
+          [(add1)
+           (unless (= 1 (length rand-vals))
+             (error 'add1 "Expected one argument"))
+           (format "(~a + 1)" 
+                   (maybe-typecheck-operand 'number 0 (first rand-vals) (first rand-knowledge)))]
+          
+          [(sub1)
+           (unless (= 1 (length rand-vals))
+             (error 'sub1 "Expected one argument"))
+           (format "(~a - 1)" 
+                   (maybe-typecheck-operand 'number 0 (first rand-vals) (first rand-knowledge)))]
+          
+          [(<)
+           (unless (> (length rand-vals) 0)
+             (error '< "Expected at least one argument"))
+           (assemble-chain "<" (maybe-typecheck-operands (repeat 'number (length rand-vals))
+                                                         rand-vals
+                                                         rand-knowledge))]
+          [(<=)
+           (unless (> (length rand-vals) 0)
+             (error '<= "Expected at least one argument"))
+           (assemble-chain "<=" (maybe-typecheck-operands (repeat 'number (length rand-vals))
+                                                         rand-vals
+                                                         rand-knowledge))]
+          
+          [(=)
+           (unless (> (length rand-vals) 0)
+             (error '= "Expected at least one argument"))
+           (assemble-chain "==" (maybe-typecheck-operands (repeat 'number (length rand-vals))
+                                                         rand-vals
+                                                         rand-knowledge))]
+          
+          [(>)
+           (unless (> (length rand-vals) 0)
+             (error '> "Expected at least one argument"))
+           (assemble-chain ">" (maybe-typecheck-operands (repeat 'number (length rand-vals))
+                                                         rand-vals
+                                                         rand-knowledge))]
+          
+          [(>=)
+           (unless (> (length rand-vals) 0)
+             (error '>= "Expected at least one argument"))
+           (assemble-chain ">=" (maybe-typecheck-operands (repeat 'number (length rand-vals))
+                                                         rand-vals
+                                                         rand-knowledge))]
+          
+          [(cons)
+           (unless (= (length rand-vals) 2)
+             (error 'cons "Expected two arguments"))
+           (format "[~a, ~a]" (first rand-vals) (second rand-vals))]
+
+          [(car)
+           (unless (= (length rand-vals) 1)
+             (error 'car "Expected one argument"))
+           (format "(~a)[0]" (maybe-typecheck-operand 'pair 0 (first rand-vals)
+                                                      (first rand-knowledge)))]
+          
+          [(cdr)
+           (unless (= (length rand-vals) 1)
+             (error 'cdr "Expected one argument"))
+           (format "(~a)[1]" (maybe-typecheck-operand 'pair 0 (first rand-vals)
+                                                      (first rand-knowledge)))]
+          
+          [(list)
+           (let loop ([rand-vals rand-vals])
+             (cond
+               [(empty? rand-vals)
+                "Primitives.null"]
+               [else
+                (format "[~a,~a]" (first rand-vals) (loop (rest rand-vals)))]))]
+          
+          [(null?)
+           (unless (= (length rand-vals) 1)
+             (error 'null? "Expected one argument"))
+           (format "(~a === Primitives.null)"
+                   (first rand-vals))]
+          [(not)
+           (unless (= (length rand-vals) 1)
+             (error 'not? "Expected one argument"))
+           (format "(!~a)" (first rand-vals))]
+          
+          [(eq?)
+           (unless (= (length rand-vals) 2)
+             (error 'eq? "Expected 2 arguments"))
+           (format "(~a === ~a)" (first rand-vals) (second rand-vals))])))
+
+
+(: assemble-chain (String (Listof String) -> String))
+(define (assemble-chain rator rands)
+  (string-append "("
+                 (string-join (let: loop : (Listof String) ([rands : (Listof String) rands])
+                                (cond
+                                  [(empty? rands)
+                                   '()]
+                                  [(empty? (rest rands))
+                                   '()]
+                                  [else
+                                   (cons (format "(~a ~a ~a)" (first rands) rator (second rands))
+                                         (loop (rest rands)))]))
+                              "&&")
+                 ")"))
+
+
+
+(define-type OperandDomain (U 'number
+                              'string
+                              'box
+                              'list
+                              'pair))
+
+
+(: assemble-domain-check (OperandDomain String Natural -> String))
+(define (assemble-domain-check domain operand-string pos)
+  (let ([test-string 
+         (case domain
+           [(number)
+            (format "typeof(~a) === 'number'"
+                    operand-string)]             
+           [(string)
+            (format "typeof(~a) === 'string'"
+                    operand-string)]
+           [(list)
+            (format "(~a === [] || (typeof(~a) === 'object' && (~a).length === 2))"
+                    operand-string operand-string operand-string)]
+           [(pair)
+            (format "(typeof(~a) === 'object' && (~a).length === 2)"
+                    operand-string operand-string)])])
+    (format "(~a ? ~a : raise(new Error('Expected ' + ~a + ' as argument ' + ~s + ' but received ' + ~a)))"
+            test-string
+            operand-string
+            domain
+            pos
+            operand-string)))
+
+(: maybe-typecheck-operands ((Listof OperandDomain) 
+                             (Listof String) 
+                             (Listof CompileTimeEnvironmentEntry) -> (Listof String)))
+(define (maybe-typecheck-operands expected-domains rand-vals rand-knowledge)
+  (map (lambda: ([rand : String]
+                 [expected-domain : OperandDomain]
+                 [knowledge : CompileTimeEnvironmentEntry]
+                 [position : Natural])
+                (maybe-typecheck-operand expected-domain position rand knowledge))
+       rand-vals
+       expected-domains
+       rand-knowledge
+       (build-list (length rand-vals)
+                   (lambda: ([i : Natural]) i))))
+
+
+(: maybe-typecheck-operand (OperandDomain Natural String CompileTimeEnvironmentEntry -> String))
+(define (maybe-typecheck-operand domain-type position operand-string knowledge)
+  (cond
+    [(redundant-check? domain-type knowledge)
+     operand-string]
+    [else
+     (assemble-domain-check domain-type operand-string position)]))
+
+
+(: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean))
+(define (redundant-check? domain-type knowledge)
+  #f)
+
+
+         (: repeat (All (A) (A Natural -> (Listof A))))
+(define (repeat x n)
+  (build-list n (lambda (i) x)))

assemble.rkt

@@ -2,6 +2,8 @@
 (require "il-structs.rkt"
          "lexical-structs.rkt"
          "helpers.rkt"
+         "assemble-helpers.rkt"
+         "assemble-open-coded.rkt"
          racket/string
          racket/list)
 
@@ -218,21 +220,7 @@ EOF
           (string-join (map assemble-statement (BasicBlock-stmts a-basic-block))
                        "\n")))
 
-(: assemble-oparg (OpArg -> String))
+
-(define (assemble-oparg v)
-  (cond 
-    [(Reg? v)
-     (assemble-reg v)]
-    [(Label? v)
-     (assemble-label v)]
-    [(Const? v)
-     (assemble-const v)]
-    [(EnvLexicalReference? v)
-     (assemble-lexical-reference v)]
-    [(EnvPrefixReference? v)
-     (assemble-prefix-reference v)]
-    [(EnvWholePrefixReference? v)
-     (assemble-whole-prefix-reference v)]))
 
 
 (: assemble-statement (UnlabeledStatement -> String))
@@ -300,64 +288,10 @@ EOF
 
 
 
-(: assemble-target (Target -> String))
-(define (assemble-target target)
-  (cond
-    [(eq? target 'proc)
-     "MACHINE.proc"]
-    [(eq? target 'val)
-     "MACHINE.val"]
-    [(EnvLexicalReference? target)
-     (assemble-lexical-reference target)]
-    [(EnvPrefixReference? target)
-     (assemble-prefix-reference target)]
-    [(PrimitivesReference? target)
-     (format "Primitives[~s]" (symbol->string (PrimitivesReference-name target)))]))
 
 
 
 
-;; fixme: use js->string
-(: assemble-const (Const -> String))
-(define (assemble-const stmt)
-  (let: loop : String ([val : Any (Const-const stmt)])
-        (cond [(symbol? val)
-               (format "~s" (symbol->string val))]
-              [(pair? val)
-               (format "[~a, ~a]" 
-                       (loop (car val))
-                       (loop (cdr val)))]
-              [(boolean? val)
-               (if val "true" "false")]
-              [(void? val)
-               "null"]
-              [(empty? val)
-               (format "Primitives.null")]
-              [(number? val)
-               (format "(~s)" val)]
-              [else
-               (format "~s" val)])))
-
-
-(: assemble-lexical-reference (EnvLexicalReference -> String))
-(define (assemble-lexical-reference a-lex-ref)
-  (if (EnvLexicalReference-unbox? a-lex-ref)
-      (format "MACHINE.env[MACHINE.env.length - 1 - ~a][0]"
-              (EnvLexicalReference-depth a-lex-ref))
-      (format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
-              (EnvLexicalReference-depth a-lex-ref))))
-
-(: assemble-prefix-reference (EnvPrefixReference -> String))
-(define (assemble-prefix-reference a-ref)
-  (format "MACHINE.env[MACHINE.env.length - 1 - ~a][~a]"
-          (EnvPrefixReference-depth a-ref)
-          (EnvPrefixReference-pos a-ref)))
-
-(: assemble-whole-prefix-reference (EnvWholePrefixReference -> String))
-(define (assemble-whole-prefix-reference a-prefix-ref)
-  (format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
-          (EnvWholePrefixReference-depth a-prefix-ref)))
-
 
 (: assemble-env-reference/closure-capture (Natural -> String))
 ;; When we're capturing the values for a closure, we need to not unbox
@@ -423,112 +357,6 @@ EOF
 
 
 
-;; FIXME: this needs to check that the domains are good!
-(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String))
-(define (open-code-kernel-primitive-procedure op)
-  (let: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)]
-         [rand-vals : (Listof String) (map assemble-input (CallKernelPrimitiveProcedure-operands op))])
-        (case operator
-          [(+)
-           (cond [(empty? rand-vals)
-                  "0"]
-                 [else
-                  (string-append "(" 
-                                 (string-join rand-vals " + ") 
-                                 ")")])]
-          [(-)
-           (cond [(empty? rand-vals)
-                  (error '- "Expects at least 1 argument, given 0")]
-                 [(empty? (rest rand-vals))
-                  (format "(-(~a))" (first rand-vals))]
-                 [else
-                  (string-append "(" (string-join rand-vals "-") ")")])]
-          [(*)
-           (cond [(empty? rand-vals)
-                  "1"]
-                 [else
-                  (string-append "(" (string-join rand-vals "*") ")")])]
-          [(/)
-           (cond [(empty? rand-vals)
-                  (error '/ "Expects at least 1 argument, given 0")]
-                 [else
-                  (string-append "(" (string-join rand-vals "/") ")")])]
-          [(add1)
-           (unless (= 1 (length rand-vals))
-             (error 'add1 "Expected one argument"))
-           (format "(~a + 1)" (first rand-vals))]
-          [(sub1)
-           (unless (= 1 (length rand-vals))
-             (error 'sub1 "Expected one argument"))
-           (format "(~a - 1)" (first rand-vals))]
-          [(<)
-           (unless (> (length rand-vals) 0)
-             (error '< "Expected at least one argument"))
-           (assemble-chain "<" rand-vals)]
-          [(<=)
-           (unless (> (length rand-vals) 0)
-             (error '<= "Expected at least one argument"))
-           (assemble-chain "<=" rand-vals)]
-          [(=)
-           (unless (> (length rand-vals) 0)
-             (error '= "Expected at least one argument"))
-           (assemble-chain "==" rand-vals)]
-          [(>)
-           (unless (> (length rand-vals) 0)
-             (error '> "Expected at least one argument"))
-           (assemble-chain ">" rand-vals)]
-          [(>=)
-           (unless (> (length rand-vals) 0)
-             (error '>= "Expected at least one argument"))
-           (assemble-chain ">=" rand-vals)]
-          [(cons)
-           (unless (= (length rand-vals) 2)
-             (error 'cons "Expected two arguments"))
-           (format "[~a, ~a]" (first rand-vals) (second rand-vals))]
-          [(car)
-           (unless (= (length rand-vals) 1)
-             (error 'car "Expected one argument"))
-           (format "(~a)[0]" (first rand-vals))]
-          [(cdr)
-           (unless (= (length rand-vals) 1)
-             (error 'cdr "Expected one argument"))
-           (format "(~a)[1]" (first rand-vals))]
-          [(list)
-           (let loop ([rand-vals rand-vals])
-             (cond
-               [(empty? rand-vals)
-                "Primitives.null"]
-               [else
-                (format "[~a,~a]" (first rand-vals) (loop (rest rand-vals)))]))]
-          [(null?)
-           (unless (= (length rand-vals) 1)
-             (error 'null? "Expected one argument"))
-           (format "(~a === Primitives.null)"
-                   (first rand-vals))]
-          [(not)
-           (unless (= (length rand-vals) 1)
-             (error 'not? "Expected one argument"))
-           (format "(!~a)" (first rand-vals))]
-          [(eq?)
-           (unless (= (length rand-vals) 2)
-             (error 'eq? "Expected 2 arguments"))
-           (format "(~a === ~a)" (first rand-vals) (second rand-vals))])))
-
-
-(: assemble-chain (String (Listof String) -> String))
-(define (assemble-chain rator rands)
-  (string-append "("
-                 (string-join (let: loop : (Listof String) ([rands : (Listof String) rands])
-                                (cond
-                                  [(empty? rands)
-                                   '()]
-                                  [(empty? (rest rands))
-                                   '()]
-                                  [else
-                                   (cons (format "(~a ~a ~a)" (first rands) rator (second rands))
-                                         (loop (rest rands)))]))
-                              "&&")
-                 ")"))
 
 
 
@@ -591,21 +419,6 @@ EOF
                           ", "))]))
 
 
-(: assemble-input (OpArg -> String))
-(define (assemble-input an-input)
-  (cond
-    [(Reg? an-input)
-     (assemble-reg an-input)]
-    [(Const? an-input)
-     (assemble-const an-input)]
-    [(Label? an-input)
-     (assemble-label an-input)]
-    [(EnvLexicalReference? an-input)
-     (assemble-lexical-reference an-input)]
-    [(EnvPrefixReference? an-input)
-     (assemble-prefix-reference an-input)]
-    [(EnvWholePrefixReference? an-input)
-     (assemble-whole-prefix-reference an-input)]))
 
 (: assemble-location ((U Reg Label) -> String))
 (define (assemble-location a-location)
@@ -615,10 +428,4 @@ EOF
     [(Label? a-location)
      (assemble-label a-location)]))
 
-(: assemble-reg (Reg -> String))
-(define (assemble-reg a-reg)
-  (string-append "MACHINE." (symbol->string (Reg-name a-reg))))
 
-(: assemble-label (Label -> String))
-(define (assemble-label a-label)
-  (symbol->string (Label-name a-label)))

compile.rkt

@@ -13,19 +13,6 @@
 
 
 
-;; We try to keep at compile time a mapping from environment positions to
-;; statically known things, to generate better code.
-(define-struct: StaticallyKnownLam ([name : (U Symbol False)]
-                                    [entry-point : Symbol]
-                                    [arity : Natural]) #:transparent)
-
-(define-type CompileTimeEnvironmentEntry 
-  (U '? Prefix StaticallyKnownLam ModuleVariable))
-
-(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))
-
-
-
 
 
 (: -compile (ExpressionCore Target Linkage -> (Listof Statement)))
@@ -450,17 +437,11 @@
 ;; of hardcoded primitives.
 (define (compile-kernel-primitive-application kernel-op exp cenv extended-cenv target linkage)
   (let* ([n (length (App-operands exp))]
-         [operand-poss
+         [operand-knowledge (map (lambda: ([arg : ExpressionCore])
-          (build-list (length (App-operands exp))
+                                          (extract-static-knowledge arg extended-cenv))
-                      (lambda: ([i : Natural])
+                                 (App-operands exp))])
-                               (make-EnvLexicalReference i #f)))]
-         [operand-codes (map (lambda: ([operand : Expression]
-                                       [target : Target])
-                                      (compile operand extended-cenv target next-linkage))
-                             (App-operands exp)
-                             operand-poss)])
     (cond 
-      ;; Special case optimization: we can avoid pushing the stack altogether
+      ;; Special case optimization: we can avoid touching the stack altogether
       [(all-operands-are-constant-or-stack-references (App-operands exp))
        => (lambda (opargs)
             (end-with-linkage
@@ -468,31 +449,43 @@
              (make-instruction-sequence
               `(,(make-AssignPrimOpStatement
                   target
-                  (make-CallKernelPrimitiveProcedure kernel-op (map (lambda: ([arg : OpArg])
+                  (make-CallKernelPrimitiveProcedure kernel-op 
-                                                                             (adjust-oparg-depth arg (- n)))
+                                                     (map (lambda: ([arg : OpArg])
-                                                                    opargs)))))))]
+                                                                   (adjust-oparg-depth arg (- n)))
+                                                          opargs)
+                                                     operand-knowledge))))))]
       [else
-       (end-with-linkage 
+       (let* ([operand-poss
-        linkage cenv
+               (build-list (length (App-operands exp))
-        (append-instruction-sequences
+                           (lambda: ([i : Natural])
-         
+                                    (make-EnvLexicalReference i #f)))]
-         (if (not (empty? (App-operands exp)))
+              [operand-codes (map (lambda: ([operand : Expression]
-             (make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f)))
+                                            [target : Target])
-             empty-instruction-sequence)
+                                           (compile operand extended-cenv target next-linkage))
-         
+                                  (App-operands exp)
-         (apply append-instruction-sequences operand-codes)
+                                  operand-poss)])
-         
+         (end-with-linkage 
-         (make-instruction-sequence 
+          linkage cenv
-          `(,(make-AssignPrimOpStatement 
+          (append-instruction-sequences
-              ;; Optimization: we put the result directly in the registers, or in
+           
-              ;; the appropriate spot on the stack.  This takes into account the popenviroment
+           (if (not (empty? (App-operands exp)))
-              ;; that happens right afterwards.
+               (make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f)))
-              (adjust-target-depth target n)                     
+               empty-instruction-sequence)
-              (make-CallKernelPrimitiveProcedure kernel-op operand-poss))))
+           
-         
+           (apply append-instruction-sequences operand-codes)
-         (if (> n 0)
+           
-             (make-instruction-sequence `(,(make-PopEnvironment n 0)))
+           (make-instruction-sequence 
-             empty-instruction-sequence)))])))
+            `(,(make-AssignPrimOpStatement 
+                ;; Optimization: we put the result directly in the registers, or in
+                ;; the appropriate spot on the stack.  This takes into account the popenviroment
+                ;; that happens right afterwards.
+                (adjust-target-depth target n)                     
+                (make-CallKernelPrimitiveProcedure kernel-op 
+                                                   operand-poss
+                                                   operand-knowledge))))
+           (if (> n 0)
+               (make-instruction-sequence `(,(make-PopEnvironment n 0)))
+               empty-instruction-sequence))))])))
 
 
 

il-structs.rkt

@@ -181,7 +181,8 @@
 
 
 (define-struct: CallKernelPrimitiveProcedure ([operator : KernelPrimitiveName]
-                                              [operands : (Listof OpArg)])
+                                              [operands : (Listof OpArg)]
+                                              [operands-knowledge : (Listof CompileTimeEnvironmentEntry)])
   #:transparent)
 
 
@@ -304,6 +305,34 @@
 
 
 
+
+
+
+
+
+
+
+;; Static knowledge about a value
+
+;; We try to keep at compile time a mapping from environment positions to
+;; statically known things, to generate better code.
+(define-struct: StaticallyKnownLam ([name : (U Symbol False)]
+                                    [entry-point : Symbol]
+                                    [arity : Natural]) #:transparent)
+
+(define-type CompileTimeEnvironmentEntry 
+  (U '?          ;; no knowledge
+     Prefix      ;; placeholder: necessary since the toplevel lives in the environment too
+     StaticallyKnownLam ;; The value is a known lam
+     ModuleVariable     ;; The value is a known module variable
+     ))
+
+(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))
+
+
+
+
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Assembly
 

runtime.js

@@ -27,6 +27,8 @@ var Closure = function(label, arity, closedVals, displayName) {
     this.displayName = displayName;
 };
 
+
+
 // A primitive function is just a Javascript function.
 
 
@@ -42,14 +44,18 @@ var testArgument = function(expectedTypeName,
     if (predicate(val)) {
 	return true;
     }
-    throw new Error(callerName + ": expected " + expectedTypeName
+    else {
-		    + " as argument #" + position 
+	raise(new Error(callerName + ": expected " + expectedTypeName
-		    + " but received " + val + " instead");
+			+ " as argument #" + position 
+			+ " but received " + val + " instead"));
+    }
 };
 
 var isNumber = function(x) { return typeof(x) === 'number'; };
 
 
+var raise = function(e) { throw e; }
+
 
 var Primitives = (function() {
     var NULL = [];
@@ -144,7 +150,7 @@ var Primitives = (function() {
 	},
 	
 	'-': function(MACHINE, arity) {
-	    if (arity === 0) { throw new Error(); }
+	    if (arity === 0) { raise(new Error()); }
 	    if (arity === 1) { 
 		testArgument('number',
 			     isNumber,
@@ -166,7 +172,7 @@ var Primitives = (function() {
 	},
 	
 	'/': function(MACHINE, arity) {
-	    if (arity === 0) { throw new Error(); }
+	    if (arity === 0) { raise(new Error();) }
 	    testArgument('number',
 			 isNumber,
 			 MACHINE.env[MACHINE.env.length - 1],