summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
Diffstat (limited to 'module/language')
-rw-r--r--module/language/cps/cse.scm8
-rw-r--r--module/language/cps/effects-analysis.scm6
-rw-r--r--module/language/cps/slot-allocation.scm8
-rw-r--r--module/language/cps/types.scm17
4 files changed, 32 insertions, 7 deletions
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 2e47f379c..ad554faa0 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -307,6 +307,14 @@ false. It could be that both true and false proofs are available."
(match defs
((scm)
(add-def! `(primcall scm->f64 ,scm) f64))))
+ (('primcall 'scm->u64 scm)
+ (match defs
+ ((u64)
+ (add-def! `(primcall u64->scm ,u64) scm))))
+ (('primcall 'u64->scm u64)
+ (match defs
+ ((scm)
+ (add-def! `(primcall scm->u64 ,scm) u64))))
(_ #t))))
(define (visit-label label equiv-labels var-substs)
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index ae7a1a614..9c9334671 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -351,10 +351,12 @@ is or might be a read or a write to the same location as A."
((string->number _) (&read-object &string) &type-check)
((string-length s) &type-check))
-;; Unboxed floats.
+;; Unboxed floats and integers.
(define-primitive-effects
((scm->f64 _) &type-check)
- ((f64->scm _)))
+ ((f64->scm _))
+ ((scm->u64 _) &type-check)
+ ((u64->scm _)))
;; Bytevectors.
(define-primitive-effects
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 8d865d739..ca8e32123 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -53,8 +53,8 @@
;;
(slots allocation-slots)
- ;; A map of VAR to representation. A representation is either 'scm or
- ;; 'f64.
+ ;; A map of VAR to representation. A representation is 'scm, 'f64, or
+ ;; 'u64.
;;
(representations allocation-representations)
@@ -793,6 +793,8 @@ are comparable with eqv?. A tmp slot may be used."
(($ $primcall (or 'scm->f64 'bv-f32-ref 'bv-f64-ref
'fadd 'fsub 'fmul 'fdiv))
(intmap-add representations var 'f64))
+ (($ $primcall (or 'scm->u64))
+ (intmap-add representations var 'u64))
(_
(intmap-add representations var 'scm))))
(vars
@@ -874,7 +876,7 @@ are comparable with eqv?. A tmp slot may be used."
(#f slot-map)
(slot
(let ((desc (match (intmap-ref representations var)
- ('f64 slot-desc-live-raw)
+ ((or 'u64 'f64) slot-desc-live-raw)
('scm slot-desc-live-scm))))
(logior slot-map (ash desc (* 2 slot)))))))
live-vars 0))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 08e8ec8de..8482b9836 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -119,6 +119,7 @@
;; Untagged types.
&f64
+ &u64
infer-types
lookup-pre-type
@@ -169,7 +170,8 @@
&array
&hash-table
- &f64)
+ &f64
+ &u64)
(define-syntax &no-type (identifier-syntax 0))
@@ -678,7 +680,7 @@ minimum, and maximum."
;;;
-;;; Unboxed double-precision floating-point numbers.
+;;; Unboxed numbers.
;;;
(define-type-checker (scm->f64 scm)
@@ -692,6 +694,17 @@ minimum, and maximum."
(define-type-inferrer (f64->scm f64 result)
(define! result &flonum (&min f64) (&max f64)))
+(define-type-checker (scm->u64 scm)
+ (check-type scm &exact-integer 0 +inf.0))
+(define-type-inferrer (scm->u64 scm result)
+ (restrict! scm &exact-integer 0 +inf.0)
+ (define! result &u64 (&min scm) (&max scm)))
+
+(define-type-checker (u64->scm u64)
+ #t)
+(define-type-inferrer (u64->scm u64 result)
+ (define! result &exact-integer (&min u64) (&max u64)))
+