Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-07-09 22:17:33 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Converted improper semi-colons into double ones

Browse source
This commit is contained in:
arthurmaciel 2019-01-25 19:10:10 -02:00
parent c04c930c3e
commit 40fbb91bc3
1 changed files with 180 additions and 179 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

359
scheme/cyclone/cgen.sld
View file

@ -24,7 +24,7 @@
autogen autogen
autogen:defprimitives autogen:defprimitives
autogen:primitive-procedures autogen:primitive-procedures
;c-compile-program ;;c-compile-program
emit emit
emit* emit*
emits emits
@ -139,7 +139,7 @@
(n (number->string num-args)) (n (number->string num-args))
(arry-assign (c-macro-array-assign num-args "buf" "a"))) (arry-assign (c-macro-array-assign num-args "buf" "a")))
(string-append (string-append
;"/* Check for GC, then call given continuation closure */\n" ;;"/* Check for GC, then call given continuation closure */\n"
"#define return_closcall" n "(td, clo" args ") { \\\n" "#define return_closcall" n "(td, clo" args ") { \\\n"
" char top; \\\n" " char top; \\\n"
" if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \\\n" " if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \\\n"
@ -159,9 +159,9 @@
(n (number->string num-args)) (n (number->string num-args))
(arry-assign (c-macro-array-assign num-args "buf" "a"))) (arry-assign (c-macro-array-assign num-args "buf" "a")))
(string-append (string-append
;"/* Check for GC, then call given continuation closure */\n" ;;"/* Check for GC, then call given continuation closure */\n"
"#define continue_or_gc" n "(td, clo" args ") { \\\n" "#define continue_or_gc" n "(td, clo" args ") { \\\n"
" char *top = alloca(sizeof(char)); \\\n" ;; TODO: consider speeding up by passing in a var already allocated " char *top = alloca(sizeof(char)); \\\n" ; TODO: consider speeding up by passing in a var already allocated
" if (stack_overflow(top, (((gc_thread_data *)data)->stack_limit))) { \\\n" " if (stack_overflow(top, (((gc_thread_data *)data)->stack_limit))) { \\\n"
" object buf[" n "]; " arry-assign "\\\n" " object buf[" n "]; " arry-assign "\\\n"
" GC(td, clo, buf, " n "); \\\n" " GC(td, clo, buf, " n "); \\\n"
@ -177,7 +177,7 @@
(n (number->string num-args)) (n (number->string num-args))
(arry-assign (c-macro-array-assign num-args "buf" "a"))) (arry-assign (c-macro-array-assign num-args "buf" "a")))
(string-append (string-append
;"/* Check for GC, then call C function directly */\n" ;;"/* Check for GC, then call C function directly */\n"
"#define return_direct" n "(td, _fn" args ") { \\\n" "#define return_direct" n "(td, _fn" args ") { \\\n"
" char top; \\\n" " char top; \\\n"
" if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \\\n" " if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \\\n"
@ -194,7 +194,7 @@
(n (number->string num-args)) (n (number->string num-args))
(arry-assign (c-macro-array-assign num-args "buf" "a"))) (arry-assign (c-macro-array-assign num-args "buf" "a")))
(string-append (string-append
;"/* Check for GC, then call C function directly */\n" ;;"/* Check for GC, then call C function directly */\n"
"#define return_direct_with_clo" n "(td, clo, _fn" args ") { \\\n" "#define return_direct_with_clo" n "(td, clo, _fn" args ") { \\\n"
" char top; \\\n" " char top; \\\n"
" if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \\\n" " if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \\\n"
@ -212,7 +212,7 @@
(n (number->string num-args)) (n (number->string num-args))
(arry-assign (c-macro-array-assign num-args "buf" "a"))) (arry-assign (c-macro-array-assign num-args "buf" "a")))
(string-append (string-append
;"/* Check for GC, then call C function directly */\n" ;;"/* Check for GC, then call C function directly */\n"
"#define return_direct_with_obj" n "(td, clo, _clo_fn, _fn" args ") { \\\n" "#define return_direct_with_obj" n "(td, clo, _clo_fn, _fn" args ") { \\\n"
" char top; \\\n" " char top; \\\n"
" if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \\\n" " if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \\\n"
@ -345,7 +345,7 @@
(append-preamble (lambda (s) (append-preamble (lambda (s)
(set! preamble (string-append preamble " " s "\n")))) (set! preamble (string-append preamble " " s "\n"))))
(body (c-compile-exp exp append-preamble "cont" -1 (list src-file) #t))) (body (c-compile-exp exp append-preamble "cont" -1 (list src-file) #t)))
;(write `(DEBUG ,body)) ;; (write `(DEBUG ,body))
(string-append (string-append
preamble preamble
(c:serialize body " ") (c:serialize body " ")
@ -363,13 +363,13 @@
;; * function name (or NULL if none) ;; * function name (or NULL if none)
;; cps? - Determine whether to compile using continuation passing style. ;; cps? - Determine whether to compile using continuation passing style.
;; Normally this is always enabled, but sometimes a function has a ;; Normally this is always enabled, but sometimes a function has a
;; version that can be inlined (as an optimization), so this will ;; version that can be inlined (as an optimization), so this will
;; be set to false to change the type of compilation. ;; be set to false to change the type of compilation.
;; NOTE: this field is not passed everywhere because a lot of forms ;; NOTE: this field is not passed everywhere because a lot of forms
;; require CPS, so this flag is not applicable to them. ;; require CPS, so this flag is not applicable to them.
(define (c-compile-exp exp append-preamble cont ast-id trace cps?) (define (c-compile-exp exp append-preamble cont ast-id trace cps?)
(cond (cond
; Special case - global function w/out a closure. Create an empty closure ;; Special case - global function w/out a closure. Create an empty closure
((ast:lambda? exp) ((ast:lambda? exp)
(c-compile-exp (c-compile-exp
`(%closure ,exp) `(%closure ,exp)
@ -378,7 +378,7 @@
ast-id ast-id
trace trace
cps?)) cps?))
; Core forms: ;; Core forms:
((const? exp) (c-compile-const exp (alloca? ast-id))) ((const? exp) (c-compile-const exp (alloca? ast-id)))
((prim? exp) ((prim? exp)
;; TODO: this needs to be more refined, probably w/a lookup table ;; TODO: this needs to be more refined, probably w/a lookup table
@ -387,16 +387,16 @@
((quote? exp) (c-compile-quote exp (alloca? ast-id))) ((quote? exp) (c-compile-quote exp (alloca? ast-id)))
((if? exp) (c-compile-if exp append-preamble cont ast-id trace cps?)) ((if? exp) (c-compile-if exp append-preamble cont ast-id trace cps?))
; IR (2): ;; IR (2):
((tagged-list? '%closure exp) ((tagged-list? '%closure exp)
(c-compile-closure exp append-preamble cont ast-id trace cps?)) (c-compile-closure exp append-preamble cont ast-id trace cps?))
; Global definition ;; Global definition
((define? exp) ((define? exp)
(c-compile-global exp append-preamble cont trace)) (c-compile-global exp append-preamble cont trace))
((define-c? exp) ((define-c? exp)
(c-compile-raw-global-lambda exp append-preamble cont trace)) (c-compile-raw-global-lambda exp append-preamble cont trace))
; Application: ;; Application:
((app? exp) (c-compile-app exp append-preamble cont ast-id trace cps?)) ((app? exp) (c-compile-app exp append-preamble cont ast-id trace cps?))
(else (error "unknown exp in c-compile-exp: " exp)))) (else (error "unknown exp in c-compile-exp: " exp))))
@ -407,13 +407,13 @@
(define (c-compile-scalars args use-alloca) (define (c-compile-scalars args use-alloca)
(letrec ( (letrec (
(addr-op (if use-alloca "" "&")) (addr-op (if use-alloca "" "&"))
;(deref-op (if use-alloca "->" ".")) ;; (deref-op (if use-alloca "->" "."))
(c-make-macro (if use-alloca "alloca_pair" "make_pair")) (c-make-macro (if use-alloca "alloca_pair" "make_pair"))
(num-args 0) (num-args 0)
(create-cons (create-cons
(lambda (cvar a b) (lambda (cvar a b)
(c-code/vars (c-code/vars
(string-append c-make-macro "(" cvar "," (c:body a) "," (c:body b) ");") (string-append c-make-macro "(" cvar "," (c:body a) "," (c:body b) ");")
(append (c:allocs a) (c:allocs b))))) (append (c:allocs a) (c:allocs b)))))
(_c-compile-scalars (_c-compile-scalars
(lambda (args) (lambda (args)
@ -444,7 +444,7 @@
(addr-op (if use-alloca "" "&")) (addr-op (if use-alloca "" "&"))
(deref-op (if use-alloca "->" ".")) (deref-op (if use-alloca "->" "."))
(c-make-macro (if use-alloca "alloca_empty_vector" "make_empty_vector")) (c-make-macro (if use-alloca "alloca_empty_vector" "make_empty_vector"))
;; Generate code for each member of the vector ;; Generate code for each member of the vector
(loop (loop
(lambda (i code) (lambda (i code)
(if (= i len) (if (= i len)
@ -453,13 +453,13 @@
(loop (loop
(+ i 1) (+ i 1)
(c-code/vars (c-code/vars
;; The vector's C variable ;; The vector's C variable
(c:body code) (c:body code)
;; Allocations ;; Allocations
(append (append
(c:allocs code) ;; Vector alloc (c:allocs code) ;; Vector alloc
(c:allocs idx-code) ;; Member alloc at index i (c:allocs idx-code) ;; Member alloc at index i
(list ;; Assign this member to vector (list ;; Assign this member to vector
(string-append (string-append
cvar-name deref-op "elements[" (number->string i) "] = " cvar-name deref-op "elements[" (number->string i) "] = "
(c:body idx-code) (c:body idx-code)
@ -489,7 +489,7 @@
(addr-op (if use-alloca "" "&")) (addr-op (if use-alloca "" "&"))
(deref-op (if use-alloca "->" ".")) (deref-op (if use-alloca "->" "."))
(c-make-macro (if use-alloca "alloca_empty_bytevector" "make_empty_bytevector")) (c-make-macro (if use-alloca "alloca_empty_bytevector" "make_empty_bytevector"))
;; Generate code for each member of the vector ;; Generate code for each member of the vector
(loop (loop
(lambda (i code) (lambda (i code)
(if (= i len) (if (= i len)
@ -498,12 +498,12 @@
(loop (loop
(+ i 1) (+ i 1)
(c-code/vars (c-code/vars
;; The bytevector's C variable ;; The bytevector's C variable
(c:body code) (c:body code)
;; Allocations ;; Allocations
(append (append
(c:allocs code) ;; Vector alloc (c:allocs code) ;; Vector alloc
(list ;; Assign this member to vector (list ;; Assign this member to vector
(string-append (string-append
cvar-name deref-op "data[" (number->string i) "] = (unsigned char)" cvar-name deref-op "data[" (number->string i) "] = (unsigned char)"
byte-val byte-val
@ -586,7 +586,7 @@
(else (else
(number->string exp))))) (number->string exp)))))
(c-code/vars (c-code/vars
(string-append "" cvar-name) ; Code is just the variable name (string-append "" cvar-name) ; Code is just the variable name
(list ; Allocate pointer on the C stack (list ; Allocate pointer on the C stack
(string-append (string-append
"alloc_bignum(data, " cvar-name "); " "alloc_bignum(data, " cvar-name "); "
@ -596,8 +596,8 @@
(let* ((cvar-name (mangle (gensym 'c))) (let* ((cvar-name (mangle (gensym 'c)))
(num2str (lambda (n) (num2str (lambda (n)
(cond (cond
;; The following two may not be very portable, ;; The following two may not be very portable,
;; may be better to use C99: ;; may be better to use C99:
((nan? n) "(0./0.)") ((nan? n) "(0./0.)")
((infinite? n) "(1./0.)") ((infinite? n) "(1./0.)")
(else (else
@ -617,7 +617,7 @@
((real? exp) ((real? exp)
(let ((cvar-name (mangle (gensym 'c))) (let ((cvar-name (mangle (gensym 'c)))
(num2str (cond (num2str (cond
;; The following two may not be very portable, ;; The following two may not be very portable,
;; may be better to use C99: ;; may be better to use C99:
((nan? exp) "(0./0.)") ((nan? exp) "(0./0.)")
((infinite? exp) "(1./0.)") ((infinite? exp) "(1./0.)")
@ -626,7 +626,7 @@
(addr-op (if use-alloca "" "&")) (addr-op (if use-alloca "" "&"))
(c-make-macro (if use-alloca "alloca_double" "make_double"))) (c-make-macro (if use-alloca "alloca_double" "make_double")))
(c-code/vars (c-code/vars
(string-append addr-op cvar-name) ; Code is just the variable name (string-append addr-op cvar-name) ; Code is just the variable name
(list ; Allocate on the C stack (list ; Allocate on the C stack
(string-append (string-append
c-make-macro "(" cvar-name ", " num2str ");"))))) c-make-macro "(" cvar-name ", " num2str ");")))))
@ -721,7 +721,7 @@
(else ""))) (else "")))
(tptr-decl (tptr-decl
(cond (cond
((and tptr-type use-alloca?) (string-append "object " tptr " = alloca(sizeof(" tptr-type ")); ")) ((and tptr-type use-alloca?) (string-append "object " tptr " = alloca(sizeof(" tptr-type ")); "))
(tptr-type (string-append tptr-type " " tptr "; ")) (tptr-type (string-append tptr-type " " tptr "; "))
(else ""))) (else "")))
(c-var-assign (c-var-assign
@ -731,14 +731,14 @@
(string-append (string-append
(if (or (prim:cont? p) (if (or (prim:cont? p)
(equal? (prim/c-var-assign p) "object") (equal? (prim/c-var-assign p) "object")
(prim/c-var-pointer p) ;; Assume returns object (prim/c-var-pointer p) ; Assume returns object
(prim->c-func-uses-alloca? p use-alloca?)) (prim->c-func-uses-alloca? p use-alloca?))
"" ""
"&") "&")
cv-name) cv-name)
(list (list
(string-append (string-append
;; Define closure if necessary (apply only) ;; Define closure if necessary (apply only)
(cond (cond
(closure-def closure-def) (closure-def closure-def)
(else "")) (else ""))
@ -767,18 +767,18 @@
((prim/c-var-assign p) ((prim/c-var-assign p)
(c-var-assign (prim/c-var-assign p))) (c-var-assign (prim/c-var-assign p)))
((prim/cvar? p) ((prim/cvar? p)
;; ;;
;; TODO: look at functions that would actually fall into this ;; TODO: look at functions that would actually fall into this
;; branch, I think they are just the macro's like list->vector??? ;; branch, I think they are just the macro's like list->vector???
;; may be able to remove this using prim:cont? and simplify ;; may be able to remove this using prim:cont? and simplify
;; the logic ;; the logic
;; ;;
(let ((cv-name (mangle (gensym 'c)))) (let ((cv-name (mangle (gensym 'c))))
(c-code/vars (c-code/vars
(if (or (prim:allocates-object? p use-alloca?) (if (or (prim:allocates-object? p use-alloca?)
(prim->c-func-uses-alloca? p use-alloca?)) (prim->c-func-uses-alloca? p use-alloca?))
cv-name ;; Already a pointer cv-name ; Already a pointer
(string-append "&" cv-name)) ;; Point to data (string-append "&" cv-name)) ; Point to data
(list (list
(string-append c-func "(" cv-name tdata-comma tdata))))) (string-append c-func "(" cv-name tdata-comma tdata)))))
(else (else
@ -801,7 +801,7 @@
;; self - Identifier for the function's "self" closure ;; self - Identifier for the function's "self" closure
;; closure-index - Index of the function's "self" closure in outer closure ;; closure-index - Index of the function's "self" closure in outer closure
(define (self-closure-call? ast self closure-index) (define (self-closure-call? ast self closure-index)
;(trace:error `(JAE self-closure-call? ,ast ,self ,closure-index)) ;; (trace:error `(JAE self-closure-call? ,ast ,self ,closure-index))
(and-let* (((tagged-list? '%closure-ref ast)) (and-let* (((tagged-list? '%closure-ref ast))
((tagged-list? 'cell-get (cadr ast))) ((tagged-list? 'cell-get (cadr ast)))
(inner-cref (cadadr ast)) (inner-cref (cadadr ast))
@ -811,14 +811,14 @@
((equal? closure-index (caddr inner-cref)))) ((equal? closure-index (caddr inner-cref))))
#t)) #t))
; c-compile-ref : ref-exp -> string ;; c-compile-ref : ref-exp -> string
(define (c-compile-ref exp) (define (c-compile-ref exp)
(c-code (c-code
(if (member exp *global-syms*) (if (member exp *global-syms*)
(cgen:mangle-global exp) (cgen:mangle-global exp)
(mangle exp)))) (mangle exp))))
; c-compile-args : list[exp] (string -> void) -> string ;; c-compile-args : list[exp] (string -> void) -> string
(define (c-compile-args args append-preamble prefix cont ast-id trace cps?) (define (c-compile-args args append-preamble prefix cont ast-id trace cps?)
(letrec ((num-args 0) (letrec ((num-args 0)
(cp-lis '()) (cp-lis '())
@ -828,7 +828,7 @@
((not (pair? args)) ((not (pair? args))
(c-code "")) (c-code ""))
(else (else
;(trace:debug `(c-compile-args ,(car args))) ;; (trace:debug `(c-compile-args ,(car args)))
(let ((cp (c-compile-exp (car args) (let ((cp (c-compile-exp (car args)
append-preamble cont ast-id trace cps?))) append-preamble cont ast-id trace cps?)))
(set! num-args (+ 1 num-args)) (set! num-args (+ 1 num-args))
@ -838,11 +838,11 @@
cp cp
(_c-compile-args (cdr args) (_c-compile-args (cdr args)
append-preamble ", " cont)))))))) append-preamble ", " cont))))))))
;; Pass back a container with: ;; Pass back a container with:
;; - Appened body (string) ;; - Appened body (string)
;; - Appended allocs (string) ;; - Appended allocs (string)
;; - Number of args (numeric) ;; - Number of args (numeric)
;; - Remaining args - Actual CP objects (lists of body/alloc) from above ;; - Remaining args - Actual CP objects (lists of body/alloc) from above
(append (append
(c:tuple/args (c:tuple/args
(_c-compile-args args (_c-compile-args args
@ -858,8 +858,9 @@
(fun (app->fun exp))) (fun (app->fun exp)))
(cond (cond
((ast:lambda? fun) ((ast:lambda? fun)
(let* ((lid (allocate-lambda fun (c-compile-lambda fun trace #t))) ;; TODO: pass in free vars? may be needed to track closures (let* ((lid (allocate-lambda fun (c-compile-lambda fun trace #t)))
;; properly, wait until this comes up in an example ;; TODO: pass in free vars? may be needed to track closures
;; properly, wait until this comes up in an example
(this-cont (string-append "__lambda_" (number->string lid))) (this-cont (string-append "__lambda_" (number->string lid)))
(cgen (cgen
(c-compile-args (c-compile-args
@ -885,7 +886,7 @@
(not (null? (cdr trace))) (not (null? (cdr trace)))
(adbv:direct-rec-call? (adb:get (cdr trace))) (adbv:direct-rec-call? (adb:get (cdr trace)))
(tagged-list? '%closure-ref fun) (tagged-list? '%closure-ref fun)
(equal? (cadr fun) (cdr trace)) ;; Needed? (equal? (cadr fun) (cdr trace)) ; Needed?
(equal? (car args) (cdr trace)) (equal? (car args) (cdr trace))
;; Make sure continuation is not a lambda, because ;; Make sure continuation is not a lambda, because
;; that means a closure may be allocated ;; that means a closure may be allocated
@ -894,14 +895,14 @@
(map (map
(lambda (e) (lambda (e)
(c-compile-exp e append-preamble "" ast-id "" cps?)) (c-compile-exp e append-preamble "" ast-id "" cps?))
(cddr args))) ;; Skip the closure (cddr args))) ; Skip the closure
(cgen-allocs (cgen-allocs
(apply string-append (apply string-append
(map (lambda (a) (c:allocs->str (c:allocs a))) cgen-lis))) (map (lambda (a) (c:allocs->str (c:allocs a))) cgen-lis)))
(parent-fnc (adbv:assigned-value (adb:get (cdr trace)))) (parent-fnc (adbv:assigned-value (adb:get (cdr trace))))
(parent-args (parent-args
(cdr ;; Skip continuation (cdr ; Skip continuation
(ast:lambda-args (ast:lambda-args
(if (pair? parent-fnc) (if (pair? parent-fnc)
(car parent-fnc) (car parent-fnc)
@ -921,9 +922,9 @@
;;(trace:info `(loop ,args ,(cadr args) ,cgen-lis ,parent-args)) ;;(trace:info `(loop ,args ,(cadr args) ,cgen-lis ,parent-args))
(c-code (c-code
(string-append (string-append
cgen-allocs ;(c:allocs->str (c:allocs cgen)) cgen-allocs ; (c:allocs->str (c:allocs cgen))
"\n" "\n"
cgen-body ;; TODO: (c:body cgen) ;; TODO: re-assign function args, longer-term using temp variables cgen-body ; TODO: (c:body cgen) ; TODO: re-assign function args, longer-term using temp variables
"\n" "\n"
"continue;")))) "continue;"))))
@ -945,7 +946,7 @@
(c-code/vars (c-code/vars
(c:body c-fun) (c:body c-fun)
(append (append
(c:allocs c-args*) ;; fun alloc depends upon arg allocs (c:allocs c-args*) ; fun alloc depends upon arg allocs
(list (string-append (list (string-append
(car (c:allocs c-fun)) (car (c:allocs c-fun))
(if (prim/c-var-assign fun) (if (prim/c-var-assign fun)
@ -978,12 +979,12 @@
ast-id ast-id
(car args) (car args)
(number->string (- (cadr args) 1))) (number->string (- (cadr args) 1)))
;"(" ;;"("
;;; TODO: probably not the ideal solution, but works for now ;;; TODO: probably not the ideal solution, but works for now
;"(closureN)" ;;"(closureN)"
;(mangle (car args)) ;; (mangle (car args))
;")->elements[" ;;")->elements["
;(number->string (- (cadr args) 1))"]" ;; (number->string (- (cadr args) 1))"]"
)))) ))))
;; TODO: may not be good enough, closure app could be from an element ;; TODO: may not be good enough, closure app could be from an element
@ -991,7 +992,7 @@
(let* ((cfun (c-compile-args (list (car args)) append-preamble " " cont ast-id trace cps?)) (let* ((cfun (c-compile-args (list (car args)) append-preamble " " cont ast-id trace cps?))
(this-cont (c:body cfun)) (this-cont (c:body cfun))
(cargs (c-compile-args (cdr args) append-preamble " " this-cont ast-id trace cps?)) (cargs (c-compile-args (cdr args) append-preamble " " this-cont ast-id trace cps?))
(raw-cargs (cdddr cargs)) ;; Same as above but with lists instead of appended strings (raw-cargs (cdddr cargs)) ; Same as above but with lists instead of appended strings
(num-cargs (c:num-args cargs))) (num-cargs (c:num-args cargs)))
(cond (cond
((not cps?) ((not cps?)
@ -1003,7 +1004,7 @@
(c:body cargs) (c:body cargs)
");"))) ");")))
(else (else
;;TODO: Consolidate with corresponding %closure code?? ;;TODO: Consolidate with corresponding %closure code??
(set-c-call-arity! (c:num-args cargs)) (set-c-call-arity! (c:num-args cargs))
(let* ((wkf (well-known-lambda (car args))) (let* ((wkf (well-known-lambda (car args)))
(fnc (if wkf (adb:get/default (ast:lambda-id wkf) #f) #f)) (fnc (if wkf (adb:get/default (ast:lambda-id wkf) #f) #f))
@ -1024,21 +1025,21 @@
params)) params))
(args (map car raw-cargs)) (args (map car raw-cargs))
(reassignments (reassignments
;; TODO: may need to detect cases where an arg is reassigned before ;; TODO: may need to detect cases where an arg is reassigned before
;; another one is assigned to that arg's old value, for example: ;; another one is assigned to that arg's old value, for example:
;; a = 1, b = 2, c = a ;; a = 1, b = 2, c = a
;; In this case the code would need to assign to a temporary variable ;; In this case the code would need to assign to a temporary variable
;; ;;
;; Right now we just play it safe and always assign to temporary variables, ;; Right now we just play it safe and always assign to temporary variables,
;; even when we don't need to. I suppose in theory the C compiler can ;; even when we don't need to. I suppose in theory the C compiler can
;; figure that out (??) but it would be cleaner overall if we could here. ;; figure that out (??) but it would be cleaner overall if we could here.
;; Something to consider for the future. ;; Something to consider for the future.
(apply string-append (apply string-append
(map (map
(lambda (param arg) (lambda (param arg)
(cond (cond
;; TODO: with tmps this is not really applicable anymore: ;; TODO: with tmps this is not really applicable anymore:
((equal? param arg) "") ;; No need to reassign ((equal? param arg) "") ; No need to reassign
(else (else
(string-append (string-append
param " = " arg ";\n")))) param " = " arg ";\n"))))
@ -1050,7 +1051,7 @@
(lambda (p tmp) (lambda (p tmp)
(string-append " " p " = " tmp "; ")) (string-append " " p " = " tmp "; "))
params tmp-params)))) params tmp-params))))
;(trace:error `(JAE ,fun ,ast-id ,params ,args (c:num-args cargs))) ;; (trace:error `(JAE ,fun ,ast-id ,params ,args (c:num-args cargs)))
(c-code/vars (c-code/vars
(string-append (string-append
(c:allocs->str (c:allocs cfun) "\n") (c:allocs->str (c:allocs cfun) "\n")
@ -1071,7 +1072,7 @@
((and wkf fnc ((and wkf fnc
*optimize-well-known-lambdas* *optimize-well-known-lambdas*
(adbf:well-known fnc) ;; not really needed (adbf:well-known fnc) ; not really needed
(equal? (adbf:closure-size fnc) 1)) (equal? (adbf:closure-size fnc) 1))
(let* ((lid (ast:lambda-id wkf)) (let* ((lid (ast:lambda-id wkf))
(c-lambda-fnc-str (string-append "__lambda_" (number->string lid))) (c-lambda-fnc-str (string-append "__lambda_" (number->string lid)))
@ -1090,10 +1091,10 @@
(if (> num-cargs 0) "," "") (if (> num-cargs 0) "," "")
(c:body cargs) (c:body cargs)
");")))) ");"))))
;; TODO: here and in other case, if well-known but closure size does not match, use ;; TODO: here and in other case, if well-known but closure size does not match, use
;; other macro to at least call out the __lambda_ function directly. seemed to ;; other macro to at least call out the __lambda_ function directly. seemed to
;; speed up C compile times (let's test that!) ;; speed up C compile times (let's test that!)
;; ;;"#define return_direct_with_clo" n "(td, clo, _fn" args ") { \\\n" ;; "#define return_direct_with_clo" n "(td, clo, _fn" args ") { \\\n"
((and wkf fnc) ((and wkf fnc)
(let* ((lid (ast:lambda-id wkf)) (let* ((lid (ast:lambda-id wkf))
(c-lambda-fnc-str (string-append "__lambda_" (number->string lid)))) (c-lambda-fnc-str (string-append "__lambda_" (number->string lid))))
@ -1137,11 +1138,11 @@
"return_copy(ptr," "return_copy(ptr,"
(c:body cargs) (c:body cargs)
");"))) ");")))
(else ;; CPS, IE normal behavior (else ; CPS, IE normal behavior
(set-c-call-arity! num-cargs) (set-c-call-arity! num-cargs)
;TODO: see corresponding code in %closure-ref that outputs return_closcall. ;; TODO: see corresponding code in %closure-ref that outputs return_closcall.
;need to use (well-known-lambda) to check the ref to see if it is a WKL. ;; need to use (well-known-lambda) to check the ref to see if it is a WKL.
;if so, lookup ast and use cgen-id to map back to emit the lambda_gc_ret there ;; if so, lookup ast and use cgen-id to map back to emit the lambda_gc_ret there
(with-fnc (ast:lambda-id (closure->lam fun)) (lambda (fnc) (with-fnc (ast:lambda-id (closure->lam fun)) (lambda (fnc)
(cond (cond
((and *optimize-well-known-lambdas* ((and *optimize-well-known-lambdas*
@ -1194,16 +1195,16 @@
((equal? 'Cyc-seq fun) ((equal? 'Cyc-seq fun)
(let ((exps (foldr (let ((exps (foldr
(lambda (expr acc) (lambda (expr acc)
;; Join expressions; based on c:append ;; Join expressions; based on c:append
(let ((cp1 (if (ref? expr) (let ((cp1 (if (ref? expr)
; Ignore lone ref to avoid C warning ;; Ignore lone ref to avoid C warning
(c-code/vars "" '()) (c-code/vars "" '())
(c-compile-exp expr append-preamble cont ast-id trace cps?))) (c-compile-exp expr append-preamble cont ast-id trace cps?)))
(cp2 acc)) (cp2 acc))
(c-code/vars (c-code/vars
(let ((cp1-body (c:body cp1))) (let ((cp1-body (c:body cp1)))
(if (zero? (string-length cp1-body)) (if (zero? (string-length cp1-body))
(c:body cp2) ;; Ignore cp1 if necessary (c:body cp2) ; Ignore cp1 if necessary
(string-append cp1-body ";" (c:body cp2)))) (string-append cp1-body ";" (c:body cp2))))
(append (c:allocs cp1) (c:allocs cp2))))) (append (c:allocs cp1) (c:allocs cp2)))))
(c-code "") (c-code "")
@ -1215,7 +1216,7 @@
(c-code/vars (c-code/vars
(string-append (mangle (cadr exp)) " = " (c:body val-exp) ";") (string-append (mangle (cadr exp)) " = " (c:body val-exp) ";")
(c:allocs val-exp))) (c:allocs val-exp)))
;(c-code (string-append (mangle (cadr exp)) " = " (mangle (caddr exp)) ";")) ;; (c-code (string-append (mangle (cadr exp)) " = " (mangle (caddr exp)) ";"))
) )
((equal? 'let fun) ((equal? 'let fun)
(let* ((vars/vals (cadr exp)) (let* ((vars/vals (cadr exp))
@ -1223,10 +1224,10 @@
(vexps (foldr (vexps (foldr
(lambda (var/val acc) (lambda (var/val acc)
(set-use-alloca! #t) ;; Force alloca to ensure safe c stack allocs (set-use-alloca! #t) ;; Force alloca to ensure safe c stack allocs
;; Join expressions; based on c:append ;; Join expressions; based on c:append
(let ((cp1 (c-compile-exp (cadr var/val) append-preamble cont ast-id trace cps?)) (let ((cp1 (c-compile-exp (cadr var/val) append-preamble cont ast-id trace cps?))
(cp2 acc)) (cp2 acc))
(set-use-alloca! #f) ;; Revert flag (set-use-alloca! #f) ; Revert flag
(c-code/vars (c-code/vars
(let ((cp1-body (c:body cp1))) (let ((cp1-body (c:body cp1)))
(string-append cp1-body ";" (c:body cp2))) (string-append cp1-body ";" (c:body cp2)))
@ -1238,12 +1239,12 @@
vars/vals)) vars/vals))
(body-exp (c-compile-exp (body-exp (c-compile-exp
body append-preamble cont ast-id trace cps?))) body append-preamble cont ast-id trace cps?)))
;;(trace:error `(JAE DEBUG body ,body ,vars/vals ,exp)) ;;(trace:error `(JAE DEBUG body ,body ,vars/vals ,exp))
(c:append vexps body-exp))) (c:append vexps body-exp)))
(else (else
(error `(Unsupported function application ,exp))))))) (error `(Unsupported function application ,exp)))))))
; c-compile-if : if-exp -> string ;; c-compile-if : if-exp -> string
(define (c-compile-if exp append-preamble cont ast-id trace cps?) (define (c-compile-if exp append-preamble cont ast-id trace cps?)
(let* ((compile (lambda (exp) (let* ((compile (lambda (exp)
(c-compile-exp exp append-preamble cont ast-id trace cps?))) (c-compile-exp exp append-preamble cont ast-id trace cps?)))
@ -1266,13 +1267,13 @@
(set! *global-inlines* (cons (cons orig-sym inline-sym) *global-inlines*))) (set! *global-inlines* (cons (cons orig-sym inline-sym) *global-inlines*)))
;; Add a global inlinable function that is written in Scheme. ;; Add a global inlinable function that is written in Scheme.
;; This is more challenging than define-c forms since the ;; This is more challenging than define-c forms since the
;; code must be compiled again to work without CPS. ;; code must be compiled again to work without CPS.
;(define *global-inline-scms* '()) ;; (define *global-inline-scms* '())
;(define (add-global-inline-scm-lambda var-sym code) ;; (define (add-global-inline-scm-lambda var-sym code)
; (add-global-inline var-sym ) ;; (add-global-inline var-sym )
; (set! *global-inline-scms* ;; (set! *global-inline-scms*
; (cons (list var-sym code) *global-inline-scms*))) ;; (cons (list var-sym code) *global-inline-scms*)))
;; Global compilation ;; Global compilation
(define *globals* '()) (define *globals* '())
@ -1280,7 +1281,7 @@
(define (global-lambda? global) (cadr global)) (define (global-lambda? global) (cadr global))
(define (global-not-lambda? global) (not (cadr global))) (define (global-not-lambda? global) (not (cadr global)))
(define (add-global var-sym lambda? code) (define (add-global var-sym lambda? code)
;(write `(add-global ,var-sym ,code)) ;; (write `(add-global ,var-sym ,code))
(set! *globals* (cons (list var-sym lambda? code) *globals*))) (set! *globals* (cons (list var-sym lambda? code) *globals*)))
(define (c-compile-global exp append-preamble cont trace) (define (c-compile-global exp append-preamble cont trace)
(let ((var (define->var exp)) (let ((var (define->var exp))
@ -1298,11 +1299,11 @@
(st:add-function! trace var) #t)) (st:add-function! trace var) #t))
;; Add inline global definition also, if applicable ;; Add inline global definition also, if applicable
; (trace:error `(JAE DEBUG ,var ;; (trace:error `(JAE DEBUG ,var
; ,(lambda? body) ;; ,(lambda? body)
; ,(define-c->inline-var exp) ;; ,(define-c->inline-var exp)
; ,(prim:udf? (define-c->inline-var exp)) ;; ,(prim:udf? (define-c->inline-var exp))
; )) ;; ))
(when (and (ast:lambda? body) (when (and (ast:lambda? body)
(prim:udf? (define-c->inline-var exp))) (prim:udf? (define-c->inline-var exp)))
(add-global-inline (add-global-inline
@ -1310,12 +1311,12 @@
(define-c->inline-var exp)) (define-c->inline-var exp))
(add-global (add-global
(define-c->inline-var exp) (define-c->inline-var exp)
#t ;; always a lambda #t ; always a lambda
(c-compile-exp (c-compile-exp
body append-preamble cont body append-preamble cont
(ast:lambda-id body) (ast:lambda-id body)
(st:add-function! trace var) (st:add-function! trace var)
#f ;; inline, so disable CPS on this pass #f ; inline, so disable CPS on this pass
))) )))
(c-code/vars "" (list "")))) (c-code/vars "" (list ""))))
@ -1327,38 +1328,38 @@
'precompiled-lambda)) 'precompiled-lambda))
(lambda-data (lambda-data
`(,precompiled-sym `(,precompiled-sym
,(caddr exp) ;; Args ,(caddr exp) ; Args
,(cadddr exp))) ;; Body ,(cadddr exp))) ; Body
(lid (allocate-lambda #f lambda-data)) (lid (allocate-lambda #f lambda-data))
(total-num-args (total-num-args
(let ((count 1)) ;; Start at 1 because there will be one less comma than args (let ((count 1)) ; Start at 1 because there will be one less comma than args
(string-for-each (string-for-each
(lambda (c) (lambda (c)
(if (equal? #\, c) (set! count (+ count 1)))) (if (equal? #\, c) (set! count (+ count 1))))
(caddr exp)) (caddr exp))
count)) ;; args count)) ; args
;; Subtract "internal" args added for runtime ;; Subtract "internal" args added for runtime
(num-args (num-args
(- total-num-args 4))) (- total-num-args 4)))
;; Is the function also defined inline? ;; Is the function also defined inline?
;(trace:error `(JAE define-c ,exp)) ;; (trace:error `(JAE define-c ,exp))
(cond (cond
((> (length exp) 4) ((> (length exp) 4)
;(trace:error `(JAE define-c inline detected)) ;; (trace:error `(JAE define-c inline detected))
(let ((fnc-sym (let ((fnc-sym
(define-c->inline-var exp))) (define-c->inline-var exp)))
;(trace:error `(JAE define-c inline detected ,fnc-sym)) ;; (trace:error `(JAE define-c inline detected ,fnc-sym))
(add-global-inline (define->var exp) fnc-sym) (add-global-inline (define->var exp) fnc-sym)
(c-compile-raw-global-lambda (c-compile-raw-global-lambda
`(define-c ,fnc-sym ,@(cddddr exp)) `(define-c ,fnc-sym ,@(cddddr exp))
append-preamble append-preamble
cont cont
trace trace
#f)))) ;; Inline this one; CPS will not be used #f)))) ; Inline this one; CPS will not be used
;; Add this define-c ;; Add this define-c
(add-global (add-global
(define->var exp) (define->var exp)
#t ;(lambda? body) #t ; (lambda? body)
(let ((cv-name (mangle (gensym 'c)))) (let ((cv-name (mangle (gensym 'c))))
(c-code/vars (c-code/vars
(string-append "&" cv-name) (string-append "&" cv-name)
@ -1375,24 +1376,24 @@
(define (allocate-symbol sym) (define (allocate-symbol sym)
(if (not (member sym *symbols*)) (if (not (member sym *symbols*))
;(not (Cyc-reserved-symbol? sym))) ;; (not (Cyc-reserved-symbol? sym)))
(set! *symbols* (cons sym *symbols*)))) (set! *symbols* (cons sym *symbols*))))
;; Lambda compilation. ;; Lambda compilation.
;; Lambdas get compiled into procedures that, ;; Lambdas get compiled into procedures that,
;; once given a C name, produce a C function ;; once given a C name, produce a C function
;; definition with that name. ;; definition with that name.
;; These procedures are stored up and eventually ;; These procedures are stored up and eventually
;; emitted. ;; emitted.
; type lambda-id = natural ;; type lambda-id = natural
; num-lambdas : natural ;; num-lambdas : natural
(define num-lambdas 0) (define num-lambdas 0)
; lambdas : alist[lambda-id,string -> string] ;; lambdas : alist[lambda-id,string -> string]
(define lambdas '()) (define lambdas '())
(define inline-lambdas '()) (define inline-lambdas '())
@ -1408,14 +1409,14 @@
(set! lambdas (cons (list id lam ast:lam) lambdas)) (set! lambdas (cons (list id lam ast:lam) lambdas))
(if (equal? cps? '(#f)) (if (equal? cps? '(#f))
(set! inline-lambdas (cons id inline-lambdas))) (set! inline-lambdas (cons id inline-lambdas)))
;(when ast:lam ;; (when ast:lam
; (with-fnc! (ast:lambda-id ast:lam) (lambda (fnc) ;; (with-fnc! (ast:lambda-id ast:lam) (lambda (fnc)
; (adbf:set-cgen-id! fnc id)))) ;; (adbf:set-cgen-id! fnc id))))
id)) id))
; get-lambda : lambda-id -> (symbol -> string) ;; get-lambda : lambda-id -> (symbol -> string)
;(define (get-lambda id) ;; (define (get-lambda id)
; (cdr (assv id lambdas))) ;; (cdr (assv id lambdas)))
(define (lambda->env exp) (define (lambda->env exp)
(let ((formals (ast:lambda-formals->list exp))) (let ((formals (ast:lambda-formals->list exp)))
@ -1423,23 +1424,23 @@
(car formals) (car formals)
'unused))) 'unused)))
; (tmp-ident (if (> (length (lambda-formals->list exp)) 0) ;; (tmp-ident (if (> (length (lambda-formals->list exp)) 0)
; (mangle (if (pair? (lambda->formals exp)) ;; (mangle (if (pair? (lambda->formals exp))
; (car (lambda->formals exp)) ;; (car (lambda->formals exp))
; (lambda->formals exp))) ;; (lambda->formals exp)))
; "")) ;; ""))
; (has-closure? ;; (has-closure?
; (and ;; (and
; (> (string-length tmp-ident) 3) ;; (> (string-length tmp-ident) 3)
; (equal? "self" (substring tmp-ident 0 4)))) ;; (equal? "self" (substring tmp-ident 0 4))))
;; Compute the minimum number of arguments a function expects. ;; Compute the minimum number of arguments a function expects.
;; Note this must be the count before additional closure/CPS arguments ;; Note this must be the count before additional closure/CPS arguments
;; are added, so we need to detect those and not include them. ;; are added, so we need to detect those and not include them.
(define (compute-num-args lam) (define (compute-num-args lam)
(let ((count (ast:lambda-num-args lam))) ;; Current arg count, may be too high (let ((count (ast:lambda-num-args lam))) ; Current arg count, may be too high
(cond (cond
((< count 0) -1) ;; Unlimited ((< count 0) -1) ; Unlimited
(else (else
(let ((formals (ast:lambda-formals->list lam))) (let ((formals (ast:lambda-formals->list lam)))
(- count (- count
@ -1452,9 +1453,9 @@
(num (length (ast:lambda-formals->list exp)))) (num (length (ast:lambda-formals->list exp))))
(cond (cond
((equal? type 'args:varargs) ((equal? type 'args:varargs)
-1) ;; Unlimited -1) ; Unlimited
((equal? type 'args:fixed-with-varargs) ((equal? type 'args:fixed-with-varargs)
(- num 1)) ;; Last arg is optional (- num 1)) ; Last arg is optional
(else (else
num)))) num))))
@ -1488,11 +1489,11 @@
;; Compile a reference to an element of a closure. ;; Compile a reference to an element of a closure.
(define (c-compile-closure-element-ref ast-id var idx) (define (c-compile-closure-element-ref ast-id var idx)
(with-fnc ast-id (lambda (fnc) (with-fnc ast-id (lambda (fnc)
;(trace:info `(c-compile-closure-element-ref ,ast-id ,var ,idx ,fnc)) ;; (trace:info `(c-compile-closure-element-ref ,ast-id ,var ,idx ,fnc))
(cond (cond
((and *optimize-well-known-lambdas* ((and *optimize-well-known-lambdas*
(adbf:well-known fnc) (adbf:well-known fnc)
;(pair? (adbf:all-params fnc)) ;; (pair? (adbf:all-params fnc))
(equal? (adbf:closure-size fnc) 1)) (equal? (adbf:closure-size fnc) 1))
(mangle (car (adbf:all-params fnc)))) (mangle (car (adbf:all-params fnc))))
(else (else
@ -1506,14 +1507,14 @@
(define (find-closure-assigned-var-index! ast-fnc closure-args) (define (find-closure-assigned-var-index! ast-fnc closure-args)
(let ((index 0) (let ((index 0)
(fnc (adb:get/default (ast:lambda-id ast-fnc) #f))) (fnc (adb:get/default (ast:lambda-id ast-fnc) #f)))
;(trace:info `(find-closure-assigned-var-index! ,ast-fnc ,fnc ,closure-args)) ;; (trace:info `(find-closure-assigned-var-index! ,ast-fnc ,fnc ,closure-args))
(cond (cond
((and fnc ((and fnc
(pair? (adbf:assigned-to-var fnc))) (pair? (adbf:assigned-to-var fnc)))
(for-each (for-each
(lambda (arg) (lambda (arg)
(when (and (ref? arg) (member arg (adbf:assigned-to-var fnc))) (when (and (ref? arg) (member arg (adbf:assigned-to-var fnc)))
;(trace:error `(JAE closure for ,(ast:lambda-id ast-fnc) self ref is index ,index)) ;; (trace:error `(JAE closure for ,(ast:lambda-id ast-fnc) self ref is index ,index))
(adbf:set-self-closure-index! fnc index) (adbf:set-self-closure-index! fnc index)
(adb:set! (ast:lambda-id ast-fnc) fnc)) (adb:set! (ast:lambda-id ast-fnc) fnc))
(set! index (+ index 1))) (set! index (+ index 1)))
@ -1545,8 +1546,8 @@
(let ((var (cadr free-var)) (let ((var (cadr free-var))
(idx (number->string (- (caddr free-var) 1)))) (idx (number->string (- (caddr free-var) 1))))
(c-compile-closure-element-ref ast-id var idx) (c-compile-closure-element-ref ast-id var idx)
;(string-append ;; (string-append
; "((closureN)" (mangle var) ")->elements[" idx "]") ;; "((closureN)" (mangle var) ")->elements[" idx "]")
) )
(mangle free-var))) (mangle free-var)))
(closure->fv exp))) ; Note these are not necessarily symbols, but in cc form (closure->fv exp))) ; Note these are not necessarily symbols, but in cc form
@ -1555,19 +1556,19 @@
(use-obj-instead-of-closure? (use-obj-instead-of-closure?
(with-fnc (ast:lambda-id lam) (lambda (fnc) (with-fnc (ast:lambda-id lam) (lambda (fnc)
(and *optimize-well-known-lambdas* (and *optimize-well-known-lambdas*
(adbf:well-known fnc) ;; Only optimize well-known functions (adbf:well-known fnc) ; Only optimize well-known functions
;(equal? (length free-vars) 1) ;; Sanity check ;; (equal? (length free-vars) 1) ; Sanity check
(equal? (adbf:closure-size fnc) 1))))) ;; From closure conv (equal? (adbf:closure-size fnc) 1))))) ; From closure conv
(macro? (assoc (st:->var trace) (get-macros))) (macro? (assoc (st:->var trace) (get-macros)))
(call/cc? (and (equal? (car trace) "scheme/base.sld") (call/cc? (and (equal? (car trace) "scheme/base.sld")
(equal? (st:->var trace) 'call/cc))) (equal? (st:->var trace) 'call/cc)))
(num-args-str (num-args-str
(if call/cc? (if call/cc?
"1" ;; Special case, need to change runtime checks for call/cc "1" ; Special case, need to change runtime checks for call/cc
(number->string (compute-num-args lam)))) (number->string (compute-num-args lam))))
(create-object (lambda () (create-object (lambda ()
;JAE - this is fine, now need to handle other side (actually reading the value without a closure obj ;; JAE - this is fine, now need to handle other side (actually reading the value without a closure obj
;(trace:error `(create-object free-vars ,free-vars ,(car free-vars))) ;; (trace:error `(create-object free-vars ,free-vars ,(car free-vars)))
(c-code/vars (c-code/vars
(car free-vars) (car free-vars)
(list)))) (list))))
@ -1608,14 +1609,14 @@
"(" cv-name ", " "(" cv-name ", "
;; NOTE: ;; NOTE:
;; Hopefully will not cause issues with varargs when casting to ;; Hopefully will not cause issues with varargs when casting to
;; generic function type below. Works fine in gcc, not sure if ;; generic function type below. Works fine in gcc, not sure if
;; this is portable to other compilers though ;; this is portable to other compilers though
"(function_type)__lambda_" (number->string lid) "(function_type)__lambda_" (number->string lid)
(if (> (length free-vars) 0) "," "") (if (> (length free-vars) 0) "," "")
(string-join free-vars ", ") (string-join free-vars ", ")
");" ");"
cv-name ".num_args = " (number->string (compute-num-args lam)) ";"))))) cv-name ".num_args = " (number->string (compute-num-args lam)) ";")))))
;(trace:info (list 'JAE-DEBUG trace macro?)) ;; (trace:info (list 'JAE-DEBUG trace macro?))
(cond (cond
(use-obj-instead-of-closure? (use-obj-instead-of-closure?
(create-object)) (create-object))
@ -1630,7 +1631,7 @@
(create-nclosure) (create-nclosure)
(create-mclosure)))))))) (create-mclosure))))))))
; c-compile-formals : list[symbol] -> string ;; c-compile-formals : list[symbol] -> string
(define (c-compile-formals formals type) (define (c-compile-formals formals type)
(cond (cond
((and (not (pair? formals)) ((and (not (pair? formals))
@ -1650,7 +1651,7 @@
(else (else
"")))))) ""))))))
; c-compile-lambda : lamda-exp (string -> void) -> (string -> string) ;; c-compile-lambda : lamda-exp (string -> void) -> (string -> string)
(define (c-compile-lambda exp trace cps?) (define (c-compile-lambda exp trace cps?)
(let* ((preamble "") (let* ((preamble "")
(append-preamble (lambda (s) (append-preamble (lambda (s)
@ -1681,7 +1682,7 @@
(or (or
(adbf:calls-self? (adb:get/default (ast:lambda-id exp) (adb:make-fnc))) (adbf:calls-self? (adb:get/default (ast:lambda-id exp) (adb:make-fnc)))
;; Older direct recursive logic ;; Older direct recursive logic
(and (not has-closure?) ;; Only top-level functions for now (and (not has-closure?) ; Only top-level functions for now
(pair? trace) (pair? trace)
(not (null? (cdr trace))) (not (null? (cdr trace)))
(adbv:direct-rec-call? (adb:get (cdr trace)))))) (adbv:direct-rec-call? (adb:get (cdr trace))))))
@ -1695,7 +1696,7 @@
formals)) formals))
(env-closure (lambda->env exp)) (env-closure (lambda->env exp))
(body (c-compile-exp (body (c-compile-exp
(car (ast:lambda-body exp)) ;; car ==> assume single expr in lambda body after CPS (car (ast:lambda-body exp)) ; car ==> assume single expr in lambda body after CPS
append-preamble append-preamble
(mangle env-closure) (mangle env-closure)
(ast:lambda-id exp) (ast:lambda-id exp)
@ -1711,9 +1712,9 @@
(if (ast:lambda-varargs? exp) (if (ast:lambda-varargs? exp)
;; Load varargs from C stack into Scheme list ;; Load varargs from C stack into Scheme list
(string-append (string-append
; DEBUGGING: ;; DEBUGGING:
;"printf(\"%d %d\\n\", argc, " ;; "printf(\"%d %d\\n\", argc, "
; (number->string (length (ast:lambda-formals->list exp))) ");" ;; (number->string (length (ast:lambda-formals->list exp))) ");"
"load_varargs(" "load_varargs("
(mangle (ast:lambda-varargs-var exp)) (mangle (ast:lambda-varargs-var exp))
", " ", "
@ -1727,7 +1728,7 @@
(c:serialize (c:serialize
(c:append (c:append
(c-code (c-code
;; Only trace when entering initial defined function ;; Only trace when entering initial defined function
(cond (cond
(has-closure? (has-closure?
(if has-loop? "\n while(1) {\n" "")) (if has-loop? "\n while(1) {\n" ""))
@ -1884,7 +1885,7 @@
*symbols*) *symbols*)
;; Emit lambdas: ;; Emit lambdas:
; Print the prototypes: ;; Print the prototypes:
(for-each (for-each
(lambda (l) (lambda (l)
(cond (cond
@ -1916,7 +1917,7 @@
(emit "") (emit "")
; Print GC return wrappers ;; Print GC return wrappers
(for-each (for-each
(lambda (l) (lambda (l)
(let ((ast (caddr l))) (let ((ast (caddr l)))
@ -1930,7 +1931,7 @@
(when (and *optimize-well-known-lambdas* (when (and *optimize-well-known-lambdas*
(adbf:well-known fnc) (adbf:well-known fnc)
(equal? (adbf:closure-size fnc) 1)) (equal? (adbf:closure-size fnc) 1))
;(trace:error `(JAE ,(car l) ,l ,fnc)) ;; (trace:error `(JAE ,(car l) ,l ,fnc))
(let* ((params-str (cdadr l)) (let* ((params-str (cdadr l))
(args-str (args-str
(string-join (string-join
@ -1957,7 +1958,7 @@
"}")))))))) "}"))))))))
lambdas) lambdas)
; Print the definitions: ;; Print the definitions:
(for-each (for-each
(lambda (l) (lambda (l)
(cond (cond
@ -1983,7 +1984,7 @@
(emit ((caadr l) (string-append "__lambda_" (number->string (car l)))))))) (emit ((caadr l) (string-append "__lambda_" (number->string (car l))))))))
lambdas) lambdas)
; Emit inlinable function list ;; Emit inlinable function list
(cond (cond
((not program?) ((not program?)
(emit* "void c_" (lib:name->string lib-name) "_inlinable_lambdas(void *data, int argc, closure _, object cont){ ") (emit* "void c_" (lib:name->string lib-name) "_inlinable_lambdas(void *data, int argc, closure _, object cont){ ")
@ -2024,7 +2025,7 @@
(emit* "(((closure)cont)->fn)(data, 1, cont, NULL);")) (emit* "(((closure)cont)->fn)(data, 1, cont, NULL);"))
(emit* " } ")))) (emit* " } "))))
; Emit entry point ;; Emit entry point
(cond (cond
(program? (program?
(emit "static void c_entry_pt_first_lambda(void *data, int argc, closure cont, object value);") (emit "static void c_entry_pt_first_lambda(void *data, int argc, closure cont, object value);")
@ -2035,7 +2036,7 @@
(emit "static void c_entry_pt(data, argc, env,cont) void *data; int argc; closure env,cont; { ")) (emit "static void c_entry_pt(data, argc, env,cont) void *data; int argc; closure env,cont; { "))
(else (else
(emit* "void c_" (lib:name->string lib-name) "_entry_pt_first_lambda(data, argc, cont,value) void *data; int argc; closure cont; object value;{ ") (emit* "void c_" (lib:name->string lib-name) "_entry_pt_first_lambda(data, argc, cont,value) void *data; int argc; closure cont; object value;{ ")
; DEBUG (emit (string-append "printf(\"init " (lib:name->string lib-name) "\\n\");")) ;; DEBUG (emit (string-append "printf(\"init " (lib:name->string lib-name) "\\n\");"))
)) ))
;; Set global-changed indicator ;; Set global-changed indicator
@ -2085,15 +2086,15 @@
;; Expose list of inlinable lambda functions ;; Expose list of inlinable lambda functions
(when (not program?) (when (not program?)
(let ( ;(cvar-sym (mangle (gensym 'cvar))) (let ( ;; (cvar-sym (mangle (gensym 'cvar)))
(pair-sym (mangle (gensym 'pair))) (pair-sym (mangle (gensym 'pair)))
(clo-sym (mangle (gensym 'clo))) (clo-sym (mangle (gensym 'clo)))
(fnc (string-append (fnc (string-append
"c_" (lib:name->string lib-name) "_inlinable_lambdas"))) "c_" (lib:name->string lib-name) "_inlinable_lambdas")))
(emits* (emits*
" mclosure0(" clo-sym ", " fnc "); " " mclosure0(" clo-sym ", " fnc "); "
; " make_cvar(" cvar-sym ;; " make_cvar(" cvar-sym
; ", (object *)&" fnc ");" ;; ", (object *)&" fnc ");"
) )
(emits* (emits*
"make_pair(" pair-sym ", find_or_add_symbol(\"" fnc "make_pair(" pair-sym ", find_or_add_symbol(\"" fnc
@ -2169,7 +2170,7 @@
"(" this-clo ".fn)(data, 0, &" this-clo ", &" this-clo ");") "(" this-clo ".fn)(data, 0, &" this-clo ", &" this-clo ");")
(emit "}") (emit "}")
(emit "static void c_entry_pt_first_lambda(void *data, int argc, closure cont, object value) {") (emit "static void c_entry_pt_first_lambda(void *data, int argc, closure cont, object value) {")
; DEBUG (emit (string-append "printf(\"init first lambda\\n\");")) ;; DEBUG (emit (string-append "printf(\"init first lambda\\n\");"))
(emit compiled-program) (emit compiled-program)
(emit ";"))) (emit ";")))
(else (else
@ -2187,8 +2188,8 @@
"\");") "\");")
(if (null? lib-pass-thru-exports) (if (null? lib-pass-thru-exports)
(emit* " c_" (lib:name->string lib-name) "_entry_pt_first_lambda(data, argc, cont,value);") (emit* " c_" (lib:name->string lib-name) "_entry_pt_first_lambda(data, argc, cont,value);")
; GC to ensure objects are moved when exporting exports. ;; GC to ensure objects are moved when exporting exports.
; Otherwise there will be broken hearts :( ;; therwise there will be broken hearts :(
(emit* (emit*
" mclosure1(clo, c_" (lib:name->string lib-name) "_entry_pt_first_lambda, ((closure1_type *)cont)->element);\n" " mclosure1(clo, c_" (lib:name->string lib-name) "_entry_pt_first_lambda, ((closure1_type *)cont)->element);\n"
" object buf[1]; buf[0] = cont;\n" " object buf[1]; buf[0] = cont;\n"
@ -2237,7 +2238,7 @@
*primitives*)))) *primitives*))))
(cond-expand (cond-expand
(chicken (chicken
(pp code fp)) ;; CHICKEN pretty-print (pp code fp)) ; CHICKEN pretty-print
(else (else
(write code fp))))) (write code fp)))))