From 4ac0f55c3125425cb1eb59a0e6d05ed05c9597e0 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Sat, 30 Oct 1993 12:58:12 +0000 Subject: [PATCH] Redo some things: - User Marc Feeley's hack for making the default case in the switch statements handle all cross-block jumps. - Divide the data and code sections so the data sections can be eliminated from the link avoiding the need to recompile the code sections. --- v7/src/compiler/machines/C/TODO | 4 - v7/src/compiler/machines/C/cout.scm | 236 +++++++++++++++----------- v7/src/compiler/machines/C/ctop.scm | 28 ++- v7/src/compiler/machines/C/lapgen.scm | 14 +- v7/src/compiler/machines/C/rules1.scm | 12 +- v7/src/compiler/machines/C/rules3.scm | 80 ++++----- 6 files changed, 207 insertions(+), 167 deletions(-) diff --git a/v7/src/compiler/machines/C/TODO b/v7/src/compiler/machines/C/TODO index 6fbb92486..873cdb568 100644 --- a/v7/src/compiler/machines/C/TODO +++ b/v7/src/compiler/machines/C/TODO @@ -10,10 +10,6 @@ * Edwin autoloads and load options. -* Dynamic C loader! - -* Dynamic generation of ymake.cclist file. - * Short documentation (how to compile files and add them to the microcode). RANDOM INFO: diff --git a/v7/src/compiler/machines/C/cout.scm b/v7/src/compiler/machines/C/cout.scm index 6047d67f2..be10cb387 100644 --- a/v7/src/compiler/machines/C/cout.scm +++ b/v7/src/compiler/machines/C/cout.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: cout.scm,v 1.5 1993/10/26 03:02:37 jawilson Exp $ +$Id: cout.scm,v 1.6 1993/10/30 12:58:08 gjr Exp $ Copyright (c) 1992-1993 Massachusetts Institute of Technology @@ -64,12 +64,12 @@ MIT in each case. |# (define (->variable-declarations vars) (if (null? vars) (list "") - `("SCHEME_OBJECT\n\t " + `("\tSCHEME_OBJECT\n\t " ,(car vars) ,@(append-map (lambda (var) (list ",\n\t " var)) (cdr vars)) - ";\n\t"))) + ";\n"))) (if *purification-root-object* (define-object "PURIFICATION_ROOT" @@ -123,25 +123,25 @@ MIT in each case. |# (values (list "") (list ""))) ((< *invoke-interface* 5) (values (list-tail (list - "\ninvoke_interface_0:\n\tsubtmp_1 = 0;\n" - "\ninvoke_interface_1:\n\tsubtmp_2 = 0;\n" - "\ninvoke_interface_2:\n\tsubtmp_3 = 0;\n" - "\ninvoke_interface_3:\n\tsubtmp_4 = 0;\n" + "\ninvoke_interface_0:\n\tutlarg_1 = 0;\n" + "\ninvoke_interface_1:\n\tutlarg_2 = 0;\n" + "\ninvoke_interface_2:\n\tutlarg_3 = 0;\n" + "\ninvoke_interface_3:\n\tutlarg_4 = 0;\n" "\ninvoke_interface_4:\n\t" "INVOKE_INTERFACE_CODE ();\n") *invoke-interface*) - (list "int subtmp_code;\n\t" - "long subtmp_1,subtmp_2,subtmp_3,subtmp_4;\n\t"))) + (list "\tint utlarg_code;\n" + "\tlong utlarg_1, utlarg_2, utlarg_3, utlarg_4;\n"))) (else - (error "subroutine-information-1: Interface utilities take at most 4 arguments" + (error "subroutine-information-1: Utilities take at most 4 args" *invoke-interface*)))) (define (subroutine-information-2) (if *used-invoke-primitive* (values (list "\ninvoke_primitive:\n\t" "INVOKE_PRIMITIVE_CODE ();") - (list "SCHEME_OBJECT primitive;\n\t" - "long primitive_nargs;\n\t")) + (list "\tSCHEME_OBJECT primitive;\n" + "\tlong primitive_nargs;\n")) (values (list "") (list "")))) (define (subroutine-information) @@ -155,23 +155,29 @@ MIT in each case. |# (let ((n 1) ; First word is vector header (initial-offset (label->offset initial-label))) (with-values (lambda () (handle-labels n)) - (lambda (n label-defines label-dispatch label-block-initialization - symbol-table) + (lambda (n ntags + label-defines label-dispatch + label-block-initialization symbol-table) (with-values (lambda () (handle-free-refs-and-sets n)) (lambda (n free-defines free-block-initialization free-symbols) (with-values (lambda () (handle-objects n)) - (lambda (n decl-code xtra-procs object-prefix object-defines temp-vars + (lambda (n decl-code decl-data + xtra-procs object-prefix + object-defines temp-vars object-block-initialization) (let* ((time-stamp (make-time-stamp)) (code-name (choose-proc-name "code" "" time-stamp)) - (block-name + (data-name (choose-proc-name "data" "_data" time-stamp)) - (decl-name (string-append "decl_" code-name))) + (decl-code-name (string-append "decl_" code-name)) + (decl-data-name (string-append "decl_" data-name))) (with-values subroutine-information (lambda (extra-code extra-variables) (values code-name + data-name + ntags (cons* (cons (special-label/environment) (-1+ n)) (cons (special-label/debugging) @@ -184,18 +190,40 @@ MIT in each case. |# (if (string-null? suffix) (append (file-prefix) - (list "DECLARE_COMPILED_CODE (\"" code-name - "\", " decl-name - ", " code-name ")\n\n")) + (list + "#ifndef WANT_ONLY_DATA\n" + ;; This must be a single line! + "DECLARE_COMPILED_CODE (\"" code-name + "\", " (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 (\"" code-name + "\", " decl-data-name + ", " data-name ")\n" + "#endif /* WANT_ONLY_CODE */\n\n" + "DECLARE_DYNAMIC_INITIALIZATION ()\n\n")) '()) xtra-procs (if (string-null? suffix) (append - (list "void\n" - "DEFUN_VOID (" decl-name ")\n{\n\t") + (list "#ifndef WANT_ONLY_DATA\n") + (list + "int\n" + "DEFUN_VOID (" decl-code-name ")\n{\n\t") decl-code - (list "return;\n}\n\n")) + (list "return (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\t") + decl-data + (list "return (0);\n}\n" + "#endif /* WANT_ONLY_CODE */\n\n")) '()) label-defines @@ -203,25 +231,32 @@ MIT in each case. |# free-defines (list "\n") - (list "#ifndef BAND_ALREADY_BUILT\n") - (cons "static " (function-header block-name)) - (list "SCHEME_OBJECT object = (ALLOCATE_VECTOR (" + (list "#ifndef WANT_ONLY_CODE\n") + (let ((header (data-function-header data-name))) + (if (string-null? suffix) + header + (cons "static " header))) + (list "\tSCHEME_OBJECT object" + " = (ALLOCATE_VECTOR (" (number->string (- n 1)) - "L));\n\t" - "SCHEME_OBJECT * current_block = " - "(OBJECT_ADDRESS (object));\n\t") + "L));\n" + "\tSCHEME_OBJECT * current_block" + " = (OBJECT_ADDRESS (object));\n") (->variable-declarations temp-vars) (list "\n\t") object-prefix label-block-initialization free-block-initialization object-block-initialization - (list "return (current_block);") - (function-trailer block-name) - (list "#endif /* BAND_ALREADY_BUILT */\n") + (list "\n\treturn (¤t_block[" + (stringify-object initial-offset) + "]);\n") + (function-trailer data-name) + (list "#endif /* WANT_ONLY_CODE */\n") (list "\n") - (let ((header (function-header code-name))) + (list "#ifndef WANT_ONLY_DATA\n") + (let ((header (code-function-header code-name))) (if (string-null? suffix) header (cons "static " header))) @@ -229,34 +264,22 @@ MIT in each case. |# (register-declarations) extra-variables (list - "goto perform_dispatch;\n\n" - (if *use-pop-return* - (string-append - "pop_return_repeat_dispatch:\n\n\t" - "POP_RETURN_REPEAT_DISPATCH();\n\n") - "") - "repeat_dispatch:\n\n\t" - "REPEAT_DISPATCH ();\n\n" + "\n\tgoto perform_dispatch;\n\n" + "pop_return:\n\t" + "Rpc = (OBJECT_ADDRESS (*Rsp++));\n\n" "perform_dispatch:\n\n\t" - "switch (LABEL_TAG (my_pc))\n\t" - "{\n\t case 0:\n" - "#ifndef BAND_ALREADY_BUILT\n\t\t" - "current_block = (" - block-name - " (my_pc));\n\t\t" - "return (¤t_block[" - (stringify-object initial-offset) - "]);\n" - "#else /* BAND_ALREADY_BUILT */\n\t\t" - "error_band_already_built ();\n" - "#endif /* BAND_ALREADY_BUILT */\n") + "switch ((* ((unsigned long *) Rpc))" + " - dispatch_base)\n\t{") label-dispatch (list "\n\t default:\n\t\t" - "ERROR_UNKNOWN_DISPATCH (my_pc);\n\t}\n\t") + "UNCACHE_VARIABLES ();\n\t\t" + "return (Rpc);\n\t}\n\t") (map stringify-object lap-code) extra-code - (function-trailer code-name)))))))))))))))) + (function-trailer code-name) + (list + "#endif /* WANT_ONLY_DATA */\n")))))))))))))))) (define-integrable (list-of-strings->string strings) (apply string-append strings)) @@ -266,45 +289,46 @@ MIT in each case. |# (define (file-prefix) (let ((time (get-decoded-time))) - (cons* "/* Emacs: this is properly parenthesized -*- C -*- code.\n" - " Thank God it was generated by a machine.\n" - " */\n\n" - "/* C code produced\n " - (decoded-time/date-string time) - " at " - (decoded-time/time-string time) - "\n by Liar version " - (let ((version false)) - (for-each-system! - (lambda (system) - (if (substring? "Liar" (system/name system)) - (set! version - (cons (system/version system) - (system/modification system)))) - unspecific)) - (if (not version) - "?.?" - (string-append (number->string (car version)) - "." - (number->string (cdr version))))) - ".\n */\n\n" - includes))) - -(define includes - (list "#include \"liarc.h\"\n\n")) - -(define (function-header name) + (list "/* Emacs: this is properly parenthesized -*- C -*- code.\n" + " Thank God it was generated by a machine.\n" + " */\n\n" + "/* C code produced\n " + (decoded-time/date-string time) + " at " + (decoded-time/time-string time) + "\n by Liar version " + (let ((version false)) + (for-each-system! + (lambda (system) + (if (substring? "Liar" (system/name system)) + (set! version + (cons (system/version system) + (system/modification system)))) + unspecific)) + (if (not version) + "?.?" + (string-append (number->string (car version)) + "." + (number->string (cdr version))))) + ".\n */\n\n" + "#include \"liarc.h\"\n\n"))) + +(define (code-function-header name) + (list "SCHEME_OBJECT *\n" + "DEFUN (" name ", (Rpc, dispatch_base),\n\t" + "SCHEME_OBJECT * Rpc AND unsigned long dispatch_base)\n" + "{\n")) + +(define (data-function-header name) (list "SCHEME_OBJECT *\n" - "DEFUN (" - name - ", (my_pc), SCHEME_OBJECT * my_pc)\n" - "{\n\tREGISTER int current_C_proc = (LABEL_PROCEDURE (my_pc));\n\t")) + "DEFUN (" name ", (dispatch_base), unsigned long dispatch_base)\n" + "{\n")) (define (function-decls) (list - "REGISTER SCHEME_OBJECT * current_block;\n\t" - "SCHEME_OBJECT * dynamic_link;\n\t" - "DECLARE_VARIABLES ();\n\n\t")) + "\tREGISTER SCHEME_OBJECT * current_block;\n" + "\tSCHEME_OBJECT * Rdl;\n" + "\tDECLARE_VARIABLES ();\n")) (define (function-trailer name) (list "\n} /* End of " name ". */\n")) @@ -725,6 +749,8 @@ MIT in each case. |# ;; All the reverses produce the correct order in the output block. ;; The incoming objects are reversed ;; (environment, debugging label, purification root, etc.) + ;; (values new-n decl-code decl-data xtra-procs object-prefix + ;; object-defines temp-vars object-block-initialization) (fluid-let ((new-variables '()) (*subblocks* '()) @@ -737,7 +763,8 @@ MIT in each case. |# (reverse objects))) (lambda (prefix suffix) (values n - (map fake-block->decl *subblocks*) + (map fake-block->code-decl *subblocks*) + (map fake-block->data-decl *subblocks*) (append-map fake-block->c-code *subblocks*) prefix defines @@ -872,6 +899,7 @@ MIT in each case. |# label-bindings) (if (null? labels) (values (- offset 1) + tagno (reverse label-defines) (reverse label-dispatch) (cons (string-append @@ -907,7 +935,7 @@ MIT in each case. |# (cons (string-append "\n\t case " (number->string tagno) ":\n\t\t" - "current_block = (my_pc - " a-symbol ");\n\t\t" + "current_block = (Rpc - " a-symbol ");\n\t\t" "goto " (symbol->string (or (label-1 label-data) (label-2 label-data))) @@ -919,9 +947,7 @@ MIT in each case. |# (number->string (code-word-sel label-data) 16) ", " a-symbol ");\n\t" "current_block [" a-symbol - "] = (MAKE_LABEL_WORD (current_C_proc, " - (number->string tagno) - "));\n\t") + "] = (dispatch_base + " (number->string tagno) ");\n\t") label-block-initialization) (append (if (label-1 label-data) @@ -932,7 +958,7 @@ MIT in each case. |# '()) label-bindings))))) - (iter (+ 2 n) 1 (reverse! labels) '() '() '() '())) + (iter (+ 2 n) 0 (reverse! labels) '() '() '() '())) (define-structure (fake-compiled-procedure (constructor make-fake-compiled-procedure) @@ -945,8 +971,10 @@ MIT in each case. |# (conc-name fake-block/)) (name 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)) + (index false read-only true) + (ntags false read-only true)) (define fake-compiled-block-name-prefix "ccBlock") @@ -954,12 +982,18 @@ MIT in each case. |# (string-append fake-compiled-block-name-prefix "_" (number->string (-1+ number)))) -(define (fake-block->decl block) - (string-append "declare_compiled_code (\"" +(define (fake-block->code-decl block) + (string-append "DECLARE_SUBCODE (\"" (fake-block/c-proc block) - "\", NO_SUBBLOCKS, " + "\", " (number->string (fake-block/ntags block)) + ", NO_SUBBLOCKS, " + (fake-block/c-proc block) ");\n\t")) + +(define (fake-block->data-decl block) + (string-append "DECLARE_SUBDATA (\"" (fake-block/c-proc block) - ");\n\t")) + "\", NO_SUBBLOCKS, " + (fake-block/d-proc block) ");\n\t")) (define (fake-block->c-code block) (list (fake-block/c-code block) diff --git a/v7/src/compiler/machines/C/ctop.scm b/v7/src/compiler/machines/C/ctop.scm index d4cf5d4ae..cb474a96b 100644 --- a/v7/src/compiler/machines/C/ctop.scm +++ b/v7/src/compiler/machines/C/ctop.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: ctop.scm,v 1.1 1993/06/08 06:13:32 gjr Exp $ +$Id: ctop.scm,v 1.2 1993/10/30 12:58:09 gjr Exp $ Copyright (c) 1992 Massachusetts Institute of Technology @@ -93,7 +93,9 @@ MIT in each case. |# ;; First set: phase/assemble ;; Last used: phase/output-generation -(define *C-proc-name*) +(define *C-code-name*) +(define *C-data-name*) +(define *ntags*) (define *labels*) (define *code*) @@ -139,7 +141,9 @@ MIT in each case. |# (*use-pop-return*) (*purification-root-object*) (*end-of-block-code*) - (*C-proc-name*) + (*C-code-name*) + (*C-data-name*) + (*ntags*) (*labels*) (*code*)) (thunk))) @@ -166,7 +170,9 @@ MIT in each case. |# (set! *use-pop-return*) (set! *purification-root-object*) (set! *end-of-block-code*) - (set! *C-proc-name*) + (set! *C-code-name*) + (set! *C-data-name*) + (set! *ntags*) (set! *labels*) (set! *code*) unspecific) @@ -214,8 +220,10 @@ MIT in each case. |# (cons *info-output-filename* *recursive-compilation-number*) pathname))) - (lambda (proc-name labels code) - (set! *C-proc-name* proc-name) + (lambda (code-name data-name ntags labels code) + (set! *C-code-name* code-name) + (set! *C-data-name* data-name) + (set! *ntags* ntags) (set! *labels* labels) (set! *code* code) unspecific))))) @@ -243,13 +251,15 @@ MIT in each case. |# (translate-label *entry-label*)) (vector (make-fake-compiled-block name - *C-proc-name* + *C-code-name* + *C-data-name* *code* - index) + index + *ntags*) (translate-symbol 0) (translate-symbol 1) (translate-symbol 2)))) - (cons *C-proc-name* + (cons *C-code-name* *code*))) (if (not compiler:preserve-data-structures?) diff --git a/v7/src/compiler/machines/C/lapgen.scm b/v7/src/compiler/machines/C/lapgen.scm index 4ccac682b..72a4b2fe1 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.7 1993/10/28 04:58:37 gjr Exp $ +$Id: lapgen.scm,v 1.8 1993/10/30 12:58:10 gjr Exp $ Copyright (c) 1992-1993 Massachusetts Institute of Technology @@ -84,15 +84,15 @@ MIT in each case. |# (define (machine-register-name reg) (cond ((eq? reg regnum:stack-pointer) - "stack_pointer") + "Rsp") ((eq? reg regnum:free) - "free_pointer") + "Rfp") ((eq? reg regnum:regs) - "register_block") + "Rrb") ((eq? reg regnum:dynamic-link) - "dynamic_link") + "Rdl") ((eq? reg regnum:value) - "value_reg") + "Rvl") (else (comp-internal-error "Unknown machine register" 'MACHINE-REGISTER-NAME reg)))) @@ -224,7 +224,7 @@ MIT in each case. |# (append-map (lambda (register) (map (lambda (spec) - (string-append (type->name (car spec)) " " (cdr spec) ";\n\t")) + (string-append "\t" (type->name (car spec)) " " (cdr spec) ";\n")) (cdr register))) permanent-register-list)) diff --git a/v7/src/compiler/machines/C/rules1.scm b/v7/src/compiler/machines/C/rules1.scm index 115a85ac1..ed3a28466 100644 --- a/v7/src/compiler/machines/C/rules1.scm +++ b/v7/src/compiler/machines/C/rules1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rules1.scm,v 1.4 1993/10/28 15:06:59 gjr Exp $ +$Id: rules1.scm,v 1.5 1993/10/30 12:58:11 gjr Exp $ Copyright (c) 1992-1993 Massachusetts Institute of Technology @@ -274,7 +274,7 @@ MIT in each case. |# (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER (? rsp)) 1)) (QUALIFIER (= rsp regnum:stack-pointer)) (let ((target (standard-target! target 'SCHEME_OBJECT))) - (LAP ,target " = *stack_pointer++;\n\t"))) + (LAP ,target " = *Rsp++;\n\t"))) ;;;; Transfers to memory @@ -294,7 +294,7 @@ MIT in each case. |# (QUALIFIER (and (word-register? source) (= rfree regnum:free))) (let ((source (standard-source! source 'SCHEME_OBJECT))) - (LAP "*free_pointer++ = " ,source ";\n\t"))) + (LAP "*Rhp++ = " ,source ";\n\t"))) (define-rule statement ;; Push an object register on the stack @@ -303,7 +303,7 @@ MIT in each case. |# (QUALIFIER (and (word-register? source) (= rsp regnum:stack-pointer))) (let ((source (standard-source! source 'SCHEME_OBJECT))) - (LAP "*--stack_pointer = " ,source ";\n\t"))) + (LAP "*--Rsp = " ,source ";\n\t"))) ;; Cheaper, common patterns. @@ -317,14 +317,14 @@ MIT in each case. |# ; 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 "*free_pointer++ = ((SCHEME_OBJECT) 0);\n\t")) + (LAP "*Rhp++ = ((SCHEME_OBJECT) 0);\n\t")) (define-rule statement ;; Push 0 on the stack (ASSIGN (PRE-INCREMENT (REGISTER (? rsp)) -1) (MACHINE-CONSTANT (? const))) (QUALIFIER (= rsp regnum:stack-pointer)) - (LAP "*--stack_pointer = ((SCHEME_OBJECT) " ,const ");\n\t")) + (LAP "*--Rsp = ((SCHEME_OBJECT) " ,const ");\n\t")) ;;;; CHAR->ASCII/BYTE-OFFSET diff --git a/v7/src/compiler/machines/C/rules3.scm b/v7/src/compiler/machines/C/rules3.scm index 311b12ac8..24fdb0f93 100644 --- a/v7/src/compiler/machines/C/rules3.scm +++ b/v7/src/compiler/machines/C/rules3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rules3.scm,v 1.5 1993/10/28 05:00:04 gjr Exp $ +$Id: rules3.scm,v 1.6 1993/10/30 12:58:12 gjr Exp $ Copyright (c) 1992-1993 Massachusetts Institute of Technology @@ -54,7 +54,7 @@ MIT in each case. |# (let () (use-invoke-interface! 2) (LAP ,@(clear-map!) - "{\n\t SCHEME_OBJECT procedure = *stack_pointer++;\n\t" + "{\n\t SCHEME_OBJECT procedure = *Rsp++;\n\t" " INVOKE_INTERFACE_2 (" ,code:compiler-apply ", procedure, " ,frame-size ");\n\t}\n\t"))) @@ -87,7 +87,7 @@ MIT in each case. |# (let () (use-invoke-interface! 2) (LAP ,@(clear-map!) - "{n\t SCHEME_OBJECT procedure = *stack_pointer++;\n\t " + "{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"))) @@ -222,27 +222,27 @@ MIT in each case. |# (define (move-frame-up frame-size new-frame pfx) (case frame-size ((0) - (LAP ,pfx "stack_pointer = " ,new-frame ";\n\t")) + (LAP ,pfx "Rsp = " ,new-frame ";\n\t")) ((1) - (LAP ,pfx "*--" ,new-frame " = stack_pointer[0];\n\t" - ,pfx "stack_pointer = " ,new-frame ";\n\t")) + (LAP ,pfx "*--" ,new-frame " = Rsp[0];\n\t" + ,pfx "Rsp = " ,new-frame ";\n\t")) ((2) - (LAP ,pfx "*--" ,new-frame " = stack_pointer[1];\n\t" - ,pfx "*--" ,new-frame " = stack_pointer[0];\n\t" - ,pfx "stack_pointer = " ,new-frame ";\n\t")) + (LAP ,pfx "*--" ,new-frame " = Rsp[1];\n\t" + ,pfx "*--" ,new-frame " = Rsp[0];\n\t" + ,pfx "Rsp = " ,new-frame ";\n\t")) ((3) - (LAP ,pfx "*--" ,new-frame " = stack_pointer[2];\n\t" - ,pfx "*--" ,new-frame " = stack_pointer[1];\n\t" - ,pfx "*--" ,new-frame " = stack_pointer[0];\n\t" - ,pfx "stack_pointer = " ,new-frame ";\n\t")) + (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")) (else - (LAP ,pfx "{\n\t SCHEME_OBJECT * frame_top = &stack_pointer[" + (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 " stack_pointer = new_frame;\n\t" + ,pfx " Rsp = new_frame;\n\t" ,pfx "}\n\t")))) ;;; DYNAMIC-LINK instructions have a , , @@ -420,23 +420,23 @@ MIT in each case. |# (define (write-closure-entry internal-label min max offset) (let ((external-label (rtl-procedure/external-label (label->object internal-label)))) - (LAP "WRITE_LABEL_DESCRIPTOR (free_pointer, 0x" + (LAP "WRITE_LABEL_DESCRIPTOR (Rhp, 0x" ,(number->string (make-procedure-code-word min max) 16) ", " ,offset ");\n\t" - "free_pointer[0] = (MAKE_LABEL_WORD (current_C_proc, " + "Rhp[0] = (dispatch_base + " ,(label->dispatch-tag external-label) - "));\n\t" - "free_pointer[1] = ((SCHEME_OBJECT) (¤t_block[" + ");\n\t" + "Rhp[1] = ((SCHEME_OBJECT) (¤t_block[" ,(label->offset external-label) "]));\n\t"))) (define (cons-closure target label min max nvars) (let ((target (standard-target! target 'SCHEME_OBJECT*))) - (LAP "* free_pointer = (MAKE_OBJECT (" ,(ucode-type manifest-closure) ", " + (LAP "* Rhp = (MAKE_OBJECT (" ,(ucode-type manifest-closure) ", " ,(+ closure-entry-size nvars) "));\n\t" - "free_pointer += 2;\n\t" - ,target " = free_pointer;\n\t" + "Rhp += 2;\n\t" + ,target " = Rhp;\n\t" ,@(write-closure-entry label min max 2) - "free_pointer += " ,(+ nvars 2) ";\n\t"))) + "Rhp += " ,(+ nvars 2) ";\n\t"))) (define-rule statement (ASSIGN (REGISTER (? target)) @@ -451,10 +451,10 @@ MIT in each case. |# (case nentries ((0) (let ((dest (standard-target! target 'SCHEME_OBJECT*))) - (LAP ,dest " = free_pointer;\n\t" - "*free_pointer = (MAKE_OBJECT (" ,(ucode-type manifest-vector) + (LAP ,dest " = Rhp;\n\t" + "*Rhp = (MAKE_OBJECT (" ,(ucode-type manifest-vector) ", " ,nvars "));\n\t" - "free_pointer += " ,(+ nvars 1) ";\n\t"))) + "Rhp += " ,(+ nvars 1) ";\n\t"))) ((1) (let ((entry (vector-ref entries 0))) (cons-closure target (car entry) (cadr entry) (caddr entry) nvars))) @@ -463,12 +463,12 @@ MIT in each case. |# (define (cons-multiclosure target nentries nvars entries) (let ((target (standard-target! target 'SCHEME_OBJECT*))) - (LAP "* free_pointer = (MAKE_OBJECT (" ,(ucode-type manifest-closure) ", " + (LAP "* Rhp = (MAKE_OBJECT (" ,(ucode-type manifest-closure) ", " ,(1+ (+ (* nentries closure-entry-size) nvars)) "));\n\t" - "free_pointer += 2;\n\t" - "WRITE_LABEL_DESCRIPTOR (free_pointer, " ,nentries ", 0);\n\t" - "free_pointer += 1;\n\t" - ,target " = free_pointer;\n\t" + "Rhp += 2;\n\t" + "WRITE_LABEL_DESCRIPTOR (Rhp, " ,nentries ", 0);\n\t" + "Rhp += 1;\n\t" + ,target " = Rhp;\n\t" ,@(reduce-right (lambda (lap1 lap2) (LAP ,@lap1 ,@lap2)) @@ -478,9 +478,9 @@ MIT in each case. |# (min (cadr entry)) (max (caddr entry))) (LAP ,@(write-closure-entry label min max offset) - "free_pointer += 3;\n\t"))) + "Rhp += 3;\n\t"))) entries (make-multiclosure-offsets nentries))) - "free_pointer += " ,(- nvars 1) ";\n\t"))) + "Rhp += " ,(- nvars 1) ";\n\t"))) (define (make-multiclosure-offsets nentries) (let generate ((x nentries) @@ -500,7 +500,7 @@ MIT in each case. |# (declare-block-label! (continuation-code-word false) false label) (use-invoke-interface! 4) (LAP "current_block[" ,environment-label - "] = register_block[REGBLOCK_ENV];\n\t" + "] = Rrb[REGBLOCK_ENV];\n\t" "INVOKE_INTERFACE_4 (" ,code:compiler-link ", ¤t_block[" ,(label->offset label) "]" ",\n\t\t\t\tcurrent_block" @@ -519,7 +519,7 @@ MIT in each case. |# (LAP "{\n\t SCHEME_OBJECT * subblock = (OBJECT_ADDRESS (current_block[" ,code-block-label "]));\n\t " "subblock[" ,environment-offset - "] = register_block[REGBLOCK_ENV];\n\t " + "] = Rrb[REGBLOCK_ENV];\n\t " "INVOKE_INTERFACE_4 (" ,code:compiler-link ", ¤t_block[" ,(label->offset label) "]" ",\n\t\t\t\t subblock" @@ -565,23 +565,23 @@ MIT in each case. |# (object-label-value code-blocks-label))) (declare-block-label! (continuation-code-word false) false label) (use-invoke-interface! 4) - (LAP "*--stack_pointer = (LONG_TO_UNSIGNED_FIXNUM (1L));\n\t" + (LAP "*--Rsp = (LONG_TO_UNSIGNED_FIXNUM (1L));\n\t" ,@(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 (* stack_pointer));\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 " - " = register_block[REGBLOCK_ENV];\n\t " + " = Rrb[REGBLOCK_ENV];\n\t " "section = sections[counter];\n\t " "counter += 1;\n\t " - "*stack_pointer = (LONG_TO_UNSIGNED_FIXNUM (counter));\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" @@ -589,7 +589,7 @@ MIT in each case. |# "\n\t\t\t\t + (2 + (OBJECT_DATUM (subblock[1]))))" ",\n\t\t\t\t section);\n\t}\n\t" ,@(label-statement done) - "stack_pointer += 1;\n\t"))) + "Rsp += 1;\n\t"))) #| (define (generate/constants-block constants references assignments uuo-links -- 2.25.1