20 Dec 2024

feedPlanet Lisp

vindarel: CLOS tutorial: I published 9 videos (1h 22min) on my course. You'll know enough to read the sources of Hunchentoot or the Kandria game 🎥 ⭐

This is a follow-up from yesterday's post on reddit and an announce I wanted to make since this summer: I created 9 videos on CLOS, for a total of 1 hour and 22 minutes, in which you learn what I detail below. You can watch the course and subscribe here (Christmas coupon) and learn more on GitHub. The whole course is made of 51 videos divided in 9 chapters, for a total of 7 hours and 12 minutes. It is rated 4.71 / 5 as of date (thank you!!).

Yesterday was a great day because I received nice feedback:

It is an amazing tutorial. What is really strange is I thought CLOS was complicated. I guess it can be but [Vincent] is amazing at explaining everything and demystifying it.

/u/intergalactic_llama

🔥 I appreciate any (constructive ;) ) feedback and positive ones a lot.

Oh hey you made that tutorial. I started it but then got distracted by other stuff, been meaning to restart it and make my way through the whole thing. Really liked what I went through (I was on video 12 about redefining functions locally etc).

/u/runevault

Look, other recent feedback on my course:

I have done some preliminary Common Lisp exploration prior to this course but had a lot of questions regarding practical use and development workflows. This course was amazing for this! I learned a lot of useful techniques for actually writing the code in Emacs, as well as conversational explanations of concepts that had previously confused me in text-heavy resources. Please keep up the good work and continue with this line of topics, it is well worth the price!

Preston, October 2024

The instructor shows lots of tricks.

Tom, November 2024

Excellent selection of content. The delivery is not always obvious just for watching, but when I do the examples, it's absolutely clear that what I need to be learning has been presented.

Steven, November 2024 <3

Table of Contents

Chapter content

1. defclass, make-instance, slots... aka CLOS crash course, part 1. This one is free to watch 🆓

We see in more details: defclass, make-instance, attributes (aka slots), slot options (initarg, initform, reader, writer, accessor, documentation), slot-value, generic functions, defmethod, dispatching on built-in types, how objects are lazily updated, Slime inspector actions, manipulating Slime presentations, unbound slots and slot-boundp, Slime shortcuts to create objects...

We see a LOT already in this video, in an efficient way (way more efficient than when I learned anyways), so if you're on a budget you can start with it (it's free to watch) and complement with the Cookbook, and the other free books. Also if you are a student shoot me an email (and avoid the reddit chat, I don't see the notifications, sorry about that).

1b. Quizz: CLOS crash test

There is a small quizz. Keep in mind that the Udemy plateform doesn't support any Lisp language so I can't put any live coding exercises, but we can read code.

2. Inheritance, multimethods, around, before and after methods... aka CLOS crash course, part 2

what we see more precisely: inheritance, multimethods, :around, :before and :after methods (think signals and overwriting default methods in other languages, that allow to control what happens when a method is called, if it is called at all), their order of execution, a Slime shortcut to export all symbols of a class at once...

3. Pretty printing

We see how to change the default printed representation of objects.

What we see: print-object, with print-unreadable-object, the object type, the object identity, classic gotchas.

You know, normally an object is printed un-readable as

#<ROBOT {1005CEBD03}>

(guess what AOC day I am at)

and we can use the print-object method to print it however we like, such as

#<ROBOT x: 47 y: 14 {1005CEBD03}>

4. defclass review

We give another pass, slower, to defclass, slot options, make-instance, and to the fact that accessors are generic functions.

You can skip this one if the crash course was crystal clear.

5. Custom constructors and custom logic.

What we see: writing our own "make-person" terse constructor. Adding some logic before the object creation, doing side-effects after the object creation: towards initialize-instance.

6. initialize-instance: control if and how any objects are created

What we see: defining a :before and an :after method of initialize-instance for our person class, in order to do the same logic than with our custom constructor, but with a built-in CL Object System mechanism. Note that using INITIALIZE-INSTANCE isn't a must, only a "can", that you can use for your own classes, or to control the creation of objects from other systems.

7. Multiple inheritance

What we see: how to inherit from multiple parent classes and who takes precedence, when the parents define the same slot with each a default value. Quick illustration. We use what is known as a mixin class to add functionality to our class.

8. defgeneric vs defmethod: when to use which, which is better?

What we see: the use of defgeneric and defmethod, either separately, either together. defgeneric has a couple advantages in regards to documentation and keeping your code in sync with your image.

9. Class allocation

What we see: the default :allocation :instance VS :allocation :class. How to automatically count how many objects of a class are created.

8b. Quizz: reading code from real-world projects.

Outcome of the chapter

There was a lot of choices to make and advanced topics to ignore for this first chapter on CLOS. What drove my choices was looking at real-world code out there. As a result, by the end of this chapter, you will know enough to read real-world Common Lisp projects such as the Hunchentoot web server or the Kandria game. Bravo!

Closing words

First of all, thank you for your encouragements, and to everyone who took the course or who shared it!

Today I'd like to answer to my past me, a newcomer to Lisp on a budget: why create a paying course? First of all, I still contribute to the Cookbook, a collaborative resource. It's not "free or paid" resources, it's both. Then, preparing and recording structured videos takes so much time that I wouldn't do this continuous effort if I hadn't the ambition to make a non-ridiculous hourly rate on them one day. Disclaimer: it isn't the case yet. Maybe next year, depending on how many videos I release ;) I can pay my rent with them once every few months though, that's cool. Rest assured I'm not a millionaire. I'm on my own projects and I don't have a fixed (nor big) income. So your contribution or sponsorship counts, if only for the good vibes that push me to spend more and more time on my growing list of projects.

You can sponsor other lispers too.

Thank you and happy lisping.

20 Dec 2024 5:01pm GMT

19 Dec 2024

feedPlanet Lisp

Lispjobs: Mid/Senior Clojure Developers | Akosweb | Latam

Job posting: https://forms.gle/tWSRKLKDJkGXTLTG6

Looking for mid/senior-level Clojure developers who are experienced, self-managing, and ready to hit the ground running.

You will need to work on US Central Time (CST).

What You'll Be Doing:

What We Offer:

What We Expect:

If you're a skilled Clojure developer looking for your next role, apply today!

We need to hire multiple Clojure Developers for this role, please let us know if you have any friends or colleagues who'd like to join the team too.

19 Dec 2024 6:55pm GMT

17 Dec 2024

feedPlanet Lisp

Joe Marshall: Does CONS take its arguments in the wrong order?

Object-oriented languages often come with a "collections" library that provides a variety of data structures for storing collections of objects. Methods on collections usually pass the collection as the first argument for two reasons: (1) the collection is the primary object being operated on, and (2) in many languages, method dispatch only works on the first argument.

In Lisp, however, lists are a collection type that is derived from a more primitive data type, the cons cell. Lists are not fully abstracted from cons cells and many list operations are actually defined as operations on cons cells. Rather than the list argument always coming first, there is little rhyme or reason to the order of arguments in list operations. This becomes evident when you try to use higher-order operations on lists.

cons constructs a cons cell, with two fields, a car and a cdr. The car is traditionally written to the left of the cdr, and cons takes the car as the first argument.

In Lisp, there is no special constructor for lists. The user directly constructs the underlying cons cell and simply "declares in his head" that the result is a list. Hence when we are extending a collection with an item, the collection is the second argument to cons rather than the first. In a "modern" curly-brace, object-oriented language, we would extend mylist by writing mylist.cons(item)

Here's where it makes a difference:

The fold-left function iterates down a list and calls a combining function on each element of the list. The first argument to the combining function is the accumulated answer, the second is the element being accumulated. If we want to accumulate into a list, the accumulated list is passed first and the new item is passed second. This means that cons is not suitable as the combining function in fold-left because the arguments come in the wrong order:

