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

@@ -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",

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

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))

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

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)

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)