[Guile-commits] 14/16: Compile "define!" via intrinsic

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit ceffb5e990efa6d8f9a2eb6cc128ebbddf61a819
Author: Andy Wingo <address@hidden>
Date:   Mon May 14 15:15:22 2018 +0200

    Compile "define!" via intrinsic
    
    * libguile/intrinsics.c (scm_bootstrap_intrinsics):
    * libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS): Add new define!
      intrinsic.
    * module/language/cps/compile-bytecode.scm (compile-function): Adapt
      compilation for define! to take two arguments.
    * module/language/cps/effects-analysis.scm (current-module): Update
      define! for two arguments.
    * module/language/tree-il/compile-cps.scm (convert): When reifying
      "define", grab the current module.
    * module/system/vm/assembler.scm (define!): Define assembler as
      intrinsic.
---
 libguile/intrinsics.c                    | 1 +
 libguile/intrinsics.h                    | 1 +
 module/language/cps/compile-bytecode.scm | 5 +++--
 module/language/cps/effects-analysis.scm | 2 +-
 module/language/tree-il/compile-cps.scm  | 8 ++++++--
 module/system/vm/assembler.scm           | 3 ++-
 6 files changed, 14 insertions(+), 6 deletions(-)

diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index 64f8d7f..0655c2a 100644
--- a/libguile/intrinsics.c
+++ b/libguile/intrinsics.c
@@ -300,6 +300,7 @@ scm_bootstrap_intrinsics (void)
   scm_vm_intrinsics.numerically_equal_p = numerically_equal_p;
   scm_vm_intrinsics.resolve_module = resolve_module;
   scm_vm_intrinsics.lookup = lookup;
+  scm_vm_intrinsics.define_x = scm_module_ensure_local_variable;
 
   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                             "scm_init_intrinsics",
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index 9d5bc7d..7b67f80 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -84,6 +84,7 @@ typedef enum scm_compare 
(*scm_t_compare_from_scm_scm_intrinsic) (SCM, SCM);
   M(bool_from_scm_scm, numerically_equal_p, "=?", NUMERICALLY_EQUAL_P) \
   M(scm_from_scm_uimm, resolve_module, "resolve-module", RESOLVE_MODULE) \
   M(scm_from_scm_scm, lookup, "lookup", LOOKUP) \
+  M(scm_from_scm_scm, define_x, "define!", DEFINE_X) \
   /* Add new intrinsics here; also update scm_bootstrap_intrinsics.  */
 
 enum scm_vm_intrinsic
diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index fddf2fd..91ae19c 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -143,8 +143,9 @@
          (emit-current-module asm (from-sp dst)))
         (($ $primcall 'current-thread)
          (emit-current-thread asm (from-sp dst)))
-        (($ $primcall 'define! #f (sym))
-         (emit-define! asm (from-sp dst) (from-sp (slot sym))))
+        (($ $primcall 'define! #f (mod sym))
+         (emit-define! asm (from-sp dst)
+                       (from-sp (slot mod)) (from-sp (slot sym))))
         (($ $primcall 'resolve (bound?) (name))
          (emit-resolve asm (from-sp dst) bound? (from-sp (slot name))))
         (($ $primcall 'allocate-words annotation (nfields))
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 1e14848..9bc2ffe 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -463,7 +463,7 @@ the LABELS that are clobbered by the effects of LABEL."
   ((lookup mod name)               (&read-object &module)      &type-check)
   ((cached-toplevel-box)                                       &type-check)
   ((cached-module-box)                                         &type-check)
-  ((define! name)                  (&read-object &module)))
+  ((define! mod name)              (&read-object &module)))
 
 ;; Cache cells.
 (define-primitive-effects
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 4574c8b..23eb5ea 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1851,13 +1851,17 @@
        (lambda (cps val)
          (with-cps cps
            (let$ k (adapt-arity k src 0))
-           (letv box)
+           (letv box mod)
            (letk kset ($kargs ('box) (box)
                         ($continue k src
                           ($primcall 'scm-set!/immediate '(box . 1) (box 
val)))))
            ($ (with-cps-constants ((name name))
+                (letk kmod
+                      ($kargs ('mod) (mod)
+                        ($continue kset src
+                          ($primcall 'define! #f (mod name)))))
                 (build-term
-                  ($continue kset src ($primcall 'define! #f (name))))))))))
+                  ($continue kmod src ($primcall 'current-module #f ())))))))))
 
     (($ <call> src proc args)
      (convert-args cps (cons proc args)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index e8e767d..650156d 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -226,6 +226,7 @@
             emit-rsh/immediate
             emit-resolve-module
             emit-lookup
+            emit-define!
 
             emit-cache-ref
             emit-cache-set!
@@ -251,7 +252,6 @@
             emit-load-label
             emit-current-module
             emit-resolve
-            emit-define!
             emit-prompt
             emit-current-thread
             emit-fadd
@@ -1375,6 +1375,7 @@ returned instead."
 (define-scm<-scm-uimm-intrinsic rsh/immediate)
 (define-scm<-scm-bool-intrinsic resolve-module)
 (define-scm<-scm-scm-intrinsic lookup)
+(define-scm<-scm-scm-intrinsic define!)
 
 (define-macro-assembler (begin-program asm label properties)
   (emit-label asm label)