(defun bad-reverse (list)
  (fold-left #'cons '() list)) ;; does not reverse a list

(defun xcons (cdr car)  ;; takes original list first
  (cons car cdr))

(defun reverse (list)
  (fold-left #'xcons '() list)) ;; correcty reverses a list

Many list operations, remove and adjoin for example, take their arguments in an inconvenient order for fold-left.

17 Dec 2024 1:05am GMT

12 Dec 2024

feedPlanet Lisp

Joe Marshall: How to Blow an Interview

I recently had to interview a candidate. He had passed earlier interviews, had done well, and was in the final running. My only task was to determine his coding ability.

I checked resume, and saw that he listed Python among his computer language skills, so I decided to pitch him a Python program. I wrote a this simple skeleton of a Tic-Tac-Toe program:

class TicTacToeBoard:
    def __init__(self):
        pass

    def __str__(self):
        pass

    def make_move(self, row, col, player):
        pass

    def is_winner(self, player) -> bool:
        return False

    def is_full(self) -> bool:
        return False

if __name__ == '__main__':
    board = TicTacToeBoard()
    print(board)
    board.make_move(0, 0, 'X')
    board.make_move(0, 1, 'O')
    board.make_move(1, 1, 'X')
    board.make_move(1, 0, 'O')
    board.make_move(2, 2, 'X')
    print(board)
    print(board.is_winner('X'))
    print(board.is_winner('O'))
    print(board.is_full())

I invited him to "go to town" on the code. I didn't care what he implemented or how he implemented it, I just wanted to watch him code.

Alas, he didn't. He studied the code for a few minutes, moved the cursor around, and then admitted that it had been a while since he had written any significant Python code and he was a bit rusty. He was more used to Java.

That's fine. I asked him to write the code in Java. I apologized for not having a Java skeleton, but I was sure he could write something.

He didn't get very far. He wrote a class declaration, but was stumped on any method definitions. He admitted that he was pretty rusty in Java, too, and wanted to switch back to Python.

I didn't care, I just wanted to see some code. He asked if the job was going to require a lot of coding. I said that it would definitely require some coding as part of the job was analyzing legacy code and identifying and fixing security bugs.

After half an hour, he still hadn't written even a single line of working code in any language. I felt bad for him and asked him about the other experiences on his resume. They looked good, but a little digging showed that his experience was a bit shallow. I thanked him for his time and told him that the recruiter would be in touch.

I gave him a solid "no". He just would not have been a good fit. The job required coding skills that he simply did not have.

I don't understand it. I would have thought that the ability to write some code was a basic requirement for any job involving computers. But I guess not.

Nutanix is hiring. It's a pretty good gig, so if you see something that interests you, apply. But be prepared to write some code.

12 Dec 2024 3:28pm GMT

10 Dec 2024

feedPlanet Lisp

vindarel: Three web views for Common Lisp: build cross platform GUIs with Electron, WebUI or CLOG Frame

You dream to build a cross-platform GUI in Common Lisp? It's now easy with web views.

Honestly GUIs are a difficult topic. Add in "cross platform" and you can spend your life trying out different solutions and hesitating between the best one for Common Lisp. It's doable: Tk, Gtk3 and Gtk4, Qt4 and Qt5, CAPI (LispWorks), IUP, Nuklear, Cocoa, McCLIM, Garnet, Alloy, Java Swing... what can of worms do you want to open?

The situation improved in the last years thanks to lispers writing new bindings. So it's possible you find one that works for your needs. That's great, but now: you have to learn the GUI framework :p

If like me you already know the web, are developing a web app, and would like to ship a desktop application, web views are making it easy. I know the following ones, listed from least favourite to most favourite.

Table of Contents

Electron

Electron is heavy, but really cross-platform, and it has many tools around it. It allows to build releases for the three major OS from your development machine, its ecosystem has tools to handle updates, etc.

Advise: study it before discarding it.

Ceramic (old but works)

Ceramic is a set of utilities around Electron to help you build an Electron app: download the npm packages, open a browser window, etc.

Here's its getting started snippet:

;; Start the underlying Electron process
(ceramic:start)
;; ^^^^^ this here downloads ±200MB of node packages under the hood.

;; Create a browser window
(defvar window (ceramic:make-window :url "https://www.google.com/"
                                    :width 800
                                    :height 600))

;; Show it
(ceramic:show window)

When you run (ceramic:bundle :ceramic-hello-world) you get a .tar file with your application, which you can distribute. Awesome!

But what if you don't want to redirect to google.com but open your own app? You just build your web app in CL, run the webserver (Hunchentoot, Clack...) on a given port, and you'll open localhost:[PORT] in Ceramic/Electron. That's it.

Ceramic wasn't updated in five years as of date and it downloads an outdated version of Electron by default (see (defparameter *electron-version* "5.0.2")), but you can change the version yourself.

The new Neomacs project, a structural editor and web browser, is a great modern example on how to use Ceramic. Give it a look and give it a try!

What Ceramic actually does is abstracted away in the CL functions, so I think it isn't the best to start with. We can do without it to understand the full process, here's how.

Electron from scratch

Here's our web app embedded in Electron:

Our steps are the following:

You can also run the Lisp web app from sources, of course, without building a binary, but then you'll have to ship all the lisp sources.

main.js

The most important file to an Electron app is the main.js. The one we show below does the following:

Here's our version.

console.log(`Hello from Electron 👋`)

const { app, BrowserWindow } = require('electron')

const { spawn } = require('child_process');

// FIXME Suppose we have our app binary at the current directory.

// FIXME This is our hard-coded binary name.
var binaryPaths = [
    "./openbookstore",
];

// FIXME Define any arg required for the binary.
// This is very specific to the one I built for the example.
var binaryArgs = ["--web"];

const binaryapp = null;

const runLocalApp = () => {
    "Run our binary app locally."
    console.log("running our app locally...");
    const binaryapp = spawn(binaryPaths[0], binaryArgs);
    return binaryapp;
}

// Start an Electron window.

const createWindow = () => {
  const win = new BrowserWindow({
    width: 800,
    height: 600,
  })

  // Open localhost on the app's port.
  // TODO: we should read the port from an environment variable or a config file.
  // FIXME hard-coded PORT number.
  win.loadURL('http://localhost:4242/')
}

// Run our app.
let child = runLocalApp();

// We want to see stdout and stderr of the child process
// (to see our Lisp app output).
child.stdout.on('data', (data) => {
  console.log(`stdout:\n${data}`);
});

child.stderr.on('data', (data) => {
  console.error(`stderr: ${data}`);
});

child.on('error', (error) => {
  console.error(`error: ${error.message}`);
});

// Handle Electron close events.
child.on('close', (code) => {
  console.log(`openbookstore process exited with code ${code}`);
});

// Open it in Electron.
app.whenReady().then(() => {
    createWindow();

    // Open a window if none are open (macOS)
    if (process.platform == 'darwin') {
        app.on('activate', () => {
            if (BrowserWindow.getAllWindows().length === 0) createWindow()
        })
    }
})


// On Linux and Windows, quit the app main all windows are closed.
app.on('window-all-closed', () => {
    if (process.platform !== 'darwin') {
        app.quit();
    }
})

Run it with npm run start (you also have an appropriate packages.json), this gets you the previous screenshot.

JS and Electron experts, please criticize and build on it.

Missing parts

We didn't fully finish the example: we need to automatically bundle the binary into the Electron release.

Then, if you want to communicate from the Lisp app to the Electron window, and the other way around, you'll have to use the JavaScript layers. Ceramic might help here.

(this section was first released here: https://dev.to/vindarel/common-lisp-gui-with-electron-how-to-28fj)

What about Tauri?

Bundling an app with Tauri will, AFAIK (I just tried quickly), involve the same steps than with Electron. Tauri might still have less tools for it.

WebUI

WebUI is a new kid in town. It is in development, it has bugs. You can view it as a wrapper around a browser window (or webview.h).

However it is ligthweight, it is easy to build and we have Lisp bindings.

A few more words about it:

Use any web browser or WebView as GUI, with your preferred language in the backend and modern web technologies in the frontend, all in a lightweight portable library.

Think of WebUI like a WebView controller, but instead of embedding the WebView controller in your program, which makes the final program big in size, and non-portable as it needs the WebView runtimes. Instead, by using WebUI, you use a tiny static/dynamic library to run any installed web browser and use it as GUI, which makes your program small, fast, and portable. All it needs is a web browser.

your program will always run on all machines, as all it needs is an installed web browser.

Sounds compelling right?

The other good news is that Common Lisp was one of the first languages it got bindings for. How it happened: I was chating in Discord, mentioned WebUI and BAM! @garlic0x1 developed bindings:

thank you so much! (@garlic0x1 has more cool projects on GitHub you can browse. He's also a contributor to Lem)

Here's a simple snippet:

(defpackage :webui/examples/minimal
  (:use :cl :webui)
  (:export :run))
(in-package :webui/examples/minimal)

(defun run ()
  (let ((w (webui-new-window)))
    (webui-show w "<html>Hello, world!</html>")
    (webui-wait)))

I would be the happiest lisper in the world if I didn't have an annoying issue. See #1. I can run my example just fine, but nothing happens the second time :/ I don't know if it's a WebUI thing, the bindings, my system, my build of WebUI... so I'll give this more time.

Fortunately though, the third solution of this blog post is my favourite! o/

CLOG Frame (webview.h for all)

CLOG Frame is part of the CLOG framework. However, it is not tied to CLOG... nor to Common Lisp!

CLOG Frame is a short C++ program that builds an executable that takes an URL and a PORT as CLI parameters and opens a webview.h window.

It's easy to build and works just fine.

It's a great approach. We don't need to develop CFFI bindings for webview.h. However such bindings would still be nice to have. I did a cursory search and didn't find a project that seems to work. But please don't take my word on it. Do you want to try this latest cl-webview, or have a go at the bindings?

Back to our matter.

This is CLOG Frame: 20 lines!

#include <iostream>
#include <sstream>
#include <string>
#include "webview.h"

int main(int argc,char* argv[]) {
  webview::webview w(true, nullptr);
  webview::webview *w2 = &w;
  w.set_title(argv[1]);
  w.set_size(std::stoi(argv[3]), std::stoi(argv[4]), WEBVIEW_HINT_NONE);
  w.bind("clogframe_quit", [w2](std::string s) -> std::string {
    w2->terminate();
    return "";
  });
  std::ostringstream o;
  o << "http://127.0.0.1:" << argv[2];
  w.navigate(o.str());
  w.run();
  return 0;
}

Compile it on GNU/Linux like this and don't you worry, it takes a fraction of a second:

c++ clogframe.cpp -ldl `pkg-config --cflags --libs gtk+-3.0 webkit2gtk-4.0` -o clogframe

(see its repo for other platforms)

this gives you a clogframe binary. Put it in your $PATH or remember its location. It's just a short C++ binary, so it weights 197Kb.

Now, back to your web app that you wrote in Common Lisp and that is waiting to be shipped to users.

Start your web app. Say it is started on port 4284.

From the Lisp side, open a CLOG Frame window like this

(uiop:launch-program (list "./clogframe"
                           "Admin"
                           (format nil "~A/admin/" 4284)
                           ;; window dimensions (strings)
                           "1280" "840"))

and voilà.

A CLOG Frame window showing a WIP Common Lisp web app on top of Emacs.

Now for the cross-platform part, you'll need to build clogframe and your web app on the target OS (like with any CL app). Webview.h is cross-platform. Leave us a comment when you have a good CI setup for the three main OSes (I am studying 40ants/ci and make-common-lisp-program for now).

CLOG Frame should be a (popular) project on its own IMO! (@dbotton might make it independant eventually)

Please share any experience you might have on the topic 👍

10 Dec 2024 9:59am GMT

30 Nov 2024

feedPlanet Lisp

Patrick Stein: Ray Tracing Extra-dimensional CSG Objects

This month, I added CSG (Constructive Solid Geometry) operators to the ray-tracer that I mentioned in the previous post. I added intersections, complements, and unions.

You can find the source code in my weekend-raytracer github repo.

Rendering of the union of three 5d-balls.

The post Ray Tracing Extra-dimensional CSG Objects first appeared on nklein software.

30 Nov 2024 3:43pm GMT

22 Nov 2024

feedPlanet Lisp

vindarel: cl-ansi-term: print tables with style, and other script utilities

I am not the original author of cl-ansi-term, but I revived it lately. In particular, I added useful stuff to print data in tables:

For example:

(progn
  (defparameter d (serapeum:dict :a 1.1 :b 2.2 :c 3.3))

  (banner "A single hash-table")
  (table d)

  (banner "A single hash-table, in columns")
  (vtable d)

  (banner "A single hash-table, ignoring column :B")
  (table d :exclude :b)

  (banner "A single hash-table, vertically ignoring column :B")
  (vtable d :exclude :b)

  (banner "A list of hash-tables")
  (table (list d d d))

  (banner "A list of hash-tables, ignoring column :B")
  (table (list d d d) :keys '(:a :c))

  (banner "A list of hash-tables, in columns")
  (vtable (list d d d))

  (banner "same, ignoring the column :b")
  (vtable (list d d d) :exclude :b))

prints:

--------------------------------------------------------------------------------
     A single hash-table
--------------------------------------------------------------------------------


+---------+---------+---------+
|A        |B        |C        |
+---------+---------+---------+
|1.1      |2.2      |3.3      |
+---------+---------+---------+

--------------------------------------------------------------------------------
     A single hash-table, in columns
--------------------------------------------------------------------------------


+---------+---------+
|A        |1.1      |
+---------+---------+
|B        |2.2      |
+---------+---------+
|C        |3.3      |
+---------+---------+

--------------------------------------------------------------------------------
     A single hash-table, ignoring column :B
--------------------------------------------------------------------------------


+---------+---------+
|A        |C        |
+---------+---------+
|1.1      |3.3      |
+---------+---------+

--------------------------------------------------------------------------------
     A single hash-table, vertically ignoring column :B
--------------------------------------------------------------------------------


+---------+---------+
|A        |1.1      |
+---------+---------+
|C        |3.3      |
+---------+---------+

--------------------------------------------------------------------------------
     A list of hash-tables
--------------------------------------------------------------------------------


+---------+---------+---------+
|A        |B        |C        |
+---------+---------+---------+
|1.1      |2.2      |3.3      |
+---------+---------+---------+
|1.1      |2.2      |3.3      |
+---------+---------+---------+
|1.1      |2.2      |3.3      |
+---------+---------+---------+

--------------------------------------------------------------------------------
     A list of hash-tables, ignoring column :B
--------------------------------------------------------------------------------


+---------+---------+
|A        |C        |
+---------+---------+
|1.1      |3.3      |
+---------+---------+
|1.1      |3.3      |
+---------+---------+
|1.1      |3.3      |
+---------+---------+

--------------------------------------------------------------------------------
     A list of hash-tables, in columns
--------------------------------------------------------------------------------


+---------+---------+---------+---------+
|A        |1.1      |1.1      |1.1      |
+---------+---------+---------+---------+
|B        |2.2      |2.2      |2.2      |
+---------+---------+---------+---------+
|C        |3.3      |3.3      |3.3      |
+---------+---------+---------+---------+

--------------------------------------------------------------------------------
     same, ignoring the column :b
--------------------------------------------------------------------------------


+---------+---------+---------+---------+
|A        |1.1      |1.1      |1.1      |
+---------+---------+---------+---------+
|C        |3.3      |3.3      |3.3      |
+---------+---------+---------+---------+

or again

TERM> (table (list d d d) :exclude :b  :border-style nil)
A         C
1.1       3.3
1.1       3.3
1.1       3.3

Real example

Remember, the scripts I use in production. I'm usually fine with big data output in the REPL, until:

In this case I extract data from my DB and I get a list of plists:

((:|isbn| "3760281971082" :|quantity| -1 :|price| 12.8d0 :|vat| NIL
  :|distributor| NIL :|discount| NIL :|type_name| NIL :|type_vat| NIL
  :|price_bought| NIL :|price_sold| 12.8d0 :|quantity_sold| 1 :|sold_date|
  "2024-04-03 09:27:12")
 (:|isbn| "9791094298169" :|quantity| 4 :|price| 15.0d0 :|vat| NIL
  :|distributor| NIL :|discount| NIL :|type_name| "book" :|type_vat| NIL
  :|price_bought| NIL :|price_sold| 15.0d0 :|quantity_sold| 1 :|sold_date|
  "2024-04-03 10:06:58")
 ...)

With the table and vtable functions, I can explore data in a clearer fashion.

(uiop:add-package-local-nickname :sera :serapeum)
(term:table (sera:take 15 *sells*)
                          :keys '(:|isbn| :|quantity| :|price|)
                          :plist t
                          :column-width '(15 10 10))

+--------------+---------+---------+
|isbn          |quantity |price    |
+--------------+---------+---------+
|3760281971082 |-1       |12.8d0   |
+--------------+---------+---------+
|9791094298169 |4        |15.0d0   |
+--------------+---------+---------+
|3700275724249 |-126     |2.8d0    |
+--------------+---------+---------+
|9782372600842 |1        |10.0d0   |
+--------------+---------+---------+
|9782372600736 |0        |10.0d0   |
+--------------+---------+---------+
|9782221256770 |1        |19.0d0   |
+--------------+---------+---------+
|3700275734392 |171      |3.95d0   |
+--------------+---------+---------+
|3662846007789 |2        |16.95d0  |
+--------------+---------+---------+
|9782368292907 |1        |8.95d0   |
+--------------+---------+---------+
|9782095022679 |1        |12.95d0  |
+--------------+---------+---------+
|3662846007871 |5        |5.9d0    |
+--------------+---------+---------+
|9782092588949 |2        |5.95d0   |
+--------------+---------+---------+
|3700275724249 |-126     |2.8d0    |
+--------------+---------+---------+
|3700275734392 |171      |3.95d0   |
+--------------+---------+---------+
|3770017095135 |0        |29.99d0  |
+--------------+---------+---------+

Yes, this calls for more features: align the numbers, automatically adapt the cells' width (DONE), style cells individually (DONE), etc.

(I'm sure we could have an explorer window, watching for changes, displaying data in a real table with interactive features... I can feel we're close... CLOG frame and malleable systems someone?)

Use case and other primitives: title, banner, vspace, o-list

The use case is cleaner output for scripts.

Other libraries exist with other goals:

Here are some of other cl-ansi-term's utilities:

ordered and un-ordered lists:

(term:o-list '((:one one-a (:one-b :one-b-1 :one-b-2)) :two))
1. ONE
   1. ONE-A
   2. ONE-B
      1. ONE-B-1
      2. ONE-B-2
2. TWO

Horizontal lines

(term:hr :filler "=")
================================================================================

printing stuff, align on screen:

(term:cat-print '(:abc :def :ghi) :align :center)
;; =>

                                   ABCDEFGHI

vspace for vertical space (default: 3 newlines)

banner:

(banner "My title" :space 1)

--------------------------------------------------------------------------------
     My title
--------------------------------------------------------------------------------

Stylesheets and colorized text

The library allows to use styles.

Start by defining your stylesheet.

(term:update-style-sheet
 '((:header :cyan   :underline)
   (:mark   :red    :reverse)
   (:term   :yellow :bold)))

:header, :mark and :term are now your own vocabulary. Anytime you use functions that accept a style, reference them.

Example:

(term:table (list '(:name :age) '(:me 7)) :header-style :header)

data printed in tables, with colors.

To see colors in a "dumb" terminal like in Emacs Slime, install the package slime-repl-ansi-color, "require" it and enable it ith M-x slime-repl-ansi-color-mode.

You can also disable styles in non-interactive terminals with term::*enable-effects-on-dumb-terminals*.

Happy lisping.

22 Nov 2024 10:56am GMT

04 Nov 2024

feedPlanet Lisp

TurtleWare: Dynamic Vars - Return of the Jedi

Table of Contents

  1. The protocol
  2. Control operators
  3. Synchronized hash tables with weakness
  4. First-class dynamic variables
    1. STANDARD-DYNAMIC-VARIABLE
    2. SURROGATE-DYNAMIC-VARIABLE
  5. Thread-local variables
    1. The protocol
    2. The implementation
  6. Thread-local slots
  7. What can we use it for?

In the previous two posts I've presented an implementation of first-class dynamic variables using PROGV and a surrogate implementation for SBCL.

Now we will double down on this idea and make the protocol extensible. Finally we'll implement a specialized version of dynamic variables where even the top level value of the variable is thread-local.

The protocol

Previously we've defined operators as either macros or functions. Different implementations were protected by the feature flag and symbols collided. Now we will introduce the protocol composed of a common superclass and functions that are specialized by particular implementations.

Most notably we will introduce a new operator CALL-WITH-DYNAMIC-VARIABLE that is responsible for establishing a single binding. Thanks to that it will be possible to mix dynamic variables of different types within a single DLET statement.

(defclass dynamic-variable () ())

(defgeneric dynamic-variable-bindings (dvar))
(defgeneric dynamic-variable-value (dvar))
(defgeneric (setf dynamic-variable-value) (value dvar))
(defgeneric dynamic-variable-bound-p (dvar))
(defgeneric dynamic-variable-makunbound (dvar))
(defgeneric call-with-dynamic-variable (cont dvar &optional value))

Moreover we'll define a constructor that is specializable by a key. This design will allow us to refer to the dynamic variable class by using a shorter name. We will also define the standard class to be used and an matching constructor.

(defparameter *default-dynamic-variable-class*
  #-fake-progv-kludge 'standard-dynamic-variable
  #+fake-progv-kludge 'surrogate-dynamic-variable)

(defgeneric make-dynamic-variable-using-key (key &rest initargs)
  (:method (class &rest initargs)
    (apply #'make-instance class initargs))
  (:method ((class (eql t)) &rest initargs)
    (apply #'make-instance *default-dynamic-variable-class* initargs))
  (:method ((class null) &rest initargs)
    (declare (ignore class initargs))
    (error "Making a dynamic variable that is not, huh?")))

(defun make-dynamic-variable (&rest initargs)
  (apply #'make-dynamic-variable-using-key t initargs))

Control operators

Control operators are the same as previously, that is a set of four macros that consume the protocol specified above. Note that DYNAMIC-VARIABLE-PROGV expands to a recursive call where each binding is processed separately.

(defmacro dlet (bindings &body body)
  (flet ((pred (binding)
           (and (listp binding) (= 2 (length binding)))))
    (unless (every #'pred bindings)
      (error "DLET: bindings must be lists of two values.~%~
              Invalid bindings:~%~{ ~s~%~}" (remove-if #'pred bindings))))
  (loop for (var val) in bindings
        collect var into vars
        collect val into vals
        finally (return `(dynamic-variable-progv (list ,@vars) (list ,@vals)
                           ,@body))))

(defmacro dset (&rest pairs)
  `(setf ,@(loop for (var val) on pairs by #'cddr
                 collect `(dref ,var)
                 collect val)))

(defmacro dref (variable)
  `(dynamic-variable-value ,variable))

(defun call-with-dynamic-variable-progv (cont vars vals)
  (flet ((thunk ()
           (if vals
               (call-with-dynamic-variable cont (car vars) (car vals))
               (call-with-dynamic-variable cont (car vars)))))
    (if vars
        (call-with-dynamic-variable-progv #'thunk (cdr vars) (cdr vals))
        (funcall cont))))

(defmacro dynamic-variable-progv (vars vals &body body)
  (let ((cont (gensym)))
    `(flet ((,cont () ,@body))
       (call-with-dynamic-variable-progv (function ,cont) ,vars ,vals))))

Synchronized hash tables with weakness

Previously we've used SBCL-specific options to define a synchronized hash table with weak keys. This won't do anymore, because we will need a similar object to implement the thread-local storage for top level values.

trivial-garbage is a portability layer that allows to define hash tables with a specified weakness, but it does not provide an argument that would abstract away synchronization. We will ensure thread-safety with locks instead.

(defclass tls-table ()
  ((table :initform (trivial-garbage:make-weak-hash-table
                     :test #'eq :weakness :key))
   (lock :initform (bt:make-lock))))

(defun make-tls-table ()
  (make-instance 'tls-table))

(defmacro with-tls-table ((var self) &body body)
  (let ((obj (gensym)))
    `(let* ((,obj ,self)
            (,var (slot-value ,obj 'table)))
       (bt:with-lock-held ((slot-value ,obj 'lock)) ,@body))))

First-class dynamic variables

STANDARD-DYNAMIC-VARIABLE

Previously in the default implementation we've represented dynamic variables with a symbol. The new implementation is similar except that the symbol is read from a STANDARD-OBJECT that represents the variable. This also enables us to specialize the function CALL-WITH-DYNAMIC-VARIABLE:

(defclass standard-dynamic-variable (dynamic-variable)
  ((symbol :initform (gensym) :accessor dynamic-variable-bindings)))

(defmethod dynamic-variable-value ((dvar standard-dynamic-variable))
  (symbol-value (dynamic-variable-bindings dvar)))

(defmethod (setf dynamic-variable-value) (value (dvar standard-dynamic-variable))
  (setf (symbol-value (dynamic-variable-bindings dvar)) value))

(defmethod dynamic-variable-bound-p ((dvar standard-dynamic-variable))
  (boundp (dynamic-variable-bindings dvar)))

(defmethod dynamic-variable-makunbound ((dvar standard-dynamic-variable))
  (makunbound (dynamic-variable-bindings dvar)))

(defmethod call-with-dynamic-variable (cont (dvar standard-dynamic-variable)
                                       &optional (val nil val-p))
  (progv (list (dynamic-variable-bindings dvar)) (if val-p (list val) ())
    (funcall cont)))

SURROGATE-DYNAMIC-VARIABLE

The implementation of the SURROGATE-DYNAMIC-VARIABLE is almost the same as previously. The only difference is that we use the previously defined indirection to safely work with hash tables. Also note, that we are not add the feature condition - both classes is always created.

(defvar +fake-unbound+ 'unbound)
(defvar +cell-unbound+ '(no-binding))

(defclass surrogate-dynamic-variable (dynamic-variable)
  ((tls-table
    :initform (make-tls-table)
    :reader dynamic-variable-tls-table)
   (top-value
    :initform +fake-unbound+
    :accessor dynamic-variable-top-value)))

(defmethod dynamic-variable-bindings ((dvar surrogate-dynamic-variable))
  (let ((process (bt:current-thread)))
    (with-tls-table (tls-table (dynamic-variable-tls-table dvar))
      (gethash process tls-table +cell-unbound+))))

(defmethod (setf dynamic-variable-bindings) (value (dvar surrogate-dynamic-variable))
  (let ((process (bt:current-thread)))
    (with-tls-table (tls-table (dynamic-variable-tls-table dvar))
      (setf (gethash process tls-table) value))))

(defun %dynamic-variable-value (dvar)
  (let ((tls-binds (dynamic-variable-bindings dvar)))
    (if (eq tls-binds +cell-unbound+)
        (dynamic-variable-top-value dvar)
        (car tls-binds))))

(defmethod dynamic-variable-value ((dvar surrogate-dynamic-variable))
  (let ((tls-value (%dynamic-variable-value dvar)))
    (when (eq tls-value +fake-unbound+)
      (error 'unbound-variable :name "(unnamed)"))
    tls-value))

(defmethod (setf dynamic-variable-value) (value (dvar surrogate-dynamic-variable))
  (let ((tls-binds (dynamic-variable-bindings dvar)))
    (if (eq tls-binds +cell-unbound+)
        (setf (dynamic-variable-top-value dvar) value)
        (setf (car tls-binds) value))))

(defmethod dynamic-variable-bound-p ((dvar surrogate-dynamic-variable))
  (not (eq +fake-unbound+ (%dynamic-variable-value dvar))))

(defmethod dynamic-variable-makunbound ((dvar surrogate-dynamic-variable))
  (setf (dynamic-variable-value dvar) +fake-unbound+))


;;; Apparently CCL likes to drop^Helide some writes and that corrupts bindings
;;; table. Let's ensure that the value is volatile.
#+ccl (defvar *ccl-ensure-volatile* nil)
(defmethod call-with-dynamic-variable (cont (dvar surrogate-dynamic-variable)
                                       &optional (val +fake-unbound+))
  (push val (dynamic-variable-bindings dvar))
  (let (#+ccl (*ccl-ensure-volatile* (dynamic-variable-bindings dvar)))
    (unwind-protect (funcall cont)
      (pop (dynamic-variable-bindings dvar)))))

Thread-local variables

We've refactored the previous code to be extensible. Now we can use metaobjects from the previous post without change. We can also test both implementations in the same process interchangeably by customizing the default class parameter.

It is the time now to have some fun and extend dynamic variables into variables with top value not shared between different threads. This will enable ultimate thread safety. With our new protocol the implementation is trivial!

The protocol

First we will define the protocol class. THREAD-LOCAL-VARIABLE is a variant of a DYNAMIC-VARIABLE with thread-local top values.

We specify initialization arguments :INITVAL and :INITFUN that will be used to assign the top value of a binding. The difference is that INITVAL specifies a single value, while INITFUN can produce an unique object on each invocation. INITARG takes a precedence over INTIFUN, and if neither is supplied, then a variable is unbound.

We include the constructor that builds on MAKE-DYNAMIC-VARIABLE-USING-KEY, and macros corresponding to DEFVAR and DEFPARAMETER. Note that they expand to :INITFUN - this assures that the initialization form is re-evaluated for each new thread where the variable is used.

(defclass thread-local-variable (dynamic-variable) ())

(defmethod initialize-instance :after
    ((self thread-local-variable) &key initfun initval)
  (declare (ignore self initfun initval)))

(defparameter *default-thread-local-variable-class*
  #-fake-progv-kludge 'standard-thread-local-variable
  #+fake-progv-kludge 'surrogate-thread-local-variable)

(defun make-thread-local-variable (&rest initargs)
  (apply #'make-dynamic-variable-using-key
         *default-thread-local-variable-class* initargs))

(defmacro create-tls-variable (&optional (form nil fp) &rest initargs)
  `(make-thread-local-variable 
    ,@(when fp `(:initfun (lambda () ,form)))
    ,@initargs))

(defmacro define-tls-variable (name &rest initform-and-initargs)
  `(defvar ,name (create-tls-variable ,@initform-and-initargs)))

(defmacro define-tls-parameter (name &rest initform-and-initargs)
  `(defparameter ,name (create-tls-variable ,@initform-and-initargs)))

Perhaps it is a good time to introduce a new convention for tls variable names. I think that surrounding names with the minus sign is a nice idea, because it signifies, that it is something less than a global value. For example:

DYNAMIC-VARS> (define-tls-variable -context- 
                  (progn
                    (print "Initializing context!")
                    (list :context)))
-CONTEXT-
DYNAMIC-VARS> -context-
#<a EU.TURTLEWARE.DYNAMIC-VARS::STANDARD-THREAD-LOCAL-VARIABLE 0x7f7636c08640>
DYNAMIC-VARS> (dref -context-)

"Initializing context!" 
(:CONTEXT)
DYNAMIC-VARS> (dref -context-)
(:CONTEXT)
DYNAMIC-VARS> (dset -context- :the-new-value)

:THE-NEW-VALUE
DYNAMIC-VARS> (dref -context-)
:THE-NEW-VALUE
DYNAMIC-VARS> (bt:make-thread
               (lambda ()
                 (print "Let's read it!")
                 (print (dref -context-))))
#<process "Anonymous thread" 0x7f7637a26cc0>

"Let's read it!" 
"Initializing context!" 
(:CONTEXT) 
DYNAMIC-VARS> (dref -context-)
:THE-NEW-VALUE

The implementation

You might have noticed the inconspicuous operator DYNAMIC-VARIABLE-BINDINGS that is part of the protocol. It returns an opaque object that represents values of the dynamic variable in the current context:

In any case all other operators first take this object and then use it to read, write or bind the value. The gist of the tls variables implementation is to always return an object that is local to the thread. To store these objects we will use the tls-table we've defined earlier.

(defclass thread-local-variable-mixin (dynamic-variable)
  ((tls-table
    :initform (make-tls-table)
    :reader dynamic-variable-tls-table)
   (tls-initfun
    :initarg :initfun
    :initform nil
    :accessor thread-local-variable-initfun)
   (tls-initval
    :initarg :initval
    :initform +fake-unbound+
    :accessor thread-local-variable-initval)))

For the class STANDARD-THREAD-LOCAL-VARIABLE we will simply return a different symbol depending on the thread:

(defclass standard-thread-local-variable (thread-local-variable-mixin
                                         thread-local-variable
                                         standard-dynamic-variable)
  ())

(defmethod dynamic-variable-bindings ((tvar standard-thread-local-variable))
  (flet ((make-new-tls-bindings ()
           (let ((symbol (gensym))
                 (initval (thread-local-variable-initval tvar))
                 (initfun (thread-local-variable-initfun tvar)))
             (cond
               ((not (eq +fake-unbound+ initval))
                (setf (symbol-value symbol) initval))
               ((not (null initfun))
                (setf (symbol-value symbol) (funcall initfun))))
             symbol)))
    (let ((key (bt:current-thread)))
      (with-tls-table (tls-table (dynamic-variable-tls-table tvar))
        (or (gethash key tls-table)
            (setf (gethash key tls-table)
                  (make-new-tls-bindings)))))))

And for the class SURROGATE-THREAD-LOCAL-VARIABLE the only difference from the SURROGATE-DYNAMIC-VARIABLE implementation is to cons a new list as the initial value (even when it is unbound) to ensure it is not EQ to +CELL-UNBOUND+.

(defclass surrogate-thread-local-variable (thread-local-variable-mixin
                                          thread-local-variable
                                          surrogate-dynamic-variable)
  ())

(defmethod dynamic-variable-bindings ((tvar surrogate-thread-local-variable))
  (flet ((make-new-tls-bindings ()
           (let ((initval (thread-local-variable-initval tvar))
                 (initfun (thread-local-variable-initfun tvar)))
             (cond
               ((not (eq +fake-unbound+ initval))
                (list initval))
               ((not (null initfun))
                (list (funcall initfun)))
               (t
                (list +fake-unbound+))))))
    (let ((key (bt:current-thread)))
      (with-tls-table (tls-table (dynamic-variable-tls-table tvar))
        (or (gethash key tls-table)
            (setf (gethash key tls-table)
                  (make-new-tls-bindings)))))))

That's all, now we have two implementations of thread-local variables. Ramifications are similar as with "ordinary" dynamic variables - the standard implementation is not advised for SBCL, because it will crash in LDB.

Thread-local slots

First we are going to allow to defined dynamic variable types with an abbreviated names. This will enable us to specify in the slot definition that type, for example (MY-SLOT :DYNAMIC :TLS :INITFORM 34)

;;; Examples how to add shorthand type names for the dynamic slots:

(defmethod make-dynamic-variable-using-key ((key (eql :tls)) &rest initargs)
  (apply #'make-dynamic-variable-using-key
         *default-thread-local-variable-class* initargs))

(defmethod make-dynamic-variable-using-key ((key (eql :normal-tls)) &rest initargs)
  (apply #'make-dynamic-variable-using-key
         'standard-thread-local-variable initargs))

(defmethod make-dynamic-variable-using-key ((key (eql :kludge-tls)) &rest initargs)
  (apply #'make-dynamic-variable-using-key
         'surrogate-thread-local-variable initargs))

;;; For *DEFAULT-DYNAMIC-VARIABLE* specify :DYNAMIC T.

(defmethod make-dynamic-variable-using-key ((key (eql :normal-dyn)) &rest initargs)
  (apply #'make-dynamic-variable-using-key
         'standard-dynamic-variable initargs))

(defmethod make-dynamic-variable-using-key ((key (eql :kludge-dyn)) &rest initargs)
  (apply #'make-dynamic-variable-using-key
         'surrogate-dynamic-variable initargs))

In order to do that, we need to remember he value of the argument :DYNAMIC. We will read it with DYNAMIC-VARIABLE-TYPE and that value will be available in both direct and the effective slot:

;;; Slot definitions
;;; There is a considerable boilerplate involving customizing slots.
;;;
;;; - direct slot definition: local to a single defclass form
;;;
;;; - effective slot definition: combination of all direct slots with the same
;;;   name in the class and its superclasses
;;;
(defclass dynamic-direct-slot (mop:standard-direct-slot-definition)
  ((dynamic :initform nil :initarg :dynamic :reader dynamic-variable-type)))

;;; The metaobject protocol did not specify an elegant way to communicate
;;; between the direct slot definition and the effective slot definition.
;;; Luckily we have dynamic bindings! :-)
(defvar *kludge/mop-deficiency/dynamic-variable-type* nil)

;;; DYNAMIC-EFFECTIVE-SLOT is implemented to return as slot-value values of the
;;; dynamic variable that is stored with the instance.
;;;
;;; It would be nice if we could specify :ALLOCATION :DYNAMIC for the slot, but
;;; then STANDARD-INSTANCE-ACCESS would go belly up. We could make a clever
;;; workaround, but who cares?
(defclass dynamic-effective-slot (mop:standard-effective-slot-definition)
  ((dynamic :initform *kludge/mop-deficiency/dynamic-variable-type*
            :reader dynamic-variable-type)))

Moreover we specialize the function MAKE-DYNAMIC-VARIABLE-USING-KEY to the effective slot class. The initargs in this method are meant for the instance. When the dynamic variable is created, we check whether it is a thread-local variable and initialize its INITVAL and INITFUN to values derived from INITARGS, MOP:SLOT-DEFINITION-INITARGS and MOP:SLOT-DEFINITION-INITFUN:

(defmethod make-dynamic-variable-using-key
    ((key dynamic-effective-slot) &rest initargs)
  (let* ((dvar-type (dynamic-variable-type key))
         (dvar (make-dynamic-variable-using-key dvar-type)))
    (when (typep dvar 'thread-local-variable)
      (loop with slot-initargs = (mop:slot-definition-initargs key)
            for (key val) on initargs by #'cddr
            when (member key slot-initargs) do
              (setf (thread-local-variable-initval dvar) val))
      (setf (thread-local-variable-initfun dvar)
            (mop:slot-definition-initfunction key)))
    dvar))

The rest of the implementation of DYNAMIC-EFFECTIVE-SLOT is unchanged:

(defmethod mop:slot-value-using-class
    ((class standard-class)
     object
     (slotd dynamic-effective-slot))
  (dref (slot-dvar object slotd)))

(defmethod (setf mop:slot-value-using-class)
    (new-value
     (class standard-class)
     object
     (slotd dynamic-effective-slot))
  (dset (slot-dvar object slotd) new-value))

(defmethod mop:slot-boundp-using-class
  ((class standard-class)
   object
   (slotd dynamic-effective-slot))
  (dynamic-variable-bound-p (slot-dvar object slotd)))

(defmethod mop:slot-makunbound-using-class
  ((class standard-class)
   object
   (slotd dynamic-effective-slot))
  (dynamic-variable-makunbound (slot-dvar object slotd)))

The implementation of CLASS-WITH-DYNAMIC-SLOTS is also very similar. The first difference in that ALLOCATE-INSTANCE calls MAKE-DYNAMIC-VARIABLE-USING-KEY instead of MAKE-DYNAMIC-VARIABLE and supplies the effective slot definition as the key, and the instance initargs as the remaining arguments. Note that at this point initargs are already validated by MAKE-INSTANCE. The second difference is that MOP:COMPUTE-EFFECTIVE-SLOT-DEFINITION binds the flag *KLUDGE/MOP-DEFICIENCY/DYNAMIC-VARIABLE-TYPE* to DYNAMIC-VARIABLE-TYPE.

;;; This is a metaclass that allows defining dynamic slots that are bound with
;;; the operator SLOT-DLET, and, depending on the type, may have thread-local
;;; top value.
;;;
;;; The metaclass CLASS-WITH-DYNAMIC-SLOTS specifies alternative effective slot
;;; definitions for slots with an initarg :dynamic.
(defclass class-with-dynamic-slots (standard-class) ())

;;; Class with dynamic slots may be subclasses of the standard class.
(defmethod mop:validate-superclass ((class class-with-dynamic-slots)
                                    (super standard-class))
  t)

;;; When allocating the instance we initialize all slots to a fresh symbol that
;;; represents the dynamic variable.
(defmethod allocate-instance ((class class-with-dynamic-slots) &rest initargs)
  (let ((object (call-next-method)))
    (loop for slotd in (mop:class-slots class)
          when (typep slotd 'dynamic-effective-slot) do
            (setf (mop:standard-instance-access
                   object
                   (mop:slot-definition-location slotd))
                  (apply #'make-dynamic-variable-using-key slotd initargs)))
    object))

;;; To improve potential composability of CLASS-WITH-DYNAMIC-SLOTS with other
;;; metaclasses we treat specially only slots that has :DYNAMIC in initargs,
;;; otherwise we call the next method.
(defmethod mop:direct-slot-definition-class
    ((class class-with-dynamic-slots) &rest initargs)
  (loop for (key) on initargs by #'cddr
        when (eq key :dynamic)
          do (return-from mop:direct-slot-definition-class
               (find-class 'dynamic-direct-slot)))
  (call-next-method))

(defmethod mop:compute-effective-slot-definition
    ((class class-with-dynamic-slots)
     name
     direct-slotds)
  (declare (ignore name))
  (let ((latest-slotd (first direct-slotds)))
    (if (typep latest-slotd 'dynamic-direct-slot)
        (let ((*kludge/mop-deficiency/dynamic-variable-type*
                (dynamic-variable-type latest-slotd)))
          (call-next-method))
        (call-next-method))))

(defmethod mop:effective-slot-definition-class
    ((class class-with-dynamic-slots) &rest initargs)
  (declare (ignore initargs))
  (if *kludge/mop-deficiency/dynamic-variable-type*
      (find-class 'dynamic-effective-slot)
      (call-next-method)))

Finally the implementation of SLOT-DLET does not change:

;;; Accessing and binding symbols behind the slot. We don't use SLOT-VALUE,
;;; because it will return the _value_ of the dynamic variable, and not the
;;; variable itself.
(defun slot-dvar (object slotd)
  (check-type slotd dynamic-effective-slot)
  (mop:standard-instance-access
   object (mop:slot-definition-location slotd)))

(defun slot-dvar* (object slot-name)
  (let* ((class (class-of object))
         (slotd (find slot-name (mop:class-slots class)
                      :key #'mop:slot-definition-name)))
    (slot-dvar object slotd)))

(defmacro slot-dlet (bindings &body body)
  `(dlet ,(loop for ((object slot-name) val) in bindings
                collect `((slot-dvar* ,object ,slot-name) ,val))
     ,@body))

Finally we can define a class with slots that do not share the top value:

DYNAMIC-VARS> (defclass c1 ()
                  ((slot1 :initarg :slot1 :dynamic nil :accessor slot1)
                   (slot2 :initarg :slot2 :dynamic t   :accessor slot2)
                   (slot3 :initarg :slot3 :dynamic :tls :accessor slot3))
                  (:metaclass class-with-dynamic-slots))
#<The EU.TURTLEWARE.DYNAMIC-VARS::CLASS-WITH-DYNAMIC-SLOTS EU.TURTLEWARE.DYNAMIC-VARS::C1>
DYNAMIC-VARS> (with-slots (slot1 slot2 slot3) *object*
                (setf slot1 :x slot2 :y slot3 :z)
                (list slot1 slot2 slot3))
(:X :Y :Z)
DYNAMIC-VARS> (bt:make-thread
               (lambda ()
                 (with-slots (slot1 slot2 slot3) *object*
                   (setf slot1 :i slot2 :j slot3 :k)
                   (print (list slot1 slot2 slot3)))))

#<process "Anonymous thread" 0x7f76424c0240>

(:I :J :K) 
DYNAMIC-VARS> (with-slots (slot1 slot2 slot3) *object*
                (list slot1 slot2 slot3))
(:I :J :Z)

What can we use it for?

Now that we know how to define thread-local variables, we are left with a question what can we use it for. Consider having a line-buffering stream. One possible implementation could be sketched as:

(defclass line-buffering-stream (fancy-stream)
  ((current-line :initform (make-adjustable-string)
                 :accessor current-line)
   (current-ink :initform +black+
                :accessor current-ink)))

(defmethod stream-write-char ((stream line-buffering-stream) char)
  (if (char= char #\newline)
      (terpri stream)
      (vector-push-extend char (current-line stream))))

(defmethod stream-terpri ((stream line-buffering-stream))
  (%put-line-on-screen (current-line stream) (current-ink stream))
  (setf (fill-pointer (current-line stream)) 0))

If this stream is shared between multiple threads, then even if individual operations and %PUT-LINE-ON-SCREEN are thread-safe , we have a problem. For example FORMAT writes are not usually atomic and individual lines are easily corrupted. If we use custom colors, these are also a subject of race conditions. The solution is as easy as making both slots thread-local. In that case the buffered line is private to each thread and it is put on the screen atomically:

(defclass line-buffering-stream (fancy-stream)
  ((current-line
    :initform (make-adjustable-string)
    :accessor current-line
    :dynamic :tls)
   (current-ink
    :initform +black+
    :accessor current-ink
    :dynamic :tls))
  (:metaclass class-with-dynamic-slots))

Technique is not limited to streams. It may benefit thread-safe drawing, request processing, resource management and more. By subclassing DYNAMIC-VARIABLE we could create also variables that are local to different objects than processes.

I hope that you've enjoyed reading this post as much as I had writing it. If you are interested in a full standalone implementation, with tests and system definitions, you may get it here. Cheers!

04 Nov 2024 12:00am GMT

02 Nov 2024

feedPlanet Lisp

Joe Marshall: Don't Try to Program in Lisp

A comment on my previous post said,

The most difficult thing when coming to a different language is to leave the other language behind. The kind of friction experienced here is common when transliterating ideas from one language to another. Go (in this case) is telling you it just doesn't like to work like this.

Try writing simple Go, instead of reaching for Lisp idioms. Then find the ways that work for Go to express the concepts you find.

That's not at all how I approach programming.

A friend of mine once paid me a high compliment. He said, "Even your C code looks like Lisp."

When I write code, I don't think in terms of the language I'm using, I think in terms of the problem I'm solving. I'm a mostly functional programmer, so I like to think in terms of functions and abstractions. I mostly reason about my code informally, but I draw upon the formal framework of Lambda Calculus. Lambda Calculus is a simple, but powerful (and universal) model of computation.

Programming therefore becomes a matter of expressing the solution to a problem with the syntax and idioms of the language I'm using. Lisp was inspired by Lambda Calculus, so there is little friction in expressing computations in Lisp. Lisp is extensible and customizable, so I can add new syntax and idioms as desired.

Other languages are less accommodating. Some computations are not easily expressable in the syntax of the language, or the semantics of the language are quirky and inconsistent. Essentially, every general purpose fourth generation programming language can be viewed as a poorly-specified, half-assed, incomplete, bug-ridden implementation of half of Common Lisp. The friction comes from working around the limitations of the language.

02 Nov 2024 5:12pm GMT

28 Oct 2024

feedPlanet Lisp

TurtleWare: Dynamic Vars - The Empire Strikes Back

Table of Contents

  1. Thread Local storage exhausted
  2. The layer of indirection
  3. I can fix her
  4. Let's write some tests!
  5. Summary

Thread Local storage exhausted

In the last post I've described a technique to use dynamic variables by value instead of the name by utilizing the operator PROGV. Apparently it works fine on all Common Lisp implementations I've tried except from SBCL, where the number of thread local variables is by default limited to something below 4000. To add salt to the injury, these variables are not garbage collected.

Try the following code to crash into LDB:

(defun foo ()
  (loop for i from 0 below 4096 do
    (when (zerop (mod i 100))
      (print i))
    (progv (list (gensym)) (list 42)
      (values))))
(foo)

This renders our new technique not very practical given SBCL popularity. We need to either abandon the idea or come up with a workaround.

The layer of indirection

Luckily for us we've already introduced a layer of indirection. Operators to access dynamic variables are called DLET, DSET and DREF. This means, that it is enough to provide a kludge implementation for SBCL with minimal changes to the remaining code.

The old code works the same as previously except that instead of SYMBOL-VALUE we use the accessor DYNAMIC-VARIABLE-VALUE, and the old call to PROGV is now DYNAMIC-VARIABLE-PROGV. Moreover DYNAMIC-EFFECTIVE-SLOT used functions BOUNDP and MAKUNBOUND, so we replace these with DYNAMIC-VARIABLE-BOUND-P and DYNAMIC-VARIABLE-MAKUNBOUND. To abstract away things further we also introduce the constructor MAKE-DYNAMIC-VARIABLE

(defpackage "EU.TURTLEWARE.BLOG/DLET"
  (:local-nicknames ("MOP" #+closer-mop "C2MOP"
                           #+(and (not closer-mop) ecl) "MOP"
                           #+(and (not closer-mop) ccl) "CCL"
                           #+(and (not closer-mop) sbcl) "SB-MOP"))
  (:use "CL"))
(in-package "EU.TURTLEWARE.BLOG/DLET")

(eval-when (:compile-toplevel :execute :load-toplevel)
  (unless (member :bordeaux-threads *features*)
    (error "Please load BORDEAUX-THREADS."))
  (when (member :sbcl *features*)
    (unless (member :fake-progv-kludge *features*)
      (format t "~&;; Using FAKE-PROGV-KLUDGE for SBCL.~%")
      (push :fake-progv-kludge *features*))))

(defmacro dlet (bindings &body body)
  (flet ((pred (binding)
           (and (listp binding) (= 2 (length binding)))))
    (unless (every #'pred bindings)
      (error "DLET: bindings must be lists of two values.~%~
                Invalid bindings:~%~{ ~s~%~}" (remove-if #'pred bindings))))
  (loop for (var val) in bindings
        collect var into vars
        collect val into vals
        finally (return `(dynamic-variable-progv (list ,@vars) (list ,@vals)
                           ,@body))))

(defmacro dset (&rest pairs)
  `(setf ,@(loop for (var val) on pairs by #'cddr
                 collect `(dref ,var)
                 collect val)))

(defmacro dref (variable)
  `(dynamic-variable-value ,variable))

;;; ...

(defmethod mop:slot-boundp-using-class
    ((class standard-class)
     object
     (slotd dynamic-effective-slot))
  (dynamic-variable-bound-p (slot-dvar object slotd)))

(defmethod mop:slot-makunbound-using-class
    ((class standard-class)
     object
     (slotd dynamic-effective-slot))
  (dynamic-variable-makunbound (slot-dvar object slotd)))

With these in place we can change the portable implementation to conform.

#-fake-progv-kludge
(progn
  (defun make-dynamic-variable ()
    (gensym))

  (defun dynamic-variable-value (variable)
    (symbol-value variable))

  (defun (setf dynamic-variable-value) (value variable)
    (setf (symbol-value variable) value))

  (defun dynamic-variable-bound-p (variable)
    (boundp variable))

  (defun dynamic-variable-makunbound (variable)
    (makunbound variable))

  (defmacro dynamic-variable-progv (vars vals &body body)
    `(progv ,vars ,vals ,@body)))

I can fix her

The implementation for SBCL will mediate access to the dynamic variable value with a synchronized hash table with weak keys. The current process is the key of the hash table and the list of bindings is the value of the hash table. For compatibility between implementations the top level value of the symbol will be shared.

The variable +FAKE-UNBOUND+ is the marker that signifies, that the variable has no value. When the list of bindings is EQ to +CELL-UNBOUND+, then it means that we should use the global value. We add new bindings by pushing to it.

#+fake-progv-kludge
(progn
  (defvar +fake-unbound+ 'unbound)
  (defvar +cell-unbound+ '(no-binding))

  (defclass dynamic-variable ()
    ((tls-table
      :initform (make-hash-table :synchronized t :weakness :key)
      :reader dynamic-variable-tls-table)
     (top-value
      :initform +fake-unbound+
      :accessor dynamic-variable-top-value)))

  (defun make-dynamic-variable ()
    (make-instance 'dynamic-variable))

  (defun dynamic-variable-bindings (dvar)
    (let ((process (bt:current-thread))
          (tls-table (dynamic-variable-tls-table dvar)))
      (gethash process tls-table +cell-unbound+)))

  (defun (setf dynamic-variable-bindings) (value dvar)
    (let ((process (bt:current-thread))
          (tls-table (dynamic-variable-tls-table dvar)))
      (setf (gethash process tls-table +cell-unbound+) value))))

We define two readers for the variable value - one that simply reads the value, and the other that signals an error if the variable is unbound. Writer for its value either replaces the current binding, or if the value cell is unbound, then we modify the top-level symbol value. We use the value +FAKE-UNBOUND+ to check whether the variable is bound and to make it unbound.

#+fake-progv-kludge
(progn
  (defun %dynamic-variable-value (dvar)
    (let ((tls-binds (dynamic-variable-bindings dvar)))
      (if (eq tls-binds +cell-unbound+)
          (dynamic-variable-top-value dvar)
          (car tls-binds))))

  (defun dynamic-variable-value (dvar)
    (let ((tls-value (%dynamic-variable-value dvar)))
      (when (eq tls-value +fake-unbound+)
        (error 'unbound-variable :name "(unnamed)"))
      tls-value))

  (defun (setf dynamic-variable-value) (value dvar)
    (let ((tls-binds (dynamic-variable-bindings dvar)))
      (if (eq tls-binds +cell-unbound+)
          (setf (dynamic-variable-top-value dvar) value)
          (setf (car tls-binds) value))))

  (defun dynamic-variable-bound-p (dvar)
    (not (eq +fake-unbound+ (%dynamic-variable-value dvar))))

  (defun dynamic-variable-makunbound (dvar)
    (setf (dynamic-variable-value dvar) +fake-unbound+)))

Finally we define the operator to dynamically bind variables that behaves similar to PROGV. Note that we PUSH and POP from the thread-local hash table DYNAMIC-VARIABLE-BINDINGS, so no synchronization is necessary.

#+fake-progv-kludge
(defmacro dynamic-variable-progv (vars vals &body body)
  (let ((svars (gensym))
        (svals (gensym))
        (var (gensym))
        (val (gensym)))
    `(let ((,svars ,vars))
       (loop for ,svals = ,vals then (rest ,svals)
             for ,var in ,svars
             for ,val = (if ,svals (car ,svals) +fake-unbound+)
             do (push ,val (dynamic-variable-bindings ,var)))
       (unwind-protect (progn ,@body)
         (loop for ,var in ,svars
               do (pop (dynamic-variable-bindings ,var)))))))

Let's write some tests!

But of course, we are going to also write a test framework. It's short, I promise. As a bonus point the API is compatibile with fiveam, so it is possible to drop tests as is in the appropriate test suite.

(defvar *all-tests* '())

(defun run-tests ()
  (dolist (test (reverse *all-tests*))
    (format *debug-io* "Test ~a... " test)
    (handler-case (funcall test)
      (serious-condition (c)
        (format *debug-io* "Failed: ~a~%" c))
      (:no-error (&rest args)
        (declare (ignore args))
        (format *debug-io* "Passed.~%")))))

(defmacro test (name &body body)
  `(progn
     (pushnew ',name *all-tests*)
     (defun ,name () ,@body)))

(defmacro is (form)
  `(assert ,form))

(defmacro pass ())

(defmacro signals (condition form)
  `(is (block nil
         (handler-case ,form
           (,condition () (return t)))
         nil)))

(defmacro finishes (form)
  `(is (handler-case ,form
         (serious-condition (c)
           (declare (ignore c))
           nil)
         (:no-error (&rest args)
           (declare (ignore args))
           t))))

Now let's get to tests. First we'll test our metaclass:

(defclass dynamic-let.test-class ()
  ((slot1 :initarg :slot1 :dynamic nil :accessor slot1)
   (slot2 :initarg :slot2 :dynamic t   :accessor slot2)
   (slot3 :initarg :slot3              :accessor slot3))
  (:metaclass class-with-dynamic-slots))

(defparameter *dynamic-let.test-instance-1*
  (make-instance 'dynamic-let.test-class
                 :slot1 :a :slot2 :b :slot3 :c))

(defparameter *dynamic-let.test-instance-2*
  (make-instance 'dynamic-let.test-class
                 :slot1 :x :slot2 :y :slot3 :z))

(test dynamic-let.1
  (let ((o1 *dynamic-let.test-instance-1*)
        (o2 *dynamic-let.test-instance-2*))
    (with-slots (slot1 slot2 slot3) o1
      (is (eq :a slot1))
      (is (eq :b slot2))
      (is (eq :c slot3)))
    (with-slots (slot1 slot2 slot3) o2
      (is (eq :x slot1))
      (is (eq :y slot2))
      (is (eq :z slot3)))))

(test dynamic-let.2
  (let ((o1 *dynamic-let.test-instance-1*)
        (o2 *dynamic-let.test-instance-2*))
    (signals error (slot-dlet (((o1 'slot1) 1)) nil))
    (slot-dlet (((o1 'slot2) :k))
      (is (eq :k (slot-value o1 'slot2)))
      (is (eq :y (slot-value o2 'slot2))))))

(test dynamic-let.3
  (let ((o1 *dynamic-let.test-instance-1*)
        (exit nil)
        (fail nil))
    (flet ((make-runner (values)
             (lambda ()
               (slot-dlet (((o1 'slot2) :start))
                 (let ((value (slot2 o1)))
                   (unless (eq value :start)
                     (setf fail value)))
                 (loop until (eq exit t) do
                   (setf (slot2 o1) (elt values (random (length values))))
                   (let ((value (slot2 o1)))
                     (unless (member value values)
                       (setf fail value)
                       (setf exit t))))))))
      (let ((r1 (bt:make-thread (make-runner '(:k1 :k2))))
            (r2 (bt:make-thread (make-runner '(:k3 :k4))))
            (r3 (bt:make-thread (make-runner '(:k5 :k6)))))
        (sleep .1)
        (setf exit t)
        (map nil #'bt:join-thread (list r1 r2 r3))
        (is (eq (slot2 o1) :b))
        (is (null fail))))))

Then let's test the dynamic variable itself:

(test dynamic-let.4
  "Test basic dvar operators."
  (let ((dvar (make-dynamic-variable)))
    (is (eql 42 (dset dvar 42)))
    (is (eql 42 (dref dvar)))
    (ignore-errors
     (dlet ((dvar :x))
       (is (eql :x (dref dvar)))
       (error "foo")))
    (is (eql 42 (dref dvar)))))

(test dynamic-let.5
  "Test bound-p operator."
  (let ((dvar (make-dynamic-variable)))
    (is (not (dynamic-variable-bound-p dvar)))
    (dset dvar 15)
    (is (dynamic-variable-bound-p dvar))
    (dynamic-variable-makunbound dvar)
    (is (not (dynamic-variable-bound-p dvar)))))

(test dynamic-let.6
  "Test makunbound operator."
  (let ((dvar (make-dynamic-variable)))
    (dset dvar t)
    (is (dynamic-variable-bound-p dvar))
    (finishes (dynamic-variable-makunbound dvar))
    (is (not (dynamic-variable-bound-p dvar)))))

(test dynamic-let.7
  "Test locally bound-p operator."
  (let ((dvar (make-dynamic-variable)))
    (is (not (dynamic-variable-bound-p dvar)))
    (dlet ((dvar 15))
      (is (dynamic-variable-bound-p dvar)))
    (is (not (dynamic-variable-bound-p dvar)))))

(test dynamic-let.8
  "Test locally unbound-p operator."
  (let ((dvar (make-dynamic-variable)))
    (dset dvar t)
    (is (dynamic-variable-bound-p dvar))
    (dlet ((dvar nil))
      (is (dynamic-variable-bound-p dvar))
      (finishes (dynamic-variable-makunbound dvar))
      (is (not (dynamic-variable-bound-p dvar))))
    (is (dynamic-variable-bound-p dvar))))

(test dynamic-let.9
  "Stress test the implementation (see :FAKE-PROGV-KLUDGE)."
  (finishes                              ; at the same time
    (let ((dvars (loop repeat 4096 collect (make-dynamic-variable))))
      ;; ensure tls variable
      (loop for v in dvars do
        (dlet ((v 1))))
      (loop for i from 0 below 4096
            for r = (random 4096)
            for v1 in dvars
            for v2 = (elt dvars r) do
              (when (zerop (mod i 64))
                (pass))
              (dlet ((v1 42)
                     (v2 43))
                (values))))))

(test dynamic-let.0
  "Stress test the implementation (see :FAKE-PROGV-KLUDGE)."
  (finishes                             ; can be gc-ed
    (loop for i from 0 below 4096 do
      (when (zerop (mod i 64))
        (pass))
      (dlet (((make-dynamic-variable) 42))
        (values)))))

All that is left is to test both dynamic variable implementations:

BLOG/DLET> (lisp-implementation-type)
"ECL"
BLOG/DLET> (run-tests)
Test DYNAMIC-LET.1... Passed.
Test DYNAMIC-LET.2... Passed.
Test DYNAMIC-LET.3... Passed.
Test DYNAMIC-LET.4... Passed.
Test DYNAMIC-LET.5... Passed.
Test DYNAMIC-LET.6... Passed.
Test DYNAMIC-LET.7... Passed.
Test DYNAMIC-LET.8... Passed.
Test DYNAMIC-LET.9... Passed.
Test DYNAMIC-LET.0... Passed.
NIL

And with the kludge:

BLOG/DLET> (lisp-implementation-type)
"SBCL"
BLOG/DLET> (run-tests)
Test DYNAMIC-LET.1... Passed.
Test DYNAMIC-LET.2... Passed.
Test DYNAMIC-LET.3... Passed.
Test DYNAMIC-LET.4... Passed.
Test DYNAMIC-LET.5... Passed.
Test DYNAMIC-LET.6... Passed.
Test DYNAMIC-LET.7... Passed.
Test DYNAMIC-LET.8... Passed.
Test DYNAMIC-LET.9... Passed.
Test DYNAMIC-LET.0... Passed.
NIL

Summary

In this post we've made our implementation to work on SBCL even when there are more than a few thousand dynamic variables. We've also added a simple test suite that checks the basic behavior.

As it often happens, after achieving some goal we get greedy and achieve more. That's the case here as well. In the next (and the last) post in this series I'll explore the idea of adding truly thread-local variables without a shared global value. This will be useful for lazily creating context on threads that are outside of our control. We'll also generalize the implementation so it is possible to subclass and implement ones own flavor of a dynamic variable.

28 Oct 2024 12:00am GMT