guile-prescheme/ps-compiler/prescheme/primop/c-vector.scm

;;; Ported from Scheme 48 1.9.  See file COPYING for notices and license.
;;;
;;; Port Author: Andrew Whatson
;;;
;;; Original Authors: Richard Kelsey, Timo Harter
;;;
;;; (make-vector size init)

(define-module (ps-compiler prescheme primop c-vector)
  #:use-module (ice-9 format)
  #:use-module (ps-compiler node node)
  #:use-module (ps-compiler node node-util)
  #:use-module (ps-compiler prescheme c)
  #:use-module (ps-compiler prescheme c-call)
  #:use-module (ps-compiler prescheme c-decl)
  #:use-module (ps-compiler prescheme primop c-primop)
  #:use-module (ps-compiler prescheme record)
  #:use-module (ps-compiler prescheme type)
  #:use-module (ps-compiler util util))

(define-c-generator make-vector #t
  (lambda (call port indent)
    (let ((type (node-type call)))
      (write-c-coercion type port)
      (format port "malloc(sizeof(")
      (display-c-type (pointer-type-to type) #f port)
      (format port ") * ")
      (c-value (call-arg call 0) port)
      (format port ")"))))

(define-c-generator vector-ref #t
  (lambda (call port indent)
    (generate-c-vector-ref (call-arg call 0) (call-arg call 1) port)))

(define (generate-c-vector-ref vector index port)
  (display "*(" port)
  (c-value vector port)
  (display " + " port)
  (c-value index port)
  (writec port #\)))

(define-c-generator vector-set! #t
  (lambda (call port indent)
    (generate-c-vector-set (call-arg call 1)
         (call-arg call 2)
         (call-arg call 3)
         port indent)))

(define (generate-c-vector-set vector index value port indent)
  (indent-to port indent)
  (generate-c-vector-ref vector index port)
  (display " = " port)
  (c-value value port)
  (writec port #\;))

(define-c-generator make-string #t
  (lambda (call port indent)
    ;; calloc is used as a hack to get a zero at the end
    (format port "(char *)calloc( 1, 1 + ")
    (c-value (call-arg call 0) port)
    (format port ")")))

(define-c-generator string-length #t
  (lambda (call port indent)
    (format port "strlen((char *) ")
    (c-value (call-arg call 0) port)
    (format port ")")))

(define-c-generator string-ref #t
  (lambda (call port indent)
    (generate-c-vector-ref (call-arg call 0) (call-arg call 1) port)))

(define-c-generator string-set! #f
  (lambda (call port indent)
    (generate-c-vector-set (call-arg call 1)
         (call-arg call 2)
         (call-arg call 3)
         port indent)))

(define-c-generator make-record #f
  (lambda (call port indent)
    (let ((type (get-record-type (literal-value (call-arg call 0)))))
      (write-c-coercion (make-pointer-type type) port)
      (format port "malloc(sizeof(struct ")
      (write-c-identifier (record-type-name type) port)
      (format port "))"))))

(define-c-generator record-ref #t
  (lambda (call port indent)
    (generate-c-record-ref (call-arg call 0)
         (call-arg call 1)
         (call-arg call 2)
         port)))

(define (generate-c-record-ref record type field port)
  (let ((field (get-record-type-field (literal-value type)
              (literal-value field))))
    (c-value record port)
    (display "->" port)
    (write-c-identifier (record-field-name field) port)))

(define-c-generator record-set! #t
  (lambda (call port indent)
    (generate-c-record-set (call-arg call 1)
         (call-arg call 2)
         (call-arg call 3)
         (call-arg call 4)
         port indent)))

(define (generate-c-record-set record value type field port indent)
  (indent-to port indent)
  (generate-c-record-ref record type field port)
  (display " = " port)
  (c-value value port)
  (writec port #\;))

(define-c-generator allocate-memory #t
  (lambda (call port indent)
    (write-c-coercion type/address port)
    (format port "malloc(")
    (c-value (call-arg call 0) port)
    (format port ")")))

(define-c-generator deallocate #t
  (lambda (call port indent)
    (format port "free(")
    (c-value (call-arg call 0) port)
    (format port ")")))

(define-c-generator deallocate-memory #t
  (lambda (call port indent)
    (format port "free(")
    (c-value (call-arg call 0) port)
    (format port ")")))

(define-c-generator address+ #t
  (lambda (call port indent)
    (simple-c-primop "+" call port)))

(define-c-generator address-difference #t
  (lambda (call port indent)
    (simple-c-primop "-" call port)))

(define-c-generator address= #t
  (lambda (call port indent)
    (simple-c-primop "==" call port)))

(define-c-generator address< #t
  (lambda (call port indent)
    (simple-c-primop "<" call port)))

(define-c-generator address->integer #t
  (lambda (call port indent)
    (format port "((long) ")
    (c-value (call-arg call 0) port)
    (format port ")")))

(define-c-generator integer->address #t
  (lambda (call port indent)
    (format port "((char *) ")
    (c-value (call-arg call 0) port)
    (format port ")")))

(define-c-generator copy-memory! #t
  (lambda (call port indent)
    (format port "memmove((void *)")
    (c-value (call-arg call 1) port)
    (format port ", (void *)")
    (c-value (call-arg call 0) port)
    (format port ",")
    (c-value (call-arg call 2) port)
    (format port ")")))

(define-c-generator memory-equal? #t
  (lambda (call port indent)
    (format port "(!memcmp((void *)")
    (c-value (call-arg call 1) port)
    (format port ", (void *)")
    (c-value (call-arg call 0) port)
    (format port ",")
    (c-value (call-arg call 2) port)
    (format port "))")))

(define-c-generator byte-ref #t
  (lambda (call port indent)
    (generate-c-memory-ref "unsigned char" (call-arg call 0) port)))

(define-c-generator word-ref #t
  (lambda (call port indent)
    (generate-c-memory-ref "long" (call-arg call 0) port)))

(define-c-generator flonum-ref #t
  (lambda (call port indent)
    (generate-c-memory-ref "double" (call-arg call 0) port)))

(define (generate-c-memory-ref type pointer port)
  (format port "*((~A *) " type)
  (c-value pointer port)
  (writec port #\)))

(define-c-generator byte-set! #t
  (lambda (call port indent)
    (generate-c-memory-set! "unsigned char"
          (call-arg call 1)
          (call-arg call 2)
          port
          indent)))

(define-c-generator word-set! #t
  (lambda (call port indent)
    (generate-c-memory-set! "long"
          (call-arg call 1)
          (call-arg call 2)
          port
          indent)))

(define-c-generator flonum-set! #t
  (lambda (call port indent)
    (generate-c-memory-set! "double"
          (call-arg call 1)
          (call-arg call 2)
          port
          indent)))

(define (generate-c-memory-set! type pointer value port indent)
  (indent-to port indent)
  (generate-c-memory-ref type pointer port)
  (display " = " port)
  (format port "(~A) (" type)
  (c-value value port)
  (writec port #\))
  (writec port #\;))

(define-c-generator char-pointer->string #t
  (lambda (call port indent)
    (format port "((char *)")
    (c-value (call-arg call 0) port)
    (format port ")")))

(define-c-generator char-pointer->nul-terminated-string #t
  (lambda (call port indent)
    (format port "((char *)")
    (c-value (call-arg call 0) port)
    (format port ")")))

(define-c-generator computed-goto #f
  (lambda (call port indent)
    (generate-c-switch call port indent)))

(define (generate-c-switch call port indent)
  (let ((size (call-exits call))
        (parent-id (lambda-id (node-parent call))))
    (display "\n#ifdef USE_DIRECT_THREADING\n" port)
    (write-goto-jump-table call port indent)
    (indent-to port indent)
    (format port "goto *Jtable~D[" parent-id)
    (c-value (call-arg call (+ size 1)) port)
    (display "];\n#else\n" port)
    (indent-to port indent)
    (display "switch (" port)
    (c-value (call-arg call (+ size 1)) port)
    (display ") {\n#endif\n" port)
    (let ((indent (+ indent 2)))
      (do ((i 0 (+ i 1))
     (labels (literal-value (call-arg call size)) (cdr labels)))
    ((>= i size))
  (display "\n#ifdef USE_DIRECT_THREADING" port)
  (for-each (lambda (l)
        (format port "\nJlabel~D_~D:" parent-id l))
      (car labels))
  (display "\n#else\n" port)
  (for-each (lambda (l)
        (indent-to port indent)
        (format port "case ~D : " l))
      (car labels))
  (display "\n#endif\n" port)
  (write-c-switch-case (call-arg call i) port indent)))
    (display "\n#ifndef USE_DIRECT_THREADING\n" port)
    (indent-to port indent)
    (display "}" port)
    (display "\n#endif\n" port)))

(define (write-c-switch-case node port indent)
  (indent-to port (+ indent 2))
  (writec port #\{)
  (write-c-block (lambda-body node) port (+ indent 2))
  (display "\n#ifndef USE_DIRECT_THREADING\n" port)
  (indent-to port (+ indent 2))
  (display "break;\n#endif\n" port))

(define (write-goto-jump-table call port indent)
  (let ((size (call-exits call))
        (parent-id (lambda-id (node-parent call))) ;; use the id of the parent lambda to identify this computed-goto
        (max-value 0))                             ;; find the highest case value in the computed goto
    (for-each
      (lambda (labels)
        (for-each
          (lambda (l) (if (> l max-value) (set! max-value l)))
          labels))
      (literal-value (call-arg call size)))
    (indent-to port indent)
    (format port "static void *Jtable~D[] = { " parent-id)
    (do ((i 0 (+ i 1))) ((>= i max-value))
      (format port "&&Jlabel~D_~D, " parent-id i)
      (if (equal? 0 (modulo i 6)) ;; make the output more readable
        (indent-to port (+ indent 2))))
    (format port "&&Jlabel~D_~D };" parent-id max-value)))