mirror of
https://github.com/justinethier/cyclone.git
synced 2025-07-08 05:27:33 +02:00
Merge branch 'foreign-dev'
This commit is contained in:
Justin Ethier
commit
8a115df516
7 changed files with 494 additions and 59 deletions
2
Makefile
2
Makefile
|
|
@ -78,6 +78,7 @@ install : libs install-libs install-includes install-bin
|
|||
$(INSTALL) -m0644 scheme/cyclone/*.scm $(DESTDIR)$(DATADIR)/scheme/cyclone
|
||||
$(INSTALL) -m0644 libs/cyclone/test.meta $(DESTDIR)$(DATADIR)/cyclone
|
||||
$(INSTALL) -m0644 libs/cyclone/match.meta $(DESTDIR)$(DATADIR)/cyclone
|
||||
$(INSTALL) -m0644 libs/cyclone/foreign.meta $(DESTDIR)$(DATADIR)/cyclone
|
||||
$(INSTALL) -m0644 scheme/cyclone/*.o $(DESTDIR)$(DATADIR)/scheme/cyclone
|
||||
$(INSTALL) -m0755 scheme/cyclone/*.so $(DESTDIR)$(DATADIR)/scheme/cyclone
|
||||
$(INSTALL) -m0644 libs/cyclone/*.sld $(DESTDIR)$(DATADIR)/cyclone
|
||||
|
|
@ -271,6 +272,7 @@ bootstrap : icyc libs
|
|||
cp scheme/cyclone/macros.c $(BOOTSTRAP_DIR)/scheme/cyclone
|
||||
cp libs/cyclone/match.c $(BOOTSTRAP_DIR)/cyclone
|
||||
cp libs/cyclone/match.meta $(BOOTSTRAP_DIR)/cyclone
|
||||
cp libs/cyclone/foreign.meta $(BOOTSTRAP_DIR)/cyclone
|
||||
cp scheme/cyclone/pretty-print.c $(BOOTSTRAP_DIR)/scheme/cyclone
|
||||
cp scheme/cyclone/primitives.c $(BOOTSTRAP_DIR)/scheme/cyclone
|
||||
cp scheme/cyclone/transforms.c $(BOOTSTRAP_DIR)/scheme/cyclone
|
||||
|
|
|
|||
|
|
@ -57,6 +57,7 @@ Cyclone supports the following [Scheme Requests for Implementation (SRFI)](http:
|
|||
These libraries are provided as Cyclone-specific extensions:
|
||||
|
||||
- [`cyclone concurrent`](api/cyclone/concurrent.md) - A helper library for writing concurrent code.
|
||||
- [`cyclone foreign`](api/cyclone/foreign.md) - Provides a convenient interface for integrating with C code.
|
||||
- [`cyclone match`](api/cyclone/match.md) - A hygienic pattern matcher based on Alex Shinn's portable `match.scm`.
|
||||
- [`cyclone test`](api/cyclone/test.md) - A unit testing framework ported from `(chibi test)`.
|
||||
- [`scheme cyclone array-list`](api/scheme/cyclone/array-list.md)
|
||||
|
|
|
|||
72
docs/api/cyclone/foreign.md
Normal file
72
docs/api/cyclone/foreign.md
Normal file
|
|
@ -0,0 +1,72 @@
|
|||
# Foreign Library
|
||||
|
||||
The `(cyclone foreign)` provides a convenient interface for integrating with C code. It is based in concept on the `(chicken foreign)` module from CHICKEN Scheme. Similarly to that module, this library manipulates the C code directly before it is compiled to a native binary. It is not possible to call these forms at runtime.
|
||||
|
||||
# Overview
|
||||
|
||||
- [`c-code`](#c-code)
|
||||
- [`c-value`](#c-value)
|
||||
- [`c-define`](#c-define)
|
||||
- [`c-define-type`](#c-define-type)
|
||||
|
||||
## c-code
|
||||
|
||||
*Syntax*
|
||||
|
||||
(c-code CODE ...)
|
||||
|
||||
Insert C code directly into the compiled program. Each `CODE` parameter must be a string containing C code.
|
||||
|
||||
## c-value
|
||||
|
||||
*Syntax*
|
||||
|
||||
(c-value CODE TYPE)
|
||||
|
||||
Generate code that takes the C code specified by the string `CODE` and converts it to a Scheme object of type `TYPE`.
|
||||
|
||||
## c-define
|
||||
|
||||
*Syntax*
|
||||
|
||||
(c-define SCM-FUNC RETURN-TYPE C-FUNC TYPE ...)
|
||||
|
||||
Define a Scheme function `SCM-FUNC` returning an object of type `RETURN-TYPE`. The function will call C function specified by the string `C-FUNC` passed parameters of type specified by any `TYPE` arguments.
|
||||
|
||||
For example, to define a function that calls `strlen`:
|
||||
|
||||
(c-define scm-strlen int "strlen" string)
|
||||
|
||||
Note that these definitions are introduced at the top-level.
|
||||
|
||||
## c-define-type
|
||||
|
||||
*Syntax*
|
||||
|
||||
(c-define-type NAME TYPE (ARG-CONVERT (RET-CONVERT)))
|
||||
|
||||
Define a custom type with symbol `NAME` that is an alias of type `TYPE`. It is also possible to specify conversion functions `ARG-CONVERT` and `RET-CONVERT` to convert to/from this custom type.
|
||||
|
||||
EG, to define a type that consists of integers in Scheme and strings in C:
|
||||
|
||||
(c-define-type string-as-integer string number->string string->number)
|
||||
|
||||
|
||||
# Type Specifiers
|
||||
|
||||
The following built-in specifiers may be used as a `TYPE` for forms in this module.
|
||||
|
||||
Scheme | C
|
||||
------ | -
|
||||
`int` | `int`
|
||||
`integer` | `int`
|
||||
`bool` | `int`
|
||||
`char` | `int`
|
||||
`string` | `char *`
|
||||
`symbol` | `const char *`
|
||||
`bytevector` | `char *`
|
||||
`float` | `double`
|
||||
`double` | `double`
|
||||
`bignum` | `mp_int`
|
||||
`opaque` | `void *`
|
||||
|
||||
282
libs/cyclone/foreign.sld
Normal file
282
libs/cyclone/foreign.sld
Normal file
|
|
@ -0,0 +1,282 @@
|
|||
;;;; Cyclone Scheme
|
||||
;;;; https://github.com/justinethier/cyclone
|
||||
;;;;
|
||||
;;;; Copyright (c) 2014-2019, Justin Ethier
|
||||
;;;; All rights reserved.
|
||||
;;;;
|
||||
;;;; This module makes it easier to interface directly with C code using the FFI.
|
||||
;;;;
|
||||
(define-library (cyclone foreign)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme eval)
|
||||
(scheme cyclone util)
|
||||
;(scheme write) ;; TODO: debugging only!
|
||||
)
|
||||
(export
|
||||
c-code
|
||||
c-value
|
||||
c-define
|
||||
c->scm
|
||||
scm->c
|
||||
c-define-type
|
||||
)
|
||||
(begin
|
||||
;;
|
||||
;;(eval `(define *foreign-types* (list)))
|
||||
|
||||
;; (c-define-type name type (pack (unpack)))
|
||||
(define-syntax c-define-type
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let ((name (cadr expr))
|
||||
(type (cddr expr)))
|
||||
;;
|
||||
;; Custom foreign types are all stored within the global environment
|
||||
;; used by `eval` at compile time. We play a few tricks using exception
|
||||
;; handlers to check if variables are defined in that environment.
|
||||
;;
|
||||
(unless (eval '(with-handler (lambda X #f) *foreign-types*))
|
||||
;(write "no foreign type table" (current-error-port))
|
||||
;(newline (current-error-port))
|
||||
(eval `(define *foreign-types* (make-hash-table))))
|
||||
(eval `(hash-table-set! *foreign-types* (quote ,name) (quote ,type)))
|
||||
#f))))
|
||||
|
||||
(define-syntax c-value
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((code-arg (cadr expr))
|
||||
(type-arg (caddr expr))
|
||||
(c-type (eval `(with-handler
|
||||
(lambda X #f)
|
||||
(hash-table-ref *foreign-types* (quote ,type-arg))
|
||||
)))
|
||||
(c-ret-convert #f)
|
||||
)
|
||||
(when c-type
|
||||
;(write `(defined c type ,c-type) (current-error-port))
|
||||
;(newline (current-error-port))
|
||||
(set! type-arg (car c-type))
|
||||
(if (= 3 (length c-type))
|
||||
(set! c-ret-convert (caddr c-type))))
|
||||
|
||||
;(for-each
|
||||
; (lambda (arg)
|
||||
; (if (not (string? arg))
|
||||
; (error "c-value" "Invalid argument: string expected, received " arg)))
|
||||
; (cdr expr))
|
||||
|
||||
(if c-ret-convert
|
||||
`((lambda () (,c-ret-convert (Cyc-foreign-value ,code-arg ,(symbol->string type-arg)))))
|
||||
`((lambda () (Cyc-foreign-value ,code-arg ,(symbol->string type-arg))))
|
||||
)
|
||||
))))
|
||||
|
||||
(define-syntax c-code
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(for-each
|
||||
(lambda (arg)
|
||||
(if (not (string? arg))
|
||||
(error "c-code" "Invalid argument: string expected, received " arg)))
|
||||
(cdr expr))
|
||||
`(Cyc-foreign-code ,@(cdr expr)))))
|
||||
|
||||
;; Unbox scheme object
|
||||
;;
|
||||
;; scm->c :: string -> symbol -> string
|
||||
;;
|
||||
;; Inputs:
|
||||
;; - code - C variable used to reference the Scheme object
|
||||
;; - type - Data type of the Scheme object
|
||||
;; Returns:
|
||||
;; - C code used to unbox the data
|
||||
;(define (scm->c code type)
|
||||
(define-syntax scm->c
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let ((code (cadr expr))
|
||||
(type (caddr expr)))
|
||||
`(case ,type
|
||||
((int integer)
|
||||
(string-append "obj_obj2int(" ,code ")"))
|
||||
((double float)
|
||||
(string-append "double_value(" ,code ")"))
|
||||
((bignum bigint)
|
||||
(string-append "bignum_value(" ,code ")"))
|
||||
((bool)
|
||||
(string-append "(" ,code " == boolean_f)"))
|
||||
((char)
|
||||
(string-append "obj_obj2char(" ,code ")"))
|
||||
((string)
|
||||
(string-append "string_str(" ,code ")"))
|
||||
((symbol)
|
||||
(string-append "symbol_desc(" ,code ")"))
|
||||
((bytevector)
|
||||
(string-append "(((bytevector_type *)" ,code ")->data)"))
|
||||
((opaque)
|
||||
(string-append "opaque_ptr(" ,code ")"))
|
||||
(else
|
||||
(error "scm->c unable to convert scheme object of type " ,type)))))))
|
||||
|
||||
;; Box C object, basically the meat of (c-value)
|
||||
;;
|
||||
;; c->scm :: string -> symbol -> string
|
||||
;;
|
||||
;; Inputs:
|
||||
;; - C expression
|
||||
;; - Data type used to box the data
|
||||
;; Returns:
|
||||
;; - Allocation code?
|
||||
;; - C code
|
||||
(define-syntax c->scm
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let ((code (cadr expr))
|
||||
(type (caddr expr)))
|
||||
`(case (if (string? ,type)
|
||||
(string->symbol ,type)
|
||||
,type)
|
||||
((int integer)
|
||||
(cons
|
||||
""
|
||||
(string-append "obj_int2obj(" ,code ")")))
|
||||
((float double)
|
||||
(let ((var (mangle (gensym 'var))))
|
||||
(cons
|
||||
(string-append
|
||||
"make_double(" var ", " ,code ");")
|
||||
(string-append "&" var)
|
||||
)))
|
||||
((bool)
|
||||
(cons
|
||||
""
|
||||
(string-append "(" ,code " == 0 ? boolean_f : boolean_t)")))
|
||||
((char)
|
||||
(cons
|
||||
""
|
||||
(string-append "obj_char2obj(" ,code ")")))
|
||||
((string)
|
||||
(let ((var (mangle (gensym 'var))))
|
||||
(cons
|
||||
(string-append
|
||||
"make_utf8_string(data," var ", " ,code ");")
|
||||
(string-append "&" var)
|
||||
)))
|
||||
((bytevector)
|
||||
(let ((var (mangle (gensym 'var))))
|
||||
(cons
|
||||
(string-append
|
||||
"make_empty_bytevector(data," var ");"
|
||||
var "->data = " ,code ";")
|
||||
(string-append "&" var)
|
||||
)))
|
||||
((opaque)
|
||||
(let ((var (mangle (gensym 'var))))
|
||||
(cons
|
||||
(string-append
|
||||
"make_c_opaque(data," var ", " ,code ");")
|
||||
(string-append "&" var)
|
||||
)))
|
||||
(else
|
||||
(error "c->scm unable to convert C object of type " ,type)))))))
|
||||
|
||||
(define-syntax c-define
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((scm-fnc (cadr expr))
|
||||
(scm-fnc-wrapper (gensym 'scm-fnc))
|
||||
(c-fnc (cadddr expr))
|
||||
(rv-type (caddr expr))
|
||||
;; boolean - Are we returning a custom (user-defined) type?
|
||||
(rv-cust-type (eval `(with-handler
|
||||
(lambda X #f)
|
||||
(hash-table-ref *foreign-types* (quote ,rv-type))
|
||||
)))
|
||||
;; boolean - Does the custom return type have a conversion function?
|
||||
(rv-cust-convert
|
||||
(if (and rv-cust-type (= 3 (length rv-cust-type)))
|
||||
(caddr rv-cust-type)
|
||||
#f))
|
||||
(arg-types (cddddr expr))
|
||||
(arg-cust-convert #f)
|
||||
(arg-syms/unbox
|
||||
(map
|
||||
(lambda (type)
|
||||
(let ((var (mangle (gensym 'arg)))
|
||||
(arg-cust-type (eval `(with-handler
|
||||
(lambda X #f)
|
||||
(hash-table-ref *foreign-types* (quote ,type))
|
||||
)))
|
||||
)
|
||||
(cons
|
||||
var
|
||||
(scm->c
|
||||
var
|
||||
(cond
|
||||
(arg-cust-type
|
||||
(if (> (length arg-cust-type) 1)
|
||||
(set! arg-cust-convert #t))
|
||||
(car arg-cust-type))
|
||||
(else
|
||||
type)))
|
||||
;(string-append "string_str(" var ")")
|
||||
)))
|
||||
arg-types))
|
||||
(returns
|
||||
(c->scm
|
||||
(string-append
|
||||
c-fnc "(" (string-join (map cdr arg-syms/unbox) ",") ")")
|
||||
(if rv-cust-type
|
||||
(car rv-cust-type)
|
||||
rv-type)))
|
||||
(return-alloc (car returns))
|
||||
(return-expr (cdr returns))
|
||||
(args (string-append
|
||||
"(void *data, int argc, closure _, object k "
|
||||
(apply string-append
|
||||
(map
|
||||
(lambda (sym/unbox)
|
||||
(string-append ", object " (car sym/unbox)))
|
||||
arg-syms/unbox))
|
||||
")"))
|
||||
(body
|
||||
(string-append
|
||||
return-alloc
|
||||
"return_closcall1(data, k, " return-expr ");"))
|
||||
)
|
||||
(cond
|
||||
;; If there are any custom type conversion functions we need to create
|
||||
;; a wrapper function in Scheme to perform those conversions
|
||||
((or rv-cust-convert arg-cust-convert)
|
||||
(if (not rv-cust-convert)
|
||||
(set! rv-cust-convert 'begin))
|
||||
(let ((arg-syms
|
||||
(map
|
||||
(lambda (type)
|
||||
(let* ((sym (gensym 'arg))
|
||||
(arg-cust-type (eval `(with-handler
|
||||
(lambda X #f)
|
||||
(hash-table-ref *foreign-types* (quote ,type)))))
|
||||
(pass-arg
|
||||
(if (and arg-cust-type
|
||||
(> (length arg-cust-type) 1))
|
||||
`(,(cadr arg-cust-type) ,sym)
|
||||
sym)) )
|
||||
(cons
|
||||
sym ;; Arg
|
||||
pass-arg)));; Passing arg to internal func
|
||||
arg-types)))
|
||||
`(begin
|
||||
(define-c ,scm-fnc-wrapper ,args ,body)
|
||||
(define (,scm-fnc ,@(map car arg-syms))
|
||||
(,rv-cust-convert
|
||||
(,scm-fnc-wrapper ,@(map cdr arg-syms)))))))
|
||||
;; Simpler case, just define the function directly
|
||||
(else
|
||||
`(define-c ,scm-fnc ,args ,body)))
|
||||
))))
|
||||
|
||||
)
|
||||
)
|
||||
57
libs/test-foreign.scm
Normal file
57
libs/test-foreign.scm
Normal file
|
|
@ -0,0 +1,57 @@
|
|||
;; Unit tests for the (cyclone foreign) module.
|
||||
;;
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(cyclone test)
|
||||
(cyclone foreign)
|
||||
(scheme cyclone util)
|
||||
(scheme cyclone pretty-print)
|
||||
)
|
||||
|
||||
(define *my-global* #f)
|
||||
|
||||
(c-define-type my-string string)
|
||||
(c-define-type my-integer integer)
|
||||
(c-define-type my-integer-as-string integer string->number number->string)
|
||||
(c-define-type string-as-integer string number->string string->number)
|
||||
|
||||
(test-group "foreign value"
|
||||
(test 3 (c-value "1 + 2" integer))
|
||||
(test 4 (c-value "2 + 2" my-integer))
|
||||
(test "4" (c-value "2 + 2" my-integer-as-string))
|
||||
(test "test" (c-value "\"test\"" string))
|
||||
)
|
||||
|
||||
(test-group "foreign code"
|
||||
(test #f *my-global*)
|
||||
(c-code
|
||||
"printf(\"test %d %d \\n\", 1, 2);"
|
||||
"printf(\"test %d %d %d\\n\", 1, 2, 3);"
|
||||
"__glo__85my_91global_85 = boolean_t;")
|
||||
(test #t *my-global*)
|
||||
(set! *my-global* 1)
|
||||
(test 1 *my-global*)
|
||||
)
|
||||
|
||||
;; Must be top-level
|
||||
|
||||
;TODO: support custom types (arg and ret) for c-define.
|
||||
; Also need to be able to support arg/ret convert optional type arguments
|
||||
; Would need to generate scheme wrappers to handle these conversions
|
||||
|
||||
(c-define scm-strlen my-integer "strlen" string)
|
||||
(c-define scm-strlen-str my-integer-as-string "strlen" string)
|
||||
;(c-define scm-strlen "int" "strlen" string)
|
||||
(c-define scm-strlend double "strlen" string)
|
||||
(c-define scm-strlen2 integer "strlen" my-string)
|
||||
(c-define scm-strlen3 integer "strlen" string-as-integer)
|
||||
|
||||
(test-group "foreign lambda"
|
||||
(test 15 (scm-strlen "testing 1, 2, 3"))
|
||||
(test 15 (scm-strlen2 "testing 1, 2, 3"))
|
||||
(test 15.0 (scm-strlend "testing 1, 2, 3"))
|
||||
(test "15" (scm-strlen-str "testing 1, 2, 3"))
|
||||
(test 3 (scm-strlen3 255))
|
||||
)
|
||||
(test-exit)
|
||||
|
|
@ -13,6 +13,7 @@
|
|||
(scheme eval)
|
||||
(scheme inexact)
|
||||
(scheme write)
|
||||
(cyclone foreign)
|
||||
(scheme cyclone primitives)
|
||||
(scheme cyclone transforms)
|
||||
(scheme cyclone ast)
|
||||
|
|
@ -283,12 +284,12 @@
|
|||
;;; Compilation routines.
|
||||
|
||||
;; Return generated code that also requests allocation of C variables on stack
|
||||
(define (c-code/vars str cvars)
|
||||
(define (c:code/vars str cvars)
|
||||
(list str
|
||||
cvars))
|
||||
|
||||
;; Return generated code with no C variables allocated on the stack
|
||||
(define (c-code str) (c-code/vars str (list)))
|
||||
(define (c:code str) (c:code/vars str (list)))
|
||||
|
||||
;; Append arg count to a C code pair
|
||||
(define (c:tuple/args cp num-args)
|
||||
|
|
@ -327,12 +328,12 @@
|
|||
c-allocs))
|
||||
|
||||
(define (c:append cp1 cp2)
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(string-append (c:body cp1) (c:body cp2))
|
||||
(append (c:allocs cp1) (c:allocs cp2))))
|
||||
|
||||
(define (c:append/prefix prefix cp1 cp2)
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(string-append prefix (c:body cp1) (c:body cp2))
|
||||
(append (c:allocs cp1) (c:allocs cp2))))
|
||||
|
||||
|
|
@ -390,7 +391,7 @@
|
|||
((const? exp) (c-compile-const exp (alloca? ast-id trace) #f)) ;; TODO: OK to hardcode immutable to false here??
|
||||
((prim? exp)
|
||||
;; TODO: this needs to be more refined, probably w/a lookup table
|
||||
(c-code (string-append "primitive_" (mangle exp))))
|
||||
(c:code (string-append "primitive_" (mangle exp))))
|
||||
((ref? exp) (c-compile-ref exp))
|
||||
((quote? exp) (c-compile-quote exp (alloca? ast-id trace)))
|
||||
((if? exp) (c-compile-if exp append-preamble cont ast-id trace cps?))
|
||||
|
|
@ -436,7 +437,7 @@
|
|||
(num-args 0)
|
||||
(create-cons
|
||||
(lambda (cvar a b)
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(string-append
|
||||
c-make-macro "(" cvar "," (c:body a) "," (c:body b) ");"
|
||||
(c-set-immutable-field cvar use-alloca immutable))
|
||||
|
|
@ -445,7 +446,7 @@
|
|||
(lambda (args)
|
||||
(cond
|
||||
((null? args)
|
||||
(c-code "NULL"))
|
||||
(c:code "NULL"))
|
||||
((not (pair? args))
|
||||
(c-compile-const args use-alloca immutable))
|
||||
(else
|
||||
|
|
@ -455,7 +456,7 @@
|
|||
(c-compile-const (car args) use-alloca immutable)
|
||||
(_c-compile-scalars (cdr args)))))
|
||||
(set! num-args (+ 1 num-args))
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(string-append addr-op cvar-name)
|
||||
(append
|
||||
(c:allocs cell)
|
||||
|
|
@ -484,7 +485,7 @@
|
|||
(let ((idx-code (c-compile-const (vector-ref exp i) use-alloca immutable)))
|
||||
(loop
|
||||
(+ i 1)
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
;; The vector's C variable
|
||||
(c:body code)
|
||||
;; Allocations
|
||||
|
|
@ -498,7 +499,7 @@
|
|||
";"))))))))))
|
||||
(cond
|
||||
((zero? len)
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(string-append addr-op cvar-name) ; Code is just the variable name
|
||||
(list ; Allocate empty vector
|
||||
(string-append
|
||||
|
|
@ -506,7 +507,7 @@
|
|||
(c-set-immutable-field cvar-name use-alloca immutable)))))
|
||||
(else
|
||||
(let ((code
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(string-append addr-op cvar-name) ; Code body is just var name
|
||||
(list ; Allocate the vector
|
||||
(string-append
|
||||
|
|
@ -532,7 +533,7 @@
|
|||
(let ((byte-val (number->string (bytevector-u8-ref exp i))))
|
||||
(loop
|
||||
(+ i 1)
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
;; The bytevector's C variable
|
||||
(c:body code)
|
||||
;; Allocations
|
||||
|
|
@ -545,7 +546,7 @@
|
|||
";"))))))))))
|
||||
(cond
|
||||
((zero? len)
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(string-append addr-op cvar-name) ; Code is just the variable name
|
||||
(list ; Allocate empty vector
|
||||
(string-append
|
||||
|
|
@ -554,7 +555,7 @@
|
|||
))))
|
||||
(else
|
||||
(let ((code
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(string-append addr-op cvar-name) ; Code body is just var name
|
||||
(list ; Allocate the vector
|
||||
(string-append
|
||||
|
|
@ -572,7 +573,7 @@
|
|||
(use-alloca
|
||||
(let ((tmp-name (mangle (gensym 'tmp)))
|
||||
(blen (number->string (string-byte-length exp))))
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(string-append "" cvar-name) ; Code is just the variable name
|
||||
(list ; Allocate integer on the C stack
|
||||
(string-append
|
||||
|
|
@ -595,7 +596,7 @@
|
|||
use-alloca immutable)
|
||||
)))))
|
||||
(else
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(string-append "&" cvar-name) ; Code is just the variable name
|
||||
(list ; Allocate integer on the C stack
|
||||
(string-append
|
||||
|
|
@ -623,7 +624,7 @@
|
|||
(define (c-compile-const exp use-alloca immutable)
|
||||
(cond
|
||||
((null? exp)
|
||||
(c-code "NULL"))
|
||||
(c:code "NULL"))
|
||||
((pair? exp)
|
||||
(c-compile-scalars exp use-alloca immutable))
|
||||
((vector? exp)
|
||||
|
|
@ -635,7 +636,7 @@
|
|||
(num2str (cond
|
||||
(else
|
||||
(number->string exp)))))
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(string-append "" cvar-name) ; Code is just the variable name
|
||||
(list ; Allocate pointer on the C stack
|
||||
(string-append
|
||||
|
|
@ -656,14 +657,14 @@
|
|||
(inum (num2str (imag-part exp)))
|
||||
(addr-op (if use-alloca "" "&"))
|
||||
(c-make-macro (if use-alloca "alloca_complex_num" "make_complex_num")))
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(string-append addr-op cvar-name) ; Code is just the variable name
|
||||
(list ; Allocate on the C stack
|
||||
(string-append
|
||||
c-make-macro "(" cvar-name ", " rnum ", " inum ");")))))
|
||||
((and (integer? exp)
|
||||
(exact? exp))
|
||||
(c-code (string-append "obj_int2obj("
|
||||
(c:code (string-append "obj_int2obj("
|
||||
(number->string exp) ")")))
|
||||
((real? exp)
|
||||
(let ((cvar-name (mangle (gensym 'c)))
|
||||
|
|
@ -676,22 +677,22 @@
|
|||
(number->string exp))))
|
||||
(addr-op (if use-alloca "" "&"))
|
||||
(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
|
||||
(list ; Allocate on the C stack
|
||||
(string-append
|
||||
c-make-macro "(" cvar-name ", " num2str ");")))))
|
||||
((boolean? exp)
|
||||
(c-code (string-append
|
||||
(c:code (string-append
|
||||
(if exp "boolean_t" "boolean_f"))))
|
||||
((char? exp)
|
||||
(c-code (string-append "obj_char2obj("
|
||||
(c:code (string-append "obj_char2obj("
|
||||
(number->string (char->integer exp)) ")")))
|
||||
((string? exp)
|
||||
(c-compile-string exp use-alloca immutable))
|
||||
((symbol? exp)
|
||||
(allocate-symbol exp)
|
||||
(c-code (string-append "quote_" (mangle exp))))
|
||||
(c:code (string-append "quote_" (mangle exp))))
|
||||
(else
|
||||
(error "unknown constant: " exp))))
|
||||
|
||||
|
|
@ -783,7 +784,7 @@
|
|||
(c-var-assign
|
||||
(lambda (type)
|
||||
(let ((cv-name (mangle (gensym 'c))))
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(string-append
|
||||
(if (or (prim:cont? p)
|
||||
(equal? (prim/c-var-assign p) "object")
|
||||
|
|
@ -830,7 +831,7 @@
|
|||
;; the logic
|
||||
;;
|
||||
(let ((cv-name (mangle (gensym 'c))))
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(if (or (prim:allocates-object? p use-alloca?)
|
||||
(prim->c-func-uses-alloca? p use-alloca?))
|
||||
cv-name ; Already a pointer
|
||||
|
|
@ -838,7 +839,7 @@
|
|||
(list
|
||||
(string-append c-func "(" cv-name tdata-comma tdata)))))
|
||||
(else
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(string-append c-func "(" tdata tptr-comma tptr)
|
||||
(list tptr-decl))))))
|
||||
|
||||
|
|
@ -869,7 +870,7 @@
|
|||
|
||||
;; c-compile-ref : ref-exp -> string
|
||||
(define (c-compile-ref exp)
|
||||
(c-code
|
||||
(c:code
|
||||
(if (member exp *global-syms*)
|
||||
(cgen:mangle-global exp)
|
||||
(mangle exp))))
|
||||
|
|
@ -882,7 +883,7 @@
|
|||
(lambda (args append-preamble prefix cont)
|
||||
(cond
|
||||
((not (pair? args))
|
||||
(c-code ""))
|
||||
(c:code ""))
|
||||
(else
|
||||
;; (trace:debug `(c-compile-args ,(car args)))
|
||||
(let ((cp (c-compile-exp (car args)
|
||||
|
|
@ -929,7 +930,7 @@
|
|||
cps?))
|
||||
(num-cargs (c:num-args cgen)))
|
||||
(set-c-call-arity! num-cargs)
|
||||
(c-code
|
||||
(c:code
|
||||
(string-append
|
||||
(c:allocs->str (c:allocs cgen))
|
||||
"return_direct" (number->string num-cargs)
|
||||
|
|
@ -978,7 +979,7 @@
|
|||
parent-args
|
||||
cgen-lis))))
|
||||
;;(trace:info `(loop ,args ,(cadr args) ,cgen-lis ,parent-args))
|
||||
(c-code
|
||||
(c:code
|
||||
(string-append
|
||||
cgen-allocs ; (c:allocs->str (c:allocs cgen))
|
||||
"\n"
|
||||
|
|
@ -986,6 +987,18 @@
|
|||
"\n"
|
||||
"continue;"))))
|
||||
|
||||
((eq? 'Cyc-foreign-code fun)
|
||||
(c:code/vars
|
||||
(string-append
|
||||
"")
|
||||
args))
|
||||
|
||||
((eq? 'Cyc-foreign-value fun)
|
||||
(let ((kons (c->scm (car args) (cadr args))))
|
||||
(c:code/vars
|
||||
(cdr kons)
|
||||
(list (car kons)))))
|
||||
|
||||
((prim? fun)
|
||||
(let* ((c-fun
|
||||
(c-compile-prim fun cont ast-id))
|
||||
|
|
@ -997,7 +1010,7 @@
|
|||
(number->string num-args)
|
||||
(if (> num-args 0) "," "")))
|
||||
(c-args* (if (prim:arg-count? fun)
|
||||
(c:append (c-code num-args-str) c-args)
|
||||
(c:append (c:code num-args-str) c-args)
|
||||
c-args)))
|
||||
;; Emit symbol when mutating global variables, so we can look
|
||||
;; up the cvar
|
||||
|
|
@ -1016,7 +1029,7 @@
|
|||
|
||||
(if (prim/cvar? fun)
|
||||
;; Args need to go with alloc function
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(c:body c-fun)
|
||||
(append
|
||||
(c:allocs c-args*) ; fun alloc depends upon arg allocs
|
||||
|
|
@ -1042,12 +1055,12 @@
|
|||
(and (prim:udf? fun)
|
||||
(zero? num-args)))
|
||||
c-fun
|
||||
(c:append c-fun (c-code ", "))))
|
||||
(c:append c-fun (c:code ", "))))
|
||||
c-args*)
|
||||
(c-code ")")))))
|
||||
(c:code ")")))))
|
||||
|
||||
((equal? '%closure-ref fun)
|
||||
(c-code (apply string-append (list
|
||||
(c:code (apply string-append (list
|
||||
(c-compile-closure-element-ref
|
||||
ast-id
|
||||
(car args)
|
||||
|
|
@ -1069,7 +1082,7 @@
|
|||
(num-cargs (c:num-args cargs)))
|
||||
(cond
|
||||
((not cps?)
|
||||
(c-code
|
||||
(c:code
|
||||
(string-append
|
||||
(c:allocs->str (c:allocs cfun) "\n")
|
||||
(c:allocs->str (c:allocs cargs) "\n")
|
||||
|
|
@ -1125,7 +1138,7 @@
|
|||
(string-append " " p " = " tmp "; "))
|
||||
params tmp-params))))
|
||||
;; (trace:error `(JAE ,fun ,ast-id ,params ,args (c:num-args cargs)))
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(string-append
|
||||
(c:allocs->str (c:allocs cfun) "\n")
|
||||
(c:allocs->str (c:allocs cargs) "\n")
|
||||
|
|
@ -1150,7 +1163,7 @@
|
|||
(let* ((lid (ast:lambda-id wkf))
|
||||
(c-lambda-fnc-str (string-append "__lambda_" (number->string lid)))
|
||||
(c-lambda-fnc-gc-ret-str (string-append "__lambda_gc_ret_" (number->string lid))))
|
||||
(c-code
|
||||
(c:code
|
||||
(string-append
|
||||
(c:allocs->str (c:allocs cfun) "\n")
|
||||
(c:allocs->str (c:allocs cargs) "\n")
|
||||
|
|
@ -1171,7 +1184,7 @@
|
|||
((and wkf fnc)
|
||||
(let* ((lid (ast:lambda-id wkf))
|
||||
(c-lambda-fnc-str (string-append "__lambda_" (number->string lid))))
|
||||
(c-code
|
||||
(c:code
|
||||
(string-append
|
||||
(c:allocs->str (c:allocs cfun) "\n")
|
||||
(c:allocs->str (c:allocs cargs) "\n")
|
||||
|
|
@ -1184,7 +1197,7 @@
|
|||
(c:body cargs)
|
||||
");"))))
|
||||
(else
|
||||
(c-code
|
||||
(c:code
|
||||
(string-append
|
||||
(c:allocs->str (c:allocs cfun) "\n")
|
||||
(c:allocs->str (c:allocs cargs) "\n")
|
||||
|
|
@ -1204,7 +1217,7 @@
|
|||
(num-cargs (c:num-args cargs)))
|
||||
(cond
|
||||
((not cps?)
|
||||
(c-code
|
||||
(c:code
|
||||
(string-append
|
||||
(c:allocs->str (c:allocs cfun) "\n")
|
||||
(c:allocs->str (c:allocs cargs) "\n")
|
||||
|
|
@ -1224,7 +1237,7 @@
|
|||
(let* ((lid (ast:lambda-id (closure->lam fun)))
|
||||
(c-lambda-fnc-str (string-append "__lambda_" (number->string lid)))
|
||||
(c-lambda-fnc-gc-ret-str (string-append "__lambda_gc_ret_" (number->string lid))))
|
||||
(c-code
|
||||
(c:code
|
||||
(string-append
|
||||
(c:allocs->str (c:allocs cfun) "\n")
|
||||
(c:allocs->str (c:allocs cargs) "\n")
|
||||
|
|
@ -1241,7 +1254,7 @@
|
|||
((adbf:well-known fnc)
|
||||
(let* ((lid (ast:lambda-id (closure->lam fun)))
|
||||
(c-lambda-fnc-str (string-append "__lambda_" (number->string lid))))
|
||||
(c-code
|
||||
(c:code
|
||||
(string-append
|
||||
(c:allocs->str (c:allocs cfun) "\n")
|
||||
(c:allocs->str (c:allocs cargs) "\n")
|
||||
|
|
@ -1254,7 +1267,7 @@
|
|||
(c:body cargs)
|
||||
");"))))
|
||||
(else
|
||||
(c-code
|
||||
(c:code
|
||||
(string-append
|
||||
(c:allocs->str (c:allocs cfun) "\n")
|
||||
(c:allocs->str (c:allocs cargs) "\n")
|
||||
|
|
@ -1271,25 +1284,25 @@
|
|||
;; Join expressions; based on c:append
|
||||
(let ((cp1 (if (ref? expr)
|
||||
;; Ignore lone ref to avoid C warning
|
||||
(c-code/vars "" '())
|
||||
(c:code/vars "" '())
|
||||
(c-compile-exp expr append-preamble cont ast-id trace cps?)))
|
||||
(cp2 acc))
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(let ((cp1-body (c:body cp1)))
|
||||
(if (zero? (string-length cp1-body))
|
||||
(c:body cp2) ; Ignore cp1 if necessary
|
||||
(string-append cp1-body ";" (c:body cp2))))
|
||||
(append (c:allocs cp1) (c:allocs cp2)))))
|
||||
(c-code "")
|
||||
(c:code "")
|
||||
args)))
|
||||
exps))
|
||||
((equal? 'Cyc-local-set! fun)
|
||||
;:(trace:error `(JAE DEBUG Cyc-local-set ,exp))
|
||||
(let ((val-exp (c-compile-exp (caddr exp) append-preamble cont ast-id trace cps?)))
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(string-append (mangle (cadr exp)) " = " (c:body 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)
|
||||
(let* ((vars/vals (cadr exp))
|
||||
|
|
@ -1301,14 +1314,14 @@
|
|||
(let ((cp1 (c-compile-exp (cadr var/val) append-preamble cont ast-id trace cps?))
|
||||
(cp2 acc))
|
||||
(set-use-alloca! #f) ; Revert flag
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(let ((cp1-body (c:body cp1)))
|
||||
(string-append cp1-body ";" (c:body cp2)))
|
||||
(append
|
||||
(list (string-append "object " (mangle (car var/val)) ";"))
|
||||
(c:allocs cp1)
|
||||
(c:allocs cp2)))))
|
||||
(c-code "")
|
||||
(c:code "")
|
||||
vars/vals))
|
||||
(body-exp (c-compile-exp
|
||||
body append-preamble cont ast-id trace cps?)))
|
||||
|
|
@ -1324,7 +1337,7 @@
|
|||
(test (compile (if->condition exp)))
|
||||
(then (compile (if->then exp)))
|
||||
(els (compile (if->else exp))))
|
||||
(c-code (string-append
|
||||
(c:code (string-append
|
||||
(c:allocs->str (c:allocs test) " ")
|
||||
"if( (boolean_f != "
|
||||
(c:body test)
|
||||
|
|
@ -1392,7 +1405,7 @@
|
|||
#f ; inline, so disable CPS on this pass
|
||||
)))
|
||||
|
||||
(c-code/vars "" (list ""))))
|
||||
(c:code/vars "" (list ""))))
|
||||
|
||||
(define (c-compile-raw-global-lambda exp append-preamble cont trace . cps?)
|
||||
(let* ((precompiled-sym
|
||||
|
|
@ -1434,14 +1447,14 @@
|
|||
(define->var exp)
|
||||
#t ; (lambda? body)
|
||||
(let ((cv-name (mangle (gensym 'c))))
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(string-append "&" cv-name)
|
||||
(list
|
||||
(string-append "mclosure0(" cv-name ", (function_type)__lambda_"
|
||||
(number->string lid) ");" cv-name ".num_args = "
|
||||
(number->string num-args)
|
||||
";")))))
|
||||
(c-code/vars "" (list ""))))
|
||||
(c:code/vars "" (list ""))))
|
||||
|
||||
;; Symbol compilation
|
||||
|
||||
|
|
@ -1642,7 +1655,7 @@
|
|||
(create-object (lambda ()
|
||||
;; 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)))
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(car free-vars)
|
||||
(list))))
|
||||
(create-nclosure (lambda ()
|
||||
|
|
@ -1700,7 +1713,7 @@
|
|||
(use-obj-instead-of-closure?
|
||||
(create-object))
|
||||
(else
|
||||
(c-code/vars
|
||||
(c:code/vars
|
||||
(if (and use-alloca?
|
||||
(> (length free-vars) 0))
|
||||
cv-name
|
||||
|
|
@ -1806,7 +1819,7 @@
|
|||
"") ; No varargs, skip
|
||||
(c:serialize
|
||||
(c:append
|
||||
(c-code
|
||||
(c:code
|
||||
;; Only trace when entering initial defined function
|
||||
(cond
|
||||
(has-closure?
|
||||
|
|
|
|||
|
|
@ -89,6 +89,8 @@
|
|||
Cyc-stderr
|
||||
Cyc-list
|
||||
Cyc-if
|
||||
Cyc-foreign-code
|
||||
Cyc-foreign-value
|
||||
Cyc-fast-plus
|
||||
Cyc-fast-sub
|
||||
Cyc-fast-mul
|
||||
|
|
@ -238,6 +240,8 @@
|
|||
(Cyc-stdin 0 0)
|
||||
(Cyc-stderr 0 0)
|
||||
(Cyc-if 3 3)
|
||||
(Cyc-foreign-code 1 #f)
|
||||
(Cyc-foreign-value 2 2)
|
||||
(Cyc-fast-plus 2 2)
|
||||
(Cyc-fast-sub 2 2)
|
||||
(Cyc-fast-mul 2 2)
|
||||
|
|
@ -529,6 +533,8 @@
|
|||
((eq? p 'Cyc-stderr) "Cyc_stderr")
|
||||
((eq? p 'Cyc-list) "Cyc_list")
|
||||
((eq? p 'Cyc-if) "Cyc_if")
|
||||
((eq? p 'Cyc-foreign-code) "UNDEF")
|
||||
((eq? p 'Cyc-foreign-value) "UNDEF")
|
||||
((eq? p 'Cyc-fast-plus) "Cyc_fast_sum")
|
||||
((eq? p 'Cyc-fast-sub) "Cyc_fast_sub")
|
||||
((eq? p 'Cyc-fast-mul) "Cyc_fast_mul")
|
||||
|
|
@ -701,6 +707,8 @@
|
|||
(or
|
||||
(memq p '(
|
||||
Cyc-list
|
||||
Cyc-foreign-code
|
||||
Cyc-foreign-value
|
||||
Cyc-fast-plus
|
||||
Cyc-fast-sub
|
||||
Cyc-fast-mul
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue