adding kernel primitive as opargs.

assemble-helpers.rkt

@@ -51,7 +51,9 @@
     [(CompiledProcedureEntry? v)
      (assemble-compiled-procedure-entry v)]
     [(CompiledProcedureClosureReference? v)
-     (assemble-compiled-procedure-closure-reference v)]))
+     (assemble-compiled-procedure-closure-reference v)]
+    [(PrimitiveKernelValue? v)
+     (assemble-primitive-kernel-value v)]))
 
 
 
@@ -260,3 +262,6 @@
       (assemble-label a-location)]))
 
 
+(: assemble-primitive-kernel-value (PrimitiveKernelValue -> String))
+(define (assemble-primitive-kernel-value a-prim)
+  (format "MACHINE.primitives[~s]" (symbol->string (PrimitiveKernelValue-id a-prim))))

collect-jump-targets.rkt

@@ -1,5 +1,6 @@
 #lang typed/racket/base
-(require "il-structs.rkt"
+(require "expression-structs.rkt"
+         "il-structs.rkt"
 	 "lexical-structs.rkt"
 	 "helpers.rkt"
 	 racket/list)
@@ -88,7 +89,9 @@
    [(CompiledProcedureEntry? an-input)
     (collect-input (CompiledProcedureEntry-proc an-input))]
    [(CompiledProcedureClosureReference? an-input)
-    (collect-input (CompiledProcedureClosureReference-proc an-input))]))
+    (collect-input (CompiledProcedureClosureReference-proc an-input))]
+   [(PrimitiveKernelValue? an-input)
+    empty]))
 
 
 (: collect-location ((U Reg Label) -> (Listof Symbol)))

compiler.rkt

@@ -137,7 +137,9 @@
            (append (loop (ApplyValues-proc exp) cenv)
                    (loop (ApplyValues-args-expr exp) cenv))]
           [(DefValues? exp)
-           (append (loop (DefValues-rhs exp) cenv))])))
+           (append (loop (DefValues-rhs exp) cenv))]
+          [(PrimitiveKernelValue? exp)
+           '()])))
 
 
 
@@ -205,7 +207,9 @@
     [(ApplyValues? exp)
      (compile-apply-values exp cenv target linkage)]
     [(DefValues? exp)
-     (compile-def-values exp cenv target linkage)]))
+     (compile-def-values exp cenv target linkage)]
+    [(PrimitiveKernelValue? exp)
+     (compile-primitive-kernel-value exp cenv target linkage)]))
 
 
 
@@ -1764,6 +1768,24 @@
            
 
 
