~ chicken-core (chicken-5) d7bd5f081b9c35ce7f13d693f52cbc20ec397f19
commit d7bd5f081b9c35ce7f13d693f52cbc20ec397f19
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sat Aug 22 15:13:04 2015 +0200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sat Aug 22 15:13:04 2015 +0200
first go at conversion of CPS-calls to use of argument-vector.
Conflicts:
c-backend.scm
diff --git a/c-backend.scm b/c-backend.scm
index f85a1c17..98770ac6 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -251,10 +251,9 @@
(gen #t "C_trace(\"" (slashify name-str) "\");")
(gen #t "/* " (uncommentify name-str) " */") ) )
(cond ((eq? '##core#proc (node-class fn))
+ (push-args args i "0")
(let ([fpars (node-parameters fn)])
- (gen #t (first fpars) #\( nf ",0,") )
- (expr-args args i)
- (gen ");") )
+ (gen #t (first fpars) #\( nf ",av);") ))
(call-id
(cond ((and (eq? call-id (lambda-literal-id ll))
(lambda-literal-looping ll) )
@@ -276,11 +275,10 @@
(gen #t #\t nc #\=)
(expr fn i)
(gen #\;) )
+ (push-args args i (and (not empty-closure) (string-append "t" (number->string nc))))
(gen #t call-id #\()
(unless customizable (gen nf #\,))
- (unless empty-closure (gen #\t nc #\,))
- (expr-args args i)
- (gen ");") ) ) )
+ (gen "av);") ) ) )
((and (eq? '##core#global (node-class fn))
(not unsafe)
(not no-procedure-checks)
@@ -290,7 +288,8 @@
(safe (second gparams))
(block (third gparams))
(carg #f))
- (gen #t "((C_proc" nf ")")
+ (push-args args i #f)
+ (gen #tr "((C_proc)")
(cond (no-global-procedure-checks
(set! carg
(if block
@@ -304,7 +303,7 @@
(gen "C_retrieve2_symbol_proc(" carg ","
(c-ify-string (##sys#symbol->qualified-string
(fourth gparams))) #\)) ) )
- (safe
+ (safe
(set! carg
(string-append "*((C_word*)lf[" (number->string index) "]+1)"))
(gen "C_fast_retrieve_proc(" carg ")"))
@@ -312,20 +311,17 @@
(set! carg
(string-append "*((C_word*)lf[" (number->string index) "]+1)"))
(gen "C_fast_retrieve_symbol_proc(lf[" index "])") ))
- (gen ")(" nf #\, carg #\,)
- (expr-args args i)
- (gen ");") ) )
+ (gen ")(" nf #\, carg ",av);")))
(else
(gen #t #\t nc #\=)
(expr fn i)
- (gen #\; #t
- "((C_proc" nf ")")
+ (gen #\;)
+ (push-args args i #f)
+ (gen #t "((C_proc)")
(if (or unsafe no-procedure-checks (first params))
(gen "(void*)(*((C_word*)t" nc "+1))")
(gen "C_fast_retrieve_proc(t" nc ")") )
- (gen ")(" nf ",t" nc #\,)
- (expr-args args i)
- (gen ");") ) ) ) )
+ (gen ")(" nf ",t" nc ",av);") ) ) ) )
((##core#recurse)
(let* ([n (length subs)]
@@ -377,9 +373,8 @@
;; one unused variable:
(let* ((n (length subs))
(nf (+ n 1)) )
- (gen #t "C_" (first params) "_toplevel(" nf ",C_SCHEME_UNDEFINED,")
- (expr-args subs i)
- (gen ");") ) )
+ (push-args subs i "C_SCHEME_UNDEFINED")
+ (gen #t "C_" (first params) "_toplevel(" nf ",av);")))
((##core#return)
(gen #t "return(")
@@ -468,6 +463,17 @@
(expr (car xs) i)
(loop (cdr xs)))))
+ (define (push-args args i karg)
+ (let ((n (length args)))
+ (gen #t "C_word av[" n "];")
+ (when karg (gen #t "av[0]=" karg ";"))
+ (do ((j 0 (add1 j))
+ (args args (cdr args)))
+ ((null? args))
+ (gen #t "av[" j "]=")
+ (expr (car xs) i)
+ (gen ";"))))
+
(expr node temps) )
(define (header)
@@ -518,7 +524,7 @@
(for-each
(lambda (uu)
(gen #t "C_noret_decl(C_" uu "_toplevel)"
- #t "C_externimport void C_ccall C_" uu "_toplevel(C_word c,C_word d,C_word k) C_noret;"))
+ #t "C_externimport void C_ccall C_" uu "_toplevel(C_word c,C_word av) C_noret;"))
used-units)
(unless (zero? n)
(gen #t #t "static C_TLS C_word lf[" n "];") )
@@ -572,7 +578,7 @@
(gen id) ]
[else
(let ((uname (if unit-name (string-append unit-name "_toplevel") "toplevel")))
- (gen "C_noret_decl(C_" uname ")" #t)
+ (gen "C_noret_decl(C_" uname ")" #t) ;XXX what's this for?
(gen "C_externexport void C_ccall ")
(gen "C_" uname) ) ] )
(gen #\()
@@ -580,20 +586,12 @@
(when (and direct (not (zero? allocated)))
(gen "C_word *a")
(when (pair? varlist) (gen #\,)) )
- (apply gen varlist)
- (cond [rest
- (gen ",...) C_noret;")
- (if (not (eq? rest-mode 'none))
- (begin
- (gen #t "C_noret_decl(" id ")"
- #t "static void C_ccall " id "r(")
- (apply gen varlist)
- (gen ",C_word t" (+ n 1) ") C_noret;") ) ) ]
- [else
- (gen #\))
- ;;(when customizable (gen " C_c_regparm"))
- (unless direct (gen " C_noret"))
- (gen #\;) ] ) ) )
+ (when (or customizable direct)
+ (apply gen varlist))
+ (gen #\))
+ ;;(when customizable (gen " C_c_regparm"))
+ (unless direct (gen " C_noret"))
+ (gen #\;) ))
lambda-table)
(for-each
(lambda (s)
@@ -614,28 +612,6 @@
(gen #t "C_word t" i "=C_pick(" j ");") )
(gen #t "C_adjust_stack(-" n ");") )
- (define (emitter vflag)
- (lambda (n)
- (gen #t #t "C_noret_decl(tr" n #\r (if vflag #\v "") ")"
- #t "static void C_fcall tr" n #\r (if vflag #\v ""))
- (gen "(C_proc" n " k) C_regparm C_noret;")
- (gen #t "C_regparm static void C_fcall tr" n #\r)
- (when vflag (gen #\v))
- (gen "(C_proc" n " k){"
- #t "int n;"
- #t "C_word *a,t" n #\;)
- (restore n)
- (gen #t "n=C_rest_count(0);")
- (if vflag
- (gen #t "a=C_alloc(n+1);")
- (gen #t "a=C_alloc(n*3);") )
- (gen #t #\t n "=C_restore_rest")
- (when vflag (gen "_vector"))
- (gen "(a,n);")
- (gen #t "(k)(")
- (apply gen (intersperse (make-argument-list (+ n 1) "t") #\,))
- (gen ");}") ) )
-
(##sys#hash-table-for-each
(lambda (id ll)
(let* ([argc (lambda-literal-argument-count ll)]
@@ -644,33 +620,16 @@
[customizable (lambda-literal-customizable ll)]
[empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))] )
(when empty-closure (set! argc (sub1 argc)))
- (unless (lambda-literal-direct ll)
- (cond [customizable
- (gen #t #t "C_noret_decl(tr" id ")"
- #t "static void C_fcall tr" id "(void *dummy) C_regparm C_noret;")
- (gen #t "C_regparm static void C_fcall tr" id "(void *dummy){")
- (restore argc)
- (gen #t id #\()
- (let ([al (make-argument-list argc "t")])
- (apply gen (intersperse al #\,)) )
- (gen ");}") ]
- [(or rest (> (lambda-literal-allocated ll) 0) (lambda-literal-external ll))
- (if (and rest (not (eq? rest-mode 'none)))
- (set! nsr (lset-adjoin/eq? nsr argc))
- (set! ns (lset-adjoin/eq? ns argc)))]))))
- lambda-table)
- (for-each
- (lambda (n)
- (gen #t #t "C_noret_decl(tr" n ")"
- #t "static void C_fcall tr" n "(C_proc" n " k) C_regparm C_noret;")
- (gen #t "C_regparm static void C_fcall tr" n "(C_proc" n " k){")
- (restore n)
- (gen #t "(k)(" n #\,)
- (apply gen (intersperse (make-argument-list n "t") #\,))
- (gen ");}") )
- ns)
- (for-each (emitter #f) nsr)
- (for-each (emitter #t) nsrv) ) )
+ (when (and (not (lambda-literal-direct ll)) customizable)
+ (gen #t #t "C_noret_decl(tr" id ")"
+ #t "static void C_ccall tr" id "(C_word c,C_word *av) C_noret;")
+ (gen #t "static void C_ccall tr" id "(C_word c,C_word *av){")
+ (restore argc)
+ (gen #t id #\()
+ (let ([al (make-argument-list argc "t")])
+ (apply gen (intersperse al #\,)) )
+ (gen ");}") )))
+ lambda-table)))
(define (literal-frame)
(do ([i 0 (add1 i)]
@@ -795,21 +754,20 @@
(gen "static C_TLS int toplevel_initialized=0;")
(unless unit-name
(gen #t "C_main_entry_point") )
- (gen #t "C_noret_decl(toplevel_trampoline)"
- #t "static void C_fcall toplevel_trampoline(void *dummy) C_regparm C_noret;"
- #t "C_regparm static void C_fcall toplevel_trampoline(void *dummy){"
- #t "C_" topname "(2,C_SCHEME_UNDEFINED,C_restore);}"
- #t #t "void C_ccall C_" topname) ] )
+ (gen #t #t "void C_ccall C_" topname) ] )
(gen #\()
(unless customizable (gen "C_word c,"))
(when (and direct (not (zero? demand)))
(gen "C_word *a")
(when (pair? varlist) (gen #\,)) )
- (apply gen varlist)
- (when rest (gen ",..."))
+ (when (or customizable direct) (apply gen varlist))
(gen "){")
(when (eq? rest-mode 'none) (set! rest #f))
(gen #t "C_word tmp;")
+ (unless (or customizable direct)
+ (do ((i 0 (add1 i)))
+ ((>= i n))
+ (gen #t "C_word t" i "=av[" i "];")))
(if rest
(gen #t "C_word t" n #\;) ; To hold rest-list if demand is met
(begin
@@ -838,7 +796,7 @@
(gen #t "C_check_nursery_minimum(" demand ");"
#t "if(!C_demand(" demand ")){"
#t "C_save(t1);"
- #t "C_reclaim((void*)toplevel_trampoline,NULL);}"
+ #t "C_reclaim((void*)toplevel);}"
#t "toplevel_initialized=1;")
(gen #t "if(!C_demand_2(" ldemand ")){"
#t "C_save(t1);"
@@ -850,7 +808,6 @@
(literal-frame)
(gen #t "C_register_lf2(lf," llen ",create_ptable());") ) ) ]
[rest
- (gen #t "va_list v;")
(gen #t "C_word *a,c2=c;")
(gen #t "C_save_rest(")
(if (> n 0)
@@ -887,37 +844,21 @@
(not direct)
(or rest external (> demand 0)) )
(cond [rest
- (gen #t (if (> nec 0) "C_save_and_reclaim" "C_reclaim") "((void*)tr" n #\r)
- (gen ",(void*)" id "r")
- (when (> nec 0)
- (gen #\, nec #\,)
- (apply gen arglist) )
- (gen ");}"
+ (gen #t "C_reclaim((void*)" id ");"
#t "else{"
#t "a=C_alloc((c-" n ")*3);")
(gen #t "t" n "=C_restore_rest(a,C_rest_count(0));")
- (gen #t id "r(")
- (apply gen (intersperse (make-argument-list n "t") #\,))
- (gen ",t" n ");}}")
- ;; Create secondary routine (no demand-check or argument-count-parameter):
- (gen #t #t "static void C_ccall " id "r(")
- (apply gen varlist)
- (gen ",C_word t" n "){")
- (gen #t "C_word tmp;")
(do ([i (+ n 1) (+ i 1)]
[j temps (- j 1)] )
((zero? j))
(gen #t "C_word t" i #\;) )
(when (> demand 0) (gen #t "C_word *a=C_alloc(" demand ");")) ]
[else
- (gen #t (if (> nec 0) "C_save_and_reclaim" "C_reclaim") "((void*)tr")
- (if customizable
- (gen id ",NULL")
- (gen n ",(void*)" id) )
- (when (> nec 0)
- (gen #\, nec #\,)
- (apply gen arglist) )
- (gen ");}") ] ) )
+ (cond ((and customizable (> nec 0))
+ (gen #t "C_save_and_reclaim_args((void *)tr" id "," nec ",")
+ (apply gen arglist) )
+ (else
+ (gen "C_save_and_reclaim((void *)" id ",av);")))]))
(expression
(lambda-literal-body ll)
(if rest
@@ -1028,7 +969,6 @@
[rname (real-name2 id db)]
[types (foreign-stub-argument-types stub)]
[n (length types)]
- [varlist (intersperse (cons "C_word C_buf" (make-variable-list n "C_a")) #\,)]
[rtype (foreign-stub-return-type stub)]
[sname (foreign-stub-name stub)]
[body (foreign-stub-body stub)]
@@ -1042,16 +982,17 @@
(when body
(gen #t "#define return(x) C_cblock C_r = (" rconv
"(x))); goto C_ret; C_cblockend"))
- (if cps
- (gen #t "C_noret_decl(" id ")"
- #t "static void C_ccall " id "(C_word C_c,C_word C_self,C_word C_k,")
- (gen #t "static C_word C_fcall " id #\() )
- (apply gen varlist)
- (if cps
- (gen ") C_noret;" #t "static void C_ccall " id "(C_word C_c,C_word C_self,C_word C_k,")
- (gen ") C_regparm;" #t "C_regparm static C_word C_fcall " id #\() )
- (apply gen varlist)
- (gen "){")
+ (cond (cps
+ (gen #t "C_noret_decl(" id ")"
+ #t "static void C_ccall " id "(C_word C_c,C_word C_av){"
+ #t "C_word C_buf=C_av[0];")
+ (do ((i 1 (add1 i)))
+ ((>= i n))
+ (gen #t "C_word C_a" i "=C-av[" i "];")))
+ (else
+ (gen #t "C_regparm static C_word C_fcall " id #\()
+ (apply gen (intersperse (cons "C_word C_buf" (make-variable-list n "C_a")) #\,))
+ (gen "){")))
(gen #t "C_word C_r=C_SCHEME_UNDEFINED,*C_a=(C_word*)C_buf;")
(for-each
(lambda (type index name)
Trap