Remove "pop" from $prompt

[bpt/guile.git] / module / language / cps / compile-bytecode.scm

diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 216fca6..8494189 100644 (file)
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -299,6 +299,8 @@
          (emit-builtin-ref asm dst (constant name)))
         (($ $primcall 'bv-u8-ref (bv idx))
          (emit-bv-u8-ref asm dst (slot bv) (slot idx)))
+        (($ $primcall 'bv-s8-ref (bv idx))
+         (emit-bv-s8-ref asm dst (slot bv) (slot idx)))
         (($ $primcall 'bv-u16-ref (bv idx))
          (emit-bv-u16-ref asm dst (slot bv) (slot idx)))
         (($ $primcall 'bv-s16-ref (bv idx))
@@ -323,7 +325,7 @@
     (define (compile-effect label exp k nlocals)
       (match exp
         (($ $values ()) #f)
-        (($ $prompt escape? tag handler pop)
+        (($ $prompt escape? tag handler)
          (match (lookup-cont handler)
            (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
             (let ((receive-args (gensym "handler"))
@@ -372,6 +374,8 @@
          (emit-wind asm (slot winder) (slot unwinder)))
         (($ $primcall 'bv-u8-set! (bv idx val))
          (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
+        (($ $primcall 'bv-s8-set! (bv idx val))
+         (emit-bv-s8-set! asm (slot bv) (slot idx) (slot val)))
         (($ $primcall 'bv-u16-set! (bv idx val))
          (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
         (($ $primcall 'bv-s16-set! (bv idx val))
@@ -417,7 +421,17 @@
           (unless (eq? kf next-label)
             (emit-br asm kf)))))
       (match exp
-        (($ $values (sym)) (unary emit-br-if-true sym))
+        (($ $values (sym))
+         (call-with-values (lambda ()
+                             (lookup-maybe-constant-value sym allocation))
+           (lambda (has-const? val)
+             (if has-const?
+                 (if val
+                     (unless (eq? kt next-label)
+                       (emit-br asm kt))
+                     (unless (eq? kf next-label)
+                       (emit-br asm kf)))
+                 (unary emit-br-if-true sym)))))
         (($ $primcall 'null? (a)) (unary emit-br-if-null a))
         (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
         (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))