[Heavy] Add new create-op syntax; Fix nested packs

Author: ricejasonf

heavy/include/heavy/Mlir.h

@@ -13,9 +13,9 @@
 #ifndef LLVM_HEAVY_MLIR_H
 #define LLVM_HEAVY_MLIR_H
 
-#define HEAVY_MLIR_LIB                _HEAVYL5SheavyL4Smlir
-#define HEAVY_MLIR_LIB_(NAME)         _HEAVYL5SheavyL4Smlir ## NAME
-#define HEAVY_MLIR_LIB_STR            "_HEAVYL5SheavyL4Smlir"
+#define HEAVY_MLIR_LIB                _HEAVYL5SheavyL4SmlirL8Sbuiltins
+#define HEAVY_MLIR_LIB_(NAME)         _HEAVYL5SheavyL4SmlirL8Sbuiltins ## NAME
+#define HEAVY_MLIR_LIB_STR            "_HEAVYL5SheavyL4SmlirL8Sbuiltins"
 #define HEAVY_MLIR_LOAD_MODULE        HEAVY_MLIR_LIB_(_load_module)
 #define HEAVY_MLIR_INIT               HEAVY_MLIR_LIB_(_init)
 

heavy/include/heavy/OpGen.h

@@ -241,7 +241,8 @@ class OpGen : public ValueVisitor<OpGen, mlir::Value> {
       // An error may occur here, but we always want
       // this function to return a valid operation.
       // Just continue until the error is realized.
-      FinishLocalDefines();
+      if (!CheckError())
+        FinishLocalDefines();
     }
     return createHelper<Op>(Builder, Loc, std::forward<Args>(args)...);
   }
@@ -345,14 +346,23 @@ class OpGen : public ValueVisitor<OpGen, mlir::Value> {
   }
 
   template <typename T>
