[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 15/16: error, scm-error primcalls expand to `throw'
From: |
Andy Wingo |
Subject: |
[Guile-commits] 15/16: error, scm-error primcalls expand to `throw' |
Date: |
Sun, 5 Nov 2017 09:00:42 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit cf486700b78a72f1bcab5b450394a63cf3ec7bff
Author: Andy Wingo <address@hidden>
Date: Sun Nov 5 13:05:19 2017 +0100
error, scm-error primcalls expand to `throw'
* module/language/tree-il/primitives.scm (scm-error, error): Expand
into `throw'.
* module/language/tree-il/peval.scm (peval): Reify "throw" for dynwind
error.
* module/language/tree-il/compile-cps.scm (canonicalize): Reify "throw"
for call-with-prompt error.
* module/language/cps/prune-bailouts.scm (prune-bailouts): Don't expect
"error" or "scm-error" here.
---
module/language/cps/prune-bailouts.scm | 3 +--
module/language/tree-il/compile-cps.scm | 2 +-
module/language/tree-il/peval.scm | 2 +-
module/language/tree-il/primitives.scm | 37 +++++++++++++++++++++++++++++++++
test-suite/tests/peval.test | 4 ++--
5 files changed, 42 insertions(+), 6 deletions(-)
diff --git a/module/language/cps/prune-bailouts.scm
b/module/language/cps/prune-bailouts.scm
index 6a46798..4120872 100644
--- a/module/language/cps/prune-bailouts.scm
+++ b/module/language/cps/prune-bailouts.scm
@@ -73,8 +73,7 @@ unreferenced terms. In that case TAIL-LABEL is either absent
or #f."
(lambda (label cont out)
(match cont
(($ $kargs names vars
- ($ $continue k src
- (and exp ($ $primcall (or 'error 'scm-error 'throw)))))
+ ($ $continue k src (and exp ($ $primcall 'throw))))
(call-with-values (lambda () (prune-bailout out tails k src exp))
(lambda (out term)
(if term
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index a242da9..8d906ff 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1149,7 +1149,7 @@ integer."
(make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
(make-void src)
(make-primcall
- src 'scm-error
+ src 'throw
(list
(make-const #f 'wrong-type-arg)
(make-const #f "call-with-prompt")
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 0c23f7b..c3df1a7 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1193,7 +1193,7 @@ top-level bindings from ENV and return the resulting
expression."
(make-primcall src 'thunk? (list u))
(make-call src w '())
(make-primcall
- src 'scm-error
+ src 'throw
(list
(make-const #f 'wrong-type-arg)
(make-const #f "dynamic-wind")
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index e716714..646eea0 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -378,6 +378,43 @@
,(consequent (cadr in)))
out)))))))
+;; Oddly, scm-error is just an explicitly 5-argument `throw'. Weird.
+(define-primitive-expander scm-error (key who message args data)
+ (throw key who message args data))
+
+(define (escape-format-directives str)
+ (string-join (string-split str #\~) "~~"))
+
+(hashq-set!
+ *primitive-expand-table*
+ 'error
+ (match-lambda*
+ ((src)
+ (make-primcall src 'throw
+ (list (make-const src 'misc-error)
+ (make-const src #f)
+ (make-const src "?")
+ (make-const src #f)
+ (make-const src #f))))
+ ((src ($ <const> src2 (? string? message)) . args)
+ (let ((msg (string-join (cons (escape-format-directives message)
+ (make-list (length args) "~S")))))
+ (make-primcall src 'throw
+ (list (make-const src 'misc-error)
+ (make-const src #f)
+ (make-const src2 msg)
+ (make-primcall src 'list args)
+ (make-const src #f)))))
+ ((src message . args)
+ (let ((msg (string-join (cons "~A" (make-list (length args) "~S")))))
+ (make-primcall src 'throw
+ (list (make-const src 'misc-error)
+ (make-const src #f)
+ (make-const src msg)
+ (make-const src "?")
+ (make-primcall src 'list (cons message args))
+ (make-const src #f)))))))
+
(define-primitive-expander zero? (x)
(= x 0))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 4e2ccf9..1b1eff9 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <address@hidden> --- May 2009
;;;;
-;;;; Copyright (C) 2009-2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2014, 2017 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
@@ -1145,7 +1145,7 @@
(let (tmp tmp) (_ _) ((toplevel foo) (toplevel baz))
(seq (seq (if (primcall thunk? (lexical tmp _))
(call (lexical tmp _))
- (primcall scm-error . _))
+ (primcall throw . _))
(primcall wind (lexical tmp _) (lexical tmp _)))
(let (tmp) (_) ((toplevel bar))
(seq (seq (primcall unwind)
- [Guile-commits] branch master updated (2d8c75f -> f96a670), Andy Wingo, 2017/11/05
- [Guile-commits] 10/16: Tweak optimization order, Andy Wingo, 2017/11/05
- [Guile-commits] 12/16: Specialize primcalls more aggressively, Andy Wingo, 2017/11/05
- [Guile-commits] 13/16: Earlier conversion to /imm primcalls, Andy Wingo, 2017/11/05
- [Guile-commits] 02/16: cache-current-module, etc use immediate primcall parameters, Andy Wingo, 2017/11/05
- [Guile-commits] 05/16: Immediate variants of vector-ref, etc use immediate param, Andy Wingo, 2017/11/05
- [Guile-commits] 15/16: error, scm-error primcalls expand to `throw',
Andy Wingo <=
- [Guile-commits] 07/16: builtin-ref takes immediate parameter, Andy Wingo, 2017/11/05
- [Guile-commits] 09/16: reify-primitives reifies constants for out-of-range imm params, Andy Wingo, 2017/11/05
- [Guile-commits] 03/16: load-f64, etc take immediate parameters, Andy Wingo, 2017/11/05
- [Guile-commits] 04/16: free-ref, free-set take immediate parameters, Andy Wingo, 2017/11/05
- [Guile-commits] 11/16: (system base types) uses target's idea of max size_t, Andy Wingo, 2017/11/05
- [Guile-commits] 16/16: Add new "throw" VM ops, Andy Wingo, 2017/11/05
- [Guile-commits] 14/16: Add lsh, rsh instructions, Andy Wingo, 2017/11/05
- [Guile-commits] 06/16: Immediate parameter for struct-ref et al, Andy Wingo, 2017/11/05
- [Guile-commits] 08/16: Remaining /immediate instructions take primcall imm param, Andy Wingo, 2017/11/05
- [Guile-commits] 01/16: $primcall has a "param" member, Andy Wingo, 2017/11/05