diff options
Diffstat (limited to 'module/language')
-rw-r--r-- | module/language/cps/cse.scm | 8 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 6 | ||||
-rw-r--r-- | module/language/cps/slot-allocation.scm | 8 | ||||
-rw-r--r-- | module/language/cps/types.scm | 17 |
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))) + |