mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-24 12:20:20 +02:00
Code Activity

Add support for comparisons against integer immediates

Browse source 
* libguile/vm-engine.c (s64-imm=?, u64-imm<?, imm-u64<?, s64-imm<?)
  (imm-s64<?): New instructions.
* libguile/instructions.c (FOR_EACH_INSTRUCTION_WORD_TYPE): Add new
  X8_S12_Z12 word type used by the new S64/immediate instructions.  A
  Z12 is a 12-bit signed integer immediate.
* module/system/vm/assembler.scm: Export new instructions, and add
  X8_S12_Z12 support.  Also, add missing shufflers for X8_S12_C12.
* module/language/bytecode.scm (compute-instruction-arity):
* module/system/vm/disassembler.scm (unpack-s12, disassembler): Add
  support for X8_S12_Z12.
* module/language/cps/types.scm (define-predicate-inferrer/param): New
  helper.
  (u64-=, u64-<, s64-<): Remove type checkers; this procedure does not
  cause &type-check.
  (u64-imm=?, s64-imm=?, u64-imm<?, imm-u64<?, s64-imm<?, imm-s64<?):
  New type inferrers.
* module/language/cps/type-fold.scm (define-unary-branch-folder*): New
  helper.
  (u64-imm=?, s64-imm=?, u64-imm<?, imm-u64<?, s64-imm<?, imm-s64<?):
  New branch folders.
* module/language/cps/reify-primitives.scm (reify-primitives): Reify
  constants for new immediate branching primcalls if values out of
  range.
* module/language/cps/effects-analysis.scm: Add support for new
  primcalls.
* module/language/cps/compile-bytecode.scm (compile-function): Add
  support for new primcalls and instructions.  Compile u64-imm-= to
  s64-imm=?.
This commit is contained in:
Andy Wingo 2017-11-14 10:41:24 +01:00
parent 4a0a930f1c
commit 294dbaad35
12 changed files with 225 additions and 19 deletions
Download patch file Download diff file Expand all files Collapse all files

41
module/language/cps/reify-primitives.scm
View file

@ -153,12 +153,13 @@
($continue kb src ($const b))))))
(($ $kargs names vars ($ $continue k src ($ $primcall name param args)))
(cond
((or (prim-instruction name) (branching-primitive? name))
((prim-instruction name)
;; Assume arities are correct.
(let ()
(define (u6? val) (and (exact-integer? val) (<= 0 val 63)))
(define (u8? val) (and (exact-integer? val) (<= 0 val 255)))
(define-syntax-rule (reify-constants wrap
(define-syntax-rule (reify-constants
wrap
((op (pred? c) in ...) (op* out ...))
...
(_ default))
@ -211,6 +212,42 @@
($continue k src ($call proc args))))
(let$ body (resolve-prim name kproc src))
(setk label ($kargs names vars ,body))))))
(($ $kargs names vars
($ $continue kf src ($ $branch kt ($ $primcall name param args))))
(let ()
(define (u11? val) (<= 0 val #x7ff))
(define (u12? val) (<= 0 val #xfff))
(define (s12? val) (<= (- #x800) val #x7ff))
(define-syntax-rule (reify-constants ((op (pred? c) in ...)
wrap-op (op* out ...))
...
(_ default))
(match name
('op
(if (pred? param)
cps
(match args
((in ...)
(with-cps cps
(letv c)
(letk kconst
($kargs ('c) (c)
($continue kf src
($branch kt ($primcall 'op* #f (out ...))))))
(setk label
($kargs names vars
($continue kconst src
($primcall 'wrap-op param ())))))))))
...
(_ default)))
(reify-constants
((u64-imm-= (u11? b) a) load-u64 (u64-= a b))
((u64-imm-< (u12? b) a) load-u64 (u64-< a b))
((imm-u64-< (u12? a) b) load-u64 (u64-< a b))
((s64-imm-= (s12? b) a) load-s64 (s64-= a b))
((s64-imm-< (s12? b) a) load-s64 (s64-< a b))
((imm-s64-< (s12? a) b) load-s64 (s64-< a b))
(_ cps))))
(($ $kargs names vars ($ $continue k src ($ $call proc args)))
(with-cps cps
(let$ k (uniquify-receive k))