Allow lifted macro definition to be expanded, for now (#139)

cogs/match/match-tests.scm

@@ -115,3 +115,209 @@
 
 ; Nano pass framework for rewriting and incrementally lowering!
 (remove-constant-anonymous-functions my-expr)
+
+(define type-table
+  (hash '#%prim.cons
+        '((any list?) list?)
+        '#%prim.car
+        '((list?) any)
+        '#%prim.cdr
+        '((list?) any)
+        '#%prim.+
+        '((number? number?) number?)))
+
+(define primitive-table
+  (hash '#%prim.list?
+        'list?
+        '#%prim.number?
+        'number?
+        '#%prim.int?
+        'int?
+        '#%prim.integer?
+        'int?
+        '#%prim.string?
+        'string?))
+
+;; Lower primitives to unsafe variants, by checking if
+;; there are redundant checks for the variable. This can also be done at
+;; the contract level, assuming those checks are visible to the optimizer
+(define (check-type-info raw-expr type-info)
+
+  (match-syntax raw-expr
+    ;; Do this generically for every type?
+    ;; For primitive checks, we can do this
+    [`(if (,primitive-type-check ,variable) ,then-expr ,else-expr)
+     ; #:when (equal? (syntax-e ifp) 'if)
+     ;; Check the type?
+     (define primitive-type-check-type (hash-try-get primitive-table (syntax-e primitive-type-check)))
+     (define maybe-type (check-type-info variable type-info))
+
+     ; (displayln "maybe-type" maybe-type)
+     ; (displayln "primitive-type-check-type" primitive-type-check-type)
+
+     ;; Check that the expected types are the same - if we've concretely found that they won't
+     ;; line up, we should suggest that the then branch is unreachable.
+     (when (and maybe-type
+                primitive-type-check-type
+                (not (equal? 'any maybe-type))
+                (not (equal? primitive-type-check-type maybe-type)))
+       (displayln "Warning: It appears that the then branch is unreachable"))
+
+     ;; Unify these types, otherwise lift to None
+     (let ([then-expr-type (check-type-info
+                            then-expr
+                            (hash-insert type-info (syntax-e variable) primitive-type-check-type))]
+           [else-expr-type (check-type-info else-expr type-info)])
+
+       (if (equal? then-expr-type else-expr-type)
+
+           then-expr-type
+
+           ;; Just promote to the any type
+           'any))
+
+     ; (list (check-type-info then-expr
+     ;                        (hash-insert type-info (syntax-e variable) primitive-type-check-type))
+     ;       (check-type-info else-expr type-info))
+     ]
+    ;; Function application, check that the variable found in `known-variable`
+    ;; matches the expected type from known-variable
+
+    [(list application args ...)
+
+     (define maybe-type (check-type-info application type-info))
+     (define args-types (map (lambda (e) (check-type-info e type-info)) args))
+
+     (match maybe-type
+       [(list args ret-val)
+
+        (unless (equal? args args-types)
+          (error-with-span (syntax-span application)
+                           "Type mismatch! expected "
+                           args
+                           " found "
+                           args-types))
+
+        ret-val]
+
+       [any any])
+
+     ;; Application
+     ; (define maybe-type (hash-try-get type-info (syntax-e known-variable)))
+     ; (define maybe-signature (hash-try-get type-info (syntax-e function-application)))
+     ; (when (and maybe-type maybe-signature (not (equal? maybe-type (car maybe-signature))))
+     ;   (error-with-span (syntax-span function-application)
+     ;                    "Type mismatch! expected "
+     ;                    (car maybe-signature)
+     ;                    " found "
+     ;                    maybe-type))
+
+     ;; This should then return the
+     ; (displayln maybe-signature)
+
+     ; (list (check-type-info function-application type-info)
+     ;       (check-type-info known-variable type-info))
+     ]
+
+    ;; If this doesn't match any of our other forms, recur
+    [(list other ...) (map (lambda (e) (check-type-info e type-info)) other)]
+
+    ;; We've bottomed out, just return the collected type information
+    [other (or (hash-try-get type-info (syntax-e other)) 'any)]))
+
+(define my-expr2
+  (quasisyntax (define loop
+                 (lambda (maybe-list)
+                   (if (#%prim.list? maybe-list) (#%prim.car maybe-list) (+ maybe-list 10))))))
+
+;; type-check...
+(check-type-info my-expr2 type-table)
+
+(define (tile-null-cdr-checks expr)
+
+  (match-syntax expr
+    ;; Function call merging optimizations
+    [`(#%prim.null? (#%prim.cdr ,expr))
+
+     ;; Map the span of this object to the span
+     ;; of the incoming one.
+     (syntax/loc (list (syntax/loc '#%prim.cdr-null?
+                         (syntax-span expr))
+                       expr)
+       (syntax-span expr))]
+
+    [(list other ...)
+
+     (syntax/loc (map tile-null-cdr-checks other)
+       (syntax-span expr))]
+
+    [other other]))
+
+(define test-expr
+
+  (quasisyntax
+   (define foo
+     (lambda (x)
+       (if (#%prim.null? (#%prim.cdr x)) (displayln "EMPTY CDR") (displayln "NOT EMPTY CDR"))))))
+
+(define res (tile-null-cdr-checks test-expr))
+
+(define-syntax define/lint
+  (syntax-rules ()
+
+    [(_ (name expr) pat ...)
+
+     (define name
+       (lambda (expr)
+
+         ;;
+         (match-syntax expr
+           pat ...
+           [other other])
+
+         (match-syntax expr
+
+           [(list other ...)
+
+            (syntax/loc (map name other)
+              (syntax-span expr))]
+
+           [other other])))]))
+
+;; define/lint
+(define/lint (null-cdr-check expr)
+             [`(#%prim.null? (#%prim.cdr ,expr))
+              (displayln "Consider turning this into #%prim.cdr-null?")])
+
+;; This works!
+(define cdr-check-test
+  (quasisyntax (define foo
+                 (lambda (x)
+                   (if (#%prim.null? (#%prim.cdr (#%prim.null? (#%prim.cdr x))))
+                       (displayln "EMPTY CDR")
+                       (displayln "NOT EMPTY CDR"))))))
+
+(null-cdr-check cdr-check-test)
+
+(define (flatten-cons expr)
+  (match-syntax expr
+
+    [`(#%prim.cons ,x (#%prim.list ,@expr))
+
+     (syntax/loc (cons (syntax/loc '#%prim.list
+                         (syntax-span (car expr)))
+                       (cons x expr))
+
+       (syntax-span (car expr)))]
+
+    [(list other ...)
+
+     (syntax/loc (map flatten-cons other)
+       (syntax-span expr))]
+
+    [other other]))
+
+(flatten-cons
+ (quasisyntax
+  (define foo
+    (#%prim.cons 10 (#%prim.cons 20 (#%prim.cons 30 (#%prim.cons 40 (#%prim.list 10 20))))))))

crates/steel-core/src/compiler/compiler.rs

@@ -647,9 +647,13 @@ impl Compiler {
                 if let Some(macro_env) = self.modules().get(module).map(|x| &x.macro_map) {
                     let source_id = sources.get_source_id(module).unwrap();
 
+                    // println!("Expanding macros from: {:?}", module);
+
                     crate::parser::expand_visitor::expand_with_source_id(
                         expr, macro_env, source_id,
                     )?
+
+                    // crate::parser::expand_visitor::expand(expr, macro_env)?
                 }
             }
 
@@ -810,7 +814,7 @@ impl Compiler {
 
                     crate::parser::expand_visitor::expand_with_source_id(
                         expr, macro_env, source_id,
-                    )?
+                    )?;
                 }
             }
 

crates/steel-core/src/compiler/passes/begin.rs

@@ -296,7 +296,6 @@ pub fn flatten_begins_and_expand_defines(
         .map(|mut x| {
             let mut checker = CheckDefinesAreInLegalPositions { depth: 0 };
             checker.visit(&mut x)?;
-
             Ok(x)
         })
         .collect();

crates/steel-core/src/parser/expand_visitor.rs

@@ -206,11 +206,15 @@ impl<'a> VisitorMutRef for Expander<'a> {
                             },
                     })) => {
                         if let Some(m) = self.map.get(s) {
+                            // println!("Macro: {} - source id: {:?}", s, sp.source_id());
+                            // println!("Source id: {:?}", self.source_id);
+
                             // If this macro has been overwritten by any local value, respect
                             // the local binding and do not expand the macro
                             if !self.in_scope_values.contains(s) {
                                 if self.source_id.is_none()
-                                    || self.source_id.is_some() && self.source_id == sp.source_id()
+                                    || self.source_id.is_some()
+                                        && self.source_id == m.location.source_id()
                                 {
                                     let span = *sp;
 

crates/steel-core/src/parser/expander.rs

@@ -146,7 +146,7 @@ pub struct SteelMacro {
     special_forms: Vec<InternedString>,
     cases: Vec<MacroCase>,
     mangled: bool,
-    location: Span,
+    pub(crate) location: Span,
 }
 
 impl SteelMacro {