From a524d8064b59988cbdc8740c8b23f6d6eb081e6c Mon Sep 17 00:00:00 2001 From: bsaleil Date: Fri, 15 Jun 2018 19:29:52 -0400 Subject: [PATCH 1/2] Add bitwise-and prim and special ##process-statistic gambit prim --- ast.scm | 4 +++- codegen.scm | 43 +++++++++++++++++++++++++++++++++++++++++++ core.scm | 31 ++++++++++++++++++++++--------- lib/num.scm | 3 --- 4 files changed, 68 insertions(+), 13 deletions(-) diff --git a/ast.scm b/ast.scm index cf20121..b9c2652 100644 --- a/ast.scm +++ b/ast.scm @@ -359,12 +359,14 @@ (vector (,ATX_VEC) #f ,lco-p-vector #f #t ,ATX_VEC #f ) (f64vector (,ATX_FEC) #f ,lco-p-f64vector #f #f ,ATX_FEC #f ,ATX_FLO ) (list (,ATX_PAI) #f ,lco-p-list #f #t ,ATX_PAI #f ) + (bitwise-and (,ATX_INT) ,dummy-cst-all #f ,codegen-p-bitwise-and #f ,ATX_INT 2 ,ATX_INT ,ATX_INT ) ;; These primitives are inlined during expansion but still here to build lambda (real? (,ATX_NUM) ,dummy-cst-all #f #f #f ,ATX_BOO 1 ,ATX_ALL ) (eqv? #f ,dummy-cst-all #f #f #f ,ATX_BOO 2 ,ATX_ALL ,ATX_ALL ) ;; (##print-double #f #f #f ,codegen-p-print-double #f ,ATX_VOI 1 ,ATX_FLO ) - (##print-perm-string #f #f #f ,codegen-p-print-perm-string #f ,ATX_VOI 1 ,ATX_STR )))) + (##print-perm-string #f #f #f ,codegen-p-print-perm-string #f ,ATX_VOI 1 ,ATX_STR ) + (##process-statistics #f #f #f ,codegen-p-process-statistics #f ,ATX_FEC 0 )))) (define (get-prim-lambda ast sym primitive) (let ((nbargs (primitive-nbargs primitive))) diff --git a/codegen.scm b/codegen.scm index 5cc8095..788191c 100644 --- a/codegen.scm +++ b/codegen.scm @@ -3459,6 +3459,39 @@ (x86-mov cgc opnd (x86-rax)) (x86-shl cgc opnd (x86-imm-int 2)))))) +(define (codegen-p-bitwise-and cgc gc-desc fs ffs op reg inlined-cond? lleft lright lcst? rcst?) + (assert (not (and lcst? rcst?)) "Internal error") + + (let ((dest (codegen-reg-to-x86reg reg)) + (lopnd (and (not lcst?) (codegen-loc-to-x86opnd fs ffs lleft))) + (ropnd (and (not rcst?) (codegen-loc-to-x86opnd fs ffs lright)))) + + (cond (lcst? + (if (not (eq? dest ropnd)) + (x86-mov cgc dest ropnd)) + (let ((imm (obj-encoding lleft))) + (if (int32? imm) + (x86-and cgc dest (x86-imm-int imm)) + (begin + (x86-mov cgc (x86-rax) (x86-imm-int imm)) + (x86-and cgc dest (x86-rax)))))) + (rcst? + (if (not (eq? dest ropnd)) + (x86-mov cgc dest lopnd)) + (let ((imm (obj-encoding lright))) + (if (int32? imm) + (x86-and cgc dest (x86-imm-int imm)) + (begin + (x86-mov cgc (x86-rax) (x86-imm-int imm)) + (x86-and cgc dest (x86-rax)))))) + ((eq? dest ropnd) + (x86-and cgc ropnd lopnd)) + ((eq? dest lopnd) + (x86-and cgc lopnd ropnd)) + (else + (x86-mov cgc dest lopnd) + (x86-and cgc dest ropnd))))) + ;;----------------------------------------------------------------------------- ;; Others ;;----------------------------------------------------------------------------- @@ -3560,6 +3593,16 @@ (x86-ppop cgc (x86-rsp)))))) (x86-mov cgc dest (x86-imm-int (obj-encoding #!void))))) +(define (codegen-p-process-statistics cgc gc-desc fs ffs op reg inlined-cond?) + (let ((dest (codegen-reg-to-x86reg reg))) + (x86-mov cgc (x86-rax) (x86-imm-int 0)) + (x86-upush cgc (x86-rax)) + (x86-pcall cgc label-gambit-process-statistics-handler) + (x86-upop cgc dest) + (if opt-nan-boxing + (begin (x86-mov cgc (x86-rax) (x86-imm-int (to-64-value NB_MASK_MEM))) + (x86-lea cgc dest (x86-mem (- TAG_MEMOBJ) dest (x86-rax))))))) + ;;----------------------------------------------------------------------------- ;; Type checks ;;----------------------------------------------------------------------------- diff --git a/core.scm b/core.scm index 88a0888..3e6b7e4 100644 --- a/core.scm +++ b/core.scm @@ -303,6 +303,13 @@ ;;----------------------------------------------------------------------------- +(c-define (gambit-process-statistics usp psp) (long long) void "gambit_process_statistics" "" + (block_gc 7) + (let ((v (##process-statistics))) + (put-i64 (+ usp 88) + (##object->encoding v))) + (unblock_gc)) + (c-define (gambit-str-to-sym-tag usp psp) (long long) void "gambit_str_to_sym_tag" "" (block_gc 1) (let* ((encoding48 (get-u48 (+ usp 88))) @@ -524,6 +531,7 @@ (define (init-labels cgc) (set-cdef-label! label-rt-error 'rt_error "___result = ___CAST(void*,rt_error);") (set-cdef-label! label-gambit-call 'gambit_call "___result = ___CAST(void*,gambit_call);") + (set-cdef-label! label-gambit-process-statistics 'gambit_process_statistics "___result = ___CAST(void*,gambit_process_statistics);") (set-cdef-label! label-gambit-str-to-sym-tag 'gambit_str_to_sym_tag "___result = ___CAST(void*,gambit_str_to_sym_tag);") (set-cdef-label! label-gambit-str-to-sym-nan 'gambit_str_to_sym_nan "___result = ___CAST(void*,gambit_str_to_sym_nan);") (set-cdef-label! label-do-callback 'do_callback "___result = ___CAST(void*,do_callback);") @@ -705,15 +713,16 @@ ;;----------------------------------------------------------------------------- -(define label-heap-limit-handler #f) -(define label-alloc-still-handler #f) -(define label-gambit-call-handler #f) -(define label-gambit-str-to-sym-handler #f) -(define label-do-callback-handler #f) -(define label-do-callback-fn-handler #f) -(define label-do-callback-cont-handler #f) -(define label-rt-error-handler #f) -(define label-err-wrong-num-args #f) +(define label-heap-limit-handler #f) +(define label-alloc-still-handler #f) +(define label-gambit-call-handler #f) +(define label-gambit-process-statistics-handler #f) +(define label-gambit-str-to-sym-handler #f) +(define label-do-callback-handler #f) +(define label-do-callback-fn-handler #f) +(define label-do-callback-cont-handler #f) +(define label-rt-error-handler #f) +(define label-err-wrong-num-args #f) (define (gen-addr-handler cgc id addr cargs-generator) (let ((label-handler (asm-make-label cgc id))) @@ -855,6 +864,10 @@ (gen-handler cgc 'gambit_call_handler label-gambit-call)) (x86-ret cgc) + (set! label-gambit-process-statistics-handler + (gen-handler cgc 'gambit_process_statistics label-gambit-process-statistics)) + (x86-ret cgc) + (set! label-gambit-str-to-sym-handler (if opt-nan-boxing (gen-handler cgc 'gambit_str_to_sym_handler label-gambit-str-to-sym-nan) diff --git a/lib/num.scm b/lib/num.scm index a9b63bf..e4a1d35 100644 --- a/lib/num.scm +++ b/lib/num.scm @@ -61,9 +61,6 @@ (min-h (cdr els) m))))) (min-h l a)) -(define (bitwise-and a b) - (gambit$$bitwise-and a b)) - (define (arithmetic-shift n s) (cond ((> s 0) (* n (expt 2 s))) (else From 1485d4ad407cf070a312148272a3c296ab30306e Mon Sep 17 00:00:00 2001 From: bsaleil Date: Fri, 15 Jun 2018 19:31:26 -0400 Subject: [PATCH 2/2] Update prefix to use special prims --- tools/benchtimes/prefix/LC.scm | 8 ++++---- tools/benchtimes/prefix/LCf64v.scm | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/tools/benchtimes/prefix/LC.scm b/tools/benchtimes/prefix/LC.scm index 4a42bff..6ee7603 100644 --- a/tools/benchtimes/prefix/LC.scm +++ b/tools/benchtimes/prefix/LC.scm @@ -75,13 +75,13 @@ r))) (define (##lc-exec-stats thunk) - (let* ((at-start (gambit$$##process-statistics)) + (let* ((at-start (##process-statistics)) (result (thunk)) - (at-end (gambit$$##process-statistics))) + (at-end (##process-statistics))) (define (get-info msg idx) (cons msg - (- (gambit$$##f64vector-ref at-end idx) - (gambit$$##f64vector-ref at-start idx)))) + (- (f64vector-ref at-end idx) + (f64vector-ref at-start idx)))) (list result (get-info "User time" 0) diff --git a/tools/benchtimes/prefix/LCf64v.scm b/tools/benchtimes/prefix/LCf64v.scm index 0b36670..10a4056 100644 --- a/tools/benchtimes/prefix/LCf64v.scm +++ b/tools/benchtimes/prefix/LCf64v.scm @@ -80,13 +80,13 @@ r))) (define (##lc-exec-stats thunk) - (let* ((at-start (gambit$$##process-statistics)) + (let* ((at-start (##process-statistics)) (result (thunk)) - (at-end (gambit$$##process-statistics))) + (at-end (##process-statistics))) (define (get-info msg idx) (cons msg - (- (gambit$$##f64vector-ref at-end idx) - (gambit$$##f64vector-ref at-start idx)))) + (- (f64vector-ref at-end idx) + (f64vector-ref at-start idx)))) (list result (get-info "User time" 0)