diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 055cc8305..ea46f68e4 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -221,13 +221,13 @@ (emit-scm->u64/truncate asm (from-sp dst) (from-sp (slot src)))) (($ $primcall 'load-u64 (src)) (emit-load-u64 asm (from-sp dst) (constant src))) - (($ $primcall 'u64->scm (src)) + (($ $primcall (or 'u64->scm 'u64->scm/unlikely) (src)) (emit-u64->scm asm (from-sp dst) (from-sp (slot src)))) (($ $primcall 'scm->s64 (src)) (emit-scm->s64 asm (from-sp dst) (from-sp (slot src)))) (($ $primcall 'load-s64 (src)) (emit-load-s64 asm (from-sp dst) (constant src))) - (($ $primcall 's64->scm (src)) + (($ $primcall (or 's64->scm 's64->scm/unlikely) (src)) (emit-s64->scm asm (from-sp dst) (from-sp (slot src)))) (($ $primcall 'bv-length (bv)) (emit-bv-length asm (from-sp dst) (from-sp (slot bv)))) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index fb27635bf..2623e4a5c 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -310,7 +310,7 @@ false. It could be that both true and false proofs are available." (match defs ((u64) (add-def! `(primcall u64->scm ,u64) scm)))) - (('primcall 'u64->scm u64) + (('primcall (or 'u64->scm 'u64->scm/unlikely) u64) (match defs ((scm) (add-def! `(primcall scm->u64 ,scm) u64) @@ -319,7 +319,7 @@ false. It could be that both true and false proofs are available." (match defs ((s64) (add-def! `(primcall s64->scm ,s64) scm)))) - (('primcall 's64->scm s64) + (('primcall (or 's64->scm 's64->scm/unlikely) s64) (match defs ((scm) (add-def! `(primcall scm->s64 ,scm) s64)))) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 87f82353d..675b5241d 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -381,9 +381,11 @@ is or might be a read or a write to the same location as A." ((scm->u64/truncate _) &type-check) ((load-u64 _)) ((u64->scm _)) + ((u64->scm/unlikely _)) ((scm->s64 _) &type-check) ((load-s64 _)) ((s64->scm _)) + ((s64->scm/unlikely _)) ((untag-fixnum _))) ;; Bytevectors. diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index 1437a4e97..f5966a54c 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -66,7 +66,9 @@ (bytevector-ieee-double-native-set! . bv-f64-set!))) (define *macro-instruction-arities* - '((cache-current-module! . (0 . 2)) + '((u64->scm/unlikely . (1 . 1)) + (s64->scm/unlikely . (1 . 1)) + (cache-current-module! . (0 . 2)) (cached-toplevel-box . (1 . 3)) (cached-module-box . (1 . 4)))) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index 67aea82c4..4a687e7df 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -550,6 +550,7 @@ BITS indicating the significant bits needed for a variable. BITS may be (define (exp-result-u64? exp) (match exp ((or ($ $primcall 'u64->scm (_)) + ($ $primcall 'u64->scm/unlikely (_)) ($ $const (and (? number?) (? exact-integer?) (? (lambda (n) (<= 0 n #xffffffffffffffff)))))) #t) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 05f6a8d3a..690595958 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -862,6 +862,7 @@ minimum, and maximum." #t) (define-type-inferrer (u64->scm u64 result) (define-exact-integer! result (&min/0 u64) (&max/u64 u64))) +(define-type-aliases u64->scm u64->scm/unlikely) (define-type-checker (scm->s64 scm) (check-type scm &exact-integer &s64-min &s64-max)) @@ -869,6 +870,7 @@ minimum, and maximum." (restrict! scm &exact-integer &s64-min &s64-max) (define! result &s64 (&min/s64 scm) (&max/s64 scm))) (define-type-aliases scm->s64 load-s64) +(define-type-aliases s64->scm s64->scm/unlikely) (define-simple-type-checker (untag-fixnum &fixnum)) (define-type-inferrer (untag-fixnum scm result)