mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 04:40:29 +02:00
Remove add1 and sub1
* libguile/vm-engine.c: Remove add1 and sub1 instructions. Will replace
with add/immediate and sub/immediate.
* module/language/tree-il/peval.scm (peval): If we reify a new
<primcall>, expand it. Removes 1- and similar primcalls.
* module/language/tree-il/primitives.scm: Don't specialize (+ x 1) to 1+.
(expand-primcall): New export, does a single primcall expansion.
(expand-primitives): Use the new helper.
* module/language/cps/effects-analysis.scm:
* module/language/cps/primitives.scm:
* module/language/cps/types.scm:
* module/system/vm/assembler.scm: Remove support for add1 and sub1 CPS
primitives.
* test-suite/tests/peval.test ("partial evaluation"): Adapt tests that
expect 1+/1- to expect +/-.
This commit is contained in:
Andy Wingo
parent
e003466039
commit
8f18b71b7a
8 changed files with 30 additions and 88 deletions
|
|
@ -2382,29 +2382,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
|
|||
BINARY_INTEGER_OP (+, scm_sum);
|
||||
}
|
||||
|
||||
/* add1 dst:12 src:12
|
||||
*
|
||||
* Add 1 to the value in SRC, and place the result in DST.
|
||||
*/
|
||||
VM_DEFINE_OP (87, add1, "add1", OP1 (X8_S12_S12) | OP_DST)
|
||||
{
|
||||
ARGS1 (x);
|
||||
|
||||
/* Check for overflow. We must avoid overflow in the signed
|
||||
addition below, even if X is not an inum. */
|
||||
if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) <= INUM_MAX - INUM_STEP))
|
||||
{
|
||||
SCM result;
|
||||
|
||||
/* Add 1 to the integer without untagging. */
|
||||
result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) + INUM_STEP);
|
||||
|
||||
if (SCM_LIKELY (SCM_I_INUMP (result)))
|
||||
RETURN (result);
|
||||
}
|
||||
|
||||
RETURN_EXP (scm_sum (x, SCM_I_MAKINUM (1)));
|
||||
}
|
||||
VM_DEFINE_OP (87, unused_87, NULL, NOP)
|
||||
|
||||
/* sub dst:8 a:8 b:8
|
||||
*
|
||||
|
|
@ -2415,29 +2393,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
|
|||
BINARY_INTEGER_OP (-, scm_difference);
|
||||
}
|
||||
|
||||
/* sub1 dst:12 src:12
|
||||
*
|
||||
* Subtract 1 from SRC, and place the result in DST.
|
||||
*/
|
||||
VM_DEFINE_OP (89, sub1, "sub1", OP1 (X8_S12_S12) | OP_DST)
|
||||
{
|
||||
ARGS1 (x);
|
||||
|
||||
/* Check for overflow. We must avoid overflow in the signed
|
||||
subtraction below, even if X is not an inum. */
|
||||
if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) >= INUM_MIN + INUM_STEP))
|
||||
{
|
||||
SCM result;
|
||||
|
||||
/* Substract 1 from the integer without untagging. */
|
||||
result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) - INUM_STEP);
|
||||
|
||||
if (SCM_LIKELY (SCM_I_INUMP (result)))
|
||||
RETURN (result);
|
||||
}
|
||||
|
||||
RETURN_EXP (scm_difference (x, SCM_I_MAKINUM (1)));
|
||||
}
|
||||
VM_DEFINE_OP (89, unused_89, NULL, NOP)
|
||||
|
||||
/* mul dst:8 a:8 b:8
|
||||
*
|
||||
|
|
|
|||
|
|
@ -428,8 +428,6 @@ is or might be a read or a write to the same location as A."
|
|||
((uadd . _))
|
||||
((usub . _))
|
||||
((umul . _))
|
||||
((sub1 . _) &type-check)
|
||||
((add1 . _) &type-check)
|
||||
((quo . _) &type-check)
|
||||
((rem . _) &type-check)
|
||||
((mod . _) &type-check)
|
||||
|
|
|
|||
|
|
@ -34,9 +34,10 @@
|
|||
))
|
||||
|
||||
(define *instruction-aliases*
|
||||
'((+ . add) (1+ . add1)
|
||||
(- . sub) (1- . sub1)
|
||||
(* . mul) (/ . div)
|
||||
'((+ . add)
|
||||
(- . sub)
|
||||
(* . mul)
|
||||
(/ . div)
|
||||
(quotient . quo) (remainder . rem)
|
||||
(modulo . mod)
|
||||
(variable-ref . box-ref)
|
||||
|
|
|
|||
|
|
@ -1061,14 +1061,6 @@ minimum, and maximum."
|
|||
(lambda (min max)
|
||||
(define! result &f64 min max)))))
|
||||
|
||||
(define-simple-type-checker (add1 &number))
|
||||
(define-type-inferrer (add1 a result)
|
||||
(define-unary-result! a result (1+ (&min a)) (1+ (&max a))))
|
||||
|
||||
(define-simple-type-checker (sub1 &number))
|
||||
(define-type-inferrer (sub1 a result)
|
||||
(define-unary-result! a result (1- (&min a)) (1- (&max a))))
|
||||
|
||||
(define-type-checker (quo a b)
|
||||
(and (check-type a &exact-integer -inf.0 +inf.0)
|
||||
(check-type b &exact-integer -inf.0 +inf.0)
|
||||
|
|
|
|||
|
|
@ -1357,7 +1357,8 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(let revisit-proc ((proc (visit orig-proc 'operator)))
|
||||
(match proc
|
||||
(($ <primitive-ref> _ name)
|
||||
(for-tail (make-primcall src name orig-args)))
|
||||
(for-tail
|
||||
(expand-primcall (make-primcall src name orig-args))))
|
||||
(($ <lambda> _ _
|
||||
($ <lambda-case> _ req opt rest #f inits gensyms body #f))
|
||||
;; Simple case: no keyword arguments.
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@
|
|||
#:use-module (srfi srfi-4)
|
||||
#:use-module (srfi srfi-16)
|
||||
#:export (resolve-primitives add-interesting-primitive!
|
||||
expand-primitives
|
||||
expand-primcall expand-primitives
|
||||
effect-free-primitive? effect+exception-free-primitive?
|
||||
constructor-primitive?
|
||||
singly-valued-primitive? equality-primitive?
|
||||
|
|
@ -313,16 +313,16 @@
|
|||
|
||||
(define *primitive-expand-table* (make-hash-table))
|
||||
|
||||
(define (expand-primitives x)
|
||||
(pre-order
|
||||
(lambda (x)
|
||||
(define (expand-primcall x)
|
||||
(record-case x
|
||||
((<primcall> src name args)
|
||||
(let ((expand (hashq-ref *primitive-expand-table* name)))
|
||||
(or (and expand (apply expand src args))
|
||||
x)))
|
||||
(else x)))
|
||||
x))
|
||||
|
||||
(define (expand-primitives x)
|
||||
(pre-order expand-primcall x))
|
||||
|
||||
;;; I actually did spend about 10 minutes trying to redo this with
|
||||
;;; syntax-rules. Patches appreciated.
|
||||
|
|
@ -388,18 +388,16 @@
|
|||
|
||||
;; FIXME: All the code that uses `const?' is redundant with `peval'.
|
||||
|
||||
(define-primitive-expander 1+ (x)
|
||||
(+ x 1))
|
||||
|
||||
(define-primitive-expander 1- (x)
|
||||
(- x 1))
|
||||
|
||||
(define-primitive-expander +
|
||||
() 0
|
||||
(x) (values x)
|
||||
(x y) (if (and (const? y) (eqv? (const-exp y) 1))
|
||||
(1+ x)
|
||||
(if (and (const? y) (eqv? (const-exp y) -1))
|
||||
(1- x)
|
||||
(if (and (const? x) (eqv? (const-exp x) 1))
|
||||
(1+ y)
|
||||
(if (and (const? x) (eqv? (const-exp x) -1))
|
||||
(1- y)
|
||||
(+ x y)))))
|
||||
(x y) (+ x y)
|
||||
(x y z ... last) (+ (+ x y . z) last))
|
||||
|
||||
(define-primitive-expander *
|
||||
|
|
@ -409,9 +407,7 @@
|
|||
|
||||
(define-primitive-expander -
|
||||
(x) (- 0 x)
|
||||
(x y) (if (and (const? y) (eqv? (const-exp y) 1))
|
||||
(1- x)
|
||||
(- x y))
|
||||
(x y) (- x y)
|
||||
(x y z ... last) (- (- x y . z) last))
|
||||
|
||||
(define-primitive-expander /
|
||||
|
|
|
|||
|
|
@ -129,9 +129,7 @@
|
|||
(emit-set-car!* . emit-set-car!)
|
||||
(emit-set-cdr!* . emit-set-cdr!)
|
||||
(emit-add* . emit-add)
|
||||
(emit-add1* . emit-add1)
|
||||
(emit-sub* . emit-sub)
|
||||
(emit-sub1* . emit-sub1)
|
||||
(emit-mul* . emit-mul)
|
||||
(emit-div* . emit-div)
|
||||
(emit-quo* . emit-quo)
|
||||
|
|
|
|||
|
|
@ -534,7 +534,7 @@
|
|||
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
|
||||
(let ((fold (lambda (f g) (f (g top)))))
|
||||
(fold 1+ (lambda (x) x)))
|
||||
(primcall 1+ (toplevel top)))
|
||||
(primcall + (toplevel top) (const 1)))
|
||||
|
||||
(pass-if-peval
|
||||
;; Procedure not inlined when residual code contains recursive calls.
|
||||
|
|
@ -557,7 +557,7 @@
|
|||
(lambda ()
|
||||
(lambda-case
|
||||
(((x2) #f #f #f () (_))
|
||||
(primcall 1- (lexical x2 _))))))))
|
||||
(primcall - (lexical x2 _) (const 1))))))))
|
||||
|
||||
(pass-if "inlined lambdas are alpha-renamed"
|
||||
;; In this example, `make-adder' is inlined more than once; thus,
|
||||
|
|
@ -788,8 +788,8 @@
|
|||
(((x) #f #f #f () (_))
|
||||
(if _ _
|
||||
(call (lexical loop _)
|
||||
(primcall 1-
|
||||
(lexical x _))))))))
|
||||
(primcall - (lexical x _)
|
||||
(const 1))))))))
|
||||
(call (lexical loop _) (toplevel x))))
|
||||
|
||||
(pass-if-peval
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue