From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Matt Wette Newsgroups: gmane.lisp.guile.user Subject: fun with wayland Date: Sun, 5 Feb 2023 11:05:11 -0800 Message-ID: <7e5725e9-4800-05f8-1157-761158effbcc@gmail.com> Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8; format=flowed Content-Transfer-Encoding: 8bit Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="16941"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:102.0) Gecko/20100101 Thunderbird/102.4.2 To: Guile User Original-X-From: guile-user-bounces+guile-user=m.gmane-mx.org@gnu.org Sun Feb 05 20:05:44 2023 Return-path: Envelope-to: guile-user@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1pOkKd-00048f-To for guile-user@m.gmane-mx.org; Sun, 05 Feb 2023 20:05:44 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1pOkKF-0007wI-CV; Sun, 05 Feb 2023 14:05:19 -0500 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1pOkKE-0007vr-Ns for guile-user@gnu.org; Sun, 05 Feb 2023 14:05:18 -0500 Original-Received: from mail-pj1-x102c.google.com ([2607:f8b0:4864:20::102c]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1pOkKC-0004aZ-Jd for guile-user@gnu.org; Sun, 05 Feb 2023 14:05:18 -0500 Original-Received: by mail-pj1-x102c.google.com with SMTP id pj3so9717365pjb.1 for ; Sun, 05 Feb 2023 11:05:15 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20210112; h=content-transfer-encoding:subject:from:to:content-language :user-agent:mime-version:date:message-id:from:to:cc:subject:date :message-id:reply-to; bh=FJSeY0FqRfIIX0HkNNPrcsaKUM6vVBJNN9RpCBHr280=; b=DbtHb79wMC5leNUAHS5Gxl3Dwzhxlev+lDATcEXZfKoRJOeWxEFvzOOwaMcEt8U2UX 4CuqJf6Ep1Z7FhlTBRiNS6ZlsefocLL1AEH/SJGEkjt1GIna0SYnQr9zMBEw9HfFNAzo HxbPEC2vJbH1apTvMrC5ts5dZ4VVhSE/IoSE65NSvmeQ/Bx20GlPKIxQZWK1p3SdyXNb dkDsi1tA6OLAkLlNW32exjcEcSxP/H5tJBHf57cGLGO/bsA0uAV87pEx9nsHPEBOk66h dujLNb2V4aZVzow9NO3reql9WQ5oSCxdb7EWwufRDBBLZ3NhyIOb+pR3gu95PkcwKLl+ +yzQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=content-transfer-encoding:subject:from:to:content-language :user-agent:mime-version:date:message-id:x-gm-message-state:from:to :cc:subject:date:message-id:reply-to; bh=FJSeY0FqRfIIX0HkNNPrcsaKUM6vVBJNN9RpCBHr280=; b=UEqfJz33HwqN3N3xUT/FLpcVR50lOrelmuKHJHNBquCv8b3CcP/RCGNC2wim6TMQvK EM/C6eyvpZ5YV+txjHE/+IhiqN3GiYxAXJwzm20ApYsZrxG8ZGSmgF0xBjOxmbX6DhC7 Tf7tWYs7kbQPuSkA5z0NyVVbGePP7Z1pgW9/dz33kh1wq1/TTKNcZbSYg7enS9zLMaiZ wuvSGKu5tXGGgBZ5ZgVByJ5FshpzVFb18b2Qkhk9llssa585+L8SFM30aqWMZDCmlrcD itAZKhIN4BioY/c/ufVOxZ+aMT1jpMqMhhDjzK1w/L947r1Nik+Acm8Mnq8bo9s8OVss RuDA== X-Gm-Message-State: AO0yUKVUB5wlvflaj1iMyFq74eE856UhEx0tUAoz6hz8QIXQbigibFGF FSo/9hKUuu/pf9CxcXyONFlD6tnz944= X-Google-Smtp-Source: AK7set/6YInVG9M95088oSfiFhnAjbdpbES2uvxqNOeZT1EKR/7kMMGbJBM7Y40EnA9ZMqU4YCRAsA== X-Received: by 2002:a17:903:32c3:b0:196:a07d:7a9c with SMTP id i3-20020a17090332c300b00196a07d7a9cmr21540835plr.28.1675623914112; Sun, 05 Feb 2023 11:05:14 -0800 (PST) Original-Received: from [192.168.2.157] (64-52-138-37.championbroadband.com. [64.52.138.37]) by smtp.gmail.com with ESMTPSA id q16-20020a170902dad000b00186cf82717fsm5208280plx.165.2023.02.05.11.05.13 for (version=TLS1_3 cipher=TLS_AES_128_GCM_SHA256 bits=128/128); Sun, 05 Feb 2023 11:05:13 -0800 (PST) Content-Language: en-US Received-SPF: pass client-ip=2607:f8b0:4864:20::102c; envelope-from=matt.wette@gmail.com; helo=mail-pj1-x102c.google.com X-Spam_score_int: -20 X-Spam_score: -2.1 X-Spam_bar: -- X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001, RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: guile-user@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: General Guile related discussions List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-user-bounces+guile-user=m.gmane-mx.org@gnu.org Original-Sender: guile-user-bounces+guile-user=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.lisp.guile.user:18886 Archived-At: I finally got my Wayland demo in guile working.  I thought I'd share some bits. (I started with creating FFI to libwayland, but with all the callbacks it was not worth it.) Wayland is a display server for Linux (and others?), meant to replace X11. It uses UNIX socket I/O between the "compositor" (i.e., server) and clients. I have written  a client app without using libwayland: I've coded down to the socket protocol in Guile Scheme. Summary: 1) I created sendmsg/recvmsg! wrappers for Guile, in C.  This allows me    to send file descriptors as shared buffer references to the server. 2) I am using my proposed mmap wrapper for Guile, in C, to create a file-    mapped shared drawing. 3) I created a "scanner" program in Guile that converts protocol specs    (e.g., wayland.xml) to scheme. 4) I created "sender", "receiver" and "monitor" tasks within Fibers to    run the client app 5) I used my ffi-helper generated code to use cairo for drawing. prototype code is located at https://github.com/mwette/guile-wl-play Here are some snippets: ;; auto-generated by "scanner" from wayland.xml: (define-public encode-wl_display:sync   (lambda (obj-id bv ix callback)     (define (encode-body)       (bytevector-u32-native-set! bv (+ ix 8) callback)       (values (+ ix 12) #f))     (call-with-values       encode-body       (lambda (msg-size control)         (bytevector-u32-native-set! bv ix obj-id)         (bytevector-u16-native-set! bv (+ ix 6) msg-size)         (bytevector-u16-native-set! bv (+ ix 4) 0)         (values msg-size control))))) ;; dispatch routine to handle events from socket (define (dispatch obj-id opcode bv ix cm)   (let* ((dec-vec (vector-ref object-decoders-vec obj-id))          (decoder (and (vector-ref dec-vec opcode)))          (hlr-vec (vector-ref object-handlers-vec obj-id))          (handler (and (vector-ref hlr-vec opcode))))     (if (and decoder handler)         (call-with-values (lambda () (decoder obj-id bv ix cm)) handler)         (begin           (sferr "dispatch: missing decoder or handler: id=~S op=~S\n"                  obj-id opcode)           (sferr "  dec-vec?=~S decoder?=~S hlr-vec?=~S handler?=~S\n"                  (and dec-vec #t) (and decoder #t)                  (and hlr-vec #t) (and handler #t)))))) (define-syntax define-wl-request   (lambda (x)     (syntax-case x ()       ((_ iface meth arg ...)        #`(define (#,(gen-id x #'iface ":" #'meth) obj-id arg ...)            (when wl-debug (sferr "=> ~S:~S ...\n" 'iface 'meth))            (put-message rq-chan              (lambda ()                (#,(gen-id x "encode-" #'iface ":" #'meth)                 obj-id rq-iobuf 0 arg ...)))))))) (define-wl-request wl_display sync callback) (define (handle-wl_callback:done obj-id callback-data)   (let ((val (vector-ref object-value-vec obj-id)))     (if (condition? val) (signal-condition! val))     (vector-set! object-value-vec obj-id #f))) (define (sync-and-wait)   (let ((id (alloc-id)) (cd (make-condition)))     (set-object! id 'wl_callback cd)     (wl_display:sync display-id id)     (wait cd))) (define socket-path   (let ((dir (getenv "XDG_RUNTIME_DIR"))     (dpy (getenv "WAYLAND_DISPLAY")))     (and dir dpy (string-append dir "/" dpy)))) (define (connect-display)   (let* ((path socket-path)          (style (logior SOCK_STREAM SOCK_CLOEXEC))          (sock (socket PF_UNIX style 0))          (conn (connect sock AF_UNIX path)))     (fcntl sock F_SETFL (logior O_NONBLOCK (fcntl sock F_GETFL)))     (set! rq-iobuf (make-bytevector 1024))     (set! ev-iobuf (make-bytevector 1024))     sock)) (define (sender)   (let loop ((n-sent 0) (n-left 0) (cm #f) (rqq '()))     (fsleep 0.01)     (cond      ((positive? n-left)       (let ((n (sendmsg wl-sock rq-iobuf n-sent n-left cm)))         (loop (+ n-sent n) (- n-left n) #f rqq)))      ((pair? rqq)       (call-with-values (car rqq)         (lambda (ln cm)           (loop 0 ln cm (cdr rqq)))))      ((get-message rq-chan) =>       (lambda (req)         (loop n-sent n-left cm (cons req rqq))))      (else       (sferr "sender says wtf\n"))))) (define (receiver)   (let loop ((n-have 0) (object-id #f) (msg-size 8) (opcode #f) (control #f))     (cond      ((< n-have msg-size)       (let* ((res (recvmsg! wl-sock ev-iobuf n-have))              (n-read (vector-ref res 0))              (control (or control (vector-ref res 1)))              (flags (vector-ref res 2)))         (when (zero? n-read) (fsleep 0.1)) ; SLEEP HERE         (loop (+ n-have n-read) object-id msg-size opcode control)))      ((not object-id)       (let* ((object-id (bytevector-u32-native-ref ev-iobuf 0))              (word1 (bytevector-u32-native-ref ev-iobuf 4))              (msg-size (bytevector-u16-native-ref ev-iobuf msg-size-offset))              (opcode (bytevector-u16-native-ref ev-iobuf opcode-offset)))         (loop n-have object-id msg-size opcode control)))      (else       (dispatch object-id opcode ev-iobuf 8 control)       (if (> n-have msg-size)           (bytevector-copy! ev-iobuf msg-size ev-iobuf 0 (- n-have msg-size)))       (loop (- n-have msg-size) #f 8 opcode control))))) (define (monitor)   (sferr "monitor starting ...\n")   (let* ((server (spawn-coop-repl-server)))     (let loop ()       (poll-coop-repl-server server)       (yield-current-task)       (fsleep 0.1)       (loop)))) (define done-cond #f) (define (done)   (and done-cond (signal-condition! done-cond))) (define (appl-main)   (run-fibers    (lambda ()      (set! wl-sock (connect-display))      (set! done-cond (make-condition))      (set! rq-chan (make-channel))      (install-handlers)      (init-object-pool)      ;;      (spawn-fiber receiver)      (spawn-fiber sender)      (get-registry)      (sync-and-wait)      (init-globals)      (sync-and-wait)      (create-file-buffer)      (spawn-fiber monitor)      ;;      (create-it)      ;;(wait done-cond)      (fsleep 3.0)      (force-output (current-error-port))      (close-port wl-sock))    #:hz 0 #:install-suspendable-ports? #f)) (use-modules (ffi ffi-help-rt)) (use-modules (ffi cairo)) (define* (create-file-buffer #:optional (size #x1000000))   (let* ((port (let ((port (tmpfile))) (truncate-file port size) port))          (fd (port->fdes port))          (bv (my-mmap 0 size (logior PROT_READ PROT_WRITE) MAP_SHARED fd 0)))     (set! my-buf-bv bv)     (set! my-buf-fd fd)     (if #f #f))) (define (draw-buffer)   (let* ((format 'CAIRO_FORMAT_ARGB32)          (format 'CAIRO_FORMAT_RGB24)          (buffer my-buf-bv)          (width 500) (height 300) (stride (* width 4))          (srf (cairo_image_surface_create_for_data                buffer format width height stride))          (cro (cairo_create srf))          (extents (make-cairo_text_extents_t))          (text "Hello, world!"))     (bytevector-fill! buffer #xee)     (cairo_move_to cro 0.0 0.0)     (cairo_move_to cro 20.0 20.0)     (cairo_line_to cro 120.0 120.0)     (cairo_stroke cro)     (cairo_select_font_face      cro "Sans" 'CAIRO_FONT_SLANT_NORMAL 'CAIRO_FONT_WEIGHT_NORMAL)     (cairo_set_font_size cro 32.0)     (cairo_text_extents cro text (pointer-to extents))     (cairo_move_to cro 50.0 50.0)     (cairo_show_text cro text)     (if #f #f))) (appl-main)