Add bitwise-and prim and special ##process-statistic gambit prim

bsaleil · Jun 15, 2018 · a524d80 · a524d80
1 parent 9a56d18
commit a524d80
Show file tree

Hide file tree

Showing 4 changed files with 68 additions and 13 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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