From f803ed06bf13ff442da0a1b9ba3ab06275862eff Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 1 Oct 2006 05:38:44 +0000 Subject: [PATCH] Reimplement C output generation. There's now a procedural layer for generating C code, which gives significantly greater control over the output formatting. Code using the layer is simpler and clearer than what it replaces. Additionally, the output no longer uses DEFUN, EXFUN, etc., instead generating ANSI C. This allows the generated code to be used with the (unreleased) v15 microcode. --- v7/src/compiler/machines/C/compiler.pkg | 5 +- v7/src/compiler/machines/C/cout.scm | 1911 +++++++++++--------- v7/src/compiler/machines/C/ctop.scm | 6 +- v7/src/compiler/machines/C/lapgen.scm | 225 ++- v7/src/compiler/machines/C/rules1.scm | 96 +- v7/src/compiler/machines/C/rules2.scm | 71 +- v7/src/compiler/machines/C/rules3.scm | 365 ++-- v7/src/compiler/machines/C/rules4.scm | 52 +- v7/src/compiler/machines/C/rulfix.scm | 318 ++-- v7/src/compiler/machines/C/rulflo.scm | 89 +- v7/src/compiler/machines/C/traditional.scm | 10 +- 11 files changed, 1709 insertions(+), 1439 deletions(-) diff --git a/v7/src/compiler/machines/C/compiler.pkg b/v7/src/compiler/machines/C/compiler.pkg index 9ca2ea416..6afb5f04d 100644 --- a/v7/src/compiler/machines/C/compiler.pkg +++ b/v7/src/compiler/machines/C/compiler.pkg @@ -1,8 +1,8 @@ #| -*-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. @@ -706,6 +706,7 @@ USA. lap:make-unconditional-branch) (export (compiler top-level) *block-associations* + c:write-group current-register-list fake-compiled-block-name free-assignments diff --git a/v7/src/compiler/machines/C/cout.scm b/v7/src/compiler/machines/C/cout.scm index b2b742d7a..cb831ea31 100644 --- a/v7/src/compiler/machines/C/cout.scm +++ b/v7/src/compiler/machines/C/cout.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -27,7 +27,7 @@ USA. ;; package: (compiler lap-syntaxer) (declare (usual-integrations)) - + (define-syntax let*/mv (rsc-macro-transformer (lambda (form environment) @@ -47,8 +47,8 @@ USA. (LAMBDA ,values-names ,(recur (cdr bindings)))))))))))) -(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 @@ -57,7 +57,7 @@ USA. (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 @@ -71,20 +71,19 @@ USA. "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)) @@ -99,270 +98,255 @@ USA. "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)))))) (define (stringify suffix initial-label lap-code info-output-pathname) ;; returns - (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))))) - - (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) - - (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)))) (define (data-function-body top-level? ntags @@ -378,27 +362,24 @@ USA. (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")) @@ -407,11 +388,11 @@ USA. (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* '())) @@ -422,255 +403,143 @@ USA. (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))))))))) (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"))) - + (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))))) (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)))) -(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)) @@ -700,9 +569,8 @@ USA. (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) @@ -725,87 +593,50 @@ USA. (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)) -;; 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)) + '()))))) -(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) @@ -814,30 +645,27 @@ USA. (define (handle-objects/stackify start-offset) ;; returns - (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 - )) - + (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 @@ -848,47 +676,38 @@ USA. (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)))) (define-integrable *execute-cache-size-in-words* 2) (define-integrable *variable-cache-size-in-words* 1) @@ -897,31 +716,8 @@ USA. ;; process free-uuo-links free-references free-assignments global-uuo-links ;; returns - (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 @@ -935,9 +731,9 @@ USA. (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 @@ -949,51 +745,75 @@ USA. (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))))))))))) - + (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 @@ -1010,14 +830,14 @@ USA. (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) @@ -1030,84 +850,69 @@ USA. ;; returns (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))))) -(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 @@ -1117,35 +922,32 @@ USA. (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") @@ -1154,21 +956,21 @@ USA. "_" (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))) ;; Miscellaneous utilities @@ -1198,3 +1000,482 @@ USA. (and (exact-integer? value) (<= guaranteed-long/lower-limit value) (< value guaranteed-long/upper-limit))) + +;;;; Output abstraction + +(define-record-type + (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))) + +(define-record-type + (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)))) + +(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))) + +(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)))) + +(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 "};")))))) + +(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 ")"))))) + +(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: diff --git a/v7/src/compiler/machines/C/ctop.scm b/v7/src/compiler/machines/C/ctop.scm index 509b7314d..cde6b1042 100644 --- a/v7/src/compiler/machines/C/ctop.scm +++ b/v7/src/compiler/machines/C/ctop.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -43,7 +43,7 @@ USA. (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) diff --git a/v7/src/compiler/machines/C/lapgen.scm b/v7/src/compiler/machines/C/lapgen.scm index 6c3ce422f..910034335 100644 --- a/v7/src/compiler/machines/C/lapgen.scm +++ b/v7/src/compiler/machines/C/lapgen.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -85,7 +85,7 @@ USA. (else (comp-internal-error "Unknown machine register" 'MACHINE-REGISTER-NAME reg)))) - + (define (machine-register-type reg) (cond ((eq? reg regnum:value) "SCHEME_OBJECT") @@ -102,10 +102,10 @@ USA. (< 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) @@ -210,12 +210,13 @@ USA. 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))) @@ -226,11 +227,11 @@ USA. ((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 @@ -240,35 +241,124 @@ USA. (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)))))))) -;;;; 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)) + +(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)) ;;;; Constants, Labels, and Various Caches @@ -548,33 +638,23 @@ USA. '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))) (define (define-arithmetic-method operator methods method) (let ((entry (assq operator (cdr methods)))) @@ -588,32 +668,33 @@ USA. (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) diff --git a/v7/src/compiler/machines/C/rules1.scm b/v7/src/compiler/machines/C/rules1.scm index fd03a0615..2d84bfd37 100644 --- a/v7/src/compiler/machines/C/rules1.scm +++ b/v7/src/compiler/machines/C/rules1.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -47,7 +47,7 @@ USA. (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)) @@ -55,21 +55,21 @@ USA. (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) @@ -85,13 +85,13 @@ USA. (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)))) @@ -119,7 +119,7 @@ USA. 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)) @@ -128,7 +128,7 @@ USA. (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)) @@ -139,7 +139,7 @@ USA. 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 @@ -155,12 +155,12 @@ USA. (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)) @@ -171,7 +171,7 @@ USA. 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)) @@ -180,7 +180,7 @@ USA. (standard-unary-conversion source 'DOUBLE* target 'DOUBLE* (lambda (source target) - (LAP ,target " = &" ,source "[" ,offset "];\n\t")))) + (LAP ,(c:= target (c:aptr source offset)))))) ;;;; Loading of Constants @@ -188,28 +188,26 @@ USA. ;; 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 @@ -217,33 +215,33 @@ USA. (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))))) (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 @@ -251,8 +249,8 @@ USA. (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 @@ -260,8 +258,8 @@ USA. (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))))))) ;;;; Transfers from memory @@ -271,13 +269,13 @@ USA. (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 @@ -288,7 +286,7 @@ USA. (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 @@ -297,7 +295,7 @@ USA. (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 @@ -306,7 +304,7 @@ USA. (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. @@ -314,20 +312,20 @@ USA. (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)))) ;;;; CHAR->ASCII/BYTE-OFFSET @@ -339,7 +337,7 @@ USA. (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 @@ -348,8 +346,8 @@ USA. (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 @@ -357,7 +355,7 @@ USA. (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 @@ -365,7 +363,7 @@ USA. (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 @@ -374,7 +372,7 @@ USA. (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 @@ -384,5 +382,5 @@ USA. (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)))))) diff --git a/v7/src/compiler/machines/C/rules2.scm b/v7/src/compiler/machines/C/rules2.scm index dc65bb3f9..b8dbd5994 100644 --- a/v7/src/compiler/machines/C/rules2.scm +++ b/v7/src/compiler/machines/C/rules2.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -31,16 +31,8 @@ USA. (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 @@ -79,59 +71,26 @@ USA. (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 diff --git a/v7/src/compiler/machines/C/rules3.scm b/v7/src/compiler/machines/C/rules3.scm index 3707ddd12..6b530a7e1 100644 --- a/v7/src/compiler/machines/C/rules3.scm +++ b/v7/src/compiler/machines/C/rules3.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -31,9 +31,8 @@ USA. ;;;; Invocations (define (pop-return) - (use-pop-return!) (LAP ,@(clear-map!) - "goto pop_return;\n\t")) + ,(c:pop-return))) (define-rule statement (POP-RETURN) @@ -42,18 +41,17 @@ USA. (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)) @@ -63,46 +61,40 @@ USA. (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)))) (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) @@ -110,10 +102,11 @@ USA. (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) @@ -122,50 +115,34 @@ USA. (? 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)))) (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 @@ -216,33 +193,32 @@ USA. ;; Move 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"))))) ;;; DYNAMIC-LINK instructions have a , , ;;; and as arguments. They pop the stack by @@ -258,11 +234,12 @@ USA. (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"))))) ;;; Entry point types @@ -331,24 +308,20 @@ USA. (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)) @@ -408,34 +381,32 @@ USA. (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)) @@ -450,10 +421,11 @@ USA. (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))) @@ -462,12 +434,13 @@ USA. (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)) @@ -477,18 +450,15 @@ USA. (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))) + '()))) ;;;; Entry Header ;;; This is invoked by the top level of the LAP generator. @@ -497,14 +467,13 @@ USA. 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 @@ -514,16 +483,17 @@ USA. (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) @@ -539,56 +509,41 @@ USA. (intern "#[PURIFICATION-ROOT]")) (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)))) #| (define (generate/constants-block constants references assignments uuo-links diff --git a/v7/src/compiler/machines/C/rules4.scm b/v7/src/compiler/machines/C/rules4.scm index d33610719..e90994b11 100644 --- a/v7/src/compiler/machines/C/rules4.scm +++ b/v7/src/compiler/machines/C/rules4.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -35,14 +35,12 @@ USA. (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) @@ -50,23 +48,20 @@ USA. (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)))) ;;;; Interpreter Calls @@ -102,12 +97,11 @@ USA. (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) @@ -126,9 +120,9 @@ USA. (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 diff --git a/v7/src/compiler/machines/C/rulfix.scm b/v7/src/compiler/machines/C/rulfix.scm index c9d0c813d..ac4b2b511 100644 --- a/v7/src/compiler/machines/C/rulfix.scm +++ b/v7/src/compiler/machines/C/rulfix.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -31,16 +31,16 @@ USA. ;;;; 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" @@ -52,7 +52,7 @@ USA. ;; 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" @@ -82,23 +82,12 @@ USA. ;; "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)) @@ -137,17 +126,18 @@ USA. (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))))) (define-rule statement ;; execute a binary fixnum operation @@ -166,46 +156,45 @@ USA. (define fixnum-methods/2-args (list 'FIXNUM-METHODS/2-ARGS)) -(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?) @@ -214,29 +203,22 @@ USA. (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)))) (define-rule statement ;; execute binary fixnum operation with constant second arg @@ -313,28 +295,24 @@ USA. (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))))) @@ -344,7 +322,7 @@ USA. (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 @@ -353,31 +331,32 @@ USA. (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 @@ -386,20 +365,29 @@ USA. (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 @@ -407,38 +395,42 @@ USA. (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))))) ;;;; Predicates @@ -455,55 +447,57 @@ USA. (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 diff --git a/v7/src/compiler/machines/C/rulflo.scm b/v7/src/compiler/machines/C/rulflo.scm index cac44e732..be2708ade 100644 --- a/v7/src/compiler/machines/C/rulflo.scm +++ b/v7/src/compiler/machines/C/rulflo.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -34,14 +34,14 @@ USA. (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 @@ -53,7 +53,7 @@ USA. 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)) @@ -61,7 +61,7 @@ USA. (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)))) (define-rule statement (ASSIGN (REGISTER (? target)) @@ -71,7 +71,7 @@ USA. 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))) @@ -79,7 +79,7 @@ USA. (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)) @@ -90,8 +90,9 @@ USA. 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)) @@ -100,8 +101,9 @@ USA. (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)) @@ -113,8 +115,9 @@ USA. 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)) @@ -124,8 +127,9 @@ USA. (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)))) ;;;; Flonum Arithmetic @@ -146,18 +150,20 @@ USA. (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") @@ -192,33 +198,34 @@ USA. (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")) @@ -228,9 +235,9 @@ USA. (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 diff --git a/v7/src/compiler/machines/C/traditional.scm b/v7/src/compiler/machines/C/traditional.scm index 08e93db9a..9affaa923 100644 --- a/v7/src/compiler/machines/C/traditional.scm +++ b/v7/src/compiler/machines/C/traditional.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -404,9 +404,9 @@ USA. (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 -- 2.25.1