summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2017-11-11 21:10:28 +0100
committerAndy Wingo <wingo@pobox.com>2017-11-11 22:08:14 +0100
commitb331ea319355e3a5eb626abc736b6fa540a516ed (patch)
tree6f1c7a3b02edc1d7aaab7cf0839f9a361c978e0d
parenta268c02fa0c7e93c390cc7adf0bfbf422e92ea29 (diff)
downloadguile-b331ea319355e3a5eb626abc736b6fa540a516ed.tar.gz
Convert "ash" to "lsh"/"rsh" when lowering to CPS
* module/language/cps/effects-analysis.scm: Remove case for "ash". * module/language/cps/types.scm (ash): Remove. * module/language/tree-il/compile-cps.scm (convert, canonicalize): Convert "ash" to "lsh"/"rsh" early on. * module/system/base/target.scm (target-fixnum?): New procedure.
-rw-r--r--module/language/cps/effects-analysis.scm1
-rw-r--r--module/language/cps/types.scm9
-rw-r--r--module/language/tree-il/compile-cps.scm48
-rw-r--r--module/system/base/target.scm9
4 files changed, 52 insertions, 15 deletions
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index 3131366d6..144f15cde 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -458,7 +458,6 @@ is or might be a read or a write to the same location as A."
((inexact? _) &type-check)
((even? _) &type-check)
((odd? _) &type-check)
- ((ash n m) &type-check)
((rsh n m) &type-check)
((lsh n m) &type-check)
((rsh/immediate n) &type-check)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index f853c979b..a185eaa82 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1300,7 +1300,6 @@ minimum, and maximum."
(define-type-aliases even? odd?)
;; Bit operations.
-(define-simple-type-checker (ash &exact-integer &exact-integer))
(define-simple-type-checker (lsh &exact-integer &u64))
(define-simple-type-checker (rsh &exact-integer &u64))
(define (compute-ash-range min-val max-val min-shift max-shift)
@@ -1318,14 +1317,6 @@ minimum, and maximum."
(++ (ash* max-val max-shift))
(+- (ash* max-val min-shift)))
(values (min -- -+ ++ +-) (max -- -+ ++ +-))))
-(define-type-inferrer (ash val count result)
- (restrict! val &exact-integer -inf.0 +inf.0)
- (restrict! count &exact-integer -inf.0 +inf.0)
- (let-values (((min max) (compute-ash-range (&min val)
- (&max val)
- (&min count)
- (&max count))))
- (define-exact-integer! result min max)))
(define-type-inferrer (lsh val count result)
(restrict! val &exact-integer -inf.0 +inf.0)
(let-values (((min max) (compute-ash-range (&min val)
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index c2b000ef6..11eed5ae3 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -54,6 +54,7 @@
#:use-module ((srfi srfi-1) #:select (fold filter-map))
#:use-module (srfi srfi-26)
#:use-module ((system foreign) #:select (make-pointer pointer->scm))
+ #:use-module (system base target)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps with-cps)
@@ -659,6 +660,13 @@
cps idx 'scm->u64
(lambda (cps idx)
(have-args cps (list obj idx val)))))))
+ ((rsh lsh)
+ (match args
+ ((a b)
+ (unbox-arg
+ cps b 'untag-fixnum
+ (lambda (cps b)
+ (have-args cps (list a b)))))))
((make-vector)
(match args
((length init)
@@ -725,11 +733,12 @@
(add/immediate y (x)))
(('sub x ($ <const> _ (? number? y)))
(sub/immediate y (x)))
- (('ash x ($ <const> _ (? uint? y)))
+ (('lsh x ($ <const> _ (? uint? y)))
(lsh/immediate y (x)))
- (('ash x ($ <const> _ (? negint? y)))
- (rsh/immediate (- y) (x)))
- (_ (default))))
+ (('rsh x ($ <const> _ (? uint? y)))
+ (rsh/immediate y (x)))
+ (_
+ (default))))
(when (branching-primitive? name)
(error "branching primcall in bad context" name))
;; Tree-IL primcalls are sloppy, in that it could be that
@@ -1192,6 +1201,37 @@ integer."
($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
exp)
+ (($ <primcall> src 'ash (a b))
+ (match b
+ (($ <const> src2 (? target-fixnum? n))
+ (if (< n 0)
+ (make-primcall src 'rsh (list a (make-const src2 (- n))))
+ (make-primcall src 'lsh (list a b))))
+ (_
+ (let* ((a-sym (gensym "a "))
+ (b-sym (gensym "b "))
+ (a-ref (make-lexical-ref src 'a a-sym))
+ (b-ref (make-lexical-ref src 'b b-sym)))
+ (make-let
+ src (list 'a 'b) (list a-sym b-sym) (list a b)
+ (make-conditional
+ src
+ (make-primcall src 'fixnum? (list b-ref))
+ (make-conditional
+ src
+ (make-primcall src '< (list b-ref (make-const src 0)))
+ (let ((n (make-primcall src '- (list (make-const src 0) b-ref))))
+ (make-primcall src 'rsh (list a-ref n)))
+ (make-primcall src 'lsh (list a-ref b-ref)))
+ (make-primcall
+ src 'throw
+ (list
+ (make-const #f 'wrong-type-arg)
+ (make-const #f "ash")
+ (make-const #f "Wrong type (expecting fixnum): ~S")
+ (make-primcall #f 'list (list b-ref))
+ (make-primcall #f 'list (list b-ref))))))))))
+
;; Eta-convert prompts without inline handlers.
(($ <prompt> src escape-only? tag body handler)
(let ((h (gensym "h "))
diff --git a/module/system/base/target.scm b/module/system/base/target.scm
index 7c6e0aca0..95ab8d8c9 100644
--- a/module/system/base/target.scm
+++ b/module/system/base/target.scm
@@ -33,7 +33,8 @@
target-max-vector-length
target-most-negative-fixnum
- target-most-positive-fixnum))
+ target-most-positive-fixnum
+ target-fixnum?))
@@ -179,3 +180,9 @@ target platform."
"Return the most positive integer representable as a fixnum on the
target platform."
(1- (ash 1 (- (* (target-word-size) 8) 3))))
+
+(define (target-fixnum? n)
+ (and (exact-integer? n)
+ (<= (target-most-negative-fixnum)
+ n
+ (target-most-positive-fixnum))))