Permalink
Browse files

Remove primitive expander dependencies with C back-end.

  • Loading branch information...
feeley committed Jun 14, 2012
1 parent c6e851a commit 001c20461ffaa695d0894540ab76fcaaceb72930
Showing with 80 additions and 49 deletions.
  1. +12 −4 gsc/_back.scm
  2. +31 −24 gsc/_prims.scm
  3. +12 −5 gsc/_t-c-1.scm
  4. +12 −12 gsc/_t-c-2.scm
  5. +1 −1 gsc/_t-c-3.scm
  6. +10 −1 gsc/_t-univ.scm
  7. +2 −2 include/stamp.h
View
@@ -105,6 +105,12 @@
;; This function tests whether an object can be tested
;; in a GVM "switch" instruction.
;;
+;; object-type Function.
+;; This function returns a symbol indicating the type of its
+;; argument. For exact integers the return value is
+;; either fixnum, bignum, or bigfixnum (when the integer
+;; could be a fixnum or bignum).
+;;
;; file-extension The file extension for generated files.
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@@ -113,13 +119,13 @@
(define (make-target version name extra)
- (define current-target-version 7) ; number for this version of the module
+ (define current-target-version 8) ; number for this version of the module
(if (not (= version current-target-version))
(compiler-internal-error
"make-target, version of target module is not current" name))
- (let ((x (make-vector (+ 14 extra))))
+ (let ((x (make-vector (+ 15 extra))))
(vector-set! x 0 'target)
(vector-set! x 1 name)
x))
@@ -149,8 +155,10 @@
(define (target-task-return-set! x y) (vector-set! x 11 y))
(define (target-switch-testable? x) (vector-ref x 12))
(define (target-switch-testable?-set! x y) (vector-set! x 12 y))
-(define (target-file-extension x) (vector-ref x 13))
-(define (target-file-extension-set! x y) (vector-set! x 13 y))
+(define (target-object-type x) (vector-ref x 13))
+(define (target-object-type-set! x y) (vector-set! x 13 y))
+(define (target-file-extension x) (vector-ref x 14))
+(define (target-file-extension-set! x y) (vector-set! x 14 y))
;;;; Frame constraints structure
View
@@ -1909,12 +1909,12 @@
(define gen-flonum-0
(lambda (source env vars invalid)
(new-cst source env
- targ-inexact-+0))) ;; TODO: remove this dependency on C backend
+ (macro-inexact-+0))))
(define gen-flonum-1
(lambda (source env vars invalid)
(new-cst source env
- targ-inexact-+1))) ;; TODO: remove this dependency on C backend
+ (macro-inexact-+1))))
(define gen-first-arg
(lambda (source env vars invalid)
@@ -2809,28 +2809,35 @@
(define **f64vector-set!-sym (string->canonical-symbol "##f64vector-set!"))
(define (make-fixnum-interval-checker lo hi)
- ; assumes (integer-length hi) >= (integer-length lo)
- (lambda (source env var)
- (if (targ-fixnum64? hi) ;; TODO: remove this dependency on C backend
- (let ((interval-check
- (gen-fixnum-interval-check source env
- var
- (new-cst source env
- lo)
- (new-cst source env
- hi)
- #t)))
- (if (targ-fixnum32? hi) ;; TODO: remove this dependency on C backend
- interval-check
- (new-conj source env
- (gen-call-prim source env
- **fixnum?-sym
- (list (new-cst source env
- hi)))
- interval-check)))
- (gen-call-prim-vars source env
- **fixnum?-sym
- (list var)))))
+
+ ;; assumes (integer-length hi) >= (integer-length lo)
+
+ (let ((hi-type ((target-object-type targ) hi)))
+ (lambda (source env var)
+ (if (eq? hi-type 'bignum)
+
+ (gen-call-prim-vars source env
+ **fixnum?-sym
+ (list var))
+
+ (let ((interval-check
+ (gen-fixnum-interval-check source env
+ var
+ (new-cst source env
+ lo)
+ (new-cst source env
+ hi)
+ #t)))
+ (if (eq? hi-type 'fixnum)
+
+ interval-check
+
+ (new-conj source env
+ (gen-call-prim source env
+ **fixnum?-sym
+ (list (new-cst source env
+ hi)))
+ interval-check)))))))
(define (make-flonum-checker)
(lambda (source env var)
View
@@ -209,7 +209,7 @@
;; Initialization/finalization of back-end
(define (targ-make-target)
- (let ((targ (make-target 7 'c 1)))
+ (let ((targ (make-target 8 'c 1)))
(define (begin! info-port)
@@ -226,6 +226,7 @@
(target-proc-result-set! targ (make-reg 1))
(target-task-return-set! targ (make-reg 0))
(target-switch-testable?-set! targ targ-switch-testable?)
+ (target-object-type-set! targ targ-object-type)
(target-file-extension-set! targ (targ-preferred-c-file-extension))
#f)
@@ -240,8 +241,8 @@
targ))
-(define (targ-prim-proc-table x) (vector-ref x 14))
-(define (targ-prim-proc-table-set! x y) (vector-set! x 14 y))
+(define (targ-prim-proc-table x) (vector-ref x 15))
+(define (targ-prim-proc-table-set! x y) (vector-set! x 15 y))
(define targ-target (targ-make-target))
@@ -282,6 +283,12 @@
(define (targ-switch-testable? obj)
(targ-testable-with-eq? obj))
+(define (targ-object-type obj)
+ (let ((t (targ-obj-type obj)))
+ (if (eq? t 'subtyped)
+ (targ-obj-subtype obj)
+ t)))
+
;;;----------------------------------------------------------------------------
;;
;; Dumping of a compilation module
@@ -659,7 +666,7 @@
'("REST"))
;; ((body)
;; '("BODY_OBJ"))
- ((fixnum32)
+ ((fixnum)
(list "FIX" (targ-c-s32 obj)))
((char)
(list "CHR" (targ-c-char obj)))
@@ -760,7 +767,7 @@
'("REF_REST"))
;; ((body)
;; '("REF_BODY_OBJ"))
- ((fixnum32)
+ ((fixnum)
(list "REF_FIX" obj))
((char)
(list "REF_CHR" (targ-c-char obj)))
View
@@ -1166,7 +1166,7 @@
(targ-adjust-stack fs))
(let loop ((lst cases)
- (rev-cases-fixnum32 '())
+ (rev-cases-fixnum '())
(rev-cases-char '())
(rev-cases-symbol '())
(rev-cases-keyword '())
@@ -1177,41 +1177,41 @@
(obj (switch-case-obj c)))
(cond ((targ-fixnum32? obj)
(loop (cdr lst)
- (cons c rev-cases-fixnum32)
+ (cons c rev-cases-fixnum)
rev-cases-char
rev-cases-symbol
rev-cases-keyword
rev-cases-other))
((char? obj)
(loop (cdr lst)
- rev-cases-fixnum32
+ rev-cases-fixnum
(cons c rev-cases-char)
rev-cases-symbol
rev-cases-keyword
rev-cases-other))
((symbol-object? obj)
(loop (cdr lst)
- rev-cases-fixnum32
+ rev-cases-fixnum
rev-cases-char
(cons c rev-cases-symbol)
rev-cases-keyword
rev-cases-other))
((keyword-object? obj)
(loop (cdr lst)
- rev-cases-fixnum32
+ rev-cases-fixnum
rev-cases-char
rev-cases-symbol
(cons c rev-cases-keyword)
rev-cases-other))
(else
(loop (cdr lst)
- rev-cases-fixnum32
+ rev-cases-fixnum
rev-cases-char
rev-cases-symbol
rev-cases-keyword
(cons c rev-cases-other)))))
- (let* ((cases-fixnum32 (reverse rev-cases-fixnum32))
+ (let* ((cases-fixnum (reverse rev-cases-fixnum))
(cases-char (reverse rev-cases-char))
(cases-symbol (reverse rev-cases-symbol))
(cases-keyword (reverse rev-cases-keyword))
@@ -1231,10 +1231,10 @@
cases)
(targ-emit (list end-macro)))))
- (if (<= (length cases-fixnum32) 2)
+ (if (<= (length cases-fixnum) 2)
(begin
- (set! cases-other (append cases-fixnum32 cases-other))
- (set! cases-fixnum32 '())))
+ (set! cases-other (append cases-fixnum cases-other))
+ (set! cases-fixnum '())))
(if (<= (length cases-char) 2)
(begin
@@ -1246,7 +1246,7 @@
"SWITCH_CASE_GOTO"
"END_SWITCH")
- (gen cases-fixnum32
+ (gen cases-fixnum
"BEGIN_SWITCH_FIXNUM"
"SWITCH_FIXNUM_CASE_GOTO"
"END_SWITCH_FIXNUM")
@@ -2651,7 +2651,7 @@
(memq (targ-obj-type obj)
'(boolean null absent unused deleted void eof optional
key rest
- fixnum32 char))))
+ fixnum char))))
;;;----------------------------------------------------------------------------
View
@@ -331,7 +331,7 @@
'pair)
((number? obj)
(cond ((targ-fixnum32? obj)
- 'fixnum32)
+ 'fixnum)
(else
'subtyped)))
((char? obj)
View
@@ -24,7 +24,7 @@
;; Initialization/finalization of back-end.
(define (univ-setup target-language file-extension)
- (let ((targ (make-target 7 target-language 0)))
+ (let ((targ (make-target 8 target-language 0)))
(define (begin! info-port)
@@ -67,6 +67,11 @@
(lambda (obj)
(univ-switch-testable? targ obj)))
+ (target-object-type-set!
+ targ
+ (lambda (obj)
+ (univ-object-type targ obj)))
+
(target-file-extension-set!
targ
file-extension)
@@ -268,6 +273,10 @@
(pretty-print (list 'univ-switch-testable? 'targ obj))
#f)
+(define (univ-object-type targ obj)
+ (pretty-print (list 'univ-object-type 'targ obj))
+ 'bignum)
+
;; ***** DUMPING OF A COMPILATION MODULE
(define (univ-dump targ procs output c-intf script-line options)
View
@@ -2,5 +2,5 @@
* Time stamp of last source code repository commit.
*/
-#define ___STAMP_YMD 20120613
-#define ___STAMP_HMS 152614
+#define ___STAMP_YMD 20120614
+#define ___STAMP_HMS 185400

0 comments on commit 001c204

Please sign in to comment.