#| -*-Scheme-*-
-$Id: compiler.pkg,v 1.17 2006/09/16 11:19:09 gjr Exp $
+$Id: compiler.pkg,v 1.18 2006/10/01 05:37:44 cph Exp $
-Copyright (c) 1992-1999, 2001, 2002, 2006 Massachusetts Institute of Technology
+Copyright 1993,1994,2001,2002,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
lap:make-unconditional-branch)
(export (compiler top-level)
*block-associations*
+ c:write-group
current-register-list
fake-compiled-block-name
free-assignments
#| -*-Scheme-*-
-$Id: cout.scm,v 1.24 2006/09/16 11:19:09 gjr Exp $
+$Id: cout.scm,v 1.25 2006/10/01 05:37:50 cph Exp $
-Copyright (c) 1992-1999, 2006 Massachusetts Institute of Technology
+Copyright 1993,1998,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
-\f
+
(define-syntax let*/mv
(rsc-macro-transformer
(lambda (form environment)
(LAMBDA ,values-names
,(recur (cdr bindings))))))))))))
\f
-(define *use-stackify?* true)
-(define *disable-timestamps?* false)
+(define *use-stackify?* #t)
+(define *disable-nonces?* #f)
(define *C-procedure-name* 'DEFAULT)
(define *subblocks*) ;referenced by stackify
(if (not *use-stackify?*)
(stringify-data/traditional object output-pathname)
(stringify-data/stackify object output-pathname)))
-
+
(define (stringify-data/stackify object output-pathname)
(let* ((str (stackify 0 object))
(handle (or (and output-pathname
"handle"))
(data-name
(canonicalize-label-name
- (string-append handle "_data" (make-time-stamp)))))
-
- (list-of-strings->string
- (append (file-prefix)
+ (string-append handle "_data_" (make-nonce)))))
+ (c:group (file-prefix)
+ (c:line)
(file-header 0 handle #f #f #f data-name)
- (list "#ifndef WANT_ONLY_CODE\n")
- (stackify-output->data-decl "prog" str)
- (list "\n")
- (object-function-header/stackify data-name)
- (list "\tDECLARE_VARIABLES_FOR_OBJECT();\n\n")
- (list
- "\treturn (unstackify (((unsigned char *) (& prog[0])), 0));")
- (function-trailer data-name)
- (list "#endif /* WANT_ONLY_CODE */\n")))))
+ (c:data-section
+ (stackify-output->data-decl 'prog str)
+ (c:line)
+ (c:fn #f 'sobj data-name '()
+ (c:scall "DECLARE_VARIABLES_FOR_OBJECT")
+ (c:line)
+ (c:return (c:ecall 'unstackify
+ (c:cast 'uchar* (c:aptr 'prog 0))
+ 0)))))))
(define (stringify-data/traditional object output-pathname)
(let*/mv (((vars prefix suffix) (handle-top-level-data/traditional object))
"handle"))
(data-name
(canonicalize-label-name
- (string-append handle "_data" (make-time-stamp)))))
-
- (list-of-strings->string
- (append (file-prefix)
+ (string-append handle "_data_" (make-nonce)))))
+ (c:group (file-prefix)
+ (c:line)
(file-header 0 handle #f #f #f data-name)
- (list "#ifndef WANT_ONLY_CODE\n")
- (object-function-header/traditional data-name)
- (->variable-declarations vars)
- (list "\tDECLARE_VARIABLES_FOR_OBJECT();\n")
- (list "\n\t")
- prefix
- suffix
- (list "\n\treturn (top_level_object);\n")
- (function-trailer data-name)
- (list "#endif /* WANT_ONLY_CODE */\n")))))
+ (c:data-section
+ (c:fn #f 'sobj data-name '()
+ (c:decl 'sobj 'top_level_object)
+ (c:group* (map (lambda (var) (c:decl 'sobj var)) vars))
+ (c:scall "DECLARE_VARIABLES_FOR_OBJECT")
+ (c:line)
+ (c:group* prefix)
+ (c:group* suffix)
+ (c:return 'top_level_object))))))
\f
(define (stringify suffix initial-label lap-code info-output-pathname)
;; returns <code-name data-name ntags symbol-table code proxy>
- (define (canonicalize-name name full?)
- (if full?
- (canonicalize-label-name name)
- (C-quotify-string name)))
-
- (define (choose-name full? default midfix time-stamp)
- (let ((path (and info-output-pathname
- (merge-pathnames
- (if (pair? info-output-pathname)
- (car info-output-pathname)
- info-output-pathname)))))
-
- (cond ((not *C-procedure-name*)
- (string-append default suffix time-stamp))
- ((not (eq? *C-procedure-name* 'DEFAULT))
- (string-append *C-procedure-name*
- midfix
- suffix))
- ((not path)
- (string-append default suffix time-stamp))
- ((or (string-null? suffix) *disable-timestamps?*)
- (let ((dir (pathname-directory path)))
- (string-append
- (if (or (not dir) (null? dir))
- default
- (canonicalize-name (car (last-pair dir)) full?))
- "_"
- (canonicalize-name (pathname-name path) full?)
- midfix
- suffix)))
- (else
- (string-append
- (canonicalize-name (pathname-name path) full?)
- "_"
- default
- suffix
- time-stamp)))))
-\f
- (define (gen-code-name time-stamp)
- (choose-name true "code" "" time-stamp))
-
- (define (gen-data-name time-stamp)
- (choose-name true "data" "_data" time-stamp))
-
- (define (gen-handle-name time-stamp)
- (choose-name false "" "" time-stamp))
-
- (define (subroutine-information-1)
- (cond ((eq? *invoke-interface* 'INFINITY)
- (values (list "") (list "")))
- ((< *invoke-interface* 5)
- (values (list-tail (list
- "\nDEFLABEL(invoke_interface_0);\n"
- "\tutlarg_1 = 0;\n"
- "\nDEFLABEL(invoke_interface_1);\n"
- "\tutlarg_2 = 0;\n"
- "\nDEFLABEL(invoke_interface_2);\n"
- "\tutlarg_3 = 0;\n"
- "\nDEFLABEL(invoke_interface_3);\n"
- "\tutlarg_4 = 0;\n"
- "\nDEFLABEL(invoke_interface_4);\n\t"
- "INVOKE_INTERFACE_CODE ();\n")
- *invoke-interface*)
- (list "\tint utlarg_code;\n"
- "\tlong utlarg_1, utlarg_2, utlarg_3, utlarg_4;\n")))
- (else
- (error "subroutine-information-1: Utilities take at most 4 args"
- *invoke-interface*))))
-
- (define (subroutine-information-2)
- (if *used-invoke-primitive*
- (values (list "\nDEFLABEL(invoke_primitive);\n\t"
- "INVOKE_PRIMITIVE_CODE ();")
- (list "\tSCHEME_OBJECT primitive;\n"
- "\tlong primitive_nargs;\n"))
- (values (list "") (list ""))))
-
- (define (subroutine-information)
- (let*/mv (((code-1 vars-1) (subroutine-information-1))
- ((code-2 vars-2) (subroutine-information-2)))
- (values (append code-1 code-2)
- (append vars-1 vars-2))))
-
- (if *purification-root-object*
- (define-object "PURIFICATION_ROOT"
- (if (vector? (cdr *purification-root-object*))
- *purification-root-object*
- (cons (car *purification-root-object*)
- (list->vector
- (reverse (cdr *purification-root-object*)))))))
-
- (define-object (special-label/debugging)
- (let frob ((obj info-output-pathname))
- (cond ((pathname? obj)
- (->namestring/shared obj))
- ((pair? obj)
- (cons (frob (car obj))
- (frob (cdr obj))))
- (else
- obj))))
-
- (define-object (special-label/environment) unspecific)
-\f
- (let*/mv ((label-offset 1) ; First word is vector header
- (initial-offset (label->offset initial-label))
- ((first-free-offset ntags label-defines label-dispatch
- label-block-initialization symbol-table)
- (handle-labels label-offset))
- ((first-object-offset free-defines
- free-block-initialization free-symbols)
- (handle-free-refs-and-sets first-free-offset))
- ((cc-block-size decl-code decl-data
- xtra-procs object-prefix
- object-defines temp-vars
- object-block-initialization)
- (handle-objects first-object-offset))
- (time-stamp (make-time-stamp))
- (handle (gen-handle-name time-stamp))
- (code-name (gen-code-name time-stamp))
- (data-name (gen-data-name time-stamp))
- (decl-code-name (string-append "decl_" code-name))
- (decl-data-name (string-append "decl_" data-name))
- ((extra-code extra-variables)
- (subroutine-information))
- ((proxy xtra-procs* decl-code* decl-data* data-prefix data-body)
- (data-function-body (string-null? suffix)
- ntags
- data-name
- initial-offset
- cc-block-size
- temp-vars
- object-prefix
- label-block-initialization
- free-block-initialization
- object-block-initialization))
- (use-stackify? *use-stackify?*))
- (values
- code-name
- data-name
- ntags
- (cons* (cons (special-label/environment)
- (- cc-block-size 1))
- (cons (special-label/debugging)
- (- cc-block-size 2))
- (append free-symbols symbol-table))
- (list-of-strings->string
- (map (lambda (x)
- (list-of-strings->string x))
- (list
- (if (string-null? suffix)
- (file-prefix)
- '())
-
- ;; Extra code
-
- xtra-procs
- xtra-procs*
-
- ;; defines for the code
-
- label-defines
- object-defines
- free-defines
- (list "\n")
-
- ;; the code itself
-
- (list "#ifndef WANT_ONLY_DATA\n")
- (let ((header (code-function-header code-name)))
- (if (string-null? suffix)
- header
- (cons "static " header)))
- (function-decls)
- (register-declarations)
- extra-variables
- (list
- "\n"
- ;; The assignment is necessary to ensure that we restart properly
- ;; after an interrupt when the dynamic link is live
- ;; (see DLINK_INTERRUPT_CHECK and comp_interrupt_restart
- "\tRdl = (OBJECT_ADDRESS (Rvl));\n"
- "\tgoto perform_dispatch;\n\n"
- "DEFLABEL(pop_return);\n\t"
- "Rpc = (OBJECT_ADDRESS (*Rsp++));\n\n"
- "DEFLABEL(perform_dispatch);\n\n\t"
- "switch ((* ((unsigned long *) Rpc))"
- " - dispatch_base)\n\t{")
- label-dispatch
- (list
- "\n\t default:\n\t\t"
- "UNCACHE_VARIABLES ();\n\t\t"
- "return (Rpc);\n\t}\n\t")
- (map stringify-object lap-code)
- extra-code
- (function-trailer code-name)
- (list
- "#endif /* WANT_ONLY_DATA */\n")
-
- (if (and (string-null? suffix) use-stackify?)
- (list "\f\n")
- '())
-
- ;; the data generator
-
- data-prefix
-
- (if (or (string-null? suffix)
- (not use-stackify?))
- (append
- (list "\n")
- (list "#ifndef WANT_ONLY_CODE\n")
- (let ((header (data-function-header data-name)))
- (if (string-null? suffix)
- header
- (cons "static " header)))
- data-body
- (function-trailer data-name)
- (list "#endif /* WANT_ONLY_CODE */\n"))
- '())
-
- ;; File footer
-
- (if (and (string-null? suffix) use-stackify?)
- (list "\f\n")
- '())
-
- (cond ((not (string-null? suffix))
- '())
- ((not use-stackify?)
- (file-decls/traditional decl-code-name
- decl-code
- decl-data-name
- decl-data))
- (else
- (file-decls/stackify decl-code-name
- decl-code*
- decl-data-name
- decl-data*)))
-
- (if (string-null? suffix)
- (file-header ntags handle
- decl-code-name code-name
- decl-data-name data-name)
- '())
- )))
- proxy)))
+ (let ((top-level? (string-null? suffix)))
+
+ (define (canonicalize-name name full?)
+ (if full?
+ (canonicalize-label-name name)
+ (C-quotify-string name)))
+
+ (define (gen-code-name nonce)
+ (choose-name #t "code" "" nonce))
+
+ (define (gen-data-name nonce)
+ (choose-name #t "data" "_data" nonce))
+
+ (define (gen-handle-name nonce)
+ (choose-name #f "" "" nonce))
+
+ (define (choose-name full? default midfix nonce)
+ (let ((path (and info-output-pathname
+ (merge-pathnames
+ (if (pair? info-output-pathname)
+ (car info-output-pathname)
+ info-output-pathname)))))
+
+ (cond ((not *C-procedure-name*)
+ (string-append default suffix "_" nonce))
+ ((not (eq? *C-procedure-name* 'DEFAULT))
+ (string-append *C-procedure-name*
+ midfix
+ suffix))
+ ((not path)
+ (string-append default suffix "_" nonce))
+ ((or top-level? *disable-nonces?*)
+ (let ((dir (pathname-directory path)))
+ (string-append
+ (if (or (not dir) (null? dir))
+ default
+ (canonicalize-name (car (last-pair dir)) full?))
+ "_"
+ (canonicalize-name (pathname-name path) full?)
+ midfix
+ suffix)))
+ (else
+ (string-append (canonicalize-name (pathname-name path) full?)
+ "_"
+ default
+ suffix
+ "_"
+ nonce)))))
+
+ (define (subroutine-information)
+ (let*/mv (((decls-1 code-1) (subroutine-information-1))
+ ((decls-2 code-2) (subroutine-information-2)))
+ (values (c:group decls-1 decls-2)
+ (c:group code-1 code-2))))
+
+ (define (subroutine-information-1)
+ (if (eq? *invoke-interface* 'INFINITY)
+ (values (c:group)
+ (c:group))
+ (begin
+ (if (not (< *invoke-interface* 5))
+ (error "Utilities take at most 4 args:" *invoke-interface*))
+ (values
+ (c:group (c:decl 'int 'utlarg_code)
+ (c:decl 'long 'utlarg_1)
+ (c:decl 'long 'utlarg_2)
+ (c:decl 'long 'utlarg_3)
+ (c:decl 'long 'utlarg_4))
+ (c:group*
+ (list-tail (list (c:group (c:label 'invoke_interface_0)
+ (c:= 'utlarg_1 0))
+ (c:group (c:label 'invoke_interface_1)
+ (c:= 'utlarg_2 0))
+ (c:group (c:label 'invoke_interface_2)
+ (c:= 'utlarg_3 0))
+ (c:group (c:label 'invoke_interface_3)
+ (c:= 'utlarg_4 0))
+ (c:group (c:label 'invoke_interface_4)
+ (c:scall "INVOKE_INTERFACE_CODE")))
+ *invoke-interface*))))))
+
+ (define (subroutine-information-2)
+ (if *used-invoke-primitive*
+ (values (c:group (c:decl 'sobj 'primitive)
+ (c:decl 'long 'primitive_nargs))
+ (c:group (c:label 'invoke_primitive)
+ (c:scall "INVOKE_PRIMITIVE_CODE")))
+ (values (c:group)
+ (c:group))))
+
+ (if *purification-root-object*
+ (define-object "PURIFICATION_ROOT"
+ (if (vector? (cdr *purification-root-object*))
+ *purification-root-object*
+ (cons (car *purification-root-object*)
+ (list->vector
+ (reverse (cdr *purification-root-object*)))))))
+
+ (define-object (special-label/debugging)
+ (let frob ((obj info-output-pathname))
+ (cond ((pathname? obj)
+ (->namestring/shared obj))
+ ((pair? obj)
+ (cons (frob (car obj))
+ (frob (cdr obj))))
+ (else
+ obj))))
+
+ (define-object (special-label/environment) unspecific)
+
+ (let*/mv ((label-offset 1) ; First word is vector header
+ (initial-offset (label->offset initial-label))
+ ((first-free-offset ntags label-defines label-dispatch
+ label-block-initialization symbol-table)
+ (handle-labels label-offset))
+ ((first-object-offset free-defines
+ free-block-initialization free-symbols)
+ (handle-free-refs-and-sets first-free-offset))
+ ((cc-block-size decl-code decl-data
+ xtra-procs object-prefix
+ object-defines temp-vars
+ object-block-initialization)
+ (handle-objects first-object-offset))
+ (nonce (make-nonce))
+ (handle (gen-handle-name nonce))
+ (code-name (gen-code-name nonce))
+ (data-name (gen-data-name nonce))
+ (decl-code-name (string-append "decl_" code-name))
+ (decl-data-name (string-append "decl_" data-name))
+ ((extra-decls extra-code)
+ (subroutine-information))
+ ((proxy xtra-procs* decl-code* decl-data* data-prefix data-body)
+ (data-function-body top-level?
+ ntags
+ data-name
+ initial-offset
+ cc-block-size
+ temp-vars
+ object-prefix
+ label-block-initialization
+ free-block-initialization
+ object-block-initialization))
+ (use-stackify? *use-stackify?*))
+ (values
+ code-name
+ data-name
+ ntags
+ (cons* (cons (special-label/environment)
+ (- cc-block-size 1))
+ (cons (special-label/debugging)
+ (- cc-block-size 2))
+ (append free-symbols symbol-table))
+ (c:group
+ (if top-level?
+ (c:group (file-prefix)
+ (c:line))
+ (c:group))
+
+ ;; Extra code
+
+ xtra-procs
+ xtra-procs*
+
+ ;; defines for the code
+
+ (c:group* label-defines)
+ object-defines
+ free-defines
+ (c:line)
+
+ ;; the code itself
+
+ (c:code-section
+ (c:fn (not top-level?) 'sobj* code-name
+ (list (cons 'sobj* (c:pc-reg))
+ (cons 'entry_count_t 'dispatch_base))
+ (function-decls)
+ (register-declarations)
+ extra-decls
+ (c:line)
+ ;; The assignment is necessary to ensure that we restart properly
+ ;; after an interrupt when the dynamic link is live
+ ;; (see DLINK_INTERRUPT_CHECK and comp_interrupt_restart)
+ (c:= (c:dlink-reg) (c:object-address (c:val-reg)))
+ (c:goto 'perform_dispatch)
+ (c:label 'pop_return)
+ (c:= (c:pc-reg) (c:object-address (c:pop)))
+ (c:label 'perform_dispatch)
+ (c:switch (c:- (c:* (c:cast 'ulong* (c:pc-reg))) 'dispatch_base)
+ (c:group* (map (lambda (item)
+ (c:group item
+ (c:line)))
+ label-dispatch))
+ (c:case #f
+ (c:scall "UNCACHE_VARIABLES")
+ (c:return (c:pc-reg))))
+ (c:group* lap-code)
+ extra-code))
+
+ (if (and top-level? use-stackify?)
+ (c:page)
+ (c:group))
+
+ ;; the data generator
+
+ data-prefix
+
+ (if (or top-level? (not use-stackify?))
+ (c:group (c:line)
+ (c:data-section
+ (c:fn (not top-level?) 'sobj* data-name
+ (list (cons 'entry_count_t 'dispatch_base))
+ data-body)))
+ (c:group))
+
+ ;; File footer
+ (if top-level?
+ (c:group (c:line)
+ (if use-stackify?
+ (file-decls/stackify decl-code-name
+ decl-code*
+ decl-data-name
+ decl-data*)
+ (file-decls/traditional decl-code-name
+ decl-code
+ decl-data-name
+ decl-data))
+ (c:line)
+ (file-header ntags handle
+ decl-code-name code-name
+ decl-data-name data-name))
+ (c:group)))
+ proxy))))
\f
(define (data-function-body top-level?
ntags
(cond ((not *use-stackify?*)
(values
#f ; proxy
- '() ; xtra-procs
- #f ; decl-code
- #f ; decl-data
- '() ; data-prefix
- (map (lambda (x) (list-of-strings->string x))
- (list (list "\tSCHEME_OBJECT object"
- " = (ALLOCATE_VECTOR ("
- (number->string (- cc-block-size 1))
- "L));\n"
- "\tSCHEME_OBJECT * current_block"
- " = (OBJECT_ADDRESS (object));\n")
- (->variable-declarations temp-vars)
- (list "\tDECLARE_VARIABLES_FOR_DATA();\n")
- (list "\n\t")
- object-prefix
- label-block-initialization
- free-block-initialization
- object-block-initialization
- (list "\n\treturn (¤t_block["
- (stringify-object initial-offset)
- "]);\n")))))
+ (c:group) ; xtra-procs
+ '() ; decl-code
+ '() ; decl-data
+ (c:group) ; data-prefix
+ (c:group
+ (c:decl 'sobj
+ 'object
+ (c:ecall "ALLOCATE_VECTOR"
+ (c:cast 'ulong (- cc-block-size 1))))
+ (c:decl 'sobj* 'current_block (c:object-address 'object))
+ (c:group* (map (lambda (var) (c:decl 'sobj var)) temp-vars))
+ (c:scall "DECLARE_VARIABLES_FOR_DATA")
+ (c:line)
+ (c:group* object-prefix)
+ (c:group* label-block-initialization)
+ (c:group* free-block-initialization)
+ (c:group* object-block-initialization)
+ (c:return (c:cptr initial-offset)))))
((or (not (null? temp-vars))
(not (null? object-prefix)))
(error "data-function-body: stackify inconsistency"))
(list->vector (append label-block-initialization
free-block-initialization
object-block-initialization))
- '() ; xtra-procs
+ (c:group) ; xtra-procs
'() ; decl-code
'() ; decl-data
- '() ; data-prefix
- '() ; data-body
+ (c:group) ; data-prefix
+ (c:group) ; data-body
))
(else
(fluid-let ((*subblocks* '()))
(list->vector (append label-block-initialization
free-block-initialization
object-block-initialization)))))
-
+
(set! *subblocks* (reverse! *subblocks*))
(values
#f ; proxy
- (append-map fake-block->c-code *subblocks*) ; xtra-procs*
+ (c:group* (map fake-block->c-code *subblocks*)) ; xtra-procs*
*subblocks* ; decl-code
'() ; decl-data
- (append
- (list "#ifndef WANT_ONLY_CODE\n")
- (stackify-output->data-decl name str)
- (list "#endif /* WANT_ONLY_CODE */\n"))
- (list
- "\tSCHEME_OBJECT ccb, * current_block;\n"
- "\tDECLARE_VARIABLES_FOR_DATA();\n\n"
- "\tccb = (unstackify (((unsigned char *)\n"
- "\t (& " name "[0])),\n"
- "\t dispatch_base));\n"
- "\tcurrent_block = (OBJECT_ADDRESS (ccb));\n"
- "\treturn (& current_block["
- (stringify-object initial-offset)
- "]);")))))))
+ (c:data-section (stackify-output->data-decl name str))
+ (c:group (c:decl 'sobj 'ccb)
+ (c:decl 'sobj* 'current_block)
+ (c:scall "DECLARE_VARIABLES_FOR_DATA")
+ (c:line)
+ (c:= 'ccb
+ (c:ecall 'unstackify
+ (c:cast 'uchar* (c:aptr name 0))
+ 'dispatch_base))
+ (c:= 'current_block (c:object-address 'ccb))
+ (c:return (c:cptr initial-offset)))))))))
\f
(define (stackify-output->data-decl name str)
- (append (list "static CONST unsigned char "
- name
- "["
- (number->string (string-length str))
- "] =\n")
- (C-quotify-data-string/breakup str)
- (list ";\n")))
-
-(define-integrable (list-of-strings->string strings)
- (%string-append strings))
-
-(define-integrable (%symbol->string sym)
- (system-pair-car sym))
-
-(define (code-function-header name)
- (list "SCHEME_OBJECT *\n"
- "DEFUN (" name ", (Rpc, dispatch_base),\n\t"
- "SCHEME_OBJECT * Rpc AND entry_count_t dispatch_base)\n"
- "{\n"))
-
-(define (data-function-header name)
- (list "SCHEME_OBJECT *\n"
- "DEFUN (" name ", (dispatch_base), entry_count_t dispatch_base)\n"
- "{\n"))
-
-(define (object-function-header/traditional name)
- (list "SCHEME_OBJECT\n"
- "DEFUN_VOID (" name ")\n"
- "{\n\tSCHEME_OBJECT top_level_object;\n"))
-
-(define (object-function-header/stackify name)
- (list "SCHEME_OBJECT\n"
- "DEFUN_VOID (" name ")\n"
- "{\n"))
+ (c:group (c:line "static const unsigned char " (c:var name)
+ "[" (c:expr (string-length str)) "] =")
+ (c:indent*
+ (let ((strings (C-quotify-data-string/breakup str)))
+ (let ((p (last-pair strings)))
+ (set-car! p (string-append (car p) ";")))
+ (map c:line strings)))))
(define (function-decls)
- (list
- "\tREGISTER SCHEME_OBJECT * current_block;\n"
- "\tDECLARE_VARIABLES ();\n"
- ;; Rdl is initialized right before perform_dispatch.
- "\tSCHEME_OBJECT * Rdl;\n"))
-
-(define (function-trailer name)
- (list "\n} /* End of " name ". */\n"))
-
-(define (make-define-statement symbol val)
- (string-append "#define " (if (symbol? symbol)
- (symbol->string symbol)
- symbol)
- " "
- (if (number? val)
- (number->string val)
- val)
- "\n"))
+ (c:group (c:decl 'sobj* 'current_block)
+ (c:scall "DECLARE_VARIABLES")
+ ;; dlink is initialized right before perform_dispatch.
+ (c:decl 'sobj* (c:dlink-reg))))
(define (file-prefix)
- (let ((time (get-decoded-time)))
- (list "/* Emacs: this is -*- C -*- code. */\n\n"
- "/* C code produced\n "
- (decoded-time/date-string time)
- " at "
- (decoded-time/time-string time)
- "\n by Liar version "
- (or (get-subsystem-version-string "liar") "?.?")
- ".\n */\n\n"
- "#include \"liarc.h\"\n\n")))
-\f
+ (c:group (c:line (c:comment "Emacs: this is -*- C -*- code,"))
+ (c:line (c:comment "generated "
+ (get-decoded-time)
+ " by Liar version "
+ (or (get-subsystem-version-string "liar")
+ "UNKNOWN")
+ "."))
+ (c:line)
+ (c:include "liarc.h")))
+
(define (file-header ntags handle
decl-code-name code-name
decl-data-name data-name)
- (if (= ntags 0)
- (list "#ifndef WANT_ONLY_CODE\n"
- ;; This must be a single line!
- "DECLARE_DATA_OBJECT (\"" handle
- "\", " data-name ")\n"
- "#endif /* WANT_ONLY_CODE */\n\n"
- "DECLARE_DYNAMIC_OBJECT_INITIALIZATION (\""
- handle "\")\n")
- (list "#ifndef WANT_ONLY_DATA\n"
- ;; This must be a single line!
- "DECLARE_COMPILED_CODE (\"" handle
- "\", " (number->string ntags)
- ", " decl-code-name
- ", " code-name ")\n"
- "#endif /* WANT_ONLY_DATA */\n\n"
- "#ifndef WANT_ONLY_CODE\n"
- ;; This must be a single line!
- "DECLARE_COMPILED_DATA (\"" handle
- "\", " (if *use-stackify?* "NO_SUBBLOCKS" decl-data-name)
- ", " data-name ")\n"
- "#endif /* WANT_ONLY_CODE */\n\n"
- "DECLARE_DYNAMIC_INITIALIZATION (\""
- handle "\")\n")))
-
-(define (make-time-stamp)
- (if *disable-timestamps?*
- "_timestamp"
- (let ((time (get-decoded-time)))
- (string-append
- "_"
- (number->string (decoded-time/second time)) "_"
- (number->string (decoded-time/minute time)) "_"
- (number->string (decoded-time/hour time)) "_"
- (number->string (decoded-time/day time)) "_"
- (number->string (decoded-time/month time)) "_"
- (number->string (decoded-time/year time))))))
-
-(define (->variable-declarations vars)
- (if (null? vars)
- (list "")
- `("\tSCHEME_OBJECT\n\t "
- ,(car vars)
- ,@(append-map (lambda (var)
- (list ",\n\t " var))
- (cdr vars))
- ";\n")))
+ (let ((hs (c:string handle)))
+ (if (= ntags 0)
+ (c:group (c:data-section
+ ;; This must be a single line!
+ (c:line (c:call "DECLARE_DATA_OBJECT" hs data-name)))
+ (c:line)
+ (c:line (c:call "DECLARE_DYNAMIC_OBJECT_INITIALIZATION" hs)))
+ (c:group (c:code-section
+ ;; This must be a single line!
+ (c:line (c:call "DECLARE_COMPILED_CODE"
+ hs
+ (number->string ntags)
+ decl-code-name
+ code-name)))
+ (c:line)
+ (c:data-section
+ ;; This must be a single line!
+ (c:line (c:call "DECLARE_COMPILED_DATA"
+ hs
+ (if *use-stackify?*
+ "NO_SUBBLOCKS"
+ decl-data-name)
+ data-name)))
+ (c:line)
+ (c:line (c:call "DECLARE_DYNAMIC_INITIALIZATION" hs))))))
+
+(define (make-nonce)
+ (if *disable-nonces?*
+ "nonce"
+ (vector-8b->hexadecimal (random-byte-vector 8))))
(define (file-decls/traditional decl-code-name decl-code
decl-data-name decl-data)
- (append (list "#ifndef WANT_ONLY_DATA\n")
- (list
- "int\n"
- "DEFUN_VOID (" decl-code-name ")\n{\n")
- decl-code
- (list "\treturn (0);\n}\n"
- "#endif /* WANT_ONLY_DATA */\n\n")
- (list "#ifndef WANT_ONLY_CODE\n")
- (list
- "int\n"
- "DEFUN_VOID (" decl-data-name ")\n{\n")
- decl-data
- (list "\treturn (0);\n}\n"
- "#endif /* WANT_ONLY_CODE */\n\n")))
+ (c:group (c:code-section (c:fn #f 'int decl-code-name '()
+ decl-code
+ (c:return 0)))
+ (c:line)
+ (c:data-section (c:fn #f 'int decl-data-name '()
+ decl-data
+ (c:return 0)))))
\f
(define (file-decls/stackify decl-code-name code-blocks
decl-data-name data-blocks)
- (append
- (append (list "#ifndef WANT_ONLY_DATA\n")
- (if (or (null? code-blocks)
- (null? (cdr code-blocks)))
- '()
- (code-blocks->array-decl decl-code-name code-blocks))
- (list
- "int\n"
- "DEFUN_VOID (" decl-code-name ")\n{\n")
- (if (or (null? code-blocks)
- (null? (cdr code-blocks)))
- (map fake-block->code-decl
- code-blocks)
- (list "\tDECLARE_SUBCODE_MULTIPLE (arr_"
- decl-code-name
- ");\n"))
- (list "\treturn (0);\n}\n"
- "#endif /* WANT_ONLY_DATA */\n\n"))
- (if *use-stackify?*
- '()
- (append
- (list "#ifndef WANT_ONLY_CODE\n")
- (if (or (null? data-blocks)
- (null? (cdr data-blocks)))
- '()
- (data-blocks->array-decl decl-data-name data-blocks))
- (list
- "int\n"
- "DEFUN_VOID (" decl-data-name ")\n{\n")
- (if (or (null? data-blocks)
- (null? (cdr data-blocks)))
- (map fake-block->data-decl data-blocks)
- (list "\tDECLARE_SUBDATA_MULTIPLE (arr_"
- decl-data-name
- ");\n"))
- (list "\treturn (0);\n}\n"
- "#endif /* WANT_ONLY_CODE */\n\n")
- ))))
-
-(define (code-blocks->array-decl decl-code-name code-blocks)
- (append (list "static CONST struct liarc_code_S arr_"
- decl-code-name
- "["
- (number->string (length code-blocks))
- "] =\n{\n")
- (map (lambda (code-block)
- (string-append
- " { \""
- (fake-block/tag code-block)
- "\", "
- (number->string (fake-block/ntags code-block))
- ", "
- (fake-block/c-proc code-block)
- " },\n"))
- code-blocks)
- (list "};\n\n")))
-
-(define (data-blocks->array-decl decl-data-name data-blocks)
- (append (list "static CONST struct liarc_data_S arr_"
- decl-data-name
- "["
- (number->string (length data-blocks))
- "] =\n{\n")
- (map (lambda (data-block)
- (string-append
- " { \""
- (fake-block/tag data-block)
- "\", "
- (fake-block/d-proc data-block)
- " },\n"))
- data-blocks)
- (list "};\n\n")))
+ (c:group
+ (c:code-section
+ (if (and (pair? code-blocks)
+ (null? (cdr code-blocks)))
+ (let ((arrname (string-append "arr_" decl-code-name)))
+ (c:group (c:array-decl "static const struct liarc_code_S"
+ arrname
+ (length code-blocks)
+ (map (lambda (code-block)
+ (c:struct-init
+ (c:string (fake-block/tag code-block))
+ (fake-block/ntags code-block)
+ (fake-block/c-proc code-block)))
+ code-blocks))
+ (c:line)
+ (c:fn #f 'int decl-code-name '()
+ (c:scall "DECLARE_SUBCODE_MULTIPLE" arrname)
+ (c:return 0))))
+ (c:fn #f 'int decl-code-name '()
+ (c:group* (map fake-block->code-decl code-blocks))
+ (c:return 0))))
+ (if (not *use-stackify?*)
+ (c:group
+ (c:line)
+ (c:data-section
+ (if (and (pair? data-blocks)
+ (null? (cdr data-blocks)))
+ (let ((arrname (string-append "arr_" decl-data-name)))
+ (c:group (c:array-decl "static const struct liarc_data_S"
+ arrname
+ (length data-blocks)
+ (map (lambda (data-block)
+ (c:struct-init
+ (c:string (fake-block/tag data-block))
+ (fake-block/d-proc data-block)))
+ data-blocks))
+ (c:line)
+ (c:fn #f 'int decl-data-name '()
+ (c:scall "DECLARE_SUBDATA_MULTIPLE" arrname)
+ (c:return 0))))
+ (c:fn #f 'int decl-data-name '()
+ (c:group* (map fake-block->data-decl data-blocks))
+ (c:return 0)))))
+ (c:group))))
\f
-(define char-set:all
- (predicate->char-set (lambda (char) char true)))
-
-(define char-set:C-string-quoted
- (char-set-union
- ;; Not char-set:not-graphic
- (char-set-difference char-set:all
- (char-set-intersection char-set:graphic
- (ascii-range->char-set 0 #x7f)))
- (char-set #\\ #\" #\? (integer->char #xA0))))
-
-(define char-set:C-named-chars
- (char-set #\\ #\" #\Tab #\BS ;; #\' Scheme does not quote it in strings
- ;; #\VT #\BEL ;; Cannot depend on ANSI C
- #\Linefeed #\Return #\Page))
-
-;; This is intended for shortish character strings with the occasionall escape.
+;; This is intended for short strings with an occasional escape.
(define (C-quotify-string string)
(let* ((len (string-length string))
(substring-move! sub 0 len* temp off)
(loop i+1 (fix:+ off len*)))))))))
-;; The following routine relies on the fact that Scheme and C use the
-;; same quoting convention for the named characters when they appear
-;; in strings.
+;; This relies on the fact that Scheme and C use the same quoting
+;; convention for the named characters when they appear in strings.
(define (C-quotify-string-char char next)
(cond ((char-set-member? char-set:C-named-chars char)
(string-append (make-string (- 3 (string-length s)) #\0)
s)
s))))))
+
+(define char-set:C-string-quoted
+ (char-set-union
+ ;; Not char-set:not-graphic
+ (char-set-invert
+ (char-set-intersection char-set:graphic (ascii-range->char-set 0 #x7f)))
+ (char-set #\\ #\" #\? (integer->char #xA0))))
+
+(define char-set:C-named-chars
+ (char-set #\\ #\" #\Tab #\BS ;; #\' Scheme does not quote it in strings
+ #\VT #\BEL
+ #\Linefeed #\Return #\Page))
\f
-;; This is intended for binary data encoded as a character string
-;; where most of the characters are not really characters at all.
+;; This is intended for binary data encoded as a string where most of
+;; the characters are not really characters at all.
(define (C-quotify-data-string/breakup string)
- (let ((len (string-length string)))
- (define (flush end temp res)
- (if (= end 0)
- res
- (cons* "\"" (substring temp 0 end) "\t\""
- (if (null? res)
- res
- (cons "\n" res)))))
-
- (define (done end temp res)
- (reverse! (flush end temp res)))
-
- (define (step3 index pos temp res)
- (let* ((i+1 (fix:+ index 1))
- (sub (C-quotify-string-char
- (string-ref string index)
- (and (fix:< i+1 len)
- (string-ref string i+1))))
- (len* (string-length sub))
- (next (fix:+ pos len*)))
- (if (fix:> len* 4)
- (error "C-quotify-string/breakup: Large character expansion!"
- sub))
- (if (fix:>= next 65)
- (error "C-quotify-string/breakup: Overrun!" next))
- (substring-move! sub 0 len* temp pos)
- (if (fix:>= next 60)
- (step1 i+1 0 (make-string 65) (flush next temp res))
- (step1 i+1 next temp res))))
-
- (define (step2 src lim dst temp res)
- (cond ((fix:< src lim)
- (let ((room (fix:- 60 dst))
- (have (fix:- lim src)))
- (cond ((fix:<= have room)
- (substring-move! string src lim temp dst)
- (step2 lim lim (fix:+ dst have) temp res))
- ((fix:= room 0)
- (step2 src lim 0 (make-string 65) (flush dst temp res)))
- (else
- (let ((src* (fix:+ src room))
- (end (fix:+ dst room)))
- (substring-move! string src src* temp dst)
- (step2 src* lim 0 (make-string 65)
- (flush end temp res)))))))
- ((fix:>= lim len)
- (done dst temp res))
- ((fix:>= dst 60)
- (step3 lim 0 (make-string 65) (flush dst temp res)))
- (else
- (step3 lim dst temp res))))
-
- (define (step1 src dst temp res)
- (if (fix:>= src len)
- (done dst temp res)
- (let ((index (substring-find-next-char-in-set
- string src len char-set:C-string-quoted)))
- (cond ((not index)
- (step2 src len dst temp res))
- ((fix:= index src)
- (step3 index dst temp res))
- (else
- (step2 src index dst temp res))))))
-
- (step1 0 0 (make-string 65) '())))
+ (let ((n-bytes (vector-8b-length string))
+ (new-string
+ (lambda ()
+ (let ((s (make-string 66)))
+ (string-set! s 0 #\")
+ s))))
+ (let loop ((i 0) (s (new-string)) (j 1))
+ (if (fix:< i n-bytes)
+ (if (fix:< j 62)
+ (let ((b (vector-8b-ref string i)))
+ (string-set! s j #\\)
+ (string-set! s (fix:+ j 1) #\x)
+ (string-set! s (fix:+ j 2)
+ (digit->char (fix:quotient b #x10) 16))
+ (string-set! s (fix:+ j 3)
+ (digit->char (fix:remainder b #x10) 16))
+ (loop (fix:+ i 1) s (fix:+ j 4)))
+ (begin
+ (string-set! s j #\")
+ (cons s (loop i (new-string) 1))))
+ (if (fix:> j 1)
+ (begin
+ (string-set! s j #\")
+ (set-string-length! s (fix:+ j 1))
+ (list s))
+ '())))))
\f
-(define (stringify-object x)
- (cond ((string? x)
- x)
- ((symbol? x)
- (%symbol->string x))
- ((number? x)
- (number->string x))
- (else
- (error "stringify: Unknown frob" x))))
-
(define (handle-objects start-offset)
(if *use-stackify?*
(handle-objects/stackify start-offset)
(define (handle-objects/stackify start-offset)
;; returns <next-offset decl-code decl-data xtra-procs object-prefix
;; object-defines temp-vars object-block-initialization>
- (define (iter offset table defines objects)
- (if (null? table)
- (values offset
- #f ; xtra code decls
- #f ; xtra data decls
- '() ; xtra procs
- '()
- defines
- '()
- (reverse! objects))
+ (let iter
+ ((offset start-offset)
+ (table (reverse (table->list-of-entries objects)))
+ (defines '())
+ (objects '()))
+ (if (pair? table)
(let ((entry (car table)))
(iter (+ offset 1)
(cdr table)
- (cons (make-define-statement (entry-label entry) offset)
- defines)
- (cons (entry-value entry)
- objects)))))
-
- (iter start-offset
- (reverse (table->list-of-entries objects))
- '() ; defines
- '() ; objects
- ))
-\f
+ (cons (c:define (entry-label entry) offset) defines)
+ (cons (entry-value entry) objects)))
+ (values offset
+ (c:group) ; code decls
+ (c:group) ; data decls
+ (c:group) ; procs
+ '() ; object-prefix
+ (c:group* defines)
+ '()
+ (reverse! objects) ; object-block-initialization
+ ))))
+
(define (handle-objects/traditional start-offset)
;; All the reverses produce the correct order in the output block.
;; The incoming objects are reversed
(fluid-let ((new-variables '())
(*subblocks* '())
(num 0))
-
- (define (iter offset table names defines objects)
- (if (null? table)
- (with-values
- (lambda () (->constructors (reverse names)
- (reverse objects)))
- (lambda (prefix suffix)
- (values offset
- (map fake-block->code-decl *subblocks*)
- (map fake-block->data-decl *subblocks*)
- (append-map fake-block->c-code *subblocks*)
- prefix
- defines
- new-variables
- suffix)))
+ (let iter
+ ((offset start-offset)
+ (table (reverse (table->list-of-entries objects)))
+ (names '())
+ (defines '())
+ (objects '()))
+ (if (pair? table)
(let ((entry (car table)))
(iter (+ offset 1)
(cdr table)
- (cons (string-append "current_block["
- (entry-label entry) "]")
- names)
- (cons (make-define-statement (entry-label entry) offset)
- defines)
- (cons (entry-value entry)
- objects)))))
-
- (iter start-offset
- (reverse (table->list-of-entries objects))
- '() ; names
- '() ; defines
- '() ; objects
- )))
+ (cons (c:aref 'current-block (entry-label entry)) names)
+ (cons (c:define (entry-label entry) offset) defines)
+ (cons (entry-value entry) objects)))
+ (receive (prefix suffix)
+ (->constructors (reverse names)
+ (reverse objects))
+ (values offset
+ (c:group* (map fake-block->code-decl *subblocks*))
+ (c:group* (map fake-block->data-decl *subblocks*))
+ (c:group* (map fake-block->c-code *subblocks*))
+ (map c:line prefix)
+ (c:group* defines)
+ new-variables
+ suffix))))))
(define (handle-top-level-data/traditional object)
(fluid-let ((new-variables '())
(num 0))
- (with-values
- (lambda () (->constructors (list "top_level_object")
- (list object)))
- (lambda (prefix suffix)
- (values new-variables prefix suffix)))))
+ (receive (prefix suffix)
+ (->constructors (list "top_level_object")
+ (list object))
+ (values new-variables prefix suffix))))
\f
(define-integrable *execute-cache-size-in-words* 2)
(define-integrable *variable-cache-size-in-words* 1)
;; process free-uuo-links free-references free-assignments global-uuo-links
;; returns <next-offset define-code data-init-code symbol-table-components>
- (define (make-linkage-section-header start kind count)
- (if *use-stackify?*
- (stackify/make-linkage-header kind count)
- (let ((kind
- (case kind
- ((operator-linkage-kind) "OPERATOR_LINKAGE_KIND")
- ((global-operator-linkage-kind) "GLOBAL_OPERATOR_LINKAGE_KIND")
- ((assignment-linkage-kind) "ASSIGNMENT_LINKAGE_KIND")
- ((reference-linkage-kind) "REFERENCE_LINKAGE_KIND")
- (else (error "make-linkage-section-header: unknown kind"
- kind)))))
- (string-append "current_block[" (number->string start)
- "L] = (MAKE_LINKER_HEADER (" kind
- ", " (number->string count) "));\n\t"))))
-
- (define (insert-symbol label symbol)
- (let ((name (symbol->string symbol)))
- (string-append "current_block[" label
- "] = (C_SYM_INTERN ("
- (number->string (string-length name))
- ", \"" name "\"));\n\t")))
-
(define (process-links start links kind)
- (if (null? (cdr links))
- (values start 0 '() '())
+ (if (pair? (cdr links))
(let ((use-stackify? *use-stackify?*))
;; The following code implicitly assumes that
;; *execute-cache-size-in-words* is 2 -- check it
(cond ((null? links)
(values offset
1
- (reverse defines)
+ (reverse! defines)
(cons (make-linkage-section-header start kind count)
- (reverse inits))))
+ (reverse! inits))))
((null? (cdr (car links)))
(process count (cdr links) offset defines inits))
(else
(cons (cons (caar links) (cddar links))
(cdr links))
(+ offset *execute-cache-size-in-words*)
- (cons (make-define-statement symbol offset)
+ (cons (c:define symbol offset)
defines)
(if use-stackify?
(cons* (stackify/make-uuo-arity arity)
(stackify/make-uuo-name name)
inits)
- (cons (string-append
+ (cons (c:group
(insert-symbol symbol name)
- "current_block["
- symbol
- " + 1] = ((SCHEME_OBJECT) ("
- (number->string arity) "));\n\t")
- inits)))))))))))
-\f
+ (c:= (c:cref (c:+ symbol 1))
+ (c:cast 'sobj arity)))
+ inits)))))))))
+ (values start 0 '() '())))
+
(define (process-table start table kind)
(let ((use-stackify? *use-stackify?*))
;; The following code implicitly assumes that
;; *variable-cache-size-in-words* is 1 -- check it below
(define (iter offset table defines inits)
- (if (null? table)
- (values offset
- 1
- (reverse defines)
- (cons (make-linkage-section-header start kind
- (- offset (+ start 1)))
- (reverse inits)))
+ (if (pair? table)
(let ((symbol (entry-label (car table))))
(iter (+ offset *variable-cache-size-in-words*)
(cdr table)
- (cons (make-define-statement symbol offset)
+ (cons (c:define symbol offset)
defines)
(if use-stackify?
(cons (stackify/make-var-ref-entry
(entry-value (car table)))
inits)
(cons (insert-symbol symbol (entry-value (car table)))
- inits))))))
+ inits))))
+ (values offset
+ 1
+ (reverse! defines)
+ (cons (make-linkage-section-header start kind
+ (- offset (+ start 1)))
+ (reverse! inits)))))
(if (and use-stackify? (not (= *variable-cache-size-in-words* 1)))
(error "process-links: Size inconsistency"))
- (if (null? table)
- (values start 0 '() '())
- (iter (+ start 1) table '() '()))))
+ (if (pair? table)
+ (iter (+ start 1) table '() '())
+ (values start 0 '() '()))))
+
+ (define (make-linkage-section-header start kind count)
+ (if *use-stackify?*
+ (stackify/make-linkage-header kind count)
+ (c:= (c:cref start)
+ (c:ecall "MAKE_LINKER_HEADER"
+ (case kind
+ ((operator-linkage-kind)
+ "OPERATOR_LINKAGE_KIND")
+ ((global-operator-linkage-kind)
+ "GLOBAL_OPERATOR_LINKAGE_KIND")
+ ((assignment-linkage-kind)
+ "ASSIGNMENT_LINKAGE_KIND")
+ ((reference-linkage-kind)
+ "REFERENCE_LINKAGE_KIND")
+ (else
+ (error "Unknown linkage kind:" kind)))
+ count))))
+
+ (define (insert-symbol label symbol)
+ (let ((name (symbol->string symbol)))
+ (c:= (c:cref label)
+ (c:ecall "C_SYM_INTERN"
+ (string-length name)
+ (c:string name)))))
(let*/mv (((offset uuos? uuodef uuoinit)
(process-links start-offset free-uuo-links
(process-links offset global-uuo-links
'global-operator-linkage-kind))
(free-references-sections (+ uuos? refs? asss? glob?)))
-
+
(values
offset
- (append uuodef refdef assdef globdef
- (list (make-define-statement (special-label/free-references)
- start-offset)
- (make-define-statement (special-label/number-of-sections)
- free-references-sections)))
+ (c:group* (append! uuodef refdef assdef globdef
+ (list (c:define (special-label/free-references)
+ start-offset)
+ (c:define (special-label/number-of-sections)
+ free-references-sections))))
(append uuoinit refinit assinit globinit)
(list (cons (special-label/free-references)
start-offset)
;; returns <next-offset n-labels define-code dispatch-code
;; data-init-code symbol-table-components>
(let ((use-stackify? *use-stackify?*))
- (define (iter offset tagno labels label-defines
- label-dispatch label-block-initialization
- label-bindings)
- (if (null? labels)
- (values (- offset 1)
- tagno
- (reverse label-defines)
- (reverse label-dispatch)
- (if (not use-stackify?)
- (cons (string-append
- "current_block["
- (number->string label-block-offset)
- "L] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, "
- (number->string (- (- offset 1)
- (+ label-block-offset 1)))
- "));\n\t")
- (reverse label-block-initialization))
- (cons (stackify/make-nm-header
- (- (- offset 1)
- (+ label-block-offset 1)))
- (reverse label-block-initialization)))
- label-bindings)
+ (let iter
+ ((offset (+ label-block-offset *label-sizes-in-words*))
+ (tagno 0)
+ (labels (reverse! labels))
+ (label-defines '())
+ (label-dispatch '())
+ (label-block-initialization '())
+ (label-bindings '()))
+ (if (pair? labels)
(let* ((label-data (car labels))
- (a-symbol (or (symbol-1 label-data)
- (symbol-2 label-data))))
+ (symbol (or (symbol-1 label-data)
+ (symbol-2 label-data))))
(iter (+ offset *label-sizes-in-words*)
(+ tagno 1)
(cdr labels)
- (cons (string-append
- (make-define-statement a-symbol offset)
- (let ((other-symbol (or (symbol-2 label-data)
- (symbol-1 label-data))))
- (if (eq? other-symbol a-symbol)
- ""
- (make-define-statement other-symbol a-symbol)))
- (if (dispatch-1 label-data)
- (make-define-statement (dispatch-1 label-data)
- tagno)
- "")
- (if (dispatch-2 label-data)
- (make-define-statement (dispatch-2 label-data)
- tagno)
- ""))
+ (cons (c:group (c:define symbol offset)
+ (let ((symbol*
+ (or (symbol-2 label-data)
+ (symbol-1 label-data))))
+ (if (eq? symbol* symbol)
+ (c:group)
+ (c:define symbol* symbol)))
+ (if (dispatch-1 label-data)
+ (c:define (dispatch-1 label-data) tagno)
+ (c:group))
+ (if (dispatch-2 label-data)
+ (c:define (dispatch-2 label-data) tagno)
+ (c:group)))
label-defines)
- (cons (string-append
- "\n\t case "
- (number->string tagno) ":\n\t\t"
- "current_block = (Rpc - " a-symbol ");\n\t\t"
- "goto "
- (symbol->string (or (label-1 label-data)
- (label-2 label-data)))
- ";\n")
+ (cons (c:case tagno
+ (c:= 'current_block (c:- (c:pc-reg) symbol))
+ (c:goto (or (label-1 label-data)
+ (label-2 label-data))))
label-dispatch)
(add-label-initialization use-stackify?
- a-symbol
+ symbol
tagno
offset
(code-word-sel label-data)
label-block-initialization)
- (append
- (if (label-1 label-data)
- (list (cons (label-1 label-data) offset))
- '())
- (if (label-2 label-data)
- (list (cons (label-2 label-data) offset))
- '())
- label-bindings)))))
-
- (iter (+ label-block-offset *label-sizes-in-words*) ; offset
- 0 ; tagno
- (reverse! labels) ; labels
- '() ; label-defines
- '() ; label-dispatch
- '() ; label-block-initialization
- '() ; label-bindings
- )))
+ (append! (if (label-1 label-data)
+ (list (cons (label-1 label-data) offset))
+ '())
+ (if (label-2 label-data)
+ (list (cons (label-2 label-data) offset))
+ '())
+ label-bindings)))
+ (values (- offset 1)
+ tagno
+ (reverse! label-defines)
+ (reverse! label-dispatch)
+ (cons (if use-stackify?
+ (stackify/make-nm-header
+ (- (- offset 1)
+ (+ label-block-offset 1)))
+ (c:= (c:cref label-block-offset)
+ (c:make-object "TC_MANIFEST_NM_VECTOR"
+ (- (- offset 1)
+ (+ label-block-offset 1)))))
+ (reverse! label-block-initialization))
+ label-bindings)))))
\f
-(define (add-label-initialization use-stackify? a-symbol tagno
+(define (add-label-initialization use-stackify? symbol tagno
offset code-word rest)
(if use-stackify?
(begin
(cons* (stackify/make-label-relative-entry tagno)
(stackify/make-label-descriptor code-word offset)
rest))
- (cons (string-append "WRITE_LABEL_DESCRIPTOR(¤t_block["
- a-symbol "], 0x"
- (number->string code-word 16)
- ", " a-symbol ");\n\t"
- "current_block [" a-symbol
- "] = (dispatch_base + "
- (number->string tagno)
- ");\n\t")
+ (cons (c:group (c:scall "WRITE_LABEL_DESCRIPTOR"
+ (c:cptr symbol)
+ (c:hex code-word)
+ symbol)
+ (c:= (c:cref symbol) (c:+ 'dispatch_base tagno)))
rest)))
(define-structure (fake-compiled-procedure
(constructor make-fake-compiled-procedure)
(conc-name fake-procedure/))
- (block-name false read-only true)
- (label-tag false read-only true)
- (block false read-only true)
- (label-value false read-only true))
+ (block-name #f read-only #t)
+ (label-tag #f read-only #t)
+ (block #f read-only #t)
+ (label-value #f read-only #t))
(define-structure (fake-compiled-block
(constructor make-fake-compiled-block)
(conc-name fake-block/))
- (name false read-only true)
- (tag false read-only true)
- (c-proc false read-only true)
- (d-proc false read-only true)
- (c-code false read-only true)
- (index false read-only true)
- (ntags false read-only true)
- (proxy false read-only true))
+ (name #f read-only #t)
+ (tag #f read-only #t)
+ (c-proc #f read-only #t)
+ (d-proc #f read-only #t)
+ (c-code #f read-only #t)
+ (index #f read-only #t)
+ (ntags #f read-only #t)
+ (proxy #f read-only #t))
(define fake-compiled-block-name-prefix "ccBlock")
"_" (number->string (-1+ number))))
(define (fake-block->code-decl block)
- (string-append "\tDECLARE_SUBCODE (\""
- (fake-block/tag block)
- "\", " (number->string (fake-block/ntags block))
- ", NO_SUBBLOCKS, "
- (fake-block/c-proc block) ");\n"))
+ (c:scall "DECLARE_SUBCODE"
+ (c:string (fake-block/tag block))
+ (fake-block/ntags block)
+ "NO_SUBBLOCKS"
+ (fake-block/c-proc block)))
(define (fake-block->data-decl block)
- (string-append "\tDECLARE_SUBDATA (\""
- (fake-block/tag block)
- "\", NO_SUBBLOCKS, "
- (fake-block/d-proc block) ");\n"))
+ (c:scall "DECLARE_SUBDATA"
+ (c:string (fake-block/tag block))
+ "NO_SUBBLOCKS"
+ (fake-block/d-proc block)))
(define (fake-block->c-code block)
- (list (fake-block/c-code block)
- "\f\n"))
+ (c:group (fake-block/c-code block)
+ (c:page)))
\f
;; Miscellaneous utilities
(and (exact-integer? value)
(<= guaranteed-long/lower-limit value)
(< value guaranteed-long/upper-limit)))
+\f
+;;;; Output abstraction
+
+(define-record-type <c:line>
+ (c:%make-line indentation text)
+ c:line?
+ (indentation c:line-indentation)
+ (text c:line-text))
+
+(define-guarantee c:line "C line")
+
+(define (c:line . items)
+ (c:%make-line 0 (apply string-append items)))
+
+(define (c:line-items items)
+ (if (pair? items)
+ (if (pair? (cdr items))
+ (apply string-append (map c:line-item items))
+ (c:line-item (car items)))
+ ""))
+
+(define (c:line-item item)
+ (cond ((string? item) item)
+ ((char? item) (string item))
+ ((symbol? item) (symbol-name item))
+ ((number? item) (number->string item))
+ ((decoded-time? item) (decoded-time->iso8601-string item))
+ (else (error:wrong-type-argument item "C line item" 'C:LINE-ITEM))))
+
+(define (c:make-line indentation text)
+ (c:%make-line (if (or (string-null? text)
+ (string-prefix? "#" text)
+ (string-prefix? "\f" text))
+ 0
+ indentation)
+ text))
+
+(define (c:write-line line port)
+ (let ((qr
+ (integer-divide (* (max 0 (c:line-indentation line))
+ c:indentation-delta)
+ c:indentation-tab-width)))
+ (let ((n (integer-divide-quotient qr)))
+ (do ((i 0 (+ i 1)))
+ ((not (< i n)))
+ (write-char #\tab port)))
+ (let ((n (integer-divide-remainder qr)))
+ (do ((i 0 (+ i 1)))
+ ((not (< i n)))
+ (write-char #\space port))))
+ (write-string (c:line-text line) port)
+ (newline port))
+
+(define c:indentation-delta 2)
+(define c:indentation-tab-width 8)
+
+(define (c:label-line? line)
+ (string-prefix? "DEFLABEL " (c:line-text line)))
+
+(define (c:blank-line? line)
+ (string-null? (c:line-text line)))
+\f
+(define-record-type <c:group>
+ (c:%make-group lines)
+ c:group?
+ (lines c:group-lines))
+
+(define-guarantee c:group "C group")
+
+(define (c:group . items)
+ (c:group* items))
+
+(define (c:group* items)
+ (if (and (pair? items)
+ (c:group? (car items))
+ (null? (cdr items)))
+ (car items)
+ (c:make-group
+ (append-map (lambda (item)
+ (cond ((c:line? item) (list item))
+ ((c:group? item) (c:group-lines item))
+ ((not item) '())
+ (else (error:not-c:line item 'C:GROUP*))))
+ items))))
+
+(define c:make-group
+ (let ((empty (c:%make-group '())))
+ (lambda (lines)
+ (if (null? lines)
+ empty
+ (c:%make-group lines)))))
+
+(define (c:group-length group)
+ (length (c:group-lines group)))
+
+(define (c:indent . items)
+ (c:indent* items))
+
+(define (c:indent* items)
+ (c:%indent (c:group* items) 1))
+
+(define (c:exdent . items)
+ (c:exdent* items))
+
+(define (c:exdent* items)
+ (c:%indent (c:group* items) -1))
+
+(define (c:%indent item delta)
+ (let ((indent-line
+ (lambda (line)
+ (c:make-line (+ (c:line-indentation line) delta)
+ (c:line-text line)))))
+ (cond ((c:line? item)
+ (indent-line item))
+ ((c:group? item)
+ (c:make-group (map indent-line (c:group-lines item))))
+ (else
+ (error:not-c:line item 'C:%INDENT)))))
+
+(define (c:write-group group port)
+ (cond ((c:line? group) (c:write-line group port))
+ ((c:group? group)
+ (let loop ((lines (c:group-lines group)) (prev #f))
+ (if (pair? lines)
+ (let ((line (car lines))
+ (lines (cdr lines)))
+ (if (and (c:label-line? line)
+ (not (and prev
+ (or (c:label-line? prev)
+ (c:blank-line? prev)))))
+ (newline port))
+ (c:write-line line port)
+ (loop lines line)))))
+ (else (error:not-c:group group 'C:WRITE-GROUP))))
+\f
+(define (c:comment . content)
+ (string-append "/* " (c:line-items content) " */"))
+
+(define (c:string . content)
+ (string-append "\"" (c:line-items content) "\""))
+
+(define (c:parens . content)
+ (string-append "(" (c:line-items content) ")"))
+
+(define (c:struct-init . exprs)
+ (string-append "{ " (c:comma-list exprs) " }"))
+
+(define (c:comma-list exprs)
+ (decorated-string-append "" ", " "" (map c:line-item exprs)))
+
+(define (c:hex n)
+ (string-append "0x" (number->string n 16)))
+
+(define (c:page)
+ (c:line "\f"))
+
+(define (c:brace-group . items)
+ (c:brace-group* items))
+
+(define (c:brace-group* items)
+ (c:group (c:line "{")
+ (c:indent* items)
+ (c:line "}")))
+
+(define (c:code-section . items)
+ (apply c:ifndef "WANT_ONLY_DATA" items))
+
+(define (c:data-section . items)
+ (apply c:ifndef "WANT_ONLY_CODE" items))
+
+(define (c:ifndef symbol . body)
+ (c:group (c:line "#ifndef " (c:var symbol))
+ (c:group* body)
+ (c:line "#endif")))
+
+(define (c:include name)
+ (c:line "#include "
+ (if (and (string-prefix? "<" name)
+ (string-suffix? ">" name))
+ name
+ (string-append "\"" name "\""))))
+
+(define (c:define symbol val)
+ (c:line "#define " (c:var symbol) " " (c:expr val)))
+
+(define (c:fn static? rtype name adecls . body)
+ (c:group (c:line (if static? "static " "")
+ (c:type rtype))
+ (c:line name
+ " "
+ (if (null? adecls)
+ "(void)"
+ (c:parens
+ (c:comma-list (map (lambda (p)
+ (string-append (c:type (car p))
+ " "
+ (c:var (cdr p))))
+ adecls)))))
+ (c:brace-group* body)))
+\f
+(define (c:= var val)
+ (c:line (c:expr var) " = " (c:expr val) ";"))
+
+(define (c:+= var val)
+ (c:line (c:expr var) " += " (c:expr val) ";"))
+
+(define (c:-= var val)
+ (c:line (c:expr var) " -= " (c:expr val) ";"))
+
+(define (c:*= var val)
+ (c:line (c:expr var) " *= " (c:expr val) ";"))
+
+(define (c:/= var val)
+ (c:line (c:expr var) " /= " (c:expr val) ";"))
+
+(define (c:goto label)
+ (c:line "goto " (c:var label) ";"))
+
+(define (c:label label)
+ (c:exdent (c:scall "DEFLABEL" label)))
+
+(define (c:return expr)
+ (c:line "return " (c:pexpr expr) ";"))
+
+(define (c:scall function . args)
+ (c:line (apply c:call function args) ";"))
+
+(define (c:ecall function . args)
+ (c:parens (apply c:call function args)))
+
+(define (c:call function . args)
+ (string-append (c:expr function)
+ " "
+ (let ((args (map c:expr args)))
+ (if (and (pair? args)
+ (null? (cdr args))
+ (c:%parenthesized? (car args)))
+ (car args)
+ (c:parens (c:comma-list args))))))
+
+(define (c:switch expr . cases)
+ (c:group (c:line "switch " (c:pexpr expr))
+ (c:indent (c:brace-group* cases))))
+
+(define (c:case tag . items)
+ (c:group (c:exdent
+ (c:line (if tag
+ (string-append "case " (c:line-item tag))
+ "default")
+ ":"))
+ (c:group* items)))
+
+(define (c:if-goto pred label)
+ (c:group (c:line "if " (c:pexpr pred))
+ (c:indent (c:goto label))))
+
+(define (c:while expr . body)
+ (c:group (c:line "while " (c:pexpr expr))
+ (c:indent (c:brace-group* body))))
+\f
+(define (c:cast type expr)
+ (let ((type (c:type type))
+ (expr (c:expr expr)))
+ (let ((p
+ (and (c:%decimal? expr)
+ (assoc type c:decimal-suffixes))))
+ (if p
+ (string-append expr (cdr p))
+ (string-append "((" type ") " expr ")")))))
+
+(define c:decimal-suffixes
+ '(("long" . "L")
+ ("unsigned" . "U")
+ ("unsigned long" . "UL")))
+
+(define (c:%decimal? e)
+ (let ((n (string-length e)))
+ (let loop
+ ((i
+ (if (or (string-prefix? "-" e)
+ (string-prefix? "+" e))
+ 1
+ 0)))
+ (if (fix:< i n)
+ (and (char-set-member? c:decimal-chars (string-ref e i))
+ (loop (fix:+ i 1)))
+ #t))))
+
+(define c:decimal-chars
+ (ascii-range->char-set (char->integer #\0)
+ (+ (char->integer #\9) 1)))
+
+(define (c:type type)
+ (or (and (symbol? type)
+ (let ((p (assq type type-abbrevs)))
+ (and p
+ (cdr p))))
+ (c:line-item type)))
+
+(define type-abbrevs
+ (let ((types
+ (let ((types '(char short int long float double)))
+ `(,@(map (lambda (t)
+ (cons t (symbol-name t)))
+ types)
+ ,@(map (lambda (t)
+ (cons (symbol 'u t)
+ (string-append "unsigned " (symbol-name t))))
+ types)
+ (sobj . "SCHEME_OBJECT")))))
+ `(,@types
+ ,@(map (lambda (p)
+ (cons (symbol (car p) '*)
+ (string-append (cdr p) " *")))
+ types))))
+
+(define (c:decl type var #!optional val)
+ (c:line (c:type type) " " (c:var var)
+ (if (default-object? val) "" (string-append " = " (c:expr val)))
+ ";"))
+
+(define (c:var item)
+ (cond ((string? item) item)
+ ((symbol? item) (symbol-name item))
+ (else (error:wrong-type-argument item "C variable" 'C:VAR))))
+
+(define (c:array-decl type name dim items)
+ (let ((lines (list-copy items)))
+ (if (pair? lines)
+ (let loop ((lines lines))
+ (if (pair? (cdr lines))
+ (begin
+ (set-car! lines (c:line (c:line-item (car lines)) ","))
+ (loop (cdr lines)))
+ (set-car! lines (c:line (c:line-item (car lines)))))))
+ (c:group (c:line (c:type type) " " (c:var name) " [" (c:expr dim) "] =")
+ (c:indent (c:group (c:line "{")
+ (c:indent (c:group* lines))
+ (c:line "};"))))))
+\f
+(define (c:expr expr)
+ (let ((expr (c:line-item expr)))
+ (if (or (c:%identifier? expr)
+ (string->number expr)
+ (c:%parenthesized? expr)
+ (and (string-prefix? "\"" expr)
+ (string-suffix? "\"" expr)))
+ expr
+ (string-append "(" expr ")"))))
+
+(define (c:pexpr expr)
+ (let ((expr (c:line-item expr)))
+ (if (c:%parenthesized? expr)
+ expr
+ (string-append "(" expr ")"))))
+
+(define (c:%identifier? e)
+ (let ((n (string-length e)))
+ (let loop ((i 0))
+ (if (fix:< i n)
+ (and (char-set-member? c:identifier-chars (string-ref e i))
+ (loop (fix:+ i 1)))
+ #t))))
+
+(define c:identifier-chars
+ (char-set-union (ascii-range->char-set (char->integer #\A)
+ (+ (char->integer #\Z) 1))
+ (ascii-range->char-set (char->integer #\a)
+ (+ (char->integer #\z) 1))
+ (ascii-range->char-set (char->integer #\0)
+ (+ (char->integer #\9) 1))
+ (char-set #\_)))
+
+(define (c:%parenthesized? e)
+ (and (string-prefix? "(" e)
+ (string-suffix? ")" e)))
+
+(define (c:predec expr)
+ (string-append "--" (c:expr expr)))
+
+(define (c:preinc expr)
+ (string-append "++" (c:expr expr)))
+
+(define (c:postdec expr)
+ (string-append (c:expr expr) "--"))
+
+(define (c:postinc expr)
+ (string-append (c:expr expr) "++"))
+
+(define (c:aref array index)
+ (string-append "(" (c:expr array) " [" (c:expr index) "])"))
+
+(define (c:aptr array index)
+ (c:& (c:aref array index)))
+
+(define (c:?: a b c . rest)
+ (apply string-append
+ "("
+ (c:expr a)
+ " ? "
+ (c:expr b)
+ " : "
+ (c:expr c)
+ (let loop ((exprs rest))
+ (if (pair? exprs)
+ (begin
+ (if (not (pair? (cdr exprs)))
+ (error "C:?: requires even number of args."))
+ (cons* " ? "
+ (c:expr (car exprs))
+ " : "
+ (c:expr (cadr exprs))
+ (loop (cddr exprs))))
+ (list ")")))))
+\f
+(define (c:unary op a)
+ (string-append "(" (c:line-item op) " " (c:expr a) ")"))
+
+(define (c:! a)
+ (c:unary "!" a))
+
+(define (c:~ a)
+ (c:unary "~" a))
+
+(define (c:binary-infix op a b)
+ (string-append "(" (c:expr a) " " (c:line-item op) " " (c:expr b) ")"))
+
+(define (c:== a b)
+ (c:binary-infix "==" a b))
+
+(define (c:!= a b)
+ (c:binary-infix "==" a b))
+
+(define (c:> a b)
+ (c:binary-infix ">" a b))
+
+(define (c:>= a b)
+ (c:binary-infix ">=" a b))
+
+(define (c:< a b)
+ (c:binary-infix "<" a b))
+
+(define (c:<= a b)
+ (c:binary-infix "<=" a b))
+
+(define (c:\| a b)
+ (c:binary-infix "|" a b))
+
+(define (c:^ a b)
+ (c:binary-infix "^" a b))
+
+(define (c:&~ a b)
+ (c:binary-infix "&~" a b))
+
+(define (c:/ a b)
+ (c:binary-infix "/" a b))
+
+(define (c:ubinary op a b)
+ (if (default-object? b)
+ (c:unary op a)
+ (c:binary-infix op a b)))
+
+(define (c:& a #!optional b)
+ (c:ubinary "&" a b))
+
+(define (c:* a #!optional b)
+ (c:ubinary "*" a b))
+
+(define (c:+ a #!optional b)
+ (c:ubinary "+" a b))
+
+(define (c:- a #!optional b)
+ (c:ubinary "-" a b))
+
+;;; Edwin Variables:
+;;; lisp-indent/c:fn: 4
+;;; lisp-indent/c:switch: 1
+;;; lisp-indent/let*/mv: 1
+;;; End:
#| -*-Scheme-*-
-$Id: ctop.scm,v 1.17 2006/09/17 12:10:04 gjr Exp $
+$Id: ctop.scm,v 1.18 2006/10/01 05:37:56 cph Exp $
-Copyright (c) 1992-1999, 2006 Massachusetts Institute of Technology
+Copyright 1993,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(let ((pair (vector-ref object 1)))
(call-with-output-file pathname
(lambda (port)
- (write-string (cdr pair) port)))
+ (c:write-group (cdr pair) port)))
(if compiler:invoke-c-compiler? (c-compile pathname))))
(define (compile-data-from-file obj pathname)
#| -*-Scheme-*-
-$Id: lapgen.scm,v 1.19 2006/09/17 12:10:04 gjr Exp $
+$Id: lapgen.scm,v 1.20 2006/10/01 05:38:02 cph Exp $
Copyright 1993,1998,2001,2002,2004,2006 Massachusetts Institute of Technology
(else
(comp-internal-error "Unknown machine register"
'MACHINE-REGISTER-NAME reg))))
-\f
+\f
(define (machine-register-type reg)
(cond ((eq? reg regnum:value)
"SCHEME_OBJECT")
(< reg number-of-machine-registers))
(define (rhs-cast reg type)
- (string-append "((" (type->name type) ") " reg ")"))
+ (c:cast (type->name type) reg))
(define (lhs-cast reg type)
- (string-append "(* ((" (type->name type) " *) &" reg "))"))
+ (c:* (c:cast (type->name type) (c:& reg))))
(define permanent-register-list)
(define current-register-list)
name))))
(define (register-declarations)
- (append-map
- (lambda (register)
- (map (lambda (spec)
- (string-append "\t" (type->name (car spec)) " " (cdr spec) ";\n"))
- (cdr register)))
- permanent-register-list))
+ (c:group*
+ (append-map
+ (lambda (register)
+ (map (lambda (spec)
+ (c:decl (type->name (car spec)) (cdr spec)))
+ (cdr register)))
+ permanent-register-list)))
(define (standard-move-to-target! src tgt)
(let ((src-type (register-type src)))
((register-is-machine-register? tgt)
(let ((src (standard-source! src
(machine-register-type-symbol tgt))))
- (LAP ,(machine-register-name tgt) " = " ,src ";\n\t")))
+ (LAP ,(c:= (machine-register-name tgt) src))))
((register-is-machine-register? src)
(let ((tgt (standard-target! tgt
(machine-register-type-symbol src))))
- (LAP ,tgt " = " ,(machine-register-name src) ";\n\t")))
+ (LAP ,(c:= tgt (machine-register-name src)))))
(else
(let ((reg-type
(case src-type
(comp-internal-error "Unknown RTL register type"
'STANDARD-MOVE-TO-TARGET!
src-type)))))
- (LAP ,(find-register! tgt reg-type) " = "
- ,(find-register! src reg-type) ";\n\t"))))))
+ (LAP ,(c:= (find-register! tgt reg-type)
+ (find-register! src reg-type))))))))
\f
-;;;; Communicate with cout.scm
+;;;; Communicate with "cout.scm"
+
+(define (c:invoke-interface-0 code)
+ (use-invoke-interface! 0)
+ (c:scall "INVOKE_INTERFACE_0" code))
+
+(define (c:invoke-interface-1 code arg1)
+ (use-invoke-interface! 1)
+ (c:scall "INVOKE_INTERFACE_1" code arg1))
+
+(define (c:invoke-interface-2 code arg1 arg2)
+ (use-invoke-interface! 2)
+ (c:scall "INVOKE_INTERFACE_2" code arg1 arg2))
+
+(define (c:invoke-interface-3 code arg1 arg2 arg3)
+ (use-invoke-interface! 3)
+ (c:scall "INVOKE_INTERFACE_3" code arg1 arg2 arg3))
+
+(define (c:invoke-interface-4 code arg1 arg2 arg3 arg4)
+ (use-invoke-interface! 4)
+ (c:scall "INVOKE_INTERFACE_4" code arg1 arg2 arg3 arg4))
(define (use-invoke-interface! number)
(set! *invoke-interface*
(let ((old *invoke-interface*))
- (if (eq? old 'infinity)
+ (if (eq? old 'INFINITY)
number
- (min old number)))))
+ (min old number))))
+ unspecific)
+
+(define (c:invoke-primitive prim arity)
+ (set! *used-invoke-primitive* #t)
+ (c:scall "INVOKE_PRIMITIVE" prim arity))
+
+(define (c:closure-interrupt-check)
+ (use-invoke-interface! 0)
+ (c:scall "CLOSURE_INTERRUPT_CHECK" code:compiler-interrupt-closure))
+
+(define (c:interrupt-check code block-label)
+ (use-invoke-interface! 1)
+ (c:scall "INTERRUPT_CHECK" code block-label))
+
+(define (c:dlink-interrupt-check block-label)
+ (use-invoke-interface! 2)
+ (c:scall "DLINK_INTERRUPT_CHECK"
+ code:compiler-interrupt-dlink
+ block-label))
+
+(define (c:jump address)
+ (set! *use-jump-execute-chache* #t)
+ (c:scall "JUMP" address))
+
+(define (c:pop-return)
+ (set! *use-pop-return* #t)
+ (c:goto 'pop_return))
+\f
+(define (c:reg-block)
+ "Rrb")
-(define (use-invoke-primitive!)
- (set! *used-invoke-primitive* true))
+(define (c:free-reg)
+ "Rhp")
-(define (use-closure-interrupt-check!)
- (use-invoke-interface! 0))
+(define (c:sp-reg)
+ "Rsp")
-(define (use-interrupt-check!)
- (use-invoke-interface! 1))
+(define (c:val-reg)
+ "Rvl")
-(define (use-dlink-interrupt-check!)
- (use-invoke-interface! 2))
+(define (c:dlink-reg)
+ "Rdl")
-(define (use-jump-execute-chache!)
- (set! *use-jump-execute-chache* #t))
+(define (c:pc-reg)
+ "Rpc")
-(define (use-pop-return!)
- (set! *use-pop-return* #t))
+(define (c:rref index)
+ (c:aref (c:reg-block) index))
+
+(define (c:env-reg)
+ (c:rref "REGBLOCK_ENV"))
+
+(define (c:push object)
+ (c:= (c:* (c:predec (c:sp-reg))) object))
+
+(define (c:pop)
+ (c:* (c:postinc (c:sp-reg))))
+
+(define (c:tos)
+ (c:* (c:sp-reg)))
+
+(define (c:sref index)
+ (c:aref (c:sp-reg) index))
+
+(define (c:sptr index)
+ (c:aptr (c:sp-reg) index))
+
+(define (c:cref index)
+ (c:aref 'current_block index))
+
+(define (c:cptr index)
+ (c:aptr 'current_block index))
+
+(define (c:make-object type datum)
+ (c:ecall "MAKE_OBJECT" type datum))
+
+(define (c:make-pointer-object type address)
+ (c:ecall "MAKE_POINTER_OBJECT" type address))
+
+(define (c:object-type expr)
+ (c:ecall "OBJECT_TYPE" expr))
+
+(define (c:object-datum expr)
+ (c:ecall "OBJECT_DATUM" expr))
+
+(define (c:object-address expr)
+ (c:ecall "OBJECT_ADDRESS" expr))
\f
;;;; Constants, Labels, and Various Caches
'REGISTER->HOME-TRANSFER one two))
(define (lap:make-label-statement label)
- (LAP "\nDEFLABEL(" ,label ");\n\t" ))
+ (LAP ,(c:label label)))
(define (lap:make-unconditional-branch label)
- (LAP "goto " ,label ";\n\t"))
+ (LAP ,(c:goto label)))
(define (lap:make-entry-point label block-start-label)
block-start-label ; ignored
(declare-block-label! expression-code-word label #f)
(lap:make-label-statement label))
-(define (compare cc val1 val2)
- (set-current-branches!
- (lambda (label)
- (LAP "if (" ,val1 ,cc ,val2 ")\n\t goto " ,label ";\n\t"))
- (lambda (label)
- (LAP "if (!(" ,val1 ,cc ,val2 "))\n\t goto " ,label ";\n\t")))
+(define (branch-on-expr expr)
+ (set-current-branches! (lambda (label) (LAP ,(c:if-goto expr label)))
+ (lambda (label) (LAP ,(c:if-goto (c:! expr) label))))
(LAP))
-(define (compare/unsigned cc val1 val2)
- (set-current-branches!
- (lambda (label)
- (LAP "if (((unsigned long) " ,val1 ")"
- ,cc "((unsigned long) " ,val2 "))\n\t goto " ,label ";\n\t"))
- (lambda (label)
- (LAP "if (!(((unsigned long) " ,val1 ")"
- ,cc "((unsigned long) " ,val2 ")))\n\t goto " ,label ";\n\t")))
- (LAP))
+(define (compare c:?? val1 val2)
+ (branch-on-expr (c:?? val1 val2)))
\f
(define (define-arithmetic-method operator methods method)
(let ((entry (assq operator (cdr methods))))
(comp-internal-error "Unknown operator" 'LOOKUP-ARITHMETIC-METHOD
operator))))
-(let-syntax ((define-codes
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(BEGIN
- ,@(let loop ((names (cddr form)) (index (cadr form)))
- (if (pair? names)
- (cons `(DEFINE-INTEGRABLE
- ,(symbol-append 'CODE:COMPILER-
- (car names))
- ,index)
- (loop (cdr names) (1+ index)))
- `())))))))
- (define-codes #x012
- primitive-apply primitive-lexpr-apply
- apply error lexpr-apply link
- interrupt-closure interrupt-dlink interrupt-procedure
- interrupt-continuation interrupt-ic-procedure
- assignment-trap cache-reference-apply
- reference-trap safe-reference-trap unassigned?-trap
- -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
- access lookup safe-lookup unassigned? unbound?
- set! define lookup-apply primitive-error
- quotient remainder modulo
- reflect-to-interface interrupt-continuation-2
- compiled-code-bkpt compiled-closure-bkpt))
+(define-syntax define-codes
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ `(BEGIN
+ ,@(let loop ((names (cddr form)) (index (cadr form)))
+ (if (pair? names)
+ (cons `(DEFINE-INTEGRABLE
+ ,(symbol-append 'CODE:COMPILER-
+ (car names))
+ ,index)
+ (loop (cdr names) (1+ index)))
+ `()))))))
+
+(define-codes #x012
+ primitive-apply primitive-lexpr-apply
+ apply error lexpr-apply link
+ interrupt-closure interrupt-dlink interrupt-procedure
+ interrupt-continuation interrupt-ic-procedure
+ assignment-trap cache-reference-apply
+ reference-trap safe-reference-trap unassigned?-trap
+ -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
+ access lookup safe-lookup unassigned? unbound?
+ set! define lookup-apply primitive-error
+ quotient remainder modulo
+ reflect-to-interface interrupt-continuation-2
+ compiled-code-bkpt compiled-closure-bkpt)
(define (pre-lapgen-analysis rgraphs)
#| -*-Scheme-*-
-$Id: rules1.scm,v 1.10 2003/02/14 18:28:02 cph Exp $
+$Id: rules1.scm,v 1.11 2006/10/01 05:38:08 cph Exp $
-Copyright (c) 1992-1999 Massachusetts Institute of Technology
+Copyright 1993,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(let* ((datum (standard-source! datum 'SCHEME_OBJECT*))
(type (standard-source! type 'ULONG))
(target (standard-target! target 'SCHEME_OBJECT)))
- (LAP ,target " = (MAKE_POINTER_OBJECT (" ,type ", " ,datum "));\n\t")))
+ (LAP ,(c:= target (c:make-pointer-object type datum)))))
(define-rule statement
(ASSIGN (REGISTER (? target))
(let* ((datum (standard-source! datum 'SCHEME_OBJECT*))
(type (standard-source! type 'ULONG))
(target (standard-target! target 'SCHEME_OBJECT)))
- (LAP ,target " = (MAKE_OBJECT (" ,type ", " ,datum "));\n\t")))
+ (LAP ,(c:= target (c:make-object type datum)))))
(define-rule statement
(ASSIGN (REGISTER (? target))
(CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
(let* ((datum (standard-source! source 'SCHEME_OBJECT*))
(target (standard-target! target 'SCHEME_OBJECT)))
- (LAP ,target " = (MAKE_POINTER_OBJECT (" ,type ", " ,datum "));\n\t")))
+ (LAP ,(c:= target (c:make-pointer-object type datum)))))
(define-rule statement
(ASSIGN (REGISTER (? target))
(CONS-NON-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
(let* ((datum (standard-source! source 'ULONG))
(target (standard-target! target 'SCHEME_OBJECT)))
- (LAP ,target " = (MAKE_OBJECT (" ,type ", " ,datum "));\n\t")))
+ (LAP ,(c:= target (c:make-object type datum)))))
(define (standard-unary-conversion source source-type target target-type
conversion)
(conversion source1 source2 target)))
(define (object->type source target)
- (LAP ,target " = (OBJECT_TYPE (" ,source "));\n\t"))
+ (LAP ,(c:= target (c:object-type source))))
(define (object->datum source target)
- (LAP ,target " = (OBJECT_DATUM (" ,source "));\n\t"))
+ (LAP ,(c:= target (c:object-datum source))))
(define (object->address source target)
- (LAP ,target " = (OBJECT_ADDRESS (" ,source "));\n\t"))
+ (LAP ,(c:= target (c:object-address source))))
(define-rule statement
(ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
index 'LONG
target 'SCHEME_OBJECT*
(lambda (base index target)
- (LAP ,target " = &" ,base "[" ,index "];\n\t"))))
+ (LAP ,(c:= target (c:aptr base index))))))
(define-rule statement
(ASSIGN (REGISTER (? target))
(standard-unary-conversion
source 'SCHEME_OBJECT* target 'SCHEME_OBJECT*
(lambda (source target)
- (LAP ,target " = &" ,source "[" ,offset "];\n\t"))))
+ (LAP ,(c:= target (c:aptr source offset))))))
(define-rule statement
(ASSIGN (REGISTER (? target))
index 'LONG
target 'CHAR*
(lambda (base index target)
- (LAP ,target " = &" ,base "[" ,index "];\n\t"))))
+ (LAP ,(c:= target (c:aptr base index))))))
;; This rule is not written in the obvious way (commented out) because
;; it is used by the code generator to bump closures. Sometimes the
(standard-unary-conversion
source 'CHAR* target 'CHAR*
(lambda (source target)
- (LAP ,target " = &" ,source "[" ,offset "];\n\t")))
+ (LAP ,(c:= target (c:aptr source offset)))))
|#
(standard-unary-conversion
source 'LONG target 'ULONG
(lambda (source target)
- (LAP ,target " = ((unsigned long) (" ,source " + " ,offset "));\n\t"))))
+ (LAP ,(c:= target (c:cast 'ulong (c:+ source offset)))))))
(define-rule statement
(ASSIGN (REGISTER (? target))
index 'LONG
target 'DOUBLE*
(lambda (base index target)
- (LAP ,target " = &" ,base "[" ,index "];\n\t"))))
+ (LAP ,(c:= target (c:aptr base index))))))
(define-rule statement
(ASSIGN (REGISTER (? target))
(standard-unary-conversion
source 'DOUBLE* target 'DOUBLE*
(lambda (source target)
- (LAP ,target " = &" ,source "[" ,offset "];\n\t"))))
+ (LAP ,(c:= target (c:aptr source offset))))))
\f
;;;; Loading of Constants
;; load a machine constant
(ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? source)))
(let ((target (standard-target! target 'SCHEME_OBJECT)))
- (LAP ,target " = ((SCHEME_OBJECT) " ,source ");\n\t")))
+ (LAP ,(c:= target (c:cast 'sobj source)))))
(define-rule statement
;; load a Scheme constant
(ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
(let ((target (standard-target! target 'SCHEME_OBJECT)))
- (LAP ,target " = current_block[" ,(object->offset source) "];\n\t")))
+ (LAP ,(c:= target (c:cref (object->offset source))))))
(define-rule statement
;; load the type part of a Scheme constant
(ASSIGN (REGISTER (? target)) (OBJECT->TYPE (CONSTANT (? constant))))
(let ((target (standard-target! target 'ULONG)))
- (LAP ,target " = (OBJECT_TYPE (current_block["
- ,(object->offset constant) "]));\n\t")))
+ (LAP ,(c:= target (c:object-type (c:cref (object->offset constant)))))))
(define-rule statement
;; load the datum part of a Scheme constant
(ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant))))
(QUALIFIER (non-pointer-object? constant))
(let ((target (standard-target! target 'ULONG)))
- (LAP ,target " = (OBJECT_DATUM (current_block["
- ,(object->offset constant) "]));\n\t")))
+ (LAP ,(c:= target (c:object-datum (c:cref (object->offset constant)))))))
(define-rule statement
;; load a synthesized constant
(CONS-NON-POINTER (MACHINE-CONSTANT (? type))
(MACHINE-CONSTANT (? datum))))
(let((target (standard-target! target 'SCHEME_OBJECT)))
- (LAP ,target " = (MAKE_OBJECT (" ,type ", " ,datum "));\n\t")))
+ (LAP ,(c:= target (c:make-object type datum)))))
\f
(define-rule statement
;; load the address of a variable reference cache
(ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
(let ((target (standard-target! target 'SCHEME_OBJECT*)))
- (LAP ,target " = ((SCHEME_OBJECT *) current_block["
- ,(free-reference->offset name) "]);\n\t")))
+ (LAP ,(c:= target
+ (c:cast 'sobj* (c:cref (free-reference->offset name)))))))
(define-rule statement
;; load the address of an assignment cache
(ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
(let ((target (standard-target! target 'SCHEME_OBJECT*)))
- (LAP ,target " = ((SCHEME_OBJECT *) current_block["
- ,(free-assignment->offset name) "]);\n\t")))
+ (LAP ,(c:= target
+ (c:cast 'sobj* (c:cref (free-assignment->offset name)))))))
(define-rule statement
;; load the address of a procedure's entry point
(ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
(let ((target (standard-target! target 'SCHEME_OBJECT*)))
- (LAP ,target " = ¤t_block[" ,(label->offset label) "];\n\t")))
+ (LAP ,(c:= target (c:cptr (label->offset label))))))
(define-rule statement
;; load the address of a continuation
(ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
(let ((target (standard-target! target 'SCHEME_OBJECT*)))
- (LAP ,target " = ¤t_block[" ,(label->offset label) "];\n\t")))
+ (LAP ,(c:= target (c:cptr (label->offset label))))))
(define-rule statement
;; load a procedure object
(CONS-POINTER (MACHINE-CONSTANT (? type))
(ENTRY:PROCEDURE (? label))))
(let ((target (standard-target! target 'SCHEME_OBJECT)))
- (LAP ,target " = (MAKE_POINTER_OBJECT (" ,type ", ¤t_block["
- ,(label->offset label) "]));\n\t")))
+ (LAP ,(c:= target
+ (c:make-pointer-object type (c:cptr (label->offset label)))))))
(define-rule statement
;; load a return address object
(CONS-POINTER (MACHINE-CONSTANT (? type))
(ENTRY:CONTINUATION (? label))))
(let ((target (standard-target! target 'SCHEME_OBJECT)))
- (LAP ,target " = (MAKE_POINTER_OBJECT (" ,type ", ¤t_block["
- ,(label->offset label) "]));\n\t")))
+ (LAP ,(c:= target
+ (c:make-pointer-object type (c:cptr (label->offset label)))))))
\f
;;;; Transfers from memory
(standard-unary-conversion
address 'SCHEME_OBJECT* target 'SCHEME_OBJECT
(lambda (address target)
- (LAP ,target " = " ,address "[" ,offset "];\n\t"))))
+ (LAP ,(c:= target (c:aref address offset))))))
(define-rule statement
(ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER (? rsp)) 1))
(QUALIFIER (= rsp regnum:stack-pointer))
(let ((target (standard-target! target 'SCHEME_OBJECT)))
- (LAP ,target " = *Rsp++;\n\t")))
+ (LAP ,(c:= target (c:pop)))))
;;;; Transfers to memory
(QUALIFIER (word-register? source))
(let* ((source (standard-source! source 'SCHEME_OBJECT))
(address (standard-source! address 'SCHEME_OBJECT*)))
- (LAP ,address "[" ,offset "] = " ,source ";\n\t")))
+ (LAP ,(c:= (c:aref address offset) source))))
(define-rule statement
;; Push an object register on the heap
(QUALIFIER (and (word-register? source)
(= rfree regnum:free)))
(let ((source (standard-source! source 'SCHEME_OBJECT)))
- (LAP "*Rhp++ = " ,source ";\n\t")))
+ (LAP ,(c:= (c:* (c:postinc (c:free-reg))) source))))
(define-rule statement
;; Push an object register on the stack
(QUALIFIER (and (word-register? source)
(= rsp regnum:stack-pointer)))
(let ((source (standard-source! source 'SCHEME_OBJECT)))
- (LAP "*--Rsp = " ,source ";\n\t")))
+ (LAP ,(c:push source))))
;; Cheaper, common patterns.
(ASSIGN (OFFSET (REGISTER (? address)) (MACHINE-CONSTANT (? offset)))
(MACHINE-CONSTANT 0))
(let ((address (standard-source! address 'SCHEME_OBJECT*)))
- (LAP ,address "[" ,offset "] = ((SCHEME_OBJECT) 0);\n\t")))
+ (LAP ,(c:= (c:aref address offset) (c:cast 'sobj 0)))))
(define-rule statement
; Push NIL (or whatever is represented by a machine 0) on heap
(ASSIGN (POST-INCREMENT (REGISTER (? rfree)) 1) (MACHINE-CONSTANT 0))
(QUALIFIER (= rfree regnum:free))
- (LAP "*Rhp++ = ((SCHEME_OBJECT) 0);\n\t"))
+ (LAP ,(c:= (c:* (c:postinc (c:free-reg))) (c:cast 'sobj 0))))
(define-rule statement
;; Push 0 on the stack
(ASSIGN (PRE-INCREMENT (REGISTER (? rsp)) -1)
(MACHINE-CONSTANT (? const)))
(QUALIFIER (= rsp regnum:stack-pointer))
- (LAP "*--Rsp = ((SCHEME_OBJECT) " ,const ");\n\t"))
+ (LAP ,(c:push (c:cast 'sobj const))))
\f
;;;; CHAR->ASCII/BYTE-OFFSET
(standard-unary-conversion
address 'SCHEME_OBJECT* target 'ULONG
(lambda (address target)
- (LAP ,target " = (CHAR_TO_ASCII (" ,address "[" ,offset "]));\n\t"))))
+ (LAP ,(c:= target (c:ecall "CHAR_TO_ASCII" (c:aref address offset)))))))
(define-rule statement
;; load ASCII byte from memory
(MACHINE-CONSTANT (? offset))))
(standard-unary-conversion address 'CHAR* target 'ULONG
(lambda (address target)
- (LAP ,target " = ((unsigned long) (((unsigned char *) " ,address ")["
- ,offset "]));\n\t"))))
+ (LAP ,(c:= target
+ (c:cast 'ulong (c:aref (c:cast 'uchar* address) offset)))))))
(define-rule statement
;; convert char object to ASCII byte
(CHAR->ASCII (REGISTER (? source))))
(standard-unary-conversion source 'SCHEME_OBJECT target 'ULONG
(lambda (source target)
- (LAP ,target " = (CHAR_TO_ASCII (" ,source "));\n\t"))))
+ (LAP ,(c:= target (c:ecall "CHAR_TO_ASCII" source))))))
(define-rule statement
;; store null byte in memory
(MACHINE-CONSTANT (? offset)))
(CHAR->ASCII (CONSTANT #\NUL)))
(let ((address (standard-source! address 'CHAR*)))
- (LAP ,address "[" ,offset "] = '\\0';\n\t")))
+ (LAP ,(c:= (c:aref address offset) "'\\0'"))))
(define-rule statement
;; store ASCII byte in memory
(REGISTER (? source)))
(let ((address (standard-source! address 'CHAR*))
(source (standard-source! source 'ULONG)))
- (LAP ,address "[" ,offset "] = ((char) " ,source ");\n\t")))
+ (LAP ,(c:= (c:aref address offset) (c:cast 'char source)))))
(define-rule statement
;; convert char object to ASCII byte and store it in memory
(CHAR->ASCII (REGISTER (? source))))
(let ((address (standard-source! address 'CHAR*))
(source (standard-source! source 'SCHEME_OBJECT)))
- (LAP ,address "[" ,offset "] = ((char) (CHAR_TO_ASCII (" ,source
- ")));\n\t")))
+ (LAP ,(c:= (c:aref address offset)
+ (c:cast 'char (c:ecall "CHAR_TO_ASCII" source))))))
#| -*-Scheme-*-
-$Id: rules2.scm,v 1.6 2006/09/16 11:19:09 gjr Exp $
+$Id: rules2.scm,v 1.7 2006/10/01 05:38:14 cph Exp $
-Copyright (c) 1992, 1999, 2006 Massachusetts Institute of Technology
+Copyright 1993,1997,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(define-rule predicate
;; test for two registers EQ?
(EQ-TEST (REGISTER (? source1)) (REGISTER (? source2)))
- (let ((source1 (standard-source! source1 'SCHEME_OBJECT))
- (source2 (standard-source! source2 'SCHEME_OBJECT)))
- (set-current-branches!
- (lambda (if-true-label)
- (LAP "if (" ,source1 " == " ,source2 ")\n\t goto "
- ,if-true-label ";\n\t"))
- (lambda (if-false-label)
- (LAP "if (" ,source1 " != " ,source2 ")\n\t goto "
- ,if-false-label ";\n\t")))
- (LAP)))
+ (%eq-test (standard-source! source1 'SCHEME_OBJECT)
+ (standard-source! source2 'SCHEME_OBJECT)))
(define-rule predicate
;; test for register EQ? to constant
(define-rule predicate
;; Branch if virtual register contains the specified type number
(TYPE-TEST (REGISTER (? source)) (? type))
- (let ((source (standard-source! source 'ULONG)))
- (set-current-branches!
- (lambda (if-true-label)
- (LAP "if (" ,source " == " ,type ")\n\t goto " ,if-true-label
- ";\n\t"))
- (lambda (if-false-label)
- (LAP "if (" ,source " != " ,type ")\n\t goto " ,if-false-label
- ";\n\t")))
- (LAP)))
+ (%eq-test (standard-source! source 'ULONG) type))
(define-rule predicate
;; Branch if virtual register contains a legal index fixnum
(PRED-1-ARG INDEX-FIXNUM?
(REGISTER (? source)))
(let ((source (standard-source! source 'ULONG)))
- (set-current-branches!
- (lambda (if-true-label)
- (LAP "if (INDEX_FIXNUM_P (" ,source "))\n\t goto " ,if-true-label
- ";\n\t"))
- (lambda (if-false-label)
- (LAP "if (!(INDEX_FIXNUM_P (" ,source ")))\n\t goto " ,if-false-label
- ";\n\t")))
- (LAP)))
+ (branch-on-expr (c:ecall "INDEX_FIXNUM_P" source))))
(define (eq-test/constant constant source)
- (let ((source (standard-source! source 'SCHEME_OBJECT)))
- (set-current-branches!
- (lambda (if-true-label)
- (LAP "if (" ,source " == current_block[" ,(object->offset constant)
- "])\n\t goto " ,if-true-label ";\n\t"))
- (lambda (if-false-label)
- (LAP "if (" ,source " != current_block[" ,(object->offset constant)
- "])\n\t goto " ,if-false-label ";\n\t")))
- (LAP)))
+ (%eq-test (standard-source! source 'SCHEME_OBJECT)
+ (c:cref (object->offset constant))))
(define (eq-test/machine-constant constant source)
- (let ((source (standard-source! source 'SCHEME_OBJECT)))
- (set-current-branches!
- (lambda (if-true-label)
- (LAP "if (" ,source " == ((SCHEME_OBJECT) " ,constant "))\n\t goto "
- ,if-true-label ";\n\t"))
- (lambda (if-false-label)
- (LAP "if (" ,source " != ((SCHEME_OBJECT) " ,constant "))\n\t goto "
- ,if-false-label ";\n\t")))
- (LAP)))
+ (%eq-test (standard-source! source 'SCHEME_OBJECT)
+ (c:cast 'sobj constant)))
(define (eq-test/non-pointer type datum source)
- (let ((source (standard-source! source 'SCHEME_OBJECT)))
- (set-current-branches!
- (lambda (if-true-label)
- (LAP "if (" ,source " == (MAKE_OBJECT (" ,type ", " ,datum
- ")))\n\t goto " ,if-true-label ";\n\t"))
- (lambda (if-false-label)
- (LAP "if (" ,source " != (MAKE_OBJECT (" ,type ", " ,datum
- ")))\n\t goto " ,if-false-label ";\n\t")))
- (LAP)))
\ No newline at end of file
+ (%eq-test (standard-source! source 'SCHEME_OBJECT)
+ (c:make-object type datum)))
+
+(define (%eq-test source1 source2)
+ (branch-on-expr (c:== source1 source2)))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: rules3.scm,v 1.13 2003/02/14 18:28:02 cph Exp $
+$Id: rules3.scm,v 1.14 2006/10/01 05:38:20 cph Exp $
-Copyright (c) 1992-1999, 2001, 2002 Massachusetts Institute of Technology
+Copyright 1993,2001,2002,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
;;;; Invocations
(define (pop-return)
- (use-pop-return!)
(LAP ,@(clear-map!)
- "goto pop_return;\n\t"))
+ ,(c:pop-return)))
(define-rule statement
(POP-RETURN)
(define-rule statement
(INVOCATION:APPLY (? frame-size) (? continuation))
continuation ;ignore
- (let ()
- (use-invoke-interface! 2)
- (LAP ,@(clear-map!)
- "{\n\t SCHEME_OBJECT procedure = *Rsp++;\n\t"
- " INVOKE_INTERFACE_2 (" ,code:compiler-apply ", procedure, "
- ,frame-size ");\n\t}\n\t")))
+ (LAP ,@(clear-map!)
+ ,(c:brace-group (c:decl 'sobj 'procedure (c:pop))
+ (c:invoke-interface-2 code:compiler-apply
+ 'procedure
+ frame-size))))
(define-rule statement
(INVOCATION:JUMP (? frame-size) (? continuation) (? label))
frame-size continuation ;ignore
(LAP ,@(clear-map!)
- "goto " ,label ";\n\t"))
+ ,(c:goto label)))
(define-rule statement
(INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
(define-rule statement
(INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
continuation ;ignore
- (let ()
- (use-invoke-interface! 2)
- (LAP ,@(clear-map!)
- "{\n\t SCHEME_OBJECT * procedure_address = ¤t_block["
- ,(label->offset label)
- "];\n\t INVOKE_INTERFACE_2 (" ,code:compiler-lexpr-apply
- ", procedure_address, " ,number-pushed ");\n\t}\n\t")))
+ (LAP ,@(clear-map!)
+ ,(c:brace-group (c:decl 'sobj*
+ 'procedure_address
+ (c:cptr (label->offset label)))
+ (c:invoke-interface-2 code:compiler-lexpr-apply
+ 'procedure_address
+ number-pushed))))
(define-rule statement
(INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
continuation ;ignore
;; Destination address is at TOS; pop it into second-arg
- (let ()
- (use-invoke-interface! 2)
- (LAP
- ,@(clear-map!)
- "{n\t SCHEME_OBJECT procedure = *Rsp++;\n\t "
- "SCHEME_OBJECT * procedure_address = (OBJECT_ADDRESS (procedure));\n\t"
- " INVOKE_INTERFACE_2 (" ,code:compiler-lexpr-apply
- ", procedure_address, " ,number-pushed ");\n\t}\n\t")))
+ (LAP ,@(clear-map!)
+ ,(c:brace-group (c:decl 'sobj 'procedure (c:pop))
+ (c:decl 'sobj*
+ 'procedure_address
+ (c:object-address 'procedure))
+ (c:invoke-interface-2 code:compiler-lexpr-apply
+ 'procedure_address
+ number-pushed))))
\f
(define-rule statement
(INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
continuation ;ignore
- (begin
- (use-jump-execute-chache!)
- (LAP ,@(clear-map!)
- "JUMP ((SCHEME_OBJECT *) (current_block["
- ,(free-uuo-link-label name frame-size)
- "]));\n\t")))
+ (LAP ,@(clear-map!)
+ ,(c:jump (c:cast 'sobj*
+ (c:cref (free-uuo-link-label name frame-size))))))
(define-rule statement
(INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
continuation ;ignore
- (begin
- (use-jump-execute-chache!)
- (LAP ,@(clear-map!)
- "JUMP ((SCHEME_OBJECT *) (current_block["
- ,(global-uuo-link-label name frame-size)
- "]));\n\t")))
+ (LAP ,@(clear-map!)
+ ,(c:jump (c:cast 'sobj*
+ (c:cref (global-uuo-link-label name frame-size))))))
(define-rule statement
(INVOCATION:CACHE-REFERENCE (? frame-size)
(REGISTER (? extension)))
continuation ;ignore
(let ((extension (standard-source! extension 'SCHEME_OBJECT*)))
- (use-invoke-interface! 3)
(LAP ,@(clear-map!)
- "INVOKE_INTERFACE_3 (" ,code:compiler-cache-reference-apply
- ", " ,extension ", current_block, " ,frame-size ");\n\t")))
+ ,(c:invoke-interface-3 code:compiler-cache-reference-apply
+ extension
+ 'current_block
+ frame-size))))
(define-rule statement
(INVOCATION:LOOKUP (? frame-size)
(? name))
continuation ;ignore
(let ((environment (standard-source! environment 'SCHEME_OBJECT)))
- (use-invoke-interface! 3)
(LAP ,@(clear-map!)
- "INVOKE_INTERFACE_3 (" ,code:compiler-lookup-apply
- ", " ,environment ", current_block[" ,(object->offset name) "]"
- ", " ,frame-size ");\n\t")))
+ ,(c:invoke-interface-3 code:compiler-lookup-apply
+ environment
+ (c:cref (object->offset name))
+ frame-size))))
\f
(define-rule statement
(INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
continuation ;ignore
- (cond ((eq? primitive compiled-error-procedure)
- (use-invoke-interface! 1)
- (LAP ,@(clear-map!)
- "INVOKE_INTERFACE_1 (" ,code:compiler-error ", "
- ,frame-size ");\n\t"))
- (else
- (let ((arity (primitive-procedure-arity primitive)))
- (cond ((= arity (-1+ frame-size))
- (use-invoke-primitive!)
- (LAP ,@(clear-map!)
- "INVOKE_PRIMITIVE (current_block["
- ,(object->offset primitive) "], "
- ,arity
- ");\n\t"))
- #|
- ((= arity -1)
- (LAP ,@(clear-map!)
- "INVOKE_INTERFACE_2 (" ,code:compiler-apply
- ", (current_block[" ,(object->offset primitive) "]"
- ", " ,frame-size ");\n\t"))
- |#
- (else
- (if (not (= arity -1))
- (error "Wrong number of arguments to primitive"
- primitive (-1+ frame-size)))
- (use-invoke-interface! 2)
- (LAP ,@(clear-map!)
- "INVOKE_INTERFACE_2 (" ,code:compiler-apply
- ", current_block[" ,(object->offset primitive) "]"
- ", " ,frame-size ");\n\t")))))))
+ (LAP ,@(clear-map!)
+ ,(if (eq? primitive compiled-error-procedure)
+ (c:invoke-interface-1 code:compiler-error frame-size)
+ (let ((prim (c:cref (object->offset primitive)))
+ (arity (primitive-procedure-arity primitive))
+ (nargs (- frame-size 1)))
+ (if (= arity nargs)
+ (c:invoke-primitive prim arity)
+ (begin
+ (if (not (= arity -1))
+ (warn "Wrong number of arguments to primitive:"
+ primitive nargs arity))
+ (c:invoke-interface-2 code:compiler-apply
+ prim
+ frame-size)))))))
(define (invoke-special-primitive code)
- (use-invoke-interface! 0)
(LAP ,@(clear-map!)
- "INVOKE_INTERFACE_0 (" ,code ");\n\t"))
+ ,(c:invoke-interface-0 code)))
(let-syntax
((define-special-primitive-invocation
;; Move <frame-size> words back to dynamic link marker
(INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? new-frame)))
(let ((new-frame (standard-source! new-frame 'SCHEME_OBJECT*)))
- (move-frame-up frame-size new-frame "")))
+ (LAP ,(move-frame-up frame-size new-frame))))
-(define (move-frame-up frame-size new-frame pfx)
+(define (move-frame-up frame-size new-frame)
(case frame-size
((0)
- (LAP ,pfx "Rsp = " ,new-frame ";\n\t"))
+ (c:group (c:= (c:sp-reg) new-frame)))
((1)
- (LAP ,pfx "*--" ,new-frame " = Rsp[0];\n\t"
- ,pfx "Rsp = " ,new-frame ";\n\t"))
+ (c:group (c:= (c:* (c:predec new-frame)) (c:sref 0))
+ (c:= (c:sp-reg) new-frame)))
((2)
- (LAP ,pfx "*--" ,new-frame " = Rsp[1];\n\t"
- ,pfx "*--" ,new-frame " = Rsp[0];\n\t"
- ,pfx "Rsp = " ,new-frame ";\n\t"))
+ (c:group (c:= (c:* (c:predec new-frame)) (c:sref 1))
+ (c:= (c:* (c:predec new-frame)) (c:sref 0))
+ (c:= (c:sp-reg) new-frame)))
((3)
- (LAP ,pfx "*--" ,new-frame " = Rsp[2];\n\t"
- ,pfx "*--" ,new-frame " = Rsp[1];\n\t"
- ,pfx "*--" ,new-frame " = Rsp[0];\n\t"
- ,pfx "Rsp = " ,new-frame ";\n\t"))
+ (c:group (c:= (c:* (c:predec new-frame)) (c:sref 2))
+ (c:= (c:* (c:predec new-frame)) (c:sref 1))
+ (c:= (c:* (c:predec new-frame)) (c:sref 0))
+ (c:= (c:sp-reg) new-frame)))
(else
- (LAP ,pfx "{\n\t SCHEME_OBJECT * frame_top = &Rsp["
- ,frame-size "];\n\t"
- ,pfx "SCHEME_OBJECT * new_frame = " ,new-frame ";\n\t"
- ,pfx " long frame_size = " ,frame-size ";\n\t"
- ,pfx " while ((--frame_size) >= 0)"
- ,pfx " *--new_frame = *--frame_top;\n\t"
- ,pfx " Rsp = new_frame;\n\t"
- ,pfx "}\n\t"))))
+ (c:brace-group
+ (c:decl 'sobj* "MFUp1" (c:sptr frame-size))
+ (c:decl 'sobj* "MFUp2" new-frame)
+ (c:while (c:> "MFUp1" (c:sp-reg))
+ (c:= (c:* (c:predec "MFUp2"))
+ (c:* (c:predec "MFUp1"))))
+ (c:= (c:sp-reg) "MFUp2")))))
\f
;;; DYNAMIC-LINK instructions have a <frame-size>, <new frame end>,
;;; and <current dynamic link> as arguments. They pop the stack by
(REGISTER (? choice-2)))
(let ((choice-1 (standard-source! choice-1 'SCHEME_OBJECT*))
(choice-2 (standard-source! choice-2 'SCHEME_OBJECT*)))
- (LAP "{\n\t SCHEME_OBJECT * new_frame_1;\n\t"
- " new_frame_1 = ((" ,choice-1 " <= " ,choice-2 ") ? "
- ,choice-1 " : " ,choice-2 ");\n\t"
- ,@(move-frame-up frame-size "new_frame_1" " ")
- "}\n\t")))
+ (LAP ,(c:brace-group
+ (c:decl 'sobj* "IPDLp1"
+ (c:?: (c:<= choice-1 choice-2)
+ choice-1
+ choice-2))
+ (move-frame-up frame-size "IPDLp1")))))
\f
;;; Entry point types
(define (simple-procedure-header code-word label e-label code)
(declare-block-label! code-word label e-label)
(let ((block-label (label->offset label)))
- (use-interrupt-check!)
(LAP ,@(if (not e-label)
(LAP)
(label-statement e-label))
,@(label-statement label)
- "INTERRUPT_CHECK (" ,code ", (" ,block-label "));\n\t")))
+ ,(c:interrupt-check code block-label))))
(define (dlink-procedure-header code-word label e-label)
(declare-block-label! code-word label e-label)
(let ((block-label (label->offset label)))
- (use-dlink-interrupt-check!)
(LAP ,@(if (not e-label)
(LAP)
(label-statement e-label))
,@(label-statement label)
- "DLINK_INTERRUPT_CHECK ("
- ,code:compiler-interrupt-dlink
- ", (" ,block-label "));\n\t")))
+ ,(c:dlink-interrupt-check block-label))))
(define-rule statement
(CONTINUATION-ENTRY (? internal-label))
(let ((external-label (rtl-procedure/external-label rtl-proc)))
(declare-block-label! (internal-procedure-code-word rtl-proc)
#f external-label)
- (use-closure-interrupt-check!)
(LAP ,@(label-statement external-label)
- "CLOSURE_HEADER (" ,(label->offset external-label) ");\n\t"
+ ,(c:scall "CLOSURE_HEADER" (label->offset external-label))
,@(label-statement internal-label)
- "CLOSURE_INTERRUPT_CHECK ("
- ,(number->string code:compiler-interrupt-closure)
- ");\n\t"))))
+ ,(c:closure-interrupt-check)))))
(define (write-closure-entry internal-label min max offset)
(let ((external-label
(rtl-procedure/external-label (label->object internal-label))))
- (LAP "WRITE_LABEL_DESCRIPTOR (Rhp, 0x"
- ,(number->string (make-procedure-code-word min max) 16) ", "
- ,offset ");\n\t"
- "Rhp[0] = (dispatch_base + "
- ,(label->dispatch-tag external-label)
- ");\n\t"
- "Rhp[1] = ((SCHEME_OBJECT) (¤t_block["
- ,(label->offset external-label) "]));\n\t")))
+ (LAP ,(c:scall "WRITE_LABEL_DESCRIPTOR"
+ (c:free-reg)
+ (c:hex (make-procedure-code-word min max))
+ offset)
+ ,(c:= (c:aref (c:free-reg) 0)
+ (c:+ 'dispatch_base (label->dispatch-tag external-label)))
+ ,(c:= (c:aref (c:free-reg) 1)
+ (c:cast 'sobj (c:cptr (label->offset external-label)))))))
(define (cons-closure target label min max nvars)
(let ((target (standard-target! target 'SCHEME_OBJECT*)))
- (LAP "* Rhp = (MAKE_OBJECT (" ,(ucode-type manifest-closure) ", "
- ,(+ closure-entry-size nvars) "));\n\t"
- "Rhp += 2;\n\t"
- ,target " = Rhp;\n\t"
+ (LAP ,(c:= (c:* (c:free-reg))
+ (c:make-object "TC_MANIFEST_CLOSURE"
+ (+ closure-entry-size nvars)))
+ ,(c:+= (c:free-reg) 2)
+ ,(c:= target (c:free-reg))
,@(write-closure-entry label min max 2)
- "Rhp += " ,(+ nvars 2) ";\n\t")))
+ ,(c:+= (c:free-reg) (+ nvars 2)))))
(define-rule statement
(ASSIGN (REGISTER (? target))
(case nentries
((0)
(let ((dest (standard-target! target 'SCHEME_OBJECT*)))
- (LAP ,dest " = Rhp;\n\t"
- "*Rhp = (MAKE_OBJECT (" ,(ucode-type manifest-vector)
- ", " ,nvars "));\n\t"
- "Rhp += " ,(+ nvars 1) ";\n\t")))
+ (LAP ,(c:= dest (c:free-reg))
+ ,(c:= (c:* (c:free-reg))
+ (c:make-object "TC_MANIFEST_VECTOR"
+ nvars))
+ ,(c:+= (c:free-reg) (+ nvars 1)))))
((1)
(let ((entry (vector-ref entries 0)))
(cons-closure target (car entry) (cadr entry) (caddr entry) nvars)))
(define (cons-multiclosure target nentries nvars entries)
(let ((target (standard-target! target 'SCHEME_OBJECT*)))
- (LAP "* Rhp = (MAKE_OBJECT (" ,(ucode-type manifest-closure) ", "
- ,(1+ (+ (* nentries closure-entry-size) nvars)) "));\n\t"
- "Rhp += 2;\n\t"
- "WRITE_LABEL_DESCRIPTOR (Rhp, " ,nentries ", 0);\n\t"
- "Rhp += 1;\n\t"
- ,target " = Rhp;\n\t"
+ (LAP ,(c:= (c:* (c:free-reg))
+ (c:make-object "TC_MANIFEST_CLOSURE"
+ (+ 1 (* nentries closure-entry-size) nvars)))
+ ,(c:+= (c:free-reg) 2)
+ ,(c:scall "WRITE_LABEL_DESCRIPTOR" (c:free-reg) nentries 0)
+ ,(c:+= (c:free-reg) 1)
+ ,(c:= target (c:free-reg))
,@(reduce-right
(lambda (lap1 lap2)
(LAP ,@lap1 ,@lap2))
(min (cadr entry))
(max (caddr entry)))
(LAP ,@(write-closure-entry label min max offset)
- "Rhp += 3;\n\t")))
+ ,(c:+= (c:free-reg) 3))))
entries (make-multiclosure-offsets nentries)))
- "Rhp += " ,(- nvars 1) ";\n\t")))
+ ,(c:+= (c:free-reg) (- nvars 1)))))
(define (make-multiclosure-offsets nentries)
- (let generate ((x nentries)
- (offset 3))
- (if (= 0 x)
- '()
- (cons offset
- (generate (-1+ x)
- (+ offset closure-entry-size))))))
+ (let generate ((n nentries) (offset 3))
+ (if (> n 0)
+ (cons offset (generate (- n 1) (+ offset closure-entry-size)))
+ '())))
\f
;;;; Entry Header
;;; This is invoked by the top level of the LAP generator.
free-ref-offset n-sections)
(let ((label (generate-label)))
(declare-block-label! (continuation-code-word false) false label)
- (use-invoke-interface! 4)
- (LAP "current_block[" ,environment-label
- "] = Rrb[REGBLOCK_ENV];\n\t"
- "INVOKE_INTERFACE_4 (" ,code:compiler-link
- ", ¤t_block[" ,(label->offset label) "]"
- ",\n\t\t\t\tcurrent_block"
- ",\n\t\t\t\t¤t_block[" ,free-ref-offset "]"
- ",\n\t\t\t\t" ,n-sections ");\n\t"
+ (LAP ,(c:= (c:cref environment-label)
+ (c:env-reg))
+ ,(c:invoke-interface-4 code:compiler-link
+ (c:cptr (label->offset label))
+ 'current_block
+ (c:cptr free-ref-offset)
+ n-sections)
,@(label-statement label))))
(define (generate/remote-link code-block-label
(let ((label (generate-label)))
(add-remote-link! code-block-label)
(declare-block-label! (continuation-code-word false) false label)
- (use-invoke-interface! 4)
- (LAP "{\n\t SCHEME_OBJECT * subblock = (OBJECT_ADDRESS (current_block["
- ,code-block-label "]));\n\t "
- "subblock[" ,environment-offset
- "] = Rrb[REGBLOCK_ENV];\n\t "
- "INVOKE_INTERFACE_4 (" ,code:compiler-link
- ", ¤t_block[" ,(label->offset label) "]"
- ",\n\t\t\t\t subblock"
- ",\n\t\t\t\t &subblock[" ,free-ref-offset "]"
- ",\n\t\t\t\t" ,n-sections ");\n\t}\n\t"
+ (LAP ,(c:brace-group
+ (c:decl 'sobj*
+ 'sub_block
+ (c:object-address (c:cref code-block-label)))
+ (c:= (c:aref 'sub_block environment-offset)
+ (c:env-reg))
+ (c:invoke-interface-4 code:compiler-link
+ (c:cptr (label->offset label))
+ 'sub_block
+ (c:aptr 'sub_block free-ref-offset)
+ n-sections))
,@(label-statement label))))
(define (add-remote-link! label)
(intern "#[PURIFICATION-ROOT]"))
\f
(define (generate/remote-links n-code-blocks code-blocks-label n-sections)
- (define-integrable max-line-width 80)
-
- (define (sections->c-sections mul? posn n-sections)
- (cond ((not (null? n-sections))
- (let* ((val (number->string (car n-sections)))
- (next (+ posn (+ 2 (string-length val)))))
- (if (>= (1+ next) max-line-width)
- (LAP ",\n\t\t" ,val
- ,@(sections->c-sections true
- (+ 16 (string-length val))
- (cdr n-sections)))
- (LAP ", " ,val
- ,@(sections->c-sections mul? next (cdr n-sections))))))
- ((or mul? (>= (+ posn 2) max-line-width))
- (LAP "\n\t "))
- (else
- (LAP))))
-
(let ((label (generate-label))
(done (generate-label)))
(set! *purification-root-object*
(cons *purification-root-marker*
(object-label-value code-blocks-label)))
(declare-block-label! (continuation-code-word false) false label)
- (use-invoke-interface! 4)
- (LAP "*--Rsp = (LONG_TO_UNSIGNED_FIXNUM (1L));\n\t"
+ (LAP ,(c:push (c:ecall "ULONG_TO_FIXNUM" (c:cast 'ulong 1)))
,@(label-statement label)
- "{\n\t "
- "static CONST short sections []\n\t = {\t0"
- ,@(sections->c-sections false 17 (vector->list n-sections))
- "};\n\t "
- "long counter = (OBJECT_DATUM (* Rsp));\n\t "
- "SCHEME_OBJECT blocks, * subblock;\n\t "
- "short section;\n\t\n\t "
- "if (counter > " ,n-code-blocks "L)\n\t goto " ,done ";\n\t "
- "blocks = current_block[" ,code-blocks-label "];\n\t "
- "subblock = (OBJECT_ADDRESS (MEMORY_REF (blocks, counter)));\n\t "
- "subblock[(OBJECT_DATUM (subblock[0]))]\n\t "
- " = Rrb[REGBLOCK_ENV];\n\t "
- "section = sections[counter];\n\t "
- "counter += 1;\n\t "
- "*Rsp = (LONG_TO_UNSIGNED_FIXNUM (counter));\n\t "
- "INVOKE_INTERFACE_4 (" ,code:compiler-link
- ", ¤t_block[" ,(label->offset label) "]"
- ",\n\t\t\t\t subblock"
- ",\n\t\t\t\t (subblock"
- "\n\t\t\t\t + (2 + (OBJECT_DATUM (subblock[1]))))"
- ",\n\t\t\t\t section);\n\t}\n\t"
+ ,(c:brace-group
+ (c:array-decl "static const short"
+ 'sections
+ ""
+ (cons 0 (vector->list n-sections)))
+ (c:decl 'ulong 'counter (c:object-datum (c:tos)))
+ (c:decl 'sobj 'blocks)
+ (c:decl 'sobj* 'sub_block)
+ (c:decl 'short 'section)
+ (c:if-goto (c:> 'counter n-code-blocks) done)
+ (c:= 'blocks (c:cref code-blocks-label))
+ (c:= 'sub_block
+ (c:object-address (c:ecall "MEMORY_REF" 'blocks 'counter)))
+ (c:= (c:aref 'sub_block (c:object-datum (c:aref 'sub_block 0)))
+ (c:env-reg))
+ (c:= 'section (c:aref 'sections 'counter))
+ (c:= (c:tos) (c:ecall "ULONG_TO_FIXNUM" (c:+ 'counter 1)))
+ (c:invoke-interface-4 code:compiler-link
+ (c:cptr (label->offset label))
+ 'sub_block
+ (c:+ 'sub_block
+ (c:+ 2
+ (c:object-datum
+ (c:aref 'sub_block 1))))
+ 'section))
,@(label-statement done)
- "Rsp += 1;\n\t")))
+ ,(c:+= (c:sp-reg) 1))))
\f
#|
(define (generate/constants-block constants references assignments uuo-links
#| -*-Scheme-*-
-$Id: rules4.scm,v 1.4 2003/02/14 18:28:02 cph Exp $
+$Id: rules4.scm,v 1.5 2006/10/01 05:38:26 cph Exp $
-Copyright (c) 1992-1999 Massachusetts Institute of Technology
+Copyright 1993,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(REGISTER (? extension))
(? safe?))
(let ((extension (standard-source! extension 'SCHEME_OBJECT*)))
- (use-invoke-interface! 2)
(LAP ,@(clear-map!)
- "INVOKE_INTERFACE_2 ("
- ,(if safe?
- code:compiler-safe-reference-trap
- code:compiler-reference-trap)
- ", ¤t_block[" ,(label->offset cont) "], "
- ,extension ");\n\t")))
+ ,(c:invoke-interface-2 (if safe?
+ code:compiler-safe-reference-trap
+ code:compiler-reference-trap)
+ (c:cptr (label->offset cont))
+ extension))))
(define-rule statement
(INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont)
(REGISTER (? value)))
(let ((value (standard-source! value 'SCHEME_OBJECT))
(extension (standard-source! extension 'SCHEME_OBJECT*)))
- (use-invoke-interface! 3)
(LAP ,@(clear-map!)
- "INVOKE_INTERFACE_3 ("
- ,code:compiler-assignment-trap
- ", ¤t_block[" ,(label->offset cont) "], "
- ,extension
- ", " ,value ");\n\t")))
+ ,(c:invoke-interface-3 code:compiler-assignment-trap
+ (c:cptr (label->offset cont))
+ extension
+ value))))
(define-rule statement
(INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont)
(REGISTER (? extension)))
(let ((extension (standard-source! extension 'SCHEME_OBJECT*)))
- (use-invoke-interface! 2)
(LAP ,@(clear-map!)
- "INVOKE_INTERFACE_2 (" ,code:compiler-unassigned?-trap
- ", ¤t_block[" ,(label->offset cont) "], "
- ,extension ");\n\t")))
+ ,(c:invoke-interface-2 code:compiler-unassigned?-trap
+ (c:cref (label->offset cont))
+ extension))))
\f
;;;; Interpreter Calls
(define (lookup-call code cont environment name)
(let ((environment (standard-source! environment 'SCHEME_OBJECT)))
- (use-invoke-interface! 3)
(LAP ,@(clear-map!)
- "INVOKE_INTERFACE_3 (" ,code
- ", ¤t_block[" ,(label->offset cont) "], "
- ,environment ", "
- "current_block[" ,(object->offset name) "]);\n\t")))
+ ,(c:invoke-interface-3 code
+ (c:cptr (label->offset cont))
+ environment
+ (c:cref (object->offset name))))))
(define-rule statement
(INTERPRETER-CALL:DEFINE (? cont)
(define (assignment-call code cont environment name value)
(let ((environment (standard-source! environment 'SCHEME_OBJECT))
(value (standard-source! value 'SCHEME_OBJECT)))
- (use-invoke-interface! 4)
(LAP ,@(clear-map!)
- "INVOKE_INTERFACE_4 (" ,code
- ", ¤t_block[" ,(label->offset cont) "], "
- ,environment ", "
- "current_block[" ,(object->offset name) "], " ,value ");\n\t")))
\ No newline at end of file
+ ,(c:invoke-interface-4 code
+ (c:cptr (label->offset cont))
+ environment
+ (c:cref (object->offset name))
+ value))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: rulfix.scm,v 1.8 2006/09/17 12:10:04 gjr Exp $
+$Id: rulfix.scm,v 1.9 2006/10/01 05:38:32 cph Exp $
-Copyright (c) 1992-1999, 2001, 2002, 2006 Massachusetts Institute of Technology
+Copyright 1993,2001,2002,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
;;;; Conversions
(define (object->fixnum source target)
- (LAP ,target " = (FIXNUM_TO_LONG (" ,source "));\n\t"))
+ (LAP ,(c:= target (c:ecall "FIXNUM_TO_LONG" source))))
(define (address->fixnum source target)
- (LAP ,target " = (ADDRESS_TO_LONG (" ,source "));\n\t"))
+ (LAP ,(c:= target (c:ecall "ADDRESS_TO_LONG" source))))
(define (fixnum->object source target)
- (LAP ,target " = (LONG_TO_FIXNUM (" ,source "));\n\t"))
+ (LAP ,(c:= target (c:ecall "LONG_TO_FIXNUM" source))))
(define (fixnum->address source target)
- (LAP ,target " = (LONG_TO_ADDRESS (" ,source "));\n\t"))
+ (LAP ,(c:= target (c:ecall "LONG_TO_ADDRESS" source))))
(define-rule statement
;; convert a fixnum object to a "fixnum integer"
;; load a fixnum constant as a "fixnum integer"
(ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
(let ((target (standard-target! target 'LONG)))
- (LAP ,target " = " ,(longify constant) ";\n\t")))
+ (LAP ,(c:= target (longify constant)))))
(define-rule statement
;; convert a memory address to a "fixnum integer"
;; "Fixnum" in this context means a C long
(define (no-overflow-branches!)
- (set-current-branches!
- (lambda (if-overflow)
- if-overflow
- (LAP))
- (lambda (if-no-overflow)
- (LAP "goto " ,if-no-overflow ";\n\t"))))
+ (set-current-branches! (lambda (label) label (LAP))
+ (lambda (label) (LAP ,(c:goto label)))))
(define (standard-overflow-branches! overflow? result)
(if overflow?
- (set-current-branches!
- (lambda (if-overflow)
- (LAP "if (!( LONG_TO_FIXNUM_P (" ,result ")))\n\t goto "
- ,if-overflow ";\n\t"))
- (lambda (if-not-overflow)
- (LAP "if ( LONG_TO_FIXNUM_P (" ,result "))\n\t goto "
- ,if-not-overflow ";\n\t"))))
- unspecific)
+ (branch-on-expr (c:! (c:ecall "LONG_TO_FIXNUM_P" result)))))
(define (guarantee-signed-fixnum n)
(if (not (signed-fixnum? n)) (error "Not a signed fixnum" n))
(define (fixnum-add-constant tgt src constant overflow?)
(standard-overflow-branches! overflow? tgt)
- (cond ((back-end:= constant 0)
- (LAP ,tgt " = " ,src ";\n\t"))
- ((and (number? constant) (< constant 0))
- (LAP ,tgt " = (" ,src " - " ,(- constant) "L);\n\t"))
- (else
- (LAP ,tgt " = (" ,src " + " ,(longify constant) ");\n\t"))))
+ (LAP ,(c:= tgt
+ (cond ((back-end:= constant 0)
+ src)
+ ((and (number? constant) (< constant 0))
+ (c:- src (longify (- constant))))
+ (else
+ (c:+ src (longify constant)))))))
(define-arithmetic-method 'FIXNUM-NOT fixnum-methods/1-arg
(lambda (tgt src1 overflow?)
(if overflow? (no-overflow-branches!))
- (LAP ,tgt " = ( ~ " ,src1 ");\n\t")))
+ (LAP ,(c:= tgt (c:~ src1)))))
\f
(define-rule statement
;; execute a binary fixnum operation
(define fixnum-methods/2-args
(list 'FIXNUM-METHODS/2-ARGS))
\f
-(let-syntax
- ((binary-fixnum
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (let ((name (cadr form))
- (instr (caddr form)))
- `(DEFINE-ARITHMETIC-METHOD ',name FIXNUM-METHODS/2-ARGS
- (LAMBDA (TGT SRC1 SRC2 OVERFLOW?)
- (IF OVERFLOW? (NO-OVERFLOW-BRANCHES!))
- (LAP ,',tgt " = (" ,',src1 ,instr ,',src2 ");\n\t"))))))))
- (binary-fixnum FIXNUM-AND " & ")
- (binary-fixnum FIXNUM-OR " | ")
- (binary-fixnum FIXNUM-XOR " ^ ")
- (binary-fixnum FIXNUM-ANDC " & ~ "))
-
-(let-syntax
- ((binary-fixnum
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (let ((name (cadr form))
- (instr (caddr form)))
- `(DEFINE-ARITHMETIC-METHOD ',name FIXNUM-METHODS/2-ARGS
- (LAMBDA (TGT SRC1 SRC2 OVERFLOW?)
- (IF OVERFLOW? (NO-OVERFLOW-BRANCHES!))
- (LAP ,',tgt
- " = (" ,instr " (" ,',src1 ", " ,',src2 "));\n\t"))))))))
- (binary-fixnum FIXNUM-REMAINDER "FIXNUM_REMAINDER")
- (binary-fixnum FIXNUM-LSH "FIXNUM_LSH"))
+(define-arithmetic-method 'FIXNUM-AND fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,(c:= tgt (c:& src1 src2)))))
+
+(define-arithmetic-method 'FIXNUM-OR fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,(c:= tgt (c:\| src1 src2)))))
+
+(define-arithmetic-method 'FIXNUM-XOR fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,(c:= tgt (c:^ src1 src2)))))
+
+(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,(c:= tgt (c:&~ src1 src2)))))
+
+(define-arithmetic-method 'FIXNUM-REMAINDER fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,(c:= tgt (c:ecall "FIXNUM_REMAINDER" src1 src2)))))
+
+(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,(c:= tgt (c:ecall "FIXNUM_LSH" src1 src2)))))
(define-arithmetic-method 'FIXNUM-QUOTIENT fixnum-methods/2-args
(lambda (tgt src1 src2 overflow?)
(standard-overflow-branches! overflow? tgt)
- (LAP ,tgt " = (FIXNUM_QUOTIENT (" ,src1 ", " ,src2 "));\n\t")))
+ (LAP ,(c:= tgt (c:ecall "FIXNUM_QUOTIENT" src1 src2)))))
(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args
(lambda (tgt src1 src2 overflow?)
(standard-overflow-branches! overflow? tgt)
- (LAP ,tgt " = (" ,src1 " + " ,src2 ");\n\t")))
+ (LAP ,(c:= tgt (c:+ src1 src2)))))
(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args
(lambda (tgt src1 src2 overflow?)
(begin
(no-overflow-branches!)
; we don't use zero directly because we care about the tag
- (LAP ,tgt " = (" ,src2 " - " ,src2 ");\n\t"))
+ (LAP ,(c:= tgt (c:- src2 src2))))
(do-overflow-subtraction tgt src1 src2))
- (LAP ,tgt " = (" ,src1 " - " ,src2 ");\n\t"))))
+ (LAP ,(c:= tgt (c:- src1 src2))))))
(define (do-overflow-subtraction tgt src1 src2)
(standard-overflow-branches! true tgt)
- (LAP ,tgt " = (" ,src1 " - " ,src2 ");\n\t"))
+ (LAP ,(c:= tgt (c:- src1 src2))))
(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
(lambda (target src1 src2 overflow?)
(if (not overflow?)
- (LAP ,target " = (" ,src1 " * " ,src2 ");\n\t")
+ (LAP ,(c:= target (c:* src1 src2)))
(overflow-product! target src1 src2))))
(define (overflow-product! target src1 src2)
- (set-current-branches!
- (lambda (if-overflow-label)
- (LAP "if (multiply_with_overflow ( " ,src1 ", " ,src2 ", &" ,target
- "))\n\t goto " ,if-overflow-label ";\n\t"))
- (lambda (if-not-overflow-label)
- (LAP "if (!(multiply_with_overflow ( " ,src1 ", " ,src2 ", &" ,target
- ")))\n\t goto " ,if-not-overflow-label ";\n\t")))
- (LAP))
+ (branch-on-expr (c:ecall "multiply_with_overflow" src1 src2 (c:& target))))
\f
(define-rule statement
;; execute binary fixnum operation with constant second arg
(lambda (tgt src constant overflow?)
(cond ((back-end:= constant 0)
(if overflow? (no-overflow-branches!))
- (LAP ,tgt " = 0L;\n\t"))
+ (LAP ,(c:= tgt (c:cast 'long 0))))
((back-end:= constant 1)
(if overflow? (no-overflow-branches!))
- (LAP ,tgt " = " ,src ";\n\t"))
+ (LAP ,(c:= tgt src)))
((and (number? constant)
(power-of-2? (abs constant)))
=>
(lambda (power-of-two)
(if (not overflow?)
- (LAP ,tgt
- ,(if (negative? constant)
- " = (- "
- " = ")
- "(LEFT_SHIFT (" ,src ", " ,power-of-two
- "))"
- ,(if (negative? constant)
- ")"
- "")
- ";\n\t")
+ (LAP ,(c:= tgt
+ (let ((shift
+ (c:ecall "LEFT_SHIFT" src power-of-two)))
+ (if (< constant 0)
+ (c:- shift)
+ shift))))
(overflow-product! tgt src constant))))
((not overflow?)
- (LAP ,tgt " = (" ,src " * " ,(longify constant) ");\n\t"))
+ (LAP ,(c:= tgt (c:* src (longify constant)))))
(else
(overflow-product! tgt src constant)))))
(guarantee-signed-fixnum constant)
(if overflow?
(do-overflow-subtraction tgt constant src)
- (LAP ,tgt " = (" ,constant " - " ,src ");\n\t"))))
+ (LAP ,(c:= tgt (c:- (longify constant) src))))))
(define-arithmetic-method 'FIXNUM-QUOTIENT
fixnum-methods/2-args/register*constant
(error "fixnum-quotient constant division by zero."))
((back-end:= constant 1)
(if overflow? (no-overflow-branches!))
- (LAP ,tgt " = " ,src ";\n\t"))
+ (LAP ,(c:= tgt src)))
((back-end:= constant -1)
(standard-overflow-branches! overflow? tgt)
- (LAP ,tgt " = - " ,src ";\n\t"))
+ (LAP ,(c:= tgt (c:- src))))
((and (number? constant)
(power-of-2? (abs constant)))
=>
(lambda (power-of-two)
(if overflow?
(no-overflow-branches!))
- (LAP ,tgt
- ,(if (negative? constant)
- " = (- "
- " = ")
- "((" ,src " < 0) ? (RIGHT_SHIFT ((" ,src " + "
- ,(-1+ (abs constant)) "), " ,power-of-two "))"
- " : (RIGHT_SHIFT (" ,src " ," ,power-of-two ")))"
- ,(if (negative? constant)
- ")"
- "")
- ";\n\t")))
+ (LAP ,(c:= tgt
+ (let ((shift
+ (c:?: (c:< src 0)
+ (c:ecall "RIGHT_SHIFT"
+ (c:+ src (- (abs constant) 1))
+ power-of-two)
+ (c:ecall "RIGHT_SHIFT"
+ src
+ power-of-two))))
+ (if (< constant 0)
+ (c:- shift)
+ shift))))))
(else
(standard-overflow-branches! overflow? tgt)
- (LAP ,tgt " = (FIXNUM_QUOTIENT (" ,src ", " ,(longify constant)
- "));\n\t")))))
+ (LAP ,(c:= tgt
+ (c:ecall "FIXNUM_QUOTIENT" src (longify constant))))))))
(define-arithmetic-method 'FIXNUM-REMAINDER
fixnum-methods/2-args/register*constant
(if overflow? (no-overflow-branches!))
(cond ((back-end:= constant 0)
(error "fixnum-remainder constant division by zero."))
- ((back-end:= constant 1)
- (LAP ,tgt " = 0;\n\t"))
+ ((back-end:= constant 1)
+ (LAP ,(c:= tgt 0)))
((and (number? constant)
(power-of-2? constant))
=>
(lambda (power-of-two)
- (LAP "{\n\t long temp = (" ,src " & " ,(-1+ constant)
- "L);\n\t "
- ,tgt " = ((" ,src " >= 0) ? temp : ((temp == 0) ? 0"
- " : (temp | (LEFT_SHIFT (-1L, " ,power-of-two
- ")))));\n\t}\n\t")))
+ (LAP ,(c:brace-group
+ (c:decl 'long 'temp
+ (c:& src (c:cast 'long (- constant 1))))
+ (c:= tgt
+ (c:?: (c:>= src 0)
+ 'temp
+ (c:== 'temp 0)
+ 0
+ (c:\| 'temp
+ (c:ecall "LEFT_SHIFT"
+ (c:cast 'long -1)
+ power-of-two))))))))
(else
- (LAP ,tgt " = (FIXNUM_REMAINDER (" ,src ", " ,(longify constant)
- "));\n\t"))))))
+ (LAP ,(c:= tgt
+ (c:ecall "FIXNUM_REMAINDER"
+ src
+ (longify constant)))))))))
(define-arithmetic-method 'FIXNUM-LSH
fixnum-methods/2-args/register*constant
(cond (overflow?
(error "fixnum-lsh overflow what??"))
((back-end:= constant 0)
- (LAP ,tgt " = " ,src ";\n\t"))
+ (LAP ,(c:= tgt src)))
((not (number? constant))
- (LAP ,tgt " = (FIXNUM_LSH (" ,src ", " ,constant "));\n\t"))
+ (LAP ,(c:= tgt (c:ecall "FIXNUM_LSH" src constant))))
((positive? constant)
- (LAP ,tgt " = (LEFT_SHIFT (" ,src ", " ,constant "));\n\t"))
+ (LAP ,(c:= tgt (c:ecall "LEFT_SHIFT" src constant))))
(else
- (LAP "{\n\t unsigned long temp = ((unsigned long) " ,src ");\n\t "
- ,tgt " = ((long) (RIGHT_SHIFT_UNSIGNED (temp, " ,(- constant)
- ")));\n\t}\n\t")))))
-
-(let-syntax
- ((binary-fixnum
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (let ((name (cadr form))
- (instr (caddr form)))
- `(DEFINE-ARITHMETIC-METHOD ',name
- FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT
- (LAMBDA (TGT SRC1 CONSTANT OVERFLOW?)
- (IF OVERFLOW? (NO-OVERFLOW-BRANCHES!))
- (LAP ,',tgt " = (" ,',src1 ,instr ,',(longify constant)
- ");\n\t"))))))))
- (binary-fixnum FIXNUM-AND " & ")
- (binary-fixnum FIXNUM-OR " | ")
- (binary-fixnum FIXNUM-XOR " ^ ")
- (binary-fixnum FIXNUM-ANDC " & ~ "))
+ (LAP ,(c:= tgt
+ (c:cast 'long
+ (c:ecall "RIGHT_SHIFT_UNSIGNED"
+ (c:cast 'ulong src)
+ (- constant)))))))))
+
+(define-arithmetic-method 'FIXNUM-AND fixnum-methods/2-args/register*constant
+ (lambda (tgt src1 constant overflow?)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,(c:= tgt (c:& src1 (longify constant))))))
+
+(define-arithmetic-method 'FIXNUM-OR fixnum-methods/2-args/register*constant
+ (lambda (tgt src1 constant overflow?)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,(c:= tgt (c:\| src1 (longify constant))))))
+
+(define-arithmetic-method 'FIXNUM-XOR fixnum-methods/2-args/register*constant
+ (lambda (tgt src1 constant overflow?)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,(c:= tgt (c:^ src1 (longify constant))))))
+
+(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args/register*constant
+ (lambda (tgt src1 constant overflow?)
+ (if overflow? (no-overflow-branches!))
+ (LAP ,(c:= tgt (c:&~ src1 (longify constant))))))
(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args/constant*register
(lambda (tgt constant src2 overflow?)
(if overflow? (no-overflow-branches!))
- (LAP ,tgt " = (" ,(longify constant) " & ~ " ,src2 ");\n\t")))
+ (LAP ,(c:= tgt (c:&~ (longify constant) src2)))))
\f
;;;; Predicates
(define-rule predicate
(FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
(compare (case predicate
- ((ZERO-FIXNUM?) " == ")
- ((NEGATIVE-FIXNUM?) " < ")
- ((POSITIVE-FIXNUM?) " > ")
+ ((ZERO-FIXNUM?) c:==)
+ ((NEGATIVE-FIXNUM?) c:<)
+ ((POSITIVE-FIXNUM?) c:>)
(else (error "unknown fixnum predicate" predicate)))
(standard-source! source 'LONG)
- "0"))
+ 0))
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
(REGISTER (? source1))
(REGISTER (? source2)))
- ((comparator predicate)
- (fixnum-pred-2->cc predicate)
- (standard-source! source1 'LONG)
- (standard-source! source2 'LONG)))
+ (fix-compare-2 predicate
+ (standard-source! source1 'LONG)
+ (standard-source! source2 'LONG)))
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
(REGISTER (? source))
(OBJECT->FIXNUM (CONSTANT (? constant))))
- ((comparator predicate)
- (fixnum-pred-2->cc predicate)
- (standard-source! source 'LONG)
- (longify constant)))
+ (fix-compare-2 predicate
+ (standard-source! source 'LONG)
+ (longify constant)))
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
(OBJECT->FIXNUM (CONSTANT (? constant)))
(REGISTER (? source)))
- ((comparator predicate)
- (fixnum-pred-2->cc predicate)
- (longify constant)
- (standard-source! source 'LONG)))
+ (fix-compare-2 predicate
+ (longify constant)
+ (standard-source! source 'LONG)))
-(define-integrable (comparator predicate)
- (if (memq predicate '(UNSIGNED-LESS-THAN-FIXNUM?
- UNSIGNED-GREATER-THAN-FIXNUM?))
- compare/unsigned
- compare))
-
-(define (fixnum-pred-2->cc predicate)
+(define (fix-compare-2 predicate src1 src2)
(case predicate
- ((EQUAL-FIXNUM?) " == ")
- ((LESS-THAN-FIXNUM? UNSIGNED-LESS-THAN-FIXNUM?) " < ")
- ((GREATER-THAN-FIXNUM? UNSIGNED-GREATER-THAN-FIXNUM?) " > ")
+ ((EQUAL-FIXNUM?)
+ (compare c:== src1 src2))
+ ((LESS-THAN-FIXNUM?)
+ (compare c:< src1 src2))
+ ((GREATER-THAN-FIXNUM?)
+ (compare c:> src1 src2))
+ ((UNSIGNED-LESS-THAN-FIXNUM?)
+ (compare c:<
+ (c:cast 'ulong src1)
+ (c:cast 'ulong src2)))
+ ((UNSIGNED-GREATER-THAN-FIXNUM?)
+ (compare c:>
+ (c:cast 'ulong src1)
+ (c:cast 'ulong src2)))
(else
(error "unknown fixnum predicate" predicate))))
(define (longify constant)
(if (number? constant)
- (string-append (number->string constant) "L")
+ (c:cast 'long constant)
constant))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: rulflo.scm,v 1.9 2003/02/14 18:28:02 cph Exp $
+$Id: rulflo.scm,v 1.10 2006/10/01 05:38:38 cph Exp $
-Copyright (c) 1992-1999, 2001, 2002 Massachusetts Institute of Technology
+Copyright 1993,2001,2002,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(FLOAT->OBJECT (REGISTER (? source))))
(let ((source (standard-source! source 'DOUBLE)))
(let ((target (standard-target! target 'SCHEME_OBJECT)))
- (LAP "INLINE_DOUBLE_TO_FLONUM (" ,source ", " ,target ");\n\t"))))
+ (LAP ,(c:scall "INLINE_DOUBLE_TO_FLONUM" source target)))))
(define-rule statement
;; convert a flonum object to a floating-point number
(ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
(let ((source (standard-source! source 'SCHEME_OBJECT)))
(let ((target (standard-target! target 'DOUBLE)))
- (LAP ,target " = (FLONUM_TO_DOUBLE (" ,source "));\n\t"))))
+ (LAP ,(c:= target (c:ecall "FLONUM_TO_DOUBLE" source))))))
;;;; Floating-point vector support
base 'DOUBLE*
target 'DOUBLE
(lambda (base target)
- (LAP ,target " = " ,base "[" ,offset "];\n\t"))))
+ (LAP ,(c:= target (c:aref base offset))))))
(define-rule statement
(ASSIGN (FLOAT-OFFSET (REGISTER (? base))
(REGISTER (? source)))
(let ((base (standard-source! base 'DOUBLE*))
(source (standard-source! source 'DOUBLE)))
- (LAP ,base "[" ,offset "] = " ,source ";\n\t")))
+ (LAP ,(c:= (c:aref base offset) source))))
\f
(define-rule statement
(ASSIGN (REGISTER (? target))
index 'LONG
target 'DOUBLE
(lambda (base index target)
- (LAP ,target " = " ,base "[" ,index "];\n\t"))))
+ (LAP ,(c:= target (c:aref base index))))))
(define-rule statement
(ASSIGN (FLOAT-OFFSET (REGISTER (? base)) (REGISTER (? index)))
(let ((base (standard-source! base 'DOUBLE*))
(source (standard-source! source 'DOUBLE))
(index (standard-source! index 'LONG)))
- (LAP ,base "[" ,index "] = " ,source ";\n\t")))
+ (LAP ,(c:= (c:aref base index) source))))
(define-rule statement
(ASSIGN (REGISTER (? target))
base 'SCHEME_OBJECT*
target 'DOUBLE
(lambda (base target)
- (LAP ,target
- " = ((double *) &" ,base "[" ,w-offset "])[" ,f-offset "];\n\t"))))
+ (LAP ,(c:= target
+ (c:aref (c:cast 'double* (c:aptr base w-offset))
+ f-offset))))))
(define-rule statement
(ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
(REGISTER (? source)))
(let ((base (standard-source! base 'SCHEME_OBJECT*))
(source (standard-source! source 'DOUBLE)))
- (LAP "((double *) &" ,base "[" ,w-offset "])[" ,f-offset "] = "
- ,source ";\n\t")))
+ (LAP ,(c:= (c:aref (c:cast 'double* (c:aptr base w-offset))
+ f-offset)
+ source))))
(define-rule statement
(ASSIGN (REGISTER (? target))
index 'LONG
target 'DOUBLE
(lambda (base index target)
- (LAP ,target
- " = ((double *) &" ,base "[" ,w-offset "])[" ,index "];\n\t"))))
+ (LAP ,(c:= target
+ (c:aref (c:cast 'double* (c:aptr base w-offset))
+ index))))))
(define-rule statement
(ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
(let ((base (standard-source! base 'SCHEME_OBJECT*))
(index (standard-source! index 'LONG))
(source (standard-source! source 'DOUBLE)))
- (LAP "((double *) &" ,base "[" ,w-offset "])[" ,index "] = "
- ,source ";\n\t")))
+ (LAP ,(c:= (c:aref (c:cast 'double* (c:aptr base w-offset))
+ index)
+ source))))
\f
;;;; Flonum Arithmetic
(define-arithmetic-method 'FLONUM-ABS flonum-methods/1-arg
(lambda (target source)
- (LAP ,target " = ((" ,source " >= 0.) ? " ,source " : (-" ,source
- "));\n\t")))
+ (LAP ,(c:= target
+ (c:?: (c:< source 0.)
+ (c:- source)
+ source)))))
(define-arithmetic-method 'FLONUM-NEGATE flonum-methods/1-arg
(lambda (target source)
- (LAP ,target " = (- " ,source ");\n\t")))
+ (LAP ,(c:= target (c:- source)))))
(let ((define-use-function
(lambda (name function)
(define-arithmetic-method name flonum-methods/1-arg
(lambda (target source)
- (LAP ,target " = (" ,function " (" ,source "));\n\t"))))))
+ (LAP ,(c:= target (c:ecall function source))))))))
(define-use-function 'FLONUM-ACOS "DOUBLE_ACOS")
(define-use-function 'FLONUM-ASIN "DOUBLE_ASIN")
(define-use-function 'FLONUM-ATAN "DOUBLE_ATAN")
(define flonum-methods/2-args
(list 'FLONUM-METHODS/2-ARGS))
-(let-syntax
- ((define-flonum-operation
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-ARITHMETIC-METHOD ',(cadr form) FLONUM-METHODS/2-ARGS
- (LAMBDA (TARGET SOURCE1 SOURCE2)
- (LAP ,',target " = (" ,',source1 ,(caddr form) ,',source2
- ");\n\t")))))))
- (define-flonum-operation flonum-add " + ")
- (define-flonum-operation flonum-subtract " - ")
- (define-flonum-operation flonum-multiply " * ")
- (define-flonum-operation flonum-divide " / "))
+(define-arithmetic-method 'FLONUM-ADD flonum-methods/2-args
+ (lambda (target source1 source2)
+ (LAP ,(c:= target (c:+ source1 source2)))))
+
+(define-arithmetic-method 'FLONUM-SUBTRACT flonum-methods/2-args
+ (lambda (target source1 source2)
+ (LAP ,(c:= target (c:- source1 source2)))))
+
+(define-arithmetic-method 'FLONUM-MULTIPLY flonum-methods/2-args
+ (lambda (target source1 source2)
+ (LAP ,(c:= target (c:* source1 source2)))))
+
+(define-arithmetic-method 'FLONUM-DIVIDE flonum-methods/2-args
+ (lambda (target source1 source2)
+ (LAP ,(c:= target (c:/ source1 source2)))))
(define-arithmetic-method 'FLONUM-ATAN2 flonum-methods/2-args
(lambda (target source1 source2)
- (LAP ,target " = (DOUBLE_ATAN2 (" ,source1 ", " ,source2
- "));\n\t")))
+ (LAP ,(c:= target (c:ecall "DOUBLE_ATAN2" source1 source2)))))
;;;; Flonum Predicates
(define-rule predicate
(FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
(compare (case predicate
- ((FLONUM-ZERO?) " == ")
- ((FLONUM-NEGATIVE?) " < ")
- ((FLONUM-POSITIVE?) " > ")
+ ((FLONUM-ZERO?) c:==)
+ ((FLONUM-NEGATIVE?) c:<)
+ ((FLONUM-POSITIVE?) c:>)
(else (error "unknown flonum predicate" predicate)))
(standard-source! source 'DOUBLE)
"0.0"))
(REGISTER (? source1))
(REGISTER (? source2)))
(compare (case predicate
- ((FLONUM-EQUAL?) " == ")
- ((FLONUM-LESS?) " < ")
- ((FLONUM-GREATER?) " > ")
+ ((FLONUM-EQUAL?) c:==)
+ ((FLONUM-LESS?) c:<)
+ ((FLONUM-GREATER?) c:>)
(else (error "unknown flonum predicate" predicate)))
(standard-source! source1 'DOUBLE)
(standard-source! source2 'DOUBLE)))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: traditional.scm,v 1.1 2006/09/16 11:19:09 gjr Exp $
+$Id: traditional.scm,v 1.2 2006/10/01 05:38:44 cph Exp $
-Copyright (c) 1992-1999, 2006 Massachusetts Institute of Technology
+Copyright 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(define char-set:C-char-quoted
(char-set-union
;; Not char-set:not-graphic
- (char-set-difference char-set:all
- (char-set-intersection char-set:graphic
- (ascii-range->char-set 0 #x7f)))
+ (char-set-invert
+ (char-set-intersection char-set:graphic
+ (ascii-range->char-set 0 #x7f)))
(char-set #\\ #\' (integer->char #xA0))))
;; The following routine relies on the fact that Scheme and C use the
projects / mit-scheme.git / commitdiff