-  mlir::Value SetError(SourceLocation Loc, T Str, Value V = Undefined()) {
-    heavy::Error* E = Context.CreateError(Loc, Str, Context.CreatePair(V));
+  mlir::Value SetError(SourceLocation Loc, T Str,
+                       llvm::ArrayRef<Value> IrrArgs = {}) {
+    heavy::Error* E = Context.CreateError(Loc, Str, Context.CreateList(IrrArgs));
     return SetError(E);
   }
 
   template <typename T>
-  mlir::Value SetError(T Str, Value V = Undefined()) {
-    return SetError(V.getSourceLocation(), Str, V);
+  mlir::Value SetError(T Str, llvm::ArrayRef<Value> IrrArgs = {}) {
+    heavy::SourceLocation Loc;
+    for (Value Irr : llvm::reverse(IrrArgs))
+      Loc = Loc.isValid() ? Loc : Irr.getSourceLocation();
+    return SetError(Loc, Str, IrrArgs);
+  }
+
+  template <typename T>
+  mlir::Value SetError(T Str, Value V) {
+    return SetError(Str, llvm::ArrayRef<Value>(V));
   }
 
   mlir::Value Error() {

heavy/include/heavy/base.sld

@@ -34,6 +34,7 @@
     *
     < <= > >=
     positive? zero?
+    range
     apply
     append
     call-with-values
@@ -64,6 +65,7 @@
     let letrec letrec*
     cond case
     and or when unless
+    do
 
     ; (heavy base list)
     caar cadr cdar cddr

heavy/include/heavy/base/int.sld

@@ -4,6 +4,13 @@
   (import (heavy builtins)
           (heavy base r7rs-syntax))
   (begin
+    (define range ; Copied from R7RS
+      (case-lambda
+        ((e) (range 0 e))
+        ((b e) (do ((r '() (cons e r))
+                    (e (- e 1) (- e 1)))
+                 ((< e b) r)))))
+
     (define (< x1 x2 . xN)
       (if (positive? (- x2 x1))
         (if (pair? xN)
@@ -37,4 +44,5 @@
     ) ; end begin
   (export
     < <= > >=
+    range
     ))

heavy/include/heavy/base/r7rs-syntax.sld

@@ -25,6 +25,29 @@
              tag)
             val ...))))
 
+    (define-syntax do
+      (syntax-rules ()
+        ((do ((var init step ...) ...)
+           (test expr ...)
+           command ...)
+         (letrec
+           ((loop
+              (lambda (var ...)
+                (if test
+                  (begin
+                    (if #f #f)
+                    expr ...)
+                  (begin
+                    command
+                    ...
+                    (loop (do "step" var step ...)
+                          ...))))))
+           (loop init ...)))
+        ((do "step" x)
+         x)
+        ((do "step" x y)
+         y)))
+
     ; FIXME cond should be in the environment within syntax body.
     ;       (this applies to all define-syntax)
     (define-syntax cond
@@ -175,4 +198,5 @@
     let letrec letrec*
     cond case
     and or when unless
+    do
     ))

heavy/include/heavy/mlir.sld

@@ -0,0 +1,80 @@
+(import (heavy builtins))
+
+(define-library (heavy mlir)
+  (import (heavy base)
+          (heavy mlir builtins))
+    (begin
+    (define (init-regions Op BlockArgTypesList UserFns)
+      (define Is (range (length BlockArgTypesList)))
+      (define (InitRegion RegionIndex BlockArgTypes UserFn)
+        (with-builder
+          (lambda ()
+            (define Region (get-region Op RegionIndex))
+            (define Block (entry-block Region))
+            (define Args
+              (let ()
+                (define (Proc BlockArgType)
+                  (add-argument Block BlockArgType Loc))
+                (map Proc BlockArgTypes)))
+            (at-block-begin Block)
+            (apply UserFn Args))))
+      (map InitRegion Is BlockArgTypesList UserFns))
+
+    (define-syntax create-op
+      (syntax-rules (: loc attributes operands result-types region)
+        ((create-op Name
+          (loc Loc)
+          (operands Operands ...)
+          (attributes (AttrName Attr) ...)
+          (result-types ResultTypes ...)
+          (region RegionName ((BlockArg : BlockArgType) ...)
+                    RegionBody ...) ...)
+         (let ((Op
+                  (old-create-op Name
+                    (loc Loc)
+                    (operands Operands ...)
+                    (attributes (list 'AttrName Attr) ...)
+                    (result-types ResultTypes ...)
+                    (regions (length '(RegionName ...)))
+                    ))
+                (BlockArgsTypesList (list (list BlockArgType ...) ...))
+                (UserFns (list (lambda (BlockArg ...)
+                                     RegionBody ...) ...)))
+            (init-regions Op BlockArgsTypesList UserFns)
+            Op)
+        )))
+    ) ; end of begin
+
+   (export
+    create-op
+    ; (heavy mlir builtins)
+    old-create-op
+    current-builder
+    get-region
+    entry-block
+    add-argument
+    results
+    result
+    at-block-begin
+    at-block-end
+    block-op
+    op-next
+    parent-op
+    set-insertion-point
+    set-insertion-after
+    type
+    %function-type
+    attr
+    type-attr
+    value-attr
+    string-attr
+    flat-symbolref-attr
+    with-new-context
+    with-builder
+    load-dialect
+    verify
+    module-lookup
+    value?
+    )
+   )
+

heavy/lib/Mlir.cpp

@@ -38,7 +38,7 @@ heavy::ContextLocal   current_context;
 heavy::ContextLocal   current_builder;
 heavy::ExternSyntax<> create_op;
 heavy::ExternFunction create_op_impl;
-heavy::ExternFunction region;
+heavy::ExternFunction get_region;
 heavy::ExternFunction entry_block;
 heavy::ExternFunction add_argument;
 heavy::ExternFunction results;
@@ -296,19 +296,19 @@ void create_op(Context& C, ValueRefs Args) {  // Syntax
   C.Cont(OpGen.fromValue(Call));
 }
 
-// Get an operation region by index (defaulting to 0).
-// (region _op_)
-// (region op _index_)
-void region(Context& C, ValueRefs Args) {
+// Get an operation get_region by index (defaulting to 0).
+// (get-region _op_)
+// (get-region op _index_)
+void get_region(Context& C, ValueRefs Args) {
   if (Args.size() != 1 && Args.size() != 2)
     return C.RaiseError("invalid arity");
 
-  mlir::Operation* Op = heavy::dyn_cast<mlir::Operation>(Args[1]);
+  mlir::Operation* Op = heavy::dyn_cast<mlir::Operation>(Args[0]);
   if (!Op)
-    return C.RaiseError("expecting mlir.op");
+    return C.RaiseError("expecting mlir.op: {}", {Args[0]});
 
   if (Args.size() > 1 && !heavy::isa<heavy::Int>(Args[1]))
-    return C.RaiseError("expecting index");
+    return C.RaiseError("expecting index: {}", {Args[1]});
 
   int32_t Index = heavy::isa<heavy::Int>(Args[1]) ?
                     int32_t{heavy::cast<heavy::Int>(Args[1])} : 0;
@@ -843,7 +843,7 @@ void HEAVY_MLIR_INIT(heavy::Context& C) {
 
   HEAVY_MLIR_VAR(create_op) = heavy::mlir_bind::create_op;
   HEAVY_MLIR_VAR(create_op_impl) = heavy::mlir_bind::create_op_impl;
-  HEAVY_MLIR_VAR(region) = heavy::mlir_bind::region;
+  HEAVY_MLIR_VAR(get_region) = heavy::mlir_bind::get_region;
   HEAVY_MLIR_VAR(entry_block) = heavy::mlir_bind::entry_block;
   HEAVY_MLIR_VAR(add_argument) = heavy::mlir_bind::add_argument;
   HEAVY_MLIR_VAR(results) = heavy::mlir_bind::results;
@@ -875,10 +875,10 @@ void HEAVY_MLIR_INIT(heavy::Context& C) {
 void HEAVY_MLIR_LOAD_MODULE(heavy::Context& C) {
   HEAVY_MLIR_INIT(C);
   heavy::initModuleNames(C, HEAVY_MLIR_LIB_STR, {
-    {"create-op", HEAVY_MLIR_VAR(create_op)},
+    {"old-create-op", HEAVY_MLIR_VAR(create_op)},
     {"%create-op", HEAVY_MLIR_VAR(create_op_impl)},
     {"current-builder", HEAVY_MLIR_VAR(current_builder).get_binding(C)},
-    {"region", HEAVY_MLIR_VAR(region)},
+    {"get-region", HEAVY_MLIR_VAR(get_region)},
     {"entry-block", HEAVY_MLIR_VAR(entry_block)},
     {"add-argument", HEAVY_MLIR_VAR(add_argument)},
     {"results", HEAVY_MLIR_VAR(results)},

heavy/lib/OpEval.cpp

@@ -610,7 +610,7 @@ class OpEvalImpl {
   BlockItrTy patternFail(mlir::Operation* Op, llvm::StringRef ErrMsg,
                          llvm::ArrayRef<heavy::Value> Irr) {
     assert((isa<MatchOp, MatchPairOp, MatchTailOp, MatchArgsOp,
-                MatchIdOp>(Op)) &&
+                MatchIdOp, SubpatternOp>(Op)) &&
         "Operation must be a pattern matcher");
 
     mlir::Operation* ParentOp = Op->getParentOp();
@@ -623,8 +623,9 @@ class OpEvalImpl {
       return BlockItrTy();
     }
 
+    // Use the SubPatternOp itself as the sentinel for pattern failure.
     if (auto SubpatternOp = dyn_cast<heavy::SubpatternOp>(ParentOp))
-      return BlockItrTy();
+      return BlockItrTy(SubpatternOp);
 
     assert(isa<heavy::PatternOp>(ParentOp) && "expecting a PatternOp.");
 
@@ -636,27 +637,36 @@ class OpEvalImpl {
     heavy::Value P = Op.getVal().getValue(Context);
     heavy::Value E = getValue(Op.getInput());
     heavy::EnvEntry Entry;
-    if (Symbol* S = dyn_cast<Symbol>(E)) {
+    if (isIdentifier(E) && isIdentifier(P)) {
       // If the symbol is in the environment we can skip
       // because it will not match a literal.
-      Entry = Context.Lookup(S);
-      if (Entry)
-        E = Entry.Value;
+      heavy::EnvEntry EntryE = Context.Lookup(E);
+      heavy::EnvEntry EntryP = Context.Lookup(P);
+      if (EntryE && EntryP && EntryE.Value == EntryP.Value)
+        return next(Op);
+      else if (EntryE || EntryP)
+        return patternFail(Op,
+            "expecting identifier with identical binding: {1}", {E, P});
+      // Unwrap syntax closures.
+      P = Context.RebuildLiteral(P);
+      E = Context.RebuildLiteral(E);
     }
-    if (equal(P, E))
+    if (equal(P, E)) {
       return next(Op);
-    else
-      return patternFail(Op, "expecting literal", {P, E});
+    } else {
+      Context.setLoc(E.getSourceLocation());
+      return patternFail(Op, "expecting literal: {1}", {E, P});
+    }
   }
 
   BlockItrTy Visit(MatchPairOp Op) {
     heavy::Value E = getValue(Op.getInput());
     if (auto* Pair = dyn_cast<heavy::Pair>(E)) {
-      Context.setLoc(E.getSourceLocation());
       setValue(Op.getCar(), Pair->Car);
       setValue(Op.getCdr(), Pair->Cdr);
       return next(Op);
     }
+    Context.setLoc(E.getSourceLocation());
     return patternFail(Op, "expecting pair", E);
   }
 
@@ -755,7 +765,7 @@ class OpEvalImpl {
 
   BlockItrTy Visit(SubpatternOp Op) {
     heavy::Value E = getValue(Op.getInput());
-    heavy::Pair* Tail = dyn_cast<heavy::Pair>(getValue(Op.getTail()));
+    heavy::Value Tail = getValue(Op.getTail());
 
     // Match the empty list.
     if (isa<heavy::Empty>(E)) {
@@ -775,16 +785,24 @@ class OpEvalImpl {
     // stopping when we find tail or a non-pair object.
     // Each "pack" should be a list.
     while (auto* Pair = dyn_cast<heavy::Pair>(E)) {
-      if (Pair == Tail)
+      if (E == Tail)
         break;
       auto Scope = ValueMapScope(ValueMap);
       BlockItrTy Itr = Op.getBody().front().begin();
       setValue(BodyArg, Pair->Car);
-      while (Itr != BlockItrTy())
+      while (Itr != BlockItrTy() && Itr != BlockItrTy(Op))
         Itr = Visit(&*Itr);
+      // Check subpattern failure.
+      if (Itr == BlockItrTy(Op))
+        break;
       E = Pair->Cdr;
     }
 
+    // Fail if E still has junk that is not Tail and
+    // did not get gobbled up by the subpattern.
+    if (E != Tail)
+      return patternFail(Op, "unexpected elements after subpattern", {E});
+
     return next(Op);
   }
 
@@ -820,7 +838,7 @@ class OpEvalImpl {
     if (P == E) {
       return next(Op);
     }
-    return patternFail(Op, "identifier does not match", {P, E});
+    return patternFail(Op, "identifier does not match", {E, P});
   }
 
   BlockItrTy Visit(SyntaxClosureOp Op) {