+(: compile-primitive-kernel-value (PrimitiveKernelValue CompileTimeEnvironment Target Linkage -> InstructionSequence))
+(define (compile-primitive-kernel-value exp cenv target linkage)
+  (let ([id (PrimitiveKernelValue-id exp)])
+    (cond
+      [(KernelPrimitiveName? id)
+       
+       (let ([singular-context-check (emit-singular-context linkage)])
+         ;; Compiles constant values.
+         (end-with-linkage linkage
+                           cenv
+                           (append-instruction-sequences
+                            (make-instruction-sequence
+                             `(,(make-AssignImmediateStatement target exp)
+                            singular-context-check)))))]
+      [else
+       (error 'unimplemented-kernel-primitive 
+              "Primitive Kernel Value ~s has not been implemented"
+              id)])))
 
 
 
@@ -1974,4 +1996,7 @@
                                    (ensure-toplevelref
                                     (adjust-expression-depth id n skip)))
                           (DefValues-ids exp))
-                     (adjust-expression-depth (DefValues-rhs exp) n skip))]))
+                     (adjust-expression-depth (DefValues-rhs exp) n skip))]
+    
+    [(PrimitiveKernelValue? exp)
+     exp]))

expression-structs.rkt

@@ -25,7 +25,8 @@
                          BoxEnv
                          WithContMark
                          ApplyValues
-                         DefValues))
+                         DefValues
+                         PrimitiveKernelValue))
 
 ;; A ModuleName is an identifier for a Module.
 (define-struct: ModuleName ([name : Symbol])
@@ -135,6 +136,11 @@
 
 
 
+(define-struct: PrimitiveKernelValue ([id : Symbol]) #:transparent)
+
+
+
+
 (: last-exp? ((Listof Expression) -> Boolean))
 (define (last-exp? seq) 
   (null? (cdr seq)))

il-structs.rkt

@@ -32,7 +32,8 @@
 		      ControlStackLabel/MultipleValueReturn
                       ControlFrameTemporary
                       CompiledProcedureEntry
-                      CompiledProcedureClosureReference))
+                      CompiledProcedureClosureReference
+                      PrimitiveKernelValue))
 
 
 ;; Targets: these are the allowable lhs's for a targetted assignment.

kernel-primitives.rkt

@@ -34,6 +34,28 @@
 (define-predicate KernelPrimitiveName? KernelPrimitiveName)
 
 
+;; These are the primitives that we know how to inline.
+(define-type KernelPrimitiveName/Inline (U '+
+                                           '-
+                                           '*
+                                           '/
+                                           'add1
+                                           'sub1
+                                           '<
+                                           '<=
+                                           '=
+                                           '>
+                                           '>=
+                                           'cons
+                                           'car
+                                           'cdr
+                                           'list
+                                           'null?
+                                           'not
+                                           'eq?))
+
+
+
 
 (: kernel-primitive-expected-operand-types (KernelPrimitiveName Natural -> (Listof OperandDomain)))
 ;; Given a primitive and the number of arguments, produces the list of expected domains.

optimize-il.rkt

@@ -1,5 +1,6 @@
 #lang typed/racket/base
-(require "il-structs.rkt"
+(require "expression-structs.rkt"
+         "il-structs.rkt"
          "lexical-structs.rkt"
          racket/list)
 
@@ -132,7 +133,9 @@
     [(CompiledProcedureClosureReference? oparg)
      (make-CompiledProcedureClosureReference 
       (adjust-oparg-depth (CompiledProcedureClosureReference-proc oparg) n)
-      (CompiledProcedureClosureReference-n oparg))]))
+      (CompiledProcedureClosureReference-n oparg))]
+    [(PrimitiveKernelValue? oparg)
+     oparg]))
 
 
 (define-predicate natural? Natural)

parse-bytecode-5.1.1.rkt

@@ -38,6 +38,43 @@
 
 
 
+
+
+
+;; Code is copied-and-pasted from compiler/decompile.  Maps the primval ids to their respective
+;; symbolic names.
+(define primitive-table
+  ;; Figure out number-to-id mapping for kernel functions in `primitive'
+  (let ([bindings
+         (let ([ns (make-base-empty-namespace)])
+           (parameterize ([current-namespace ns])
+             (namespace-require ''#%kernel)
+             (namespace-require ''#%unsafe)
+             (namespace-require ''#%flfxnum)
+             (for/list ([l (namespace-mapped-symbols)])
+               (cons l (with-handlers ([exn:fail? (lambda (x) 
+                                                    #f)])
+                         (compile l))))))]
+        [table (make-hash)])
+    (for ([b (in-list bindings)])
+      (let ([v (and (cdr b)
+                    (zo-parse (let ([out (open-output-bytes)])
+                                (write (cdr b) out)
+                                (close-output-port out)
+                                (open-input-bytes (get-output-bytes out)))))])
+        (let ([n (match v
+                   [(struct compilation-top (_ prefix (struct primval (n)))) n]
+                   [else #f])])
+          (hash-set! table n (car b)))))
+    table))
+
+
+
+
+
+
+
+
 ;; parse-bytecode: Input-Port -> Expression
 (define (parse-bytecode in)
   (parameterize ([seen-closures (make-hasheq)])
@@ -430,5 +467,9 @@
 (define (parse-apply-values expr)
   (error 'fixme))
 
+
 (define (parse-primval expr)
-  (error 'fixme))
+  (match expr
+    [(struct primval (id))
+     (let ([name (hash-ref primitive-table id)])
+       (make-PrimitiveKernelValue name))]))

simulator.rkt

@@ -5,7 +5,8 @@
 ;; For example, I'll need to be able to count the number of statements executed by an evaluation.
 ;; I also need to do things like count pushes and pops.  Basically, low-level benchmarking.
 
-(require "il-structs.rkt"
+(require "expression-structs.rkt"
+         "il-structs.rkt"
          "lexical-structs.rkt"
          "simulator-structs.rkt"
          "bootstrapped-primitives.rkt"
@@ -766,7 +767,10 @@
     
     [(CompiledProcedureClosureReference? an-oparg)
      (let ([proc (ensure-closure (evaluate-oparg m (CompiledProcedureClosureReference-proc an-oparg)))])
-       (list-ref (closure-vals proc) (CompiledProcedureClosureReference-n an-oparg)))]))
+       (list-ref (closure-vals proc) (CompiledProcedureClosureReference-n an-oparg)))]
+    
+    [(PrimitiveKernelValue? an-oparg)
+     (lookup-primitive (PrimitiveKernelValue-id an-oparg))]))
 
 
 

test-parse-bytecode-5.1.1.rkt

@@ -23,6 +23,9 @@
       (parse-bytecode (open-input-bytes (get-output-bytes op))))))
 
 
+(check-equal? (run-my-parse #''hello) 
+              (make-Top (make-Prefix '()) 
+                        (make-Constant 'hello)))
 
 (check-equal? (run-my-parse #'"hello world")
               (make-Top (make-Prefix (list))
@@ -85,6 +88,7 @@
 
 
 
+;; let1's
 (check-equal? (run-my-parse #'(let ([y (f)])
                                 'ok))
               (make-Top (make-Prefix (list (make-GlobalBucket 'f)))
@@ -123,6 +127,9 @@
                                               (make-LocalRef 0 #f)))))
 
 
+
+
+;; branches
 (check-equal? (run-my-parse #'(if (f) (g) (h)))
               (make-Top (make-Prefix (list (make-GlobalBucket 'f)
                                            (make-GlobalBucket 'g)
@@ -140,6 +147,31 @@
 
 
 
+(check-equal? (run-my-parse #'(if x (if y z 1) #t))
+              (make-Top (make-Prefix (list (make-GlobalBucket 'x)
+                                           (make-GlobalBucket 'y)
+                                           (make-GlobalBucket 'z)))
+                        (make-Branch (make-ToplevelRef 0 0)
+                                     (make-Branch (make-ToplevelRef 0 1)
+                                                  (make-ToplevelRef 0 2)
+                                                  (make-Constant 1))
+                                     (make-Constant #t))))
+
+
+(check-equal? (run-my-parse #'(cond [x y]))
+              (make-Top (make-Prefix (list (make-GlobalBucket 'x)
+                                           (make-GlobalBucket 'y)))
+                        (make-Branch (make-ToplevelRef 0 0)
+                                     (make-ToplevelRef 0 1)
+                                     (make-Constant (void)))))
+
+
+
+
+(check-equal? (run-my-parse #'+)
+              (make-Top (make-Prefix (list))
+                        (make-PrimitiveKernelValue '+)))
+
 
 
 ;; make sure we don't see an infinite loop
@@ -147,13 +179,12 @@
                   (g)))
 (void (run-my-parse #'(letrec ([g (lambda () (g))])
                         (g))))
-;; todo: add tests to make sure we're parsing this as expected.
+;; todo: add tests to make sure we're parsing this as expected.  We expect to see an EmptyClosureReference here.
-
 
 
 #;(run-zo-parse #'(letrec ([g (lambda () (h))]
-                         [h (lambda () (g))])
+                           [h (lambda () (g))])
-                  (g)))
+                    (g)))
 ;; FIXME: we need to handle closure cycles here.