trying to move the type analysis over to compile time rather than assemble time

assemble-open-coded.rkt

@@ -3,6 +3,7 @@
 (require "il-structs.rkt"
          "lexical-structs.rkt"
          "assemble-helpers.rkt"
+         "kernel-primitives.rkt"
          racket/string
          racket/list)
 
@@ -160,11 +161,6 @@
 
 
 
-(define-type OperandDomain (U 'number
-                              'string
-                              'box
-                              'list
-                              'pair))
 
 
 (: assemble-domain-check (OperandDomain String Natural -> String))

compile.rkt

@@ -3,6 +3,7 @@
 (require "expression-structs.rkt"
          "lexical-structs.rkt"
          "il-structs.rkt"
+         "kernel-primitives.rkt"
          racket/bool
          racket/list)
 
@@ -439,9 +440,15 @@
 ;; of hardcoded primitives.
 (define (compile-kernel-primitive-application kernel-op exp cenv extended-cenv target linkage)
   (let* ([n (length (App-operands exp))]
+         [expected-operand-types (kernel-primitive-expected-operand-types kernel-op n)]
          [operand-knowledge (map (lambda: ([arg : Expression])
                                           (extract-static-knowledge arg extended-cenv))
-                                 (App-operands exp))])
+                                 (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)])
     (cond 
       ;; Special case optimization: we can avoid touching the stack altogether
       [(all-operands-are-constant-or-stack-references (App-operands exp))
@@ -455,7 +462,8 @@
                                                      (map (lambda: ([arg : OpArg])
                                                                    (adjust-oparg-depth arg (- n)))
                                                           opargs)
-                                                     operand-knowledge))))))]
+                                                     expected-operand-types
+                                                     typechecks?))))))]
       [else
        (let* ([operand-poss
                (build-list (length (App-operands exp))
@@ -484,12 +492,34 @@
                 (adjust-target-depth target n)                     
                 (make-CallKernelPrimitiveProcedure kernel-op 
                                                    operand-poss
-                                                   operand-knowledge))))
+                                                   expected-operand-types
+                                                   typechecks?))))
+           
            (if (> n 0)
                (make-instruction-sequence `(,(make-PopEnvironment n 0)))
                empty-instruction-sequence))))])))
 
 
+(: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean))
+;; Produces true if we know the knowledge implies the domain-type.
+(define (redundant-check? domain-type knowledge)
+  (cond [(Const? knowledge)
+         (case domain-type
+           [(number)
+            (number? (Const-const knowledge))]
+           [(string)
+            (string? (Const-const knowledge))]
+           [(box)
+            (box? (Const-const knowledge))]
+           [(list)
+            (list? (Const-const knowledge))]
+           [(pair)
+            (pair? (Const-const knowledge))]
+           [(any)
+            #t])]
+        [else
+         #f]))
+
 
 (: all-operands-are-constant-or-stack-references ((Listof Expression) -> (U False (Listof OpArg))))
 ;; Produces a list of OpArgs if all the operands are particularly simple, and false otherwise.

il-structs.rkt

@@ -1,7 +1,8 @@
 #lang typed/racket/base
 (provide (all-defined-out))
 
-(require "lexical-structs.rkt")
+(require "lexical-structs.rkt"
+         "kernel-primitives.rkt")
 
 
 
@@ -157,32 +158,16 @@
 
 
 
-;; The following are primitives that the compiler knows about:
+
-(define-type KernelPrimitiveName (U '+
+
-                                    '-
-                                    '*
-                                    '/
-                                    'add1
-                                    'sub1
-                                    '<
-                                    '<=
-                                    '=
-                                    '>
-                                    '>=
-                                    'cons
-                                    'car
-                                    'cdr
-                                    'list
-                                    'null?
-                                    'not
-                                    'eq?
-                                    ))
-(define-predicate KernelPrimitiveName? KernelPrimitiveName)
 
 
 (define-struct: CallKernelPrimitiveProcedure ([operator : KernelPrimitiveName]
+
                                               [operands : (Listof OpArg)]
-                                              [operands-knowledge : (Listof CompileTimeEnvironmentEntry)])
+                                              [expected-operand-types : (Listof OperandDomain)]
+                                              ;; For each operand, #t will add code to typecheck the operand
+                                              [typechecks? : (Listof Boolean)])
   #:transparent)
 
 

kernel-primitives.rkt

@@ -0,0 +1,115 @@
+#lang typed/racket/base
+
+(provide (all-defined-out))
+
+
+(define-type OperandDomain (U 'number
+                              'string
+                              'box
+                              'list
+                              'pair
+                              'any))
+
+
+;; The following are primitives that the compiler knows about:
+(define-type KernelPrimitiveName (U '+
+                                    '-
+                                    '*
+                                    '/
+                                    'add1
+                                    'sub1
+                                    '<
+                                    '<=
+                                    '=
+                                    '>
+                                    '>=
+                                    'cons
+                                    'car
+                                    'cdr
+                                    'list
+                                    'null?
+                                    'not
+                                    'eq?
+                                    ))
+(define-predicate KernelPrimitiveName? KernelPrimitiveName)
+
+
+
+(: kernel-primitive-expected-operand-types (KernelPrimitiveName Natural -> (Listof OperandDomain)))
+;; Given a primitive and the number of arguments, produces the list of expected domains.
+;; TODO: do something more polymorphic.
+(define (kernel-primitive-expected-operand-types prim arity)
+  (cond
+    [(eq? prim '+)
+     (build-list arity (lambda (i) 'number))]
+
+    [(eq? prim '-)
+     (unless (> arity 0)
+       (error '- "expects at least one argument, given ~a" arity))
+     (build-list arity (lambda (i) 'number))]
+
+    [(eq? prim '*)
+     (build-list arity (lambda (i) 'number))]
+
+    [(eq? prim '/)
+     (unless (> arity 0)
+       (error '/ "expects at least one argument, given ~a" arity))
+     (build-list arity (lambda (i) 'number))]
+
+    [(eq? prim 'add1)
+     (unless (= arity 1)
+       (error 'add1 "expects exactly one argument, given ~a" arity))
+     (list 'number)]
+    
+    [(eq? prim 'sub1)
+     (unless (= arity 1)
+       (error 'sub1 "expects exactly one argument, given ~a" arity))
+     (list 'number)]
+    
+    [(eq? prim '<)
+     (build-list arity (lambda (i) 'number))]
+    
+    [(eq? prim '<=)
+     (build-list arity (lambda (i) 'number))]
+    
+    [(eq? prim '=)
+     (build-list arity (lambda (i) 'number))]
+    
+    [(eq? prim '>)
+     (build-list arity (lambda (i) 'number))]
+    
+    [(eq? prim '>=)
+     (build-list arity (lambda (i) 'number))]
+
+    [(eq? prim 'cons)
+     (unless (= arity 2)
+       (error 'cons "expects exactly two arguments, given ~a" arity))
+     (list 'any 'any)]
+
+    [(eq? prim 'car)
+     (unless (= arity 1)
+       (error 'car "expects exactly one argument, given ~a" arity))
+     (list 'pair)]
+    
+    [(eq? prim 'cdr)
+     (unless (= arity 1)
+       (error 'cdr "expects exactly one argument, given ~a" arity))
+     (list 'pair)]
+    
+    [(eq? prim 'list)
+     (build-list arity (lambda (i) 'any))]
+    
+    [(eq? prim 'null?)
+     (unless (= arity 1)
+       (error 'null? "expects exactly one argument, given ~a" arity))
+     (list 'any)]
+
+    [(eq? prim 'not)
+     (unless (= arity 1)
+       (error 'not "expects exactly one argument, given ~a" arity))
+     (list 'any)]
+
+    [(eq? prim 'eq?)
+     (unless (= arity 2)
+       (error 'eq? "expects exactly two arguments, given ~a" arity))
+     (list 'any 'any)]))