* 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:
#| -*-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
(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"
(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)
(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)
(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
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)))
(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"))))))))))))))))
\f
(define-integrable (list-of-strings->string strings)
(apply string-append strings))
(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"))
;; 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* '())
(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
label-bindings)
(if (null? labels)
(values (- offset 1)
+ tagno
(reverse label-defines)
(reverse label-dispatch)
(cons (string-append
(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)))
(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)
'())
label-bindings)))))
- (iter (+ 2 n) 1 (reverse! labels) '() '() '() '()))
+ (iter (+ 2 n) 0 (reverse! labels) '() '() '() '()))
\f
(define-structure (fake-compiled-procedure
(constructor make-fake-compiled-procedure)
(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")
(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)
#| -*-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
;; 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*)
(*use-pop-return*)
(*purification-root-object*)
(*end-of-block-code*)
- (*C-proc-name*)
+ (*C-code-name*)
+ (*C-data-name*)
+ (*ntags*)
(*labels*)
(*code*))
(thunk)))
(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)
(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)))))
(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?)
#| -*-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
(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))))
(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))
#| -*-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
(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
(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
(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.
; 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"))
\f
;;;; CHAR->ASCII/BYTE-OFFSET
#| -*-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
(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")))
(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")))
(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"))))
\f
;;; DYNAMIC-LINK instructions have a <frame-size>, <new frame end>,
(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))
(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)))
(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))
(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)
(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"
(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"
(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"
"\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")))
\f
#|
(define (generate/constants-block constants references assignments uuo-links
projects / mit-scheme.git / commitdiff