Use type inference in compile-reference

2 files changed, 92 insertions, 102 deletions

diff --git a/compiler/passes/compile-reference.scm b/compiler/passes/compile-reference.scm
index 790a7b3..101f33b 100644
--- a/compiler/passes/compile-reference.scm
+++ b/compiler/passes/compile-reference.scm
@@ -17,6 +17,7 @@
 (define-module (compiler passes compile-reference)
   #:use-module ((rnrs base) #:select (assert))
   #:use-module (compiler lean)
+  #:use-module (compiler type-inference)
   #:use-module (compiler types)
   #:use-module (compiler utilities)
   #:use-module (ice-9 match)
@@ -24,30 +25,52 @@
   #:export (compile-reference))
 
 (define (compile-reference policy)
-  (define (recur input-identifier form new-identifiers)
-    (match form
-      ((($ <constant> value) rest ...)
-       (let* ((target-cast-id (fresh-identifier new-identifiers))
-              (new-identifiers (cons target-cast-id new-identifiers))
-              (target-cast-id (make <variable-ref> #:name target-cast-id))
+  (define (specialize breadcrumb scope)
+    (define (recur input-identifier form new-identifiers)
+      (match form
+        ((($ <constant> value) rest ...)
+         (let* ((target-cast-id (fresh-identifier new-identifiers))
+                (new-identifiers (cons target-cast-id new-identifiers))
+                (target-cast-id (make <variable-ref> #:name target-cast-id))
 
-              (deref-id (fresh-identifier new-identifiers))
-              (new-identifiers (cons deref-id new-identifiers))
-              (deref-id (make <variable-ref> #:name deref-id)))
-         ;; TODO: If we can infer that the target is an array, we don't want to do the object deref...
-         `((,target-cast-id ,(make <lean-funcall>
-                               #:name "Rego.expectObject"
-                               #:args `(,input-identifier)))
-           (,deref-id       ,(make <lean-funcall>
-                               #:name "Rego.Object.ref"
-                               #:args `(,target-cast-id ,(make <constant> #:value value))))
-           ,@(recur deref-id rest new-identifiers))))
-      (() '())))
+                (deref-id (fresh-identifier new-identifiers))
+                (new-identifiers (cons deref-id new-identifiers))
+                (deref-id (make <variable-ref> #:name deref-id)))
+           (cond ((and (infer-is-a? input-identifier 'array breadcrumb scope)
+                       (infer-is-a? input-identifier 'number breadcrumb scope))
+                  `((,target-cast-id ,(make <lean-funcall>
+                                        #:name "Rego.expectArray"
+                                        #:args `(,input-identifier)))
+                    (,deref-id       ,(make <lean-funcall>
+                                        #:name "Array.get?"
+                                        #:args `(,target-cast-id ,(make <constant> #:value value))))
+                    ,@(recur deref-id rest new-identifiers)))
+                 ((and (infer-is-a? input-identifier 'set breadcrumb scope)
+                       (infer-is-a? input-identifier 'number breadcrumb scope))
+                  `((,target-cast-id ,(make <lean-funcall>
+                                        #:name "Rego.expectSet"
+                                        #:args `(,input-identifier)))
+                    (,deref-id       ,(make <lean-funcall>
+                                        #:name "Array.get?"
+                                        ;; Yes, you're reading this right. Set indices start at `1',
+                                        ;; despite array indices starting at `0'.
+                                        #:args `(,target-cast-id ,(make <constant> #:value (+ 1 value)))))
+                    ,@(recur deref-id rest new-identifiers)))
+                 (else
+                  `((,target-cast-id ,(make <lean-funcall>
+                                        #:name "Rego.expectObject"
+                                        #:args `(,input-identifier)))
+                    (,deref-id       ,(make <lean-funcall>
+                                        #:name "Rego.Object.ref"
+                                        #:args `(,target-cast-id ,(make <constant> #:value value))))
+                    ,@(recur deref-id rest new-identifiers))))))
+        (() '())))
+    recur)
 
   (policy-map
    policy
    (lambda (scope breadcrumb form)
      (match form
        (($ <reference> (first rest ...))
-        (make <lean-assignment-chain> #:identifiers (recur first rest '())))
+        (make <lean-assignment-chain> #:identifiers ((specialize breadcrumb scope) first rest '())))
        (_ form)))))
diff --git a/compiler/type-inference.scm b/compiler/type-inference.scm
index 289ed1b..b5f4189 100644
--- a/compiler/type-inference.scm
+++ b/compiler/type-inference.scm
@@ -17,12 +17,15 @@
 (define-module (compiler type-inference)
   #:use-module ((rnrs base) #:select (assert))
   #:use-module (compiler types)
+  #:use-module (compiler utilities)
   #:use-module (ice-9 match)
   #:use-module (minikanren mk)
   #:use-module (minikanren mkextraforms)
   #:use-module (minikanren mkprelude)
   #:use-module (srfi srfi-1)
-  #:export (constrain-form))
+  #:use-module (oop goops)
+  #:export (infer-type
+            infer-is-a?))
 
 ;; Given a pair (x y), assert that y is a valid type for dereferencing.
 (define valid-deref
@@ -44,102 +47,66 @@
 
 
 
-(define (normalize form)
-  "Return FORM with all free variables replaced with a unique `var'"
-  (make-reference
-   (map (match-lambda
-          (($ <variable-ref> name) (make-variable-ref (var (string->symbol name))))
-          (otherwise otherwise))
-        (reference-parts form))))
-
-(define (normalize-context form context)
-  "Replace references in CONTEXT with normalized `var' forms from FORM"
-  (define variables (free-variables form))
-  (define (lookup-var name)
-    (find (lambda (mk-var)
-            (string= name (symbol->string (vector-ref mk-var 0))))
-          variables))
-  (map (lambda (pair)
-         (list (lookup-var (car pair)) (cadr pair)))
-       context))
+(define types
+  '(null bool number string array set object
+    any))
 
-(define (reference->constraints ref anon)
-  "Generate implicit constraints for reference REF in terms of ANON intermediate variables"
-  (define anon-normalized
-    (map make-variable-ref anon))
-  (define triples
-    (cons (append (take (reference-parts ref) 2) (take anon-normalized 1))
-          (zip anon-normalized (drop (reference-parts ref) 2) (drop anon-normalized 1))))
-  (define result
-    (map (lambda (triple)
-           (match triple
-             ((($ <variable-ref> x) ($ <constant> value) ($ <variable-ref> z))
-              (cond ((string? value) `(,(== x 'object)))
-                    ((number? value) `(,(membero x '(array list))))
-                    (error "attempting to deref with unknown type" value)))
-             ((($ <variable-ref> x) ($ <variable-ref> y) ($ <variable-ref> z))
-              `(,(valid-deref x y)))
-             (_ '())))
-         triples))
-  (map first (filter (negate null?) result)))
+(define constraints
+  '(== membero))
 
-(define (context->constraints context)
-  "Generate a list of constraints and a list of variables from CONTEXT"
-  (define result
-    (map (match-lambda
-           ((name type) `(,(== name type))))
-         context))
-  (map first (filter (negate null?) result)))
+(define (normalize form)
+  "Return FORM with all free variables replaced with a unique `var'"
+  (map (lambda (x)
+         (if (and (symbol? x)
+                  (not (memq x types))
+                  (not (memq x constraints)))
+             (var x)
+             x))
+       form))
 
 (define (free-variables form)
   "Return all `var' forms in a normalized FORM"
-  (map variable-ref-name (filter variable-ref? (reference-parts form))))
+  (filter var? form))
+
+(define (mk-variable-for constraints identifier breadcrumb)
+  "Search CONSTRAINTS for the minikanren variable associated with IDENTIFIER
 
-(define (anonymous-variables form)
-  "Return anonymous `var' forms for each intermediate in the deref chain"
-  (map (lambda (_) (var 'x)) (iota (1- (length (reference-parts form))))))
+`breadcrumb' is necessary to uniquely identify `identifier'."
+  (find (lambda (x)
+          (eqv? (canonicalize identifier breadcrumb)
+                (vector-ref x 0)))
+        (flat-map free-variables constraints)))
 
-(define (constrain-form form context)
-  "Return a set of (variable-name type) pairs for any variables whose type is deducible
+(define (evaluate-constraints constraints)
+  "Make CONSTRAINTS, generated by compiler passes, usable by minikanren"
+  (map (match-lambda
+         (('== args ...) (apply == args))
+         (('membero args ...) (apply membero args)))
+       constraints))
 
-Context is a list of (variable-name type) that is already known, e.g., from the
-local scope.
+(define (infer-type identifier breadcrumb scope)
+  "Return a list of possible types for IDENTIFIER
 
-Raises an error if there is no information to deduce (i.e., `form' consists of 0
-or 1 components.)"
-  (assert (< 1 (length (reference-parts form))))
-  (let* ((form (normalize form))
-         (variables (free-variables form))
-         (anonymous (anonymous-variables form))
-         (cf-constraints (reference->constraints form anonymous))
-         (context (normalize-context form context))
-         (context-constraints (context->constraints context)))
+`breadcrumb' is necessary to uniquely identify `identifier' within `scope'."
+  (let* ((constraints (collapse-constraints scope))
+         (constraints (map normalize constraints))
+         (variables (flat-map free-variables constraints)))
     (let* ((x (var 'pairs))
            (solutions
             (map-inf #f
                      (lambda (s)
                        (reify (walk* x s)))
-                     ((primitive-all (append (list (== x variables))
-                                             cf-constraints
-                                             context-constraints))
+                     ((primitive-all (append ;; (list (== x variables))
+                                      `(,(== x (mk-variable-for constraints identifier breadcrumb)))
+                                      (evaluate-constraints constraints)))
                       empty-s))))
-      (map (lambda (solution)
-             (zip (map (lambda (mk-var) (symbol->string (vector-ref mk-var 0))) variables)
-                  solution))
-           (delete-duplicates! solutions)))))
+      (delete-duplicates! solutions))))
 
-;; (define form
-;;   (make-reference
-;;    `(,(make-variable-ref "apps")
-;;      ,(make-variable-ref "i")
-;;      ,(make-variable-ref "servers")
-;;      ,(make-constant 2))))
+(define (infer-is-a? identifier type breadcrumb scope)
+  "Return whether or not we can infer IDENTIFIER to be a TYPE
 
-;; scheme@(compiler type-inference)> (constrain-form form '())
-;; $72 = ((("apps" object) ("i" string) ("servers" string)) (("apps" object) ("i" string) ("servers" number)) (("apps" array) ("i" number) ("servers" string)) (("apps" array) ("i" number) ("servers" number)) (("apps" list) ("i" number) ("servers" string)) (("apps" list) ("i" number) ("servers" number)))
-;; scheme@(compiler type-inference)> (constrain-form form '(("apps" object)))
-;; $73 = ((("apps" object) ("i" string) ("servers" string)) (("apps" object) ("i" string) ("servers" number)))
-;; scheme@(compiler type-inference)> (constrain-form form '(("apps" object) ("servers" object)))
-;; $74 = ()
-;; scheme@(compiler type-inference)> (constrain-form form '(("apps" object) ("servers" number)))
-;; $75 = ((("apps" object) ("i" string) ("servers" number)))
+`breadcrumb' is necessary to uniquely identify `identifier' within `scope'."
+  (let ((possible-types (infer-type identifier breadcrumb scope)))
+    (if (= 1 (length possible-types))
+        (eqv? type (first possible-types))
+        #f)))