From 8f18b71b7afcd475553f760f83af7d79fc34cf01 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 20 Nov 2015 14:03:32 +0100 Subject: [PATCH] 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 , 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 +/-. --- libguile/vm-engine.c | 48 +----------------------- module/language/cps/effects-analysis.scm | 2 - module/language/cps/primitives.scm | 7 ++-- module/language/cps/types.scm | 8 ---- module/language/tree-il/peval.scm | 3 +- module/language/tree-il/primitives.scm | 40 +++++++++----------- module/system/vm/assembler.scm | 2 - test-suite/tests/peval.test | 8 ++-- 8 files changed, 30 insertions(+), 88 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index d615af1aa..80ab3afd8 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -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 * diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 9112c429b..21df42ccd 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -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) diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index 3628b5cf7..d6488450d 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -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) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 4fd5e569e..1a0eebbe1 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -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) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index fca849ec0..355d423dd 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -1357,7 +1357,8 @@ top-level bindings from ENV and return the resulting expression." (let revisit-proc ((proc (visit orig-proc 'operator))) (match proc (($ _ name) - (for-tail (make-primcall src name orig-args))) + (for-tail + (expand-primcall (make-primcall src name orig-args)))) (($ _ _ ($ _ req opt rest #f inits gensyms body #f)) ;; Simple case: no keyword arguments. diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 7bed7832c..57072d4d9 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -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-primcall x) + (record-case x + (( src name args) + (let ((expand (hashq-ref *primitive-expand-table* name))) + (or (and expand (apply expand src args)) + x))) + (else x))) + (define (expand-primitives x) - (pre-order - (lambda (x) - (record-case x - (( src name args) - (let ((expand (hashq-ref *primitive-expand-table* name))) - (or (and expand (apply expand src args)) - x))) - (else x))) - 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 / diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 76ae892a3..9dcd6dc79 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -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) diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index 93988af14..547510311 100644 --- a/test-suite/tests/peval.test +++ b/test-suite/tests/peval.test @@ -534,7 +534,7 @@ ;; . (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