A New Compiler for XLISP-STAT

Luke Tierney ^{1} September 16, 1998

1Research supported in part by grant DMS-9303557 from the National Science Foundation.

Contents

1 Introduction 5 1.1 Background . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 5 1.2 Interface . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 5 1.3 Issues . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 7

2 Intermediate Representation 9

2.1 Data Representation . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 9 2.1.1 Global Variables . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 9 2.1.2 Values . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 9 2.1.3 Compound Expressions . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 10 2.1.4 Some Utility Functions . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 15

2.2 Parser for the Intermediate Form . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 16 2.2.1 Parsing Values . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 16 2.2.2 Parsing Compound Expressions . . . . . . . . . . . . . . . . . . . . . . . . . . 16

2.3 Simple Transformations . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 19 2.3.1 Value Substitution . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 19 2.3.2 Cell Insertion . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 20

3 Conversion to Intermediate Form 23 3.1 Some Utility Functions . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 23 3.2 Macro Expansion . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 25 3.3 Maintaining the Compilation Context . . . . . . . . . . . . . . . . . . . . . . . . . . 25 3.4 Managing the Conversion Environment . . . . . . . . . . . . . . . . . . . . . . . . . . 26

3.4.1 Data Structures . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 26 3.4.2 Variables . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 26 3.4.3 Functions . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 27 3.4.4 Block Tags . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 28 3.4.5 Tagbody Tags . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 28 3.4.6 Declarations . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 28

3.5 Main Conversion Functions . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 29 3.5.1 Main Driver Function . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 29 3.5.2 Converter Dispatch System . . . . . . . . . . . . . . . . . . . . . . . . . . . . 29 3.5.3 Compound Expression Converters . . . . . . . . . . . . . . . . . . . . . . . . 30 3.5.4 A Simple Inlining System . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 32 3.5.5 Converters for Atoms . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 32

3.6 Lambda Expression Conversion . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 34 3.6.1 Parsing Lambda Lists . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 34

3.6.2 Processing the Expression . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 36 3.7 Special Operator Converters . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 38

3.7.1 BLOCK Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 39 3.7.2 CASE Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 39 3.7.3 CATCH Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 41 3.7.4 ERRSET Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 41 3.7.5 FLET Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 41 3.7.6 FUNCTION Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 42 3.7.7 GO Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 42 3.7.8 IF Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 43 3.7.9 LABELS Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 43 3.7.10 LAMBDA Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 43 3.7.11 LET Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 44 3.7.12 LET* Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 45 3.7.13 LOAD-TIME-VALUE Converter . . . . . . . . . . . . . . . . . . . . . . . . . 46 3.7.14 LOCALLY Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 46 3.7.15 MACROLET Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 46 3.7.16 MULTIPLE-VALUE-CALL Converter . . . . . . . . . . . . . . . . . . . . . . 47 3.7.17 MULTIPLE-VALUE-PROG1 Converter . . . . . . . . . . . . . . . . . . . . . 47 3.7.18 NTH-VALUE Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 48 3.7.19 PROGN Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 48 3.7.20 PROGV Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 49 3.7.21 QUOTE Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 49 3.7.22 RETURN-FROM Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . 49 3.7.23 SETQ Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 49 3.7.24 SYMBOL-MACROLET Converter . . . . . . . . . . . . . . . . . . . . . . . . 50 3.7.25 TAGBODY Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 50 3.7.26 THE Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 52 3.7.27 THROW Converter . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 52 3.7.28 UNWIND-PROTECT Converter . . . . . . . . . . . . . . . . . . . . . . . . . 52

3.8 Error Checking . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 53 3.8.1 Error and Warning Messages . . . . . . . . . . . . . . . . . . . . . . . . . . . 53 3.8.2 Checking Function Calls . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 55

3.9 Registering Built-In Functions . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 57 3.9.1 Functions with No Required Arguments . . . . . . . . . . . . . . . . . . . . . 57 3.9.2 Functions with One Required Argument . . . . . . . . . . . . . . . . . . . . . 58 3.9.3 Functions with Two Required Arguments . . . . . . . . . . . . . . . . . . . . 60 3.9.4 Functions with Three or More Required Arguments . . . . . . . . . . . . . . 62

4 Removing Blocks, Tagbodies, and Cells 63

4.1 Computing a Call Graph . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 63 4.1.1 Call Graph Data Structures . . . . . . . . . . . . . . . . . . . . . . . . . . . . 63 4.1.2 Computing the Graph . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 64

4.2 Identifying Tail-Only Uses . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 65 4.2.1 Collecting Non-Tail Use Information . . . . . . . . . . . . . . . . . . . . . . . 65 4.2.2 Examining Call Paths . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 67

4.3 Removing Safe Blocks and Tagbodies . . . . . . . . . . . . . . . . . . . . . . . . . . . 67 4.3.1 Main Routines . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 67 4.3.2 Collecting Tags information . . . . . . . . . . . . . . . . . . . . . . . . . . . . 68 4.3.3 Replacing Safe Jumps . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 69 4.3.4 Removing Unused Blocks and Tagbodies . . . . . . . . . . . . . . . . . . . . . 71

4.4 Removing Safe Cells . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 72 4.4.1 Identifying Cells for Removal . . . . . . . . . . . . . . . . . . . . . . . . . . . 72 4.4.2 Finding Free Cells . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 73 4.4.3 Removing Cells . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 76

5 Code Simplification and Optimization 79 5.1 Dropping Unused Functions . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 79 5.2 Substituting Functions Called Only Once . . . . . . . . . . . . . . . . . . . . . . . . 80

5.2.1 Counting Function Uses . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 80 5.2.2 Substituting the Functions . . . . . . . . . . . . . . . . . . . . . . . . . . . . 82 5.2.3 Substituting a Call . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 83

5.3 Eta Substitution . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 85 5.4 Copying with Alpha Conversion . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 87 5.5 Simplifier . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 87

5.5.1 Variable Use Information . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 87 5.5.2 Simplification Driver . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 88 5.5.3 Some Call Simplifiers . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 92 5.5.4 Converting Calls to Primops . . . . . . . . . . . . . . . . . . . . . . . . . . . 93 5.5.5 Simplifiers For Some Primops . . . . . . . . . . . . . . . . . . . . . . . . . . . 98 5.5.6 Simplifiers For Values Primops . . . . . . . . . . . . . . . . . . . . . . . . . . 103 5.5.7 Simplifiers For Some Testops . . . . . . . . . . . . . . . . . . . . . . . . . . . 104 5.5.8 Dead Variable Elimination . . . . . . . . . . . . . . . . . . . . . . . . . . . . 106 5.5.9 Other Optimizations . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 106

5.6 Common Subexpression Elimination . . . . . . . . . . . . . . . . . . . . . . . . . . . 106 5.7 Inline Expansion . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 107

5.7.1 Expanding Small Non-Recursive Functions . . . . . . . . . . . . . . . . . . . 107 5.7.2 Expanding Some Built-In Functions . . . . . . . . . . . . . . . . . . . . . . . 108

5.8 Hoisting . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 111 5.9 Pushing Continuations into Letrecs . . . . . . . . . . . . . . . . . . . . . . . . . . . . 111

5.9.1 Main Routine . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 111 5.9.2 Comparing Expressions . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 112 5.9.3 Another Free Variable Determination Routine . . . . . . . . . . . . . . . . . . 113 5.9.4 Finding Eligible Entry Points . . . . . . . . . . . . . . . . . . . . . . . . . . . 114 5.9.5 Finding the Tail Functions . . . . . . . . . . . . . . . . . . . . . . . . . . . . 115 5.9.6 Inserting the Continuation . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 118

6 Lambda and Constant Lifting 120

6.1 Splitting Functions . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 120 6.1.1 Data Structures . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 121 6.1.2 Main Functions . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 121 6.1.3 Splitting Functions in letrec Expressions . . . . . . . . . . . . . . . . . . . . 122 6.1.4 Rewriting call Expressions . . . . . . . . . . . . . . . . . . . . . . . . . . . . 124 6.1.5 Other Expressions . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 125 6.2 Find Free Variables . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 126 6.3 Lambda Lifting . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 127 6.4 Constant Lifting . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 130

7 Code Generation for the Old Machine 133

7.1 Register Assignment . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 133 7.1.1 A Simple Version . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 133 7.1.2 Register Allocation by Graph Coloring . . . . . . . . . . . . . . . . . . . . . . 134

7.2 Computing Frame Sizes . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 141 7.3 Code Representation and Emission . . . . . . . . . . . . . . . . . . . . . . . . . . . . 142 7.4 Main Entry Point . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 143 7.5 Function Code Generators . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 144 7.6 Primop Code Generators . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 144

7.6.1 Constant Loading Primop . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 145 7.6.2 Arithmetic Primop Generators . . . . . . . . . . . . . . . . . . . . . . . . . . 146 7.6.3 Values Primop Generators . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 147 7.6.4 Catch-Related Primop Generators . . . . . . . . . . . . . . . . . . . . . . . . 148 7.6.5 Closure Primop Generators . . . . . . . . . . . . . . . . . . . . . . . . . . . . 150 7.6.6 Dynamic Binding Primop Generators . . . . . . . . . . . . . . . . . . . . . . 151 7.6.7 Structure Primop Generators . . . . . . . . . . . . . . . . . . . . . . . . . . . 151 7.6.8 Symbol Primop Generators . . . . . . . . . . . . . . . . . . . . . . . . . . . . 152

7.7 Testop Code Generators . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 155 7.8 Letrec Code Generators . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 157 7.9 Call Generators . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 158

7.9.1 Core Call Code Generation . . . . . . . . . . . . . . . . . . . . . . . . . . . . 158 7.9.2 Register Moving Code for Local Tail Calls . . . . . . . . . . . . . . . . . . . . 159

7.10 A Simple Front End . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 160

8 Compiler Top Level 161

8.1 Compiler Interface . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 161 8.1.1 Compiler Components . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 161 8.1.2 The COMPILE Function . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 163 8.1.3 The COMPILE-FILE Function . . . . . . . . . . . . . . . . . . . . . . . . . . 164 8.1.4 An Alternative Approach . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 168 8.1.5 The COMPILE-FILE-PATHNAME Function . . . . . . . . . . . . . . . . . . 169 8.1.6 Checking Definitions Against Calls . . . . . . . . . . . . . . . . . . . . . . . . 169 8.1.7 Registering Inline Information . . . . . . . . . . . . . . . . . . . . . . . . . . . 171

8.2 Loading and Building the System . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 172

9 Environment Management 174 9.1 Proclamations . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 174 9.2 Augmenting and Querying the Environment . . . . . . . . . . . . . . . . . . . . . . . 175

9.2.1 Environment Structure . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 175 9.2.2 Augmenting the Environment . . . . . . . . . . . . . . . . . . . . . . . . . . . 175 9.2.3 Querying the Environment . . . . . . . . . . . . . . . . . . . . . . . . . . . . 179

9.3 Modifications to Some Functions and Macros . . . . . . . . . . . . . . . . . . . . . . 180

Chapter 1

Introduction

1.1 Background

This report present the implementation of a new compiler for XLISP-STAT. This compiler targets essentially the same byte code engine as the original compiler, but a few new opcodes have been added. The design is similar to the design of the original compiler, but there are some important differences.

There are a number of reasons for rewriting the compiler:

• The original compiler works reasonably well, but it is not documented and is becoming increasingly hard to maintain and extend.

• While the new compiler does not yet use type information, its design should allow the use of type information to be incorporated fairly easily. This will be important for the generation of C or Java code.

• The dependence on the Lisp source language has been pretty much limited to the conversion module. This should allow the core of the compiler to be used with other source languages.

• The new compiler does more consistency checking and issues more warning of possible errors.

• The dependence on the byte code engine has been limited almost entirely to the code generation module. This should allow the core of the compiler to be used for targeting other runtime systems.

The last point is the most important: This is the first step in redesigning the runtime system to allow it to work with either a native engine or a Java runtime system.

1.2 Interface

The interface consists of the compile and compile-file functions and several variables.

compile name &optional definition [Function]

The definition is compiled. If name is not nil, then the compiled definition replaces the function definition of name. Definition should be a lambda expression or a function; if it is a function, it must be defined in the top level environment. The default definition is the function definition of name. If name is nil, then the compiled function is returned as the primary value. Otherwise, name is returned.

Two additional values are returned. The second value is true if any errors or warnings were signaled; otherwise it is false. The third value is true if any errors or warnings other than style-warnings were signaled.

compile-file file &key :output-file :load :print :verbose :temporary-file :print-symbol-package  [Function]

The contents of file is compiled and placed in the file specified by :output-file. The default output file is file with the type replaced by .fsl. If :load is not nil then the compiled file is loaded after compilation. If :print is not nil, then information about the forms being compiled is printed to the standard output. If :verbose is not nil, then a message about the file being compiled and the functions defined and used is printed as a comment to standard output. The temporary file used during compilation defaults to cmptmp.fsl; this can be changed with :temporary-file. Whether symbols are printed fully qualified in the compiler output file is de-

termined by :print-symbol-package.

Three values are returned by compile-file. The primary value is the true name of the output file. The second and third values are as for compile.

*compile-print*  [Variable]

The default value of the :print argument to compile-file.

*compile-verbose*  [Variable]

The default value of the :verbose argument to compile-file.

*compile-file-pathname*  [Variable]

Bound to the path name of the file being compiled by compile-file.

*compile-file-truename*  [Variable]

Bound to the true name of the file being compiled by compile-file.

*compile-print-symbol-package*  [Variable]
The default value of the :print-symbol-package argument to compile-file.
*inlining-enabled*  [Variable]

If this variables is not nil, globally defined functions declared or proclaimed inline and not covered by a notinline declaration are inlined.

*warn-undeclared-globals*  [Variable]

If this variable is not nil, then the compiler warns when a global variable is accessed or modified but has not been declared or proclaimed special.

This variable is initially nil. It is useful during development to turn this option on occasionally since it helps to identify errors like incorrectly spelled local variables. But the object system uses globals to represent prototypes, and defproto does not make these variables special. In principle making them special might be a good idea, but it would end up breaking lots of code. (For example, defining a prototype with name x as an experiment would then make x special).

*save-lambda-expressions*  [Variable]

If this variable is not nil, then the lambda expression is saved when a function is compiled.

1.3 Issues

1. • **** get rid of supplied-p.

• **** need summary of the abstract machine

• **** need description of ANF form

• **** add val-ignored slot to primops, use for block/tagbody?

• **** cleanup of simplify.nw – **** check handling of multiple value calls everywhere

– **** keep or remove car constant folder and friends?

• **** cleanup of environ.nw – **** clean up *inline-table* stuff

• **** cleanup of toplevel.nw:

– **** need better way of generating temporary file name for uniqueness.

– **** handling of inlining recursive isn’t quite right.

• **** cleanup of convert.nw – **** fix declarations for labels

– **** review inlining.

– **** do better job of maintaining context – abstract out a bit

– **** cache for inlining compilations?

– **** need load-time-value.

– **** leave unreadable defined constants as symbol value references?

– **** can gensyms be avoided for function arguments? At least use sensible name

strings?

• **** performance checking:

– **** check compiling whole system

– **** check when cells/tags are not dropped.

– **** do some more profiling.

– **** Compare assembly for simple loop and rem for new/old compilers.

2. • **** revise defstruct to use inlining instead of compiler macros; make the inlining op-

tional, controlled by some variable; drop use of compiler macros.

• **** split compiler into several packages?

• **** think about going to a single examine-cexpr/modify-cexpr function or macro.

• **** do something more sensible with context information.

3. • **** think about compiler macros — drop on redefinition?

• **** debugging/tracing/timing hooks 4. • **** eliminate opt arg test for inlined functions?

• **** inline nonrecursive functions. Need way of costing inline. Call costs more that tail call, costs more that ordinary op; cost may depend on type of function (estimate of chance of further simplification). Def costs something too.

• **** inline recursives.

• **** CSE

5. • **** Hoisting • **** Use type info.

• **** inline some other library functions

• **** get rid of keyword arguments in library functions.

Intermediate Representation

This chapter presents the intermediate representation used for code generation and optimization. The data structures used are based on those in Appel [1], but instead of using CPS a representation closer to the Administrative-Normal Form (ANF) of Flanagan et al. [3] is used.

A parser for reading in printed representations of the intermediate form is provided. It is less than perfect but is only meant for debugging purposes.

Finally, some simple transformations are included. ⟨intermed.lsp 9⟩≡

  (in-package "NEWCMP")

⟨data representation 9⟩

⟨parser for intermediate form 16⟩

⟨simple transformations 19⟩

2.1 Data Representation

There are two primary forms of expressions, values (constants and variables), and compound expressions. There are also a few globals used by the printing system.

⟨data representation 9⟩≡ (9)

⟨global variables 9⟩

⟨values 9⟩

⟨compound expressions 11⟩

2.1.1 Global Variables

Two global variables are used by the printing system. One represents the current indentation level, and the other is the indentation step to be used.

⟨global variables 9⟩≡ (9)

  (defparameter *cexpr-indent-level* 0)
  (defparameter *cexpr-indent-step* 1)

2.1.2 Values

Values are represented by the abstract structure type val. This structure contains a type slot to hold type information for the value. The name slot holds a name if one is available. The two concrete forms of values are constants and variables.

⟨values 9⟩≡ (9)

  (defstruct val type name)

⟨constants 10⟩

⟨variables 10⟩

Constants

Constants are represented by a structure that extends val. The value slot holds the value of the constant.

⟨constants 10⟩≡ (9) 10 ▷

  (defstruct (const (:include val)
                    (:constructor (new-const (value type name)))
                    (:print-function

⟨constant print function 10⟩))

    value)

The constructor forms an eql type specified from the value. The name is optional.

⟨constants 10⟩+≡ (9) ◁ 10

  (defun make-const (value &optional name)
    (new-const value `(eql ,value) name))

The print function for a constant prints it by name if a name is available and as its value otherwise. If the value is recognized as a constant by constantp, it is not quoted; otherwise it is quoted.

⟨constant print function 10⟩≡ (10)

  (lambda (x s d)
    (declare (ignore d))
    (let ((n (const-name x)))
      (if n
          (prin1 n s)
        (let  ((v (const-value x)))
          (prin1 (if (constantp v) v `(quote ,v)) s)))))

Variables

Variables also inherit from var. The tag slot is used by the converter to store use information, and the context slot is used for debugging information. The print function prints a variable as its name.

⟨variables 10⟩≡ (9)

  (defstruct (var (:include val)
                  (:constructor (make-var (name type context)))
                  (:print-function (lambda (x s d)
                                       (declare (ignore d))
                                       (prin1 (var-name x) s))))
    context tag)

2.1.3 Compound Expressions

CHAPTER 2. INTERMEDIATE REPRESENTATION 11

Generic compound expressions are represented by the abstract structure cexpr. Concrete versions represent primitive operations, functions, function calls, binding expressions, and test operations. The cexpr structure has four slots, fun, args, vars, and conts. The fun slot is used differently by different particular expression forms. The args slot represents arguments to the expression; it should contain a list of values. vars holds a list of the variables bound by the expression, and conts is a list of the continuations expressions. If conts is nil then the expression is in tail position. context is used for debugging information.

⟨compound expressions 11⟩≡ (9)

(defstruct cexpr fun args vars conts context)

⟨primop expressions 11⟩ ⟨function expressions 12⟩ ⟨call expressions 13⟩ ⟨binding expressions 14⟩ ⟨testop expressions 14⟩

⟨utility functions 15⟩

Primop Expressions

Primitive operations are represented by primop structures, which inherit from the cexpr structure. The primop structure adds one slot, data, for supplementing the fun slot if necessary.

⟨primop expressions 11⟩≡ (11) 11 ▷

(defstruct (primop (:include cexpr)
                   (:constructor
                    (new-primop (fun args vars conts data context)))
                   (:print-function print-primop))
  data)

The constructor function makes the continuation form argument into a list if it is supplied.

⟨primop expressions 11⟩+≡ (11) ◁ 11 11 ▷

(defun make-primop (fun args vars form data context)
  (new-primop fun args vars (if form (list form)) data context))

The accessor function primop-form retrieves the single continuation element.

⟨primop expressions 11⟩+≡ (11) ◁ 11 11 ▷

(defun primop-form (e) (first (primop-conts e)))

The printing function prints primops as a list of three elements or five elements, depending on whether the expression is in tail position or not.

⟨primop expressions 11⟩+≡ (11) ◁ 11 15 ▷

(defun print-primop (e s d)
  (declare (ignore d))
  (let* ((*cexpr-indent-level* (+ *cexpr-indent-level* *cexpr-indent-step*))
         (fun (primop-fun e))
         (args (primop-args e))
         (vars (primop-vars e))
         (form (primop-form e))
         (data (primop-data e))
         (fd (if data (list fun data) fun))
         (lev *cexpr-indent-level*))
    (cond
     (form (format s "(PRIMOP ~s ~s ~s ~%~vt~s)" fd args vars lev form))
     (vars (format s "(PRIMOP ~s ~s ~s)" fd args vars))
     (t (format s "(PRIMOP ~s ~s)" fd args)))))

Function Expressions

Functions are represented by the func structure. The structure adds name, type, nreq, nopt, has-rest, and nfree slots. The type slot records whether the function is an escaping function or a local function. The nreq, nopt and has-free slots record the number of required and optional arguments the function takes and whether the function has a rest argument. The nfree slot is used by the lambda-lifting code to record how many of the function’s leading arguments were added to represent free variables.

⟨function expressions 12⟩≡ (11) 12 ▷

  (defstruct (func
              (:include cexpr)
              (:constructor
               (new-func (vars name conts type nreq nopt has-rest context)))
              (:print-function print-func))
    name type nreq nopt has-rest (nfree 0))

The constructor make-func takes name, lambda-list and body arguments and an optional type argument. The lambda-list variables are installed in the vars slot. The list can include &optional and &rest markers, but the other elements must be variables (i. e. var structures).

⟨function expressions 12⟩+≡ (11) ◁ 12 12 ▷

  (defun make-func (name lambda-list body type context)
    (let* ((vars (remove '&optional (remove '&rest lambda-list)))
           (nv (length vars))
           (opt-pos (position '&optional lambda-list))
           (has-rest (if (member '&rest lambda-list) t nil))
           (nreq (if has-rest
                     (if opt-pos opt-pos (- nv 1))
                   (if opt-pos opt-pos nv)))
           (nopt (- nv nreq (if has-rest 1 0))))
      (new-func vars name (list body) type nreq nopt has-rest context)))

The func-body accessor retrieves the single conts entry.

⟨function expressions 12⟩+≡ (11) ◁ 12 12 ▷

  (defun func-body (e) (first (func-conts e)))

The func-lambda-list function constructs a lambda list for the function.

⟨function expressions 12⟩+≡ (11) ◁ 12 12 ▷

  (defun func-lambda-list (e)
    (let* ((vars (func-vars e))
           (nreq (func-nreq e))
           (has-rest (func-has-rest e))
           (rvrest (nthcdr nreq vars))
           (reqvars (ldiff vars rvrest))
           (optvars (if has-rest (butlast rvrest) rvrest))
           (restvar (if has-rest (first (last vars)) nil)))
      (cond
       ((and has-rest optvars)
        `(,@reqvars &optional ,@optvars &rest ,restvar))
       (has-rest `(,@reqvars &rest ,restvar))
       (optvars `(,@reqvars &optional ,@optvars))
       (t reqvars))))

The print function uses this lambda list to make a printed representation of the function. The type is used as the first element of the printed representation.

⟨function expressions 12⟩+≡ (11) ◁ 12

(defun print-func (e s d)
(declare (ignore d))
(let ((*cexpr-indent-level* (+ *cexpr-indent-level* *cexpr-indent-step*)))
  (format s "(~s ~s ~s~%~vt~s)"
          (func-type e)
          (func-name e)
          (func-lambda-list e)
          *cexpr-indent-level*
          (func-body e))))

Call Expressions

Call expressions are represented by call structures. The val-ignored slot is used to mark non-tail calls whose values are ignored. The is-mvcall slot is non-nil if the call arguments are to be taken from the value registers. In this case the args slot is nil. The weight slot is used in deciding whether a call can be inlined.

⟨call expressions 13⟩≡ (11) 13 ▷

(defstruct (call (:include cexpr)
               (:constructor (new-call (fun args vars conts val-ignored
                                            is-mvcall context)))
               (:print-function print-call))
val-ignored is-mvcall (weight 1))

The constructor make-call just wraps the continuation form, if there is one, in a list.

⟨call expressions 13⟩+≡ (11) ◁ 13 13 ▷

(defun make-call (fun args vars form val-ignored is-mvcall context)
(new-call fun args vars (if form (list form) nil) val-ignored
          is-mvcall context))

The accessor call-form retrieves the single continuation form.

⟨call expressions 13⟩+≡ (11) ◁ 13 13 ▷

(defun call-form (e) (first (call-conts e)))

The print function prints a call as a list of three or five elements, depending on whether it is in tail position or not.

⟨call expressions 13⟩+≡ (11) ◁ 13

(defun print-call (e s d)
(declare (ignore d))
(let* ((*cexpr-indent-level* (+ *cexpr-indent-level* *cexpr-indent-step*))
       (fun (call-fun e))
       (args (call-args e))
       (pargs (if (call-is-mvcall e) t args))
       (vars (call-vars e))
       (form (call-form e))
       (lev *cexpr-indent-level*))
  (if form
      (let ((pvars (if (and (null vars) (not (call-val-ignored e)))
                       t
                     vars)))
        (format s "(CALL ~s ~s ~s~%~vt~s)" fun pargs pvars lev form))
    (format s "(CALL ~s ~s)" fun pargs))))

Binding Expressions

There are two forms of binding expressions, bind expressions for binding values, and letrec expressions for binding functions. These expressions use the bind and letrec structures.

⟨binding expressions 14⟩≡ (11) 14 ▷

(defstruct (bind (:include cexpr)
                 (:constructor (new-bind (vars args conts context)))
                 (:print-function print-bindings)))
(defstruct (letrec (:include cexpr)
                   (:constructor (new-letrec (vars args conts context)))
                   (:print-function print-bindings)))

The constructors wrap the bodies in a list

⟨binding expressions 14⟩+≡ (11) ◁ 14 14 ▷

(defun make-bind (vars args body context)
  (new-bind vars args (list body) context))
(defun make-letrec (vars args body context)
  (new-letrec vars args (list body) context))

and the accessors bind-body and letrec-body extract the first conts element.

⟨binding expressions 14⟩+≡ (11) ◁ 14 14 ▷

(defun bind-body (e) (first (bind-conts e)))
(defun letrec-body (e) (first (letrec-conts e)))

The print function makes a bind or letrec form look a bit like a Scheme letrec expression.

⟨binding expressions 14⟩+≡ (11) ◁ 14

(defun print-bindings (x s d)
  (declare (ignore d))
  (let* ((head (if (bind-p x) "(BIND (" "(LETREC ("))
         (vars (letrec-vars x))
         (args (letrec-args x))
         (body (letrec-body x))
         (vs (format nil "~s" (first vars))))
    (format s "~a(~a " head vs)
    (let ((baselev (+ *cexpr-indent-level* (length head))))
      (let ((*cexpr-indent-level* (+ baselev (length vs) 2)))
        (format s "~s)" (first args)))
      (mapc #'(lambda (v a)
                (let ((vs (format nil "~s" v)))
                  (format s "~%~vt(~a " baselev vs)
                  (let ((*cexpr-indent-level* (+ baselev (length vs) 2)))
                    (format s "~s)" a))))
            (rest vars)
            (rest args)))
    (format s ")")
    (let ((*cexpr-indent-level* (+ *cexpr-indent-level* *cexpr-indent-step*)))
      (format s "~%~vt~s)" *cexpr-indent-level* body))))

Testop Expressions

Testops use the testop structure. Like primops, testops have a data slot for holding additional data for the function.

⟨testop expressions 14⟩≡ (11) 15 ▷

(defstruct (testop (:include cexpr)
           (:constructor (make-testop (fun args conts data context)))
           (:print-function print-testop))
data)

The print function uses the data, if there is any, to augment the function.

⟨testop expressions 14⟩+≡ (11) ◁ 14

(defun print-testop (e s d)
(declare (ignore d))
(let* ((fun (testop-fun e))
 (args (testop-args e))
 (conts (testop-conts e))
 (data (testop-data e))
 (fd (if data (list fun data) fun)))
(format s "(TESTOP ~s ~s" fd args)
(let ((*cexpr-indent-level*
   (+ *cexpr-indent-level* *cexpr-indent-step* 1)))
(format s "~%~vt(~s" (- *cexpr-indent-level* 1) (first conts))
(dolist (c (rest conts))
(format s "~%~vt~s" *cexpr-indent-level* c))
(format s "))"))))

2.1.4 Some Utility Functions

This section provides a few utility functions. The first one remakes a compound expression if one of its components differs from the supplied values. The comparison allows the lists in the list slots to differ, but the elements must be the same.

⟨utility functions 15⟩≡ (11)

(defun remake-cexpr (e fun args vars conts)
(flet ((eqlist (a b)
   (or (eq a b) (and (= (length a) (length b)) (every #'eq a b)))))
(if (and (eq fun (cexpr-fun e))
     (eqlist args (cexpr-args e))
     (eqlist vars (cexpr-vars e))
     (eqlist conts (cexpr-conts e)))
e
(let ((ne (copy-structure e)))
(setf (cexpr-fun ne) fun)
(setf (cexpr-args ne) args)
(setf (cexpr-vars ne) vars)
(setf (cexpr-conts ne) conts)
ne))))

The predicate primop-eq tests whether an expression is a primop with a particular function.

⟨primop expressions 11⟩+≡ (11) ◁ 11

(defun primop-eq (e fun)
(and (primop-p e) (eq (primop-fun e) fun)))

2.2 Parser for the Intermediate Form

This section presents a simple parser for the intermediate form. It is less than perfect but is only intended as a debugging tool so intermediate form expressions can be specified directly.

⟨parser for intermediate form 16⟩≡ (9)

⟨parser for values 16⟩ ⟨parser for compound expressions 16⟩

2.2.1 Parsing Values

Values can be constants or variables. Constants can be symbols defined as global constants by defconst, quote expressions, or other objects recognized as constants by constantp. Variables are represented by symbols bound to variable objects in the current environment. Anything else is invalid.

⟨parser for values 16⟩≡ (16)

(defun parse-value (e &optional env)
(cond
((and (symbolp e) (constantp e))
(make-const (symbol-value e) e))
((and (consp e) (eq (first e) 'quote) (null (rest (rest e))))
(make-const (second e)))
((constantp e) (make-const e))
((symbolp e)
(let ((var (rest (assoc e env))))
(if var var (error "symbol ~s is not bound" e))))
(t (error "bad value expression: ~s" e))))

2.2.2 Parsing Compound Expressions

Compound expressions are parsed by parse-cexpr. The expression must be a list starting with one of the appropriate type labels.

⟨parser for compound expressions 16⟩≡ (16) 16 ▷

(defun parse-cexpr (e &optional env)
(if (consp e)
(case (first e)
(primop (parse-primop e env))
((lambda local-lambda tail-lambda) (parse-func e env))
(call (parse-call e env))
((bind letrec) (parse-binding e env))
(testop (parse-testop e env))
(t (error "bad compound expression: ~s" e)))
(error "bad compound expression: ~s" e)))

Arguments for compound expressions are parsed by parse-cexpr-args. The optional argument t-ok specifies when arguments may be placed in value registers.

⟨parser for compound expressions 16⟩+≡ (16) ◁ 16 17 ▷

(defun parse-cexpr-args (args env &optional t-ok)
(if (and t-ok (eq args t))
t
(mapcar #'(lambda (x) (parse-value x env)) args)))

Variables bound by a compound expression are parsed by parse-cexpr-vars. Again t-ok specifies whether results may be put in value registers.

⟨parser for compound expressions 16⟩+≡ (16) ◁ 16 17 ▷

(defun parse-cexpr-vars (vars env &optional t-ok)
(if (and t-ok (eq vars t))
(values t env)
(let ((nll nil))
(dolist (s vars)
  (if (member s '(&optional &rest))
      (push s nll)
    (let ((v (make-var s t nil)))
      (push (cons s v) env)
      (push v nll))))
(values (nreverse nll) env))))

Parsing Primop Expressions

The primop parser reverses the printing process. The generic argument and variable parsers are used.

⟨parser for compound expressions 16⟩+≡ (16) ◁ 17 17 ▷

(defun parse-primop (e &optional env)
(let* ((fd (second e))
   (fun (if (consp fd) (first fd) fd))
   (data (if (consp fd) (second fd) nil))
   (args (parse-cexpr-args (third e) env t)))
(case (length e)
    (3 (make-primop fun args nil nil data nil))
    ((4 5)
     (let ((vars (fourth e))
           (form (fifth e)))
       (multiple-value-bind (parsed-vars new-env)
                            (parse-cexpr-vars vars env t)
         (let ((parsed-form (if form (parse-cexpr form new-env) nil)))
           (make-primop fun args parsed-vars parsed-form data nil)))))
    (t (error "bad primop form: ~s" e)))))

Parsing Function Expressions

The function parser also simply reverses the printing process.

⟨parser for compound expressions 16⟩+≡ (16) ◁ 17 18 ▷

(defun parse-func (e &optional env)
(let ((name (second e))
  (llist (third e))
  (body (fourth e)))
(multiple-value-bind (new-llist new-env)
                   (parse-cexpr-vars llist env)
(make-func name new-llist (parse-cexpr body new-env) (first e) nil))))

Parsing Call Expressions

Call expressions are parsed by parse-call.

⟨parser for compound expressions 16⟩+≡ (16) ◁ 17 18 ▷

(defun parse-call (e &optional env)
(let* ((fun (parse-call-fun (second e) env))
       (is-mvcall (eq (third e) t))
       (args (if is-mvcall nil (parse-cexpr-args (third e) env t))))
  (case (length e)
        (3 (make-call fun args nil nil nil is-mvcall nil))
        (5 (multiple-value-bind (parsed-vars new-env)
                                (parse-cexpr-vars (fourth e) env t)
             (let* ((parsed-form (parse-cexpr (fifth e) new-env))
                    (vars (if (eq parsed-vars t) nil parsed-vars))
                    (vi (if (and parsed-form (null parsed-vars)) t nil)))
               (make-call fun args vars parsed-form vi is-mvcall nil)))))))

The function argument must be a symbol; it either represents a local variable or a global function binding.

⟨parser for compound expressions 16⟩+≡ (16) ◁ 18 18 ▷

(defun parse-call-fun (e env)
(unless (symbolp e) (error "bad call function: ~s" e))
(let ((var (rest (assoc e env))))
  (if var var e)))

Parsing Binding Expressions

Binding expressions are parsed by inverting the printing process. The args are parsed using an environment that includes the new vars.

⟨parser for compound expressions 16⟩+≡ (16) ◁ 18 18 ▷

(defun parse-binding (e env)
(let ((vars (mapcar #'first (second e)))
      (args (mapcar #'second (second e))))
  (multiple-value-bind (parsed-vars new-env)
                       (parse-cexpr-vars vars env)
    (let ((parsed-args (parse-letrec-args args new-env))
          (parsed-form (parse-cexpr (third e) new-env)))
      (if (eq (first e) 'bind)
          (make-bind parsed-vars parsed-args parsed-form nil)
        (make-letrec parsed-vars parsed-args parsed-form nil))))))

The args must be functions, which means this doesn’t actually work for bind expressions.

⟨parser for compound expressions 16⟩+≡ (16) ◁ 18 18 ▷

(defun parse-letrec-args (args env)
(mapcar #'(lambda (e) (parse-func e env)) args))

Parsing Testops

⟨parser for compound expressions 16⟩+≡ (16) ◁ 18

(defun parse-testop (e &optional env)
(let* ((fd (second e))
       (fun (if (consp fd) (first fd) fd))
       (data (if (consp fd) (second fd) nil))

           (args (parse-cexpr-args (third e) env t))
           (forms (fourth e))
           (parsed-forms (mapcar #'(lambda (x) (parse-cexpr x env)) forms)))
      (make-testop fun args parsed-forms data nil)))

2.3 Simple Transformations

This section presents two simple transformations. One eliminates bind expressions by replacing bound variables by their values. The second transformation adds cells for variables that are changed by assignment.

⟨simple transformations 19⟩≡ (9)

⟨value substitution 19⟩

⟨cell insertion 20⟩

2.3.1 Value Substitution

Value substitution is carried out by substitute-values. This function takes an expression and an environment as arguments. The environment is a list of variable-value pairs. bind expressions are handled specially; all other compound expressions are handled identically. Variables with entries in the environment are replaced by their values; other value expressions are returned unchanged.

⟨value substitution 19⟩≡ (19)

  (defun substitute-values (e &optional env)
    (labels ((sv (e env)
               (if (bind-p e)

⟨value substitution for bind expressions 19⟩ ⟨value substitution for other expressions 19⟩)))

      (sv e env)))

For bind expressions, the variable bindings of the expression are added to the environment, and then substitution is carried out in the body with the new environment. Arguments are substituted from the environment with sublis before creating the new environment.

⟨value substitution for bind expressions 19⟩≡ (19)

  (let* ((args (sublis env (cexpr-args e)))
         (vars (cexpr-vars e))
         (nenv (append (mapcar #'cons vars args) env)))
    (substitute-values (letrec-body e) nenv))

Other expressions have their function and arguments substituted from the environment, and are remade with the possibly changed new slot values. For letrec expressions, the substitution is applied recursively to the arguments; for others the variables are substitutes with sublis.

⟨value substitution for other expressions 19⟩≡ (19)

  (let ((fun (sublis env (cexpr-fun e)))
        (args (if (letrec-p e)
                  (mapcar #'(lambda (x) (sv x env)) (cexpr-args e))
                (sublis env (cexpr-args e))))
        (vars (cexpr-vars e))
        (conts (mapcar #'(lambda (x) (sv x env)) (cexpr-conts e))))
    (remake-cexpr e fun args vars conts))

2.3.2 Cell Insertion

The first step is to identify the variables that are modified by setq primops. The function find-setq-vars returns a list of these variables. An iterative (tail-recursive) style is used to reduce recursion depth. letrec expressions are handled separately since the function arguments need to be processed. All other cexprs only have value arguments.

⟨cell insertion 20⟩≡ (19) 20 ▷

(defun find-setq-vars (e vars)
  (cond
   ((primop-eq e 'setq)
    (find-setq-vars (primop-form e) (cons (first (primop-args e)) vars)))
   ((letrec-p e)
    (let ((nvars (find-setq-vars-list (cexpr-args e) vars)))
      (find-setq-vars-list (cexpr-conts e) nvars)))
   ((cexpr-p e) (find-setq-vars-list (cexpr-conts e) vars))
   (t vars)))
(defun find-setq-vars-list (elist vars)
  (if elist
      (find-setq-vars-list (rest elist) (find-setq-vars (first elist) vars))
    vars))

The function make-cell-env returns an environment list of variable-cell variable pairs for the setq’ed variables in its argument expression.

⟨cell insertion 20⟩+≡ (19) ◁ 20 20 ▷

(defun make-cell-env (e)
  (mapcar #'(lambda (v)
              (let ((cv (copy-var v)))
                (setf (var-type cv) `(cell ,(var-type v)))
                (cons v cv)))
          (find-setq-vars e nil)))

Cell insertion is handled by add-cells. This function takes an expression, constructs an environment with make-cell-env, and returns the modified expression. A setq expression is first rewritten and then reprocessed. letrec expressions are again handled separately, and all other cexprs are handled identically.

⟨cell insertion 20⟩+≡ (19) ◁ 20 21 ▷

(defun add-cells (e)
  (labels ((ac (e env)
             (cond
              ((primop-eq e 'setq)

⟨cell insertion for setq expressions 20⟩)

              ((letrec-p e)

⟨cell insertion for letrec expressions 21⟩)

              ((cexpr-p e)

⟨add cells for other expressions 21⟩))))

    (ac e (make-cell-env e))))

⟨cell insertion for setq expressions 20⟩≡ (20)

(let* ((args (primop-args e))
       (vars (primop-vars e))
       (form (primop-form e))
       (cell (rest (assoc (first args) env)))
       (nargs (cons cell (rest args)))

     (ctx (primop-context e))
     (ne (make-primop 'set-cell-value nargs vars form nil ctx)))
(ac ne env))

letrec expression need to have their function arguments processed, but are otherwise simple since their variable bindings are never modified.

⟨cell insertion for letrec expressions 21⟩≡ (20)

(let ((args (mapcar #'(lambda (x) (ac x env)) (letrec-args e)))
    (vars (letrec-vars e))
    (body (ac (letrec-body e) env)))
(remake-cexpr e nil args vars (list body)))

For other expressions, first the continuations are processed. If the expression binds variables (and therefore has one and only one continuation expression) then new cells are introduced for its variables by wrap-new-cells if needed. Finally, any arguments that now refer to cell contents are

handled by add-ref-cells.

⟨add cells for other expressions 21⟩≡ (20)

(let* ((conts (mapcar #'(lambda (x) (ac x env)) (cexpr-conts e)))
       (vars (cexpr-vars e))
       (nconts (if (consp vars)
                   (wrap-new-cells vars (first conts) env)
                 conts)))
  (add-ref-cells e nconts env))

The function wrap-new-cells uses a loop to wrap a make-cell primop for each cell that is needed around the continuation.

⟨cell insertion 20⟩+≡ (19) ◁ 20 21 ▷

(defun wrap-new-cells (vars cont env)
(dolist (v vars (list cont))
  (let ((c (cdr (assoc v env))))
    (when c
          (setf cont (make-primop 'make-cell (list v) (list c) cont
                                  nil (var-context v)))))))

To add cell references where needed, we first need to find the args involved and pair them with a new variable to be used by the cell value.

⟨make cell-variable pairs 21⟩≡ (21)

(let ((pairs nil))
(dolist (a args pairs)
  (when (assoc a env)
        (push (cons a (copy-var a)) pairs))))

Using these pairs, add-ref-cells creates a new arguments list and wraps cell-value primops around the expression.

⟨cell insertion 20⟩+≡ (19) ◁ 21

(defun add-ref-cells (e conts env)
(let ((fun (cexpr-fun e))
      (vars (cexpr-vars e))
      (args (cexpr-args e)))
  (if (consp args)

(let* ((pairs ⟨make cell-variable pairs 21⟩)

             (nargs (sublis pairs args))
             (ne (remake-cexpr e fun nargs vars conts)))
        (dolist (p pairs ne)

(let ((c (cdr (assoc (first p) env)))
      (v (cdr p)))
  (setf ne (make-primop 'cell-value (list c) (list v) ne
                        nil (var-context c))))))
(remake-cexpr e fun args vars conts))))

Conversion to Intermediate Form

This chapter presents the mechanism for converting Lisp expressions into the intermediate representation.

⟨convert.lsp 23⟩≡

(in-package "NEWCMP")

⟨utility functions 23⟩ ⟨macro expansion 25⟩ ⟨compilation context 26⟩ ⟨converter environment 26⟩ ⟨main driver function 29⟩ ⟨converter dispatch system 29⟩ ⟨compound expression converters 30⟩ ⟨inlining calls 32⟩ ⟨atom converters 32⟩ ⟨lambda expression conversion 34⟩ ⟨special operator conversion 38⟩ ⟨error checking 53⟩ ⟨register built-in functions 57⟩

3.1 Some Utility Functions

The function proper-list-p checks whether its argument is either nil or a nil-terminated list.

⟨utility functions 23⟩≡ (23) 23 ▷

(defun proper-list-p (list)
  (do ((list list (rest list)))
      ((null list) t)
      (unless (consp list) (return nil))))

lambda-expression-p checks whether its argument is a lambda expression. The checking is rather minimal—the lambda list is only checked for whether it is a proper list, and the body forms are not checked.

⟨utility functions 23⟩+≡ (23) ◁ 23 24 ▷

(defun lambda-expression-p (x)
  (and (consp x)
       (eq (first x) 'lambda)
       (proper-list-p (second x))
       (proper-list-p (rest (rest x)))))

CHAPTER 3. CONVERSION TO INTERMEDIATE FORM 24

The function split-decls-body takes a body list and a flag indicating whether a documentation string is allowed. It returns three values, the accumulated declaration forms, the body as a single expression, wrapped in a progn if necessary, and the documentation string, if requested.

⟨utility functions 23⟩+≡ (23) ◁ 23 24 ▷

(defun split-decls-body (body doc)
  (let ((decls nil)
        (docstr (if doc nil "")))
    (dolist (e body)
      (cond
       ((stringp e) (if docstr (return) (setf docstr e)))
       ((and (consp e) (eq (first e) 'declare))
        (setf decls (append (rest e) decls)))
       (t (return)))
      (pop body))
    (values decls
            (if (null (rest body))
                (first body)
              (cons 'progn body))
            docstr)))

The functions not-inline-p and inline-p test whether a notinline or an inline declaration are in effect for a symbol in an environment.

⟨utility functions 23⟩+≡ (23) ◁ 24 24 ▷

(defun not-inline-p (sym env)
  (eq (second (assoc 'inline (nth-value 2 (function-information sym env))))
      'notinline))
(defun inline-p (sym env)
  (eq (second (assoc 'inline (nth-value 2 (function-information sym env))))
      'inline))

Temporary variable nodes are created by make-tmp-var. If the optional first argument is a symbol or a string it is used to form a name for the variable.

⟨utility functions 23⟩+≡ (23) ◁ 24 24 ▷

(defun make-tmp-var (&optional (name "TMP") (type t))
  (let ((sym (if (and (symbolp name) (not (null name)))
                 name
               (gensym (if (stringp name) name "TMP")))))
    (make-var sym type nil)))

The function make-var-list creates a list of variable nodes for a list of symbols and a current context.

⟨utility functions 23⟩+≡ (23) ◁ 24 24 ▷

(defun make-var-list (syms ctx)
  (mapcar #'(lambda (s) (make-var s t ctx)) syms))

The function simple-constant-p tests whether its argument is a constant with a value that is either a symbol, a number, or a character.

⟨utility functions 23⟩+≡ (23) ◁ 24

(defun simple-constant-p (e)
  (flet ((simple-value-p (v) (or (symbolp v) (numberp v) (characterp v))))
    (and (constantp e)
         (if (symbolp e)
             (simple-value-p (symbol-value e))

             (simple-value-p e)))))

3.2 Macro Expansion

The functions in this section provide a variation on macroexpand and macroexpand-1 that allows for compiler macros. I may decide to just ignore compiler macros eventually once inlining is working properly; at that time I think this stuff can be replaced by the standard macroexpand functions.

expand-expression-1 is like macroexpand-1. If the expression is a list with a symbol in the function position, the symbol does not have a local binding, and is not declared notinline, then a compiler macro expansion is attempted. Otherwise, macroexpand-1 is used. Some compiler macros defined by the old compiler are ruled out.

⟨macro expansion 25⟩≡ (23) 25 ▷

  (defun expand-expression-1 (e env)
    (if (and (consp e) (symbolp (first e)))
        (if (or (member (first e)
                        '(progv not null row-major-aref xlisp::%set-rm-aref))
                (nth-value 1 (function-information (first e) env))
                (not-inline-p (first e) env))
            (macroexpand-1 e env)
          (let ((entry (assoc (first e) xlisp::*cmp-global-macros*)))
            (if entry
                (let ((ne (macroexpand-1 e (list nil (list entry)))))
                  ;;**** a hack for compiler macros -- need to fix ctx
                  (register-global-call (first e) (rest e) nil)
                  (if (eq e ne)
                      (macroexpand-1 e env)
                    (values ne t)))
              (macroexpand-1 e env))))
      (macroexpand-1 e env)))
   expand-expression is like macroexpand. It repeatedly calls expand-expression-1 until there

are no more changes.

⟨macro expansion 25⟩+≡ (23) ◁ 25

  (defun expand-expression (form env)
    (multiple-value-bind (form expanded)
                         (expand-expression-1 form env)
      (if expanded
          (loop
           (multiple-value-bind (newform expanded)
                                (expand-expression-1 form env)
             (unless expanded (return (values newform t)))
             (setf form newform)))
        (values form nil))))

3.3 Maintaining the Compilation Context

The compilation context will eventually be used to maintain information for locating the source of an intermediate form expression in the original code. It uses a stack of expressions that is started by make-context and has new entries pushed on it by augment-context. To be really useful I probably need some mechanism by which the file reader can annotate cons cells it creates by the file and line number they were read from.

⟨compilation context 26⟩≡ (23)

(defun make-context (e) (declare (ignore e)) nil)
(defun augment-context (e ctx) (cons e ctx))

3.4 Managing the Conversion Environment

3.4.1 Data Structures

The conversion process needs to maintain a standard environment as well as information mapping symbols to variables, blocks names to tags, and tagbody tags to continuations. This is done with an info structure consisting of a dictionary and an environment.

⟨converter environment 26⟩≡ (23) 26 ▷

(declaim (inline info-dict info-env make-info))
(defun info-dict (x) (car x))
(defun info-env (x) (cdr x))
(defun make-info (x y) (cons x y))

Entries in a dictionary are indexed by a name and a type. New entries are added by

⟨converter environment 26⟩+≡ (23) ◁ 26 26 ▷

(defun add-dict-entries (names values type dict)
  (append (mapcar #'(lambda (x y) (list x type y)) names values) dict))

find-dict-entry retrieves the value associated with the specified name and type. A second return value indicates whether an entry was found or not.

⟨converter environment 26⟩+≡ (23) ◁ 26 26 ▷

(defun find-dict-entry (name type dict)
  (dolist (d dict)
    (when (and (eql name (first d)) (eq type (second d)))
          (return (values (third d) t)))))

3.4.2 Variables

The function add-local-vars augments the environment with specified variable symbols and declarations, and adds dictionary entries mapping the variable symbols to variable nodes. In addition, the type field of the variable nodes are set according to the declarations in the environment. If a variable is declared ignore, then its type is set to nil.

⟨converter environment 26⟩+≡ (23) ◁ 26 27 ▷

(defun add-local-vars (names nodes decls info)
  (let* ((vars (remove-if #'(lambda (x) (special-var-p x info)) names))
         (nenv (augment-environment (info-env info) :variable vars))
         (nnenv (augment-environment nenv :declare decls))
         (dict (add-dict-entries names nodes :variable (info-dict info))))
    (do ((names names (rest names))
         (nodes nodes (rest nodes)))
        ((or (null names) (null nodes)))
        (let* ((vdecs (nth-value 2 (variable-information (first names) nnenv)))
               (tentry (assoc 'type vdecs))
               (type (if tentry (second tentry) t))
               (ignore (eql (second (assoc 'ignore vdecs)) 'ignore)))

      (setf (var-type (first nodes)) (if ignore nil type))))
(make-info dict nnenv)))

Variables are looked up with lookup-var. If the type field is nil a warning is issued and the type field is set to t. The tag field is marked to indicate that the variable has been used. This function assumes a pretest has determined that the symbol names a local variable.

⟨converter environment 26⟩+≡ (23) ◁ 26 27 ▷

(defun lookup-var (e info ctx)
(let ((v (find-dict-entry e :variable (info-dict info))))
(when (null (var-type v))
      (warn-ignored-variable-used v ctx)
      (setf (var-type v) t))
(setf (var-tag v) t)
v))

The function local-var-p uses the environment to test whether a symbol names a local variable or not.

⟨converter environment 26⟩+≡ (23) ◁ 27 27 ▷

(defun local-var-p (e info)
(and (symbolp e) (eq (variable-information e (info-env info)) :lexical)))

3.4.3 Functions

Local function information is added by add-local-funs. In addition to the variable node associated with a function symbol, the dictionary entry also records the call information. Function declarations are not processed at this time.

⟨converter environment 26⟩+≡ (23) ◁ 27 27 ▷

(defun add-local-funs (names nodes callinfos decls info)
(declare (ignore decls))
(let ((entries (mapcar #'list nodes callinfos)))
(make-info (add-dict-entries names entries :function (info-dict info))
           (augment-environment (info-env info) :function names))))

lookup-fun retrieves the variable node for a local function symbol and marks it as used. local-callinfo retrieves the call information. lookup-fun assumes that the symbol names a local function.

⟨converter environment 26⟩+≡ (23) ◁ 27 27 ▷

(defun lookup-fun (e info)
(let* ((entry (find-dict-entry e :function (info-dict info)))
     (v (first entry)))
(setf (var-tag v) t)
v))
(defun local-callinfo (e info)
(let ((entry (find-dict-entry e :function (info-dict info))))
(second entry)))

The predicate local-fun-p uses the environment to check whether a symbol names a local function.

⟨converter environment 26⟩+≡ (23) ◁ 27 28 ▷

(defun local-fun-p (e info)
(and (symbolp e) (nth-value 1 (function-information e (info-env info)))))

3.4.4 Block Tags

Block tags are maintained in the dictionary under the type :block. The lookup function signals an error if a block by the requested name does not exist. The dictionary includes a use flag that is set by a lookup request. The predicate block-used-p retrieves the use flag’s value.

⟨converter environment 26⟩+≡ (23) ◁ 27 28 ▷

(defun add-block (name tag info)
  (make-info (add-dict-entries (list name) (list (list tag nil))
                               :block (info-dict info))
             (info-env info)))
(defun lookup-block (name info)
  (let ((val (find-dict-entry name :block (info-dict info))))
    (unless val (error "no block named ~s in current lexical context" name))
    (setf (second val) t)
    (first val)))
(defun block-used-p (name info)
  (second (find-dict-entry name :block (info-dict info))))

3.4.5 Tagbody Tags

Tagbody tags are entered under the type :go. The lookup function signals an error if no tag is found. The entry returned by the lookup function is a list of a tag variable, indicating the owning tagbody, and a function variable representing the continuation.

⟨converter environment 26⟩+≡ (23) ◁ 28 28 ▷

(defun add-go-tags (names tag funs info)
  (let ((tlist (mapcar #'(lambda (fun) (list tag fun)) funs)))
    (make-info (add-dict-entries names tlist :go (info-dict info))
               (info-env info))))
(defun lookup-go-tag (name info)
  (let ((val (find-dict-entry name :go (info-dict info))))
    (unless val (error "no tag named ~s in current lexical context" name))
    val))

3.4.6 Declarations

Declarations other than those directly related to variable or function bindings are entered by add-decls-info. The predicate special-var-p checks whether a symbol has been proclaimed special or is declared special in the environment portion of its info argument.

⟨converter environment 26⟩+≡ (23) ◁ 28

(defun add-decls-info (decls info)
  (if decls
      (make-info (info-dict info)
                 (augment-environment (info-env info) :declare decls))
    info))
(defun special-var-p (e info)
  (and (symbolp e)
       (or (specialp e)
           (eq (variable-information e (info-env info)) :special))))

3.5 Main Conversion Functions

This section presents the core of the conversion system. The conversion routines take an info structure, some continuation information, and a context as their final arguments. The continuation information consists of two pieces, variable information kv and a form kf. These fall in one of the following categories:

• The form kf is nil. This means the expression to be converted is in tail position. Values produced by the expression should be placed in the value registers and a return from the current function should be executed. The value of kv, which should be nil as well, can be ignored.

• The form kf is an expression in the intermediate representation. This means the expression to be converted is in non-tail position. The handling of values from the expression depends on the value of kv:

– If kv in nil then the values are ignored.

– If kv is a variable, then it should be bound to the first value of the expression being converted; any other values are ignored.

– If kv is t then the values of the converted expression should be placed in the multiple value registers; kf will retrieve them from there.

3.5.1 Main Driver Function

The main entry point is the function convert. It does macro expansion, updates the context, and then processes the form according to whether it is a cons, a symbol, or something else.

⟨main driver function 29⟩≡ (23)

  (defun convert (e info kv kf ctx)
    (let* ((actx (augment-context e ctx))
           (ee (expand-expression e (info-env info)))
           (ectx (augment-context ee actx)))
      (cond
       ((consp ee)
        (let ((fun (first ee))
              (args (rest ee)))
          (cond
           ((lambda-expression-p fun)
            (convert-lambda-call fun args info kv kf ectx))
           ((symbolp fun) (convert-symbol-call fun args info kv kf ectx))
           (t (error "~s is not a valid function" fun)))))
       ((symbolp ee) (convert-symbol ee info kv kf ectx))
       (t (convert-constant ee kv kf ectx)))))

3.5.2 Converter Dispatch System

Special forms are handled by a dispatching mechanism. A hash table contains the conversion func-

tions entered by add-converter and retrieved by get-converter. The macro define-converter

provides a convenient interface for adding new converters.

⟨converter dispatch system 29⟩≡ (23)

(let ((table (make-hash-table :test 'eq)))
(defun add-converter (name fun) (setf (gethash name table) fun))
(defun get-converter (name) (gethash name table)))
(defmacro define-converter (name args &body body)
`(progn
   (add-converter ',name #'(lambda ,args ,@body))
   ',name))

3.5.3 Compound Expression Converters

Calls to lambda expressions are converted by converting the lambda expression, constructing a temporary name for the function, converting the call as a call to the temporary, and then forming a letrec expression with the call as its body.

⟨compound expression converters 30⟩≡ (23) 30 ▷

(defun convert-lambda-call (fun args info kv kf ctx)
(let ((arg (convert-lambda nil fun info nil nil ctx))
      (var (make-tmp-var)))
  (check-lambda-argument-count fun args ctx)
  (let ((body (convert-call var args info kv kf ctx)))
    (make-letrec (list var) (list arg) body ctx))))

Calls with symbols in the function position are handled as local or global calls, depending on whether there is a local function binding in effect. Global calls are handled by a converter if one is available. If not, they are either inlined or converted as a call to the symbol naming the global function.

⟨compound expression converters 30⟩+≡ (23) ◁ 30 30 ▷

(defun convert-symbol-call (fun args info kv kf ctx)
(cond
 ((local-fun-p fun info)
  (check-local-argument-count fun args info ctx)
  (convert-call (lookup-fun fun info) args info kv kf ctx))
 (t (let ((c (get-converter fun)))
      (cond
       (c (funcall c args info kv kf ctx))
       ((and (inline-p fun (info-env info)) (get-inline-definition fun))
        (convert-call-inline fun args info kv kf ctx))
       (t (check-global-argument-count fun args info ctx)
          (convert-call fun args info kv kf ctx)))))))

Calls to global or local functions are converted by constructing argument variables, making a call expression, and then converting the arguments.

⟨compound expression converters 30⟩+≡ (23) ◁ 30 31 ▷

(defun convert-call (cf args info kv kf ctx)
(let* ((argvars (mapcar #'make-tmp-var args))
       (vars (if (var-p kv) (list kv) nil))
       (vi (if (and kf (null kv)) t nil))
       (call (make-call cf argvars vars kf vi nil ctx)))
  (convert-call-args argvars args call info ctx)))

A simple definition of the argument converting function is given by ⟨simple argument conversion 30⟩≡

(defun convert-call-args (vars args call info ctx)
(let ((form call))
(do ((rvars (reverse vars) (rest rvars))
 (rargs (reverse args) (rest rargs)))
((or (null rvars) (null rargs)))
(setf form (convert (first rargs) info (first rvars) form ctx)))
form))

Unfortunately this produces excessively complicated expressions for cases where arguments are simple variables or constants. A more complicated definition leads to simpler expressions by processing simple arguments directly.

⟨compound expression converters 30⟩+≡ (23) ◁ 30

(defun convert-call-args (vars args call info ctx)
(let ((form call)
(rvars nil)
(rargs nil)
(env nil))

⟨preprocess arguments and build up rvars, rargs, and env 31⟩ ⟨substitute simple arguments from env 31⟩

(do ((rvars rvars (rest rvars))
 (rargs rargs (rest rargs)))
((or (null rvars) (null rargs)))
(setf form (convert (first rargs) info (first rvars) form ctx)))
form))

For arguments that are local variables or simple constant expressions, a pair consisting of the argument variable and the converted form is pushed onto env. For other arguments, the argument is pushed on rargs and the variable on rvars.

⟨preprocess arguments and build up rvars, rargs, and env 31⟩≡ (31)

(do ((vars vars (rest vars))
(args args (rest args)))
((or (null vars) (null args)))
(let ((ea (expand-expression (first args) (info-env info)))
  (v (first vars)))
(cond
((and (symbolp ea) (local-var-p ea info))
(push (cons v (lookup-var ea info ctx)) env))
((and (symbolp ea) (simple-constant-p ea))
(push (cons v (make-const (symbol-value ea))) env))
((and (consp ea) (eq (first ea) 'quote) (null (nthcdr 3 ea)))
(push (cons v (make-const (second ea))) env))
((and (not (symbolp ea)) (not (consp ea)))
(push (cons v (make-const ea)) env))
(t (push v rvars) (push ea rargs)))))

If any simple arguments were found, they are substituted for their variables in the call. The call is copied before the substitution so the original call expression remains unaltered.

⟨substitute simple arguments from env 31⟩≡ (31)

(when env
(setf form (copy-structure form))
(setf (cexpr-args form) (sublis env (cexpr-args form))))

3.5.4 A Simple Inlining System

When inlining is enabled, any function declared inline for which the lambda expression is available is inlined. Recursion is prevented by placing functions currently being inlined in a list that is checked before proceeding.

The public variable *inlining-enabled* determines whether inlining is to be used. If code uses inline declarations too aggressively, it might help to turn inlining off. This is meant as an external control for the code compiler above and beyond the control provided to the code writer by optimize declarations (which are currently ignored anyway).

⟨inlining calls 32⟩≡ (23) 32 ▷

  (export '*inlining-enabled*)
  (defvar *inlining-enabled* t)

The functions currently being inlined are stored in the variable *inlining*. If inlining is enabled, the call is checked against the function definition, which is assumed to be available. If the function is already being inlined, the call is converted without inlining. Otherwise, the current function is registered as being inlined and the inlined call is produced.

⟨inlining calls 32⟩+≡ (23) ◁ 32

  (defvar *inlining* nil)
  (defun convert-call-inline (fun args info kv kf ctx)
    (if *inlining-enabled*
        (let ((def (get-inline-definition fun)))
          (let ((val (check-call args (lambda-list-callinfo (second def)))))
            (when val (signal-argument-count-error fun val ctx)))
          (if (member fun *inlining*)
              (convert-call fun args info kv kf ctx)
            (let ((*inlining* (cons fun *inlining*)))

⟨convert as an inline call 32⟩)))

      (convert-call fun args info kv kf ctx)))

The first step in the actual inlining is to register the call for checking consistency of definitions and recording function use. Then a labels expression is constructed and compiled to an optimized intermediate letrec representation. The function variable from this expression is used in converting the call, and the call expression is installed as the body of the letrec expression.

⟨convert as an inline call 32⟩≡ (32)

  (register-global-call fun args ctx)
  (let* ((form `(labels ((,fun ,@(rest def))) #',fun))
         (cform (func-body (optimize (compile-front-form form nil))))
         (fvars (letrec-vars cform))
         (fargs (letrec-args cform))
         (nbody (convert-call (first fvars) args info kv kf ctx)))
    (remake-cexpr cform nil fargs fvars (list nbody)))

3.5.5 Converters for Atoms

Symbols can represent local variables, globally defined constants, or global variables. Defined constants with simple values can have their values used directly; others need to be treated as special variables.

⟨atom converters 32⟩≡ (23) 33 ▷

  (defun convert-symbol (e info kv kf ctx)
    (cond
     ((local-var-p e info) (convert-value (lookup-var e info ctx) kv kf ctx))
     ((simple-constant-p e) (convert-constant (symbol-value e) kv kf ctx))
     (t (convert-special-variable e info kv kf ctx))))
  (defun convert-constant (e kv kf ctx)
    (convert-value (make-const e) kv kf ctx))

Values, i.e. variable nodes or constant nodes, are converted according to the continuation data. For a null form kf or a kv equal to t, a values primop is used to put the value in the value registers. If kv is nil but kf is not, then the value is ignored and kf is the converted form. Finally, if kv is a variable, the value is bound to it with a bind expression. After cell insertion this can be removed by value substitution.

⟨atom converters 32⟩+≡ (23) ◁ 32 33 ▷

  (defun convert-value (v kv kf ctx)
    (cond
     ((or (null kf) (eql kv t)) (make-primop 'values (list v) nil kf nil ctx))
     ((null kv) kf)
     (t (make-bind (list kv) (list v) kf ctx))))

References to global variables are handled by first checking that the variable is declared special and then treating the expression as a call to the symbol-value primop .

⟨atom converters 32⟩+≡ (23) ◁ 33 33 ▷

  (defun convert-special-variable (e info kv kf ctx)
    (unless (special-var-p e info) (warn-undeclared-global e ctx))
    (convert-standard-primop 'symbol-value nil info kv kf e ctx))

Standard primops represent functions returning one value. Their arguments are processed by convert-call-args. The “call” passed to this function is a primop expression. The variables bound in this expression and its continuation form depend on the continuation data. If kf is nil no variables are bound since the expression is in tail position. Otherwise, if kv is a variable it is bound; if kv is not a variable, a temporary variable is created and bound. The continuation form is kf unless kf is not nil and kv is t, meaning that kf expects the expression values in the value registers. In this case, a new continuation form is constructed that places the single value in the values registers with a values primop and then continues with the original continuation form kf.

⟨atom converters 32⟩+≡ (23) ◁ 33

  (defun convert-standard-primop (which args info kv kf data ctx)
    (let* ((vars (mapcar #'make-tmp-var args))
           (vl (cond
                ((null kf) nil)
                ((var-p kv) (list kv))
                (t (list (make-tmp-var)))))
           (nkf (if (and kf (eq kv t))
                    (make-primop 'values vl nil kf nil ctx)
                  kf))
           (form (make-primop which vars vl nkf data ctx)))
      (convert-call-args vars args form info ctx)))

3.6 Lambda Expression Conversion

3.6.1 Parsing Lambda Lists

The first step in converting lambda expressions is to parse the lambda list. This is done by pulling the pieces off from the end, parsing the optional and keyword arguments, and returning the results as multiple values.

⟨lambda expression conversion 34⟩≡ (23) 34 ▷

(defun parse-lambda-list (lambda-list ctx)
(unless (proper-list-p lambda-list) (bad-lambda-list lambda-list ctx))
(flet ((chop (x y) (if y (ldiff x y) x)))
(let* ((list0 lambda-list)
(aux (member '&aux list0))
(list1 (chop list0 aux))
(other (member '&allow-other-keys list1))
(list2 (chop list1 other))
(key (member '&key list2))
(list3 (chop list2 key))
(rest (member '&rest list3))
(list4 (chop list3 rest))
(opt (member '&optional list4))
(req (chop list4 opt)))

⟨check the lambda list components for some errors 34⟩

(values req
   (parse-opt-args (rest opt) lambda-list ctx)
   (second rest)
   (if key t nil)
   (parse-key-args (rest key) lambda-list ctx)
   (if other t nil)
   (rest aux)))))

Minimal checking involves making sure there are no misplaced lambda list keywords and the like. This is less than perfect; there is plenty of illegal syntax that can get by this.

⟨check the lambda list components for some errors 34⟩≡ (34)

(flet ((no-lkeys (x) (null (intersection x lambda-list-keywords))))
(unless (and (no-lkeys (rest aux))
    (null (rest other))
    (or (null other) key)
    (no-lkeys (rest key))
    (or (null rest)
        (and (= (length rest) 2) (symbolp (second rest))))
    (no-lkeys (rest rest))
    (no-lkeys (rest opt))
    (no-lkeys req)
    (every #'symbolp req))
(bad-lambda-list lambda-list ctx)))

Errors are signaled by

⟨lambda expression conversion 34⟩+≡ (23) ◁ 34 35 ▷

(defun bad-lambda-list (list ctx)
(declare (ignore ctx))
(error "~s is not a proper lambda list" list))

Keyword and optional argument parsing uses an arginfo list structure to store the parsed arguments.

⟨lambda expression conversion 34⟩+≡ (23) ◁ 34 35 ▷

(defstruct (arginfo
            (:type list)
            (:constructor make-arginfo (sym val suppsym &optional key)))
  key sym val suppsym var suppvar)

Optional arguments are parsed into an arginfo structure by

⟨lambda expression conversion 34⟩+≡ (23) ◁ 35 35 ▷

(defun parse-opt-args (list lambda-list ctx)
  (let ((val nil))
    (dolist (a list (nreverse val))
      (cond
       ((symbolp a) (push (make-arginfo a nil nil) val))

(t ⟨check compound optional argument for errors 35⟩

          (push (make-arginfo (first a) (second a) (third a)) val))))))

Error checking is done by

⟨check compound optional argument for errors 35⟩≡ (35)

(unless (and (proper-list-p a)
             (member (length a) '(1 2 3))
             (symbolp (first a))
             (symbolp (third a)))
        (bad-lambda-list lambda-list ctx))

Keyword arguments are parsed by parse-key-args.

⟨lambda expression conversion 34⟩+≡ (23) ◁ 35 36 ▷

(defun parse-key-args (list lambda-list ctx)
  (flet ((mk-key (sym) (intern (symbol-name sym) "KEYWORD")))
    (let ((val nil))
      (dolist (a list (nreverse val))
        (cond
         ((symbolp a) (push (make-arginfo a nil nil (mk-key a)) val))
         ((proper-list-p a)
          (let ((arg (first a)))

⟨check compound keyword argument for errors 35⟩

            (let ((sym (if (symbolp arg) arg (second arg)))
                  (key (if (symbolp arg) (mk-key arg) (first arg))))
              (push (make-arginfo sym (second a) (third a) key) val))))
         (t (bad-lambda-list lambda-list ctx)))))))

Some error checking is handled by

⟨check compound keyword argument for errors 35⟩≡ (35)

(unless (and (member (length a) '(1 2 3))
             (or (symbolp arg)
                 (and (proper-list-p arg)
                      (= (length arg) 2)
                      (symbolp (first arg))
                      (symbolp (second arg))))
             (symbolp (third a)))
        (bad-lambda-list lambda-list ctx))

3.6.2 Processing the Expression

A lambda expression is converted by splitting its lambda list, rewriting its body to include a block if necessary, and processing the result.

⟨lambda expression conversion 34⟩+≡ (23) ◁ 35 36 ▷

(defun convert-lambda (name e info block have-block ctx)
(multiple-value-bind (req opt rest has-key key other aux)
               (parse-lambda-list (second e) ctx)
(let ((lbody (multiple-value-bind (decls body)
                              (split-decls-body (rest (rest e)) nil)
           (let ((bbody (if have-block `(block ,block ,body) body)))
             (if decls
                 (list (cons 'declare decls) bbody)
               (list bbody))))))
(convert-lambda-1 name req opt rest has-key key other aux lbody info
                ctx))))

The split expression is processed by creating and converting an inner let*, wrapping the let* form in expressions that extract optional and keyword argument information, if necessary, and finally wrapping the result in a func expression.

⟨lambda expression conversion 34⟩+≡ (23) ◁ 36 37 ▷

(defun convert-lambda-1 (name req opt rest has-key key other aux body info ctx)
(let ((letform `(let* ,aux ,@body))
(vars nil)
(reqvars nil)
(optvars nil)
(restvar nil)
(keylistvar nil))

⟨push variable bindings onto the letform 36⟩

(let* ((ninfo (add-local-vars (mapcar #'var-name vars) vars nil info))
   (cbody (convert letform ninfo nil nil ctx))
   (kargs (list keylistvar)))
(when has-key

⟨wrap code to extract keyword arguments around cbody 37⟩) ⟨wrap code to extract optional arguments around cbody 38⟩

(let ((list (if (or rest key) (list '&rest restvar) nil)))
(when opt (setf list (append (cons '&optional optvars) list)))
(setf list (append reqvars list))
(make-func name list cbody 'lambda ctx)))))

Pushing bindings onto letform involves four steps. First, if keyword arguments are present then a variable for holding the keyword/value list is created and placed on the variables list. Then the keyword forms are processed.

⟨push variable bindings onto the letform 36⟩≡ (36) 36 ▷

(when has-key
(setf keylistvar (make-var (gensym) t ctx))
(push keylistvar vars)
(setf vars (proccess-opt-key-args letform key vars ctx)))

Second, if there is a rest variable or there are keyword variables, then a rest variables is created and pushed on the variables list. If the lambda list includes a rest variable, then a binding is pushed onto the binding list of letform.

⟨push variable bindings onto the letform 36⟩+≡ (36) ◁ 36 37 ▷

  (when (or rest has-key)
        (setf restvar (make-var (gensym) t ctx))
        (push restvar vars)
        (when rest (push `(,rest ,(var-name restvar)) (second letform))))

Third, if there are optional arguments then they are processed.

⟨push variable bindings onto the letform 36⟩+≡ (36) ◁ 36 37 ▷

  (when opt (setf vars (proccess-opt-key-args letform opt vars ctx)))

Finally, a variable is created for each required argument and a binding is pushed onto letform.

⟨push variable bindings onto the letform 36⟩+≡ (36) ◁ 37

  (dolist (v (reverse req))
    (let ((var (make-var (gensym) t ctx)))
      (push var reqvars)
      (push var vars)
      (push `(,v ,(var-name var)) (second letform))))

The processing of optional and keyword forms is handled by proccess-opt-key-args. This function creates variables for the value and the supplied-p arguments, adds bindings to letform, enters the new variables in the arginfo structures, and returns the augmented list of variables. The bindings for the letform include a conditional expression if the default expression is not a constant; if the default expression is a constant then the appropriate value will be installed by the wrapper code and the conditional is not needed.

⟨lambda expression conversion 34⟩+≡ (23) ◁ 36

  (defun proccess-opt-key-args (letform args vars ctx)
    (dolist (k (reverse args) vars)
      (let ((var (make-var (gensym) t ctx))
            (suppvar (make-var (gensym) t ctx))
            (sym (arginfo-sym k))
            (suppsym (arginfo-suppsym k))
            (val (arginfo-val k)))
        (when suppsym (push `(,suppsym ,(var-name suppvar)) (second letform)))
        (if (simple-constant-p val)
            (push `(,sym ,(var-name var)) (second letform))
          (push `(,sym (if ,(var-name suppvar) ,(var-name var) ,val))
                (second letform)))
        (setf (arginfo-var k) var)
        (setf (arginfo-suppvar k) suppvar)
        (push var vars)
        (push suppvar vars))))

The wrapping for keyword arguments first adds a check-last-keyarg primop for checking whether there are any unsupported keywords left after processing.

⟨wrap code to extract keyword arguments around cbody 37⟩≡ (36) 37 ▷

  (setf cbody
        (make-primop 'check-last-keyarg kargs nil cbody other ctx))

Next, get-keyarg primop expressions are added to destructively extract the keyword argument from the keyword/value list. The data for the primop is a list of the keyword and a default value. If the arginfo default form is a constant, it is used; otherwise nil is used. The get-keyarg primop binds two variables, the value and the supplied-p indicator.

⟨wrap code to extract keyword arguments around cbody 37⟩+≡ (36) ◁ 37 38 ▷

(dolist (k (reverse key))
(let* ((vars (list (arginfo-var k) (arginfo-suppvar k)))
     (val (arginfo-val k))
     (data (list (arginfo-key k)
                 (if (simple-constant-p val)
                     (if (symbolp val) (symbol-value val) val)
                   nil))))
(setf cbody
      (make-primop 'get-keyarg kargs vars cbody data ctx))))

Finally, a make-keyargs primop expression is added to create the keyword/value list from the rest argument.

⟨wrap code to extract keyword arguments around cbody 37⟩+≡ (36) ◁ 37

(setf cbody
  (make-primop 'make-keyargs (list restvar) kargs cbody nil
               ctx))

Wrapping code for extracting optional arguments adds get-optarg primop expressions for each argument. The expressions bind the value and supplied-p variables. Their argument is the appropriate function argument, and their data is the default value for missing arguments. Again the supplied value is used if it is a constant; otherwise nil is used.

⟨wrap code to extract optional arguments around cbody 38⟩≡ (36)

(dolist (k (reverse opt))
(let* ((vars (list (arginfo-var k) (arginfo-suppvar k)))
     (val (arginfo-val k))
     (data (if (simple-constant-p val)
               (if (symbolp val) (symbol-value val) val)
             nil))
     (arg (make-var (gensym) t ctx)))
(setf cbody (make-primop 'get-optarg (list arg) vars cbody data ctx))
(push arg optvars)))

3.7 Special Operator Converters

This section presents converters for the standard special operators and a small number of additional operators that are treated as special operators. The constant special-operators contains the standard special operator symbols.

⟨special operator conversion 38⟩≡ (23) 38 ▷

(defconstant special-operators
'(block      let*                  return-from
catch      load-time-value       setq
eval-when  locally               symbol-macrolet
flet       macrolet              tagbody
function   multiple-value-call   the
go         multiple-value-prog1  throw
if         progn                 unwind-protect
labels     progv
let        quote))

As a precaution, we start by installing a converter to signal an error for all special operators and the four additional operators that are to be handled here.

⟨special operator conversion 38⟩+≡ (23) ◁ 38 39 ▷

(dolist (s (append '(case errset lambda nth-value) special-operators))
(add-converter s
               (let ((sym s))
                 #'(lambda (args info kv kf)
                     (declare (ignore args info kv kf))
                     (error "converter for ~a not implemented yet" sym)))))

3.7.1 BLOCK Converter

Blocks are handled by block primops. These take a single argument, a closure that executes the block’s body code. The closure is called with one argument, a tag that can be used by the return-from primop to execute a throw. The closures could in principle be allocated on the stack since they are known to have dynamic extent. But the hope is that most of these blocks will be optimized away in any case. If the block is not used for an exit with return-from then it is not created. Instead, the body function is called directly. Standard optimizations will inline the function.

⟨special operator conversion 38⟩+≡ (23) ◁ 38 39 ▷

(define-converter block (args info kv kf ctx)
(check-specop-argument-count 'block args 1 0 t)
(let ((name (first args)))
  (check-block-name name 'block ctx)
  (let* ((tag (make-tmp-var))
         (bv (make-tmp-var))
         (ninfo (add-block name tag info))
         (body (convert (cons 'progn (rest args)) ninfo nil nil ctx))
         (vl (if (var-p kv) (list kv) nil))
         (vi (if (and kf (null kv)) t nil)))
    (if (block-used-p name ninfo)
        (let ((bfun (make-func nil (list tag) body 'lambda ctx))
              (nbody (make-primop 'block (list bv) vl kf nil ctx)))
          (make-letrec (list bv) (list bfun) nbody ctx))
      (let ((bfun (make-func nil nil body 'lambda ctx))
            (nbody (make-call bv nil vl kf vi nil ctx)))
        (make-letrec (list bv) (list bfun) nbody ctx))))))

The function check-block-name is used by the block and return-from converters to signal an error if the name is not a symbol.

⟨special operator conversion 38⟩+≡ (23) ◁ 39 39 ▷

(defun check-block-name (name operator ctx)
(declare (ignore ctx))
(unless (symbolp name)
        (error "~s is not a valid block name in ~s" name operator)))

3.7.2 CASE Converter

The case operator is implemented by the case testop. This testop takes a single argument, the selector, and data consisting of a vector of the case keys without the final otherwise/t key. Its number of continuations is the length of the data vector plus one.

⟨special operator conversion 38⟩+≡ (23) ◁ 39 40 ▷

(define-converter case (args info kv kf ctx)
(check-specop-argument-count 'case args 1 0 t)
(let* ((clauses (case-add-default (rest args)))
   (conts (mapcar #'(lambda (x) (cons 'progn (rest x))) clauses))
   (data (coerce (butlast (mapcar #'first clauses)) 'vector)))
(multiple-value-bind (k kfun)
                   (make-test-cont kv kf ctx)
(let* ((v (make-tmp-var))
       (cconts (convert-test-conts conts info kv k ctx))
       (call (make-testop 'case (list v) cconts data ctx))
       (vl (list (first args)))
       (form (convert-call-args (list v) vl call info ctx)))
  (if k
      (make-letrec (list k) (list kfun) form ctx)
    form)))))

The function case-add-default adds a default clause if there isn’t one and does some error checking.

⟨special operator conversion 38⟩+≡ (23) ◁ 39 40 ▷

(defun case-add-default (clauses)
(let ((val nil))
(dolist (c clauses (nreverse (cons '(t nil) val)))
(unless (and (proper-list-p c)
             (or (not (consp (first c))) (proper-list-p (first c))))
        (error "bad case clause: ~s" c))
(when (member (first c) '(t otherwise))
      (when (rest (member c clauses))
            (issue-style-warning "OTHERWISE clause ~s is not last" c))
      (return (nreverse (cons c val))))
(push c val))))

make-test-cont converts a non-tail continuation into a function name and a function; the function can then be called from each of a testop’s continuations.

⟨special operator conversion 38⟩+≡ (23) ◁ 40 40 ▷

(defun make-test-cont (kv kf ctx)
(if kf
(values (make-tmp-var)
        (make-func nil (if (var-p kv) (list kv) nil) kf 'lambda ctx))
(values nil nil)))

convert-test-conts uses the results of make-test-cont to convert each continuation expression. For non-tail uses, the continuation form is a call to the continuation function.

⟨special operator conversion 38⟩+≡ (23) ◁ 40 41 ▷

(defun convert-test-conts (conts info kv k ctx)
(if k
(mapcar #'(lambda (cont)
            (let* ((ckv (if (var-p kv) (copy-var kv) kv))
                   (ckf (make-call k (if (var-p kv) (list ckv) nil)
                                   nil nil nil nil ctx)))
              (convert cont info ckv ckf ctx)))
        conts)
(mapcar #'(lambda (cont) (convert cont info nil nil ctx)) conts)))

3.7.3 CATCH Converter

The catch operator is implemented by the catch primop. This primop takes as its arguments the catch tag and a closure that executes the body of the catch.

⟨special operator conversion 38⟩+≡ (23) ◁ 40 41 ▷

(define-converter catch (args info kv kf ctx)
(check-specop-argument-count 'catch args 1 0 t)
(let* ((tag (first args))
(tv (make-tmp-var))
(bv (make-tmp-var))
(body (convert (cons 'progn (rest args)) info nil nil ctx))
(bfun (make-func nil nil body 'lambda ctx))
(vl (if (var-p kv) (list kv) nil))
(catch (make-primop 'catch (list tv bv) vl kf nil ctx))
(tkf (make-letrec (list bv) (list bfun) catch ctx)))
(convert tag info tv tkf ctx)))

3.7.4 ERRSET Converter

The errset operator uses the errset primop. This primop takes a closure representing the body and a print flag value as its arguments.

⟨special operator conversion 38⟩+≡ (23) ◁ 41 41 ▷

(define-converter errset (args info kv kf ctx)
(check-specop-argument-count 'errset args 1 1 nil)
(let* ((pflag (if (consp (rest args)) (second args) t))
(pv (make-tmp-var))
(bv (make-tmp-var))
(bfbody (convert (first args) info nil nil ctx))
(bfun (make-func nil nil bfbody 'lambda ctx))
(vl (if (var-p kv) (list kv) nil))
(body (make-primop 'errset (list bv pv) vl kf nil ctx))
(nkf (make-letrec (list bv) (list bfun) body ctx)))
(convert pflag info pv nkf ctx)))

3.7.5 FLET Converter

The converter for flet shares most of its code with the labels converter.

⟨special operator conversion 38⟩+≡ (23) ◁ 41 41 ▷

(define-converter flet (args info kv kf ctx)
(convert-funs args info kv kf 'flet ctx))

The common code is given by convert-funs. The only difference between flet and labels is in the cinfo value used in converting the functions. For flet it is the original info value. For labels it is the intermediate value constructed by add-local-funs; this includes the function bindings and any ftype or inlining declarations related to the bound functions.

⟨special operator conversion 38⟩+≡ (23) ◁ 41 42 ▷

(defun convert-funs (args info kv kf which ctx)
(check-specop-argument-count which args 1 0 t)
(let* ((funs (first args))
(names (mapcar #'first funs))
(cis (mapcar #'(lambda (x) (lambda-list-callinfo (second x))) funs)))
(multiple-value-bind (decls body)

                   (split-decls-body (rest args) nil)
(let* ((fvars (make-var-list names ctx))
       (ninfo (add-local-funs names fvars cis decls info))
       (nninfo (add-decls-info decls ninfo))
       (cinfo (if (eq which 'labels) ninfo info)))
  (flet ((cvtfun (f)
           (let ((n (first f))
                 (e (cons 'lambda (rest f))))
             (convert-lambda n e cinfo n t ctx))))
    (let ((fargs (mapcar #'cvtfun funs))
          (bform (convert body nninfo kv kf ctx)))
      (check-unused-funs fvars ctx)
      (make-letrec fvars fargs bform ctx)))))))

3.7.6 FUNCTION Converter

The converter for function uses convert-value for local functions. For global functions, the expression is converted as a symbol-functionprimop. For lambda expressions, a letrec is created and convert-value is used on the bound variable.

⟨special operator conversion 38⟩+≡ (23) ◁ 41 42 ▷

(define-converter function (args info kv kf ctx)
(check-specop-argument-count 'function args 1 0 nil)
(let ((fun (first args)))
(cond
((local-fun-p fun info)
(convert-value (lookup-fun fun info) kv kf ctx))
((symbolp fun)
(convert-standard-primop 'symbol-function nil info kv kf fun ctx))
((lambda-expression-p fun)
(let* ((v (make-tmp-var)) ;;**** type??
       (cf (convert-lambda nil fun info nil nil ctx)))
  (make-letrec (list v) (list cf) (convert-value v kv kf ctx) ctx)))
(t (error "bad argument for FUNCTION - ~s" fun)))))

3.7.7 GO Converter

The go operator uses the go primop with the arguments returned by lookup-go-tag. The error check on the tag isn’t really necessary since an illegal tag will be signaled by the tagbody converter and a missing tag by the lookup function, but it might help with debugging.

⟨special operator conversion 38⟩+≡ (23) ◁ 42 42 ▷

(define-converter go (args info kv kf ctx)
(declare (ignore kv kf))
(check-specop-argument-count 'go args 1 0 nil)
(let ((name (first args)))
(check-tagbody-tag name 'go ctx)
(let ((vars (lookup-go-tag name info)))
(make-primop 'go vars nil nil nil ctx))))

The function check-tagbody-tag is used by the go and tagbody converters to signal an error for an invalid tag.

⟨special operator conversion 38⟩+≡ (23) ◁ 42 43 ▷

(defun check-tagbody-tag (tag operator ctx)
(declare (ignore ctx))
(unless (tagbody-tag-p tag) (error "~s is not a valid ~s tag" tag operator)))

The predicate tagbody-tag-p tests whether its argument is a valid tagbody tag.

⟨special operator conversion 38⟩+≡ (23) ◁ 42 43 ▷

(defun tagbody-tag-p (val)
(or (symbolp val) (integerp val)))

3.7.8 IF Converter

The converter for if does constant folding for constant test expressions. convert-call-args is used to avoid creating a bind if the test form is a local variable.

⟨special operator conversion 38⟩+≡ (23) ◁ 43 43 ▷

(define-converter if (args info kv kf ctx)
(check-specop-argument-count 'if args 2 1 nil)
(let ((test (first args))
      (consequent (second args))
      (alternative (third args)))
  (if (constantp test)
      (convert (if test consequent alternative) info kv kf ctx)
    (multiple-value-bind (k kfun)
                         (make-test-cont kv kf ctx)
      (let* ((v (make-tmp-var))
             (conts (list consequent alternative))
             (cconts (convert-test-conts conts info kv k ctx))
             (call (make-testop t (list v) cconts nil ctx))
             (form (convert-call-args (list v) (list test) call info ctx)))
        (if k
            (make-letrec (list k) (list kfun) form ctx)
          form))))))

3.7.9 LABELS Converter

The labels converter just uses the convert-funs function defined for the flet converter.

⟨special operator conversion 38⟩+≡ (23) ◁ 43 43 ▷

(define-converter labels (args info kv kf ctx)
(convert-funs args info kv kf 'labels ctx))

3.7.10 LAMBDA Converter

lambda is treated as a special operator rather than a macro. It is converted as the corresponding function expression.

⟨special operator conversion 38⟩+≡ (23) ◁ 43 44 ▷

(define-converter lambda (args info kv kf ctx)
(convert `(function (lambda ,@args)) info kv kf ctx))

3.7.11 LET Converter

Converting a let expression involves creating variable nodes and adding them to the environment, converting the body, and converting the arguments. A warning is issued for non-special variables that are not used.

⟨special operator conversion 38⟩+≡ (23) ◁ 43 44 ▷

(define-converter let (args info kv kf ctx)
(check-specop-argument-count 'let args 1 0 t)
(let ((binds (canonicalize-bindings 'let (first args) ctx)))
  (multiple-value-bind (decls body)
                       (split-decls-body (rest args) nil)
    (let* ((vars (mapcar #'first binds))
           (args (mapcar #'second binds))
           (nodes (make-var-list vars ctx))
           (ninfo (add-local-vars vars nodes decls info))
           (specs (find-special-variable-nodes nodes ninfo))
           (form (convert-let-body body specs ninfo kv kf ctx)))
      (check-unused-vars (set-difference nodes specs) ninfo ctx)
      (do ((rnodes (reverse nodes) (rest rnodes))
           (rargs (reverse args) (rest rargs)))
          ((or (null rnodes) (null rargs)))
          (setf form (convert (first rargs) info (first rnodes) form ctx)))
      form))))

The function canonicalize-bindings checks the bindings and turns them into a canonical (name value) form. Both let and let* allow a symbol in place of a list or a list of a symbol. symbol-macrolet only allows the list form. This definition leaves bindings of the form (name) unchanged and considers them valid for all cases.

⟨special operator conversion 38⟩+≡ (23) ◁ 44 44 ▷

(defun canonicalize-bindings (fun binds ctx)
(declare (ignore ctx))
(unless (proper-list-p binds) (error "not a proper bindings list: ~s" binds))
(flet ((canon (b)
         (when (and (symbolp b) (not (eq fun 'symbol-macrolet)))
               (setf b (list b nil)))
         (unless (and (proper-list-p b)
                      (symbolp (first b))
                      (null (rest (rest b))))
                 (error "~s is not a proper ~s binding form" b fun))
         (when (constantp (first b))
               (error "can't bind to the constant ~s" (first b)))
         b))
  (mapcar #'canon binds)))

The function find-special-variable-nodes collects the nodes that represent variables proclaimed or declared special.

⟨special operator conversion 38⟩+≡ (23) ◁ 44 44 ▷

(defun find-special-variable-nodes (nodes info)
(remove-if-not #'(lambda (x) (special-var-p (var-name x) info)) nodes))

The conversion of the body form of the let expression is handled by convert-let-body. When there are no special variables the conversion is simple. When some of the variables are special, the body’s continuation has to unbind the variables and the body is wrapped in expressions that assign the symbol values and an expression that creates new dynamic bindings for the symbols.

⟨special operator conversion 38⟩+≡ (23) ◁ 44 45 ▷

(defun convert-let-body (body specs info kv kf ctx)
(if specs
(let* ((denv (make-tmp-var))
(nkf (make-primop 'dynamic-unbind (list denv) nil kf nil ctx))
(form (convert body info (if kf kv t) nkf ctx)))
(dolist (s (reverse specs))
(setf form (make-primop 'set-symbol-value (list s) nil form
                     (var-name s) ctx)))
(let ((syms (make-const (mapcar #'var-name specs)))
 (tc (make-const t)))
(make-primop 'dynamic-bind (list syms tc) (list denv) form nil ctx)))
(convert body info kv kf ctx)))

3.7.12 LET* Converter

A let* is in principle just a nested let, but declarations complicate the issue. The arguments each must be converted in an environment that reflects the preceding variables and their declarations. The corresponding info structures are computed as the ilist list prior to argument conversion.

⟨special operator conversion 38⟩+≡ (23) ◁ 44 45 ▷

(define-converter let* (args info kv kf ctx)
(check-specop-argument-count 'let* args 1 0 t)
(let ((binds (canonicalize-bindings 'let* (first args) ctx)))
(multiple-value-bind (decls body)
            (split-decls-body (rest args) nil)
(let* ((vars (mapcar #'first binds))
(args (mapcar #'second binds))
(nodes (make-var-list vars ctx))
(ninfo (add-local-vars vars nodes decls info))
(ilist (make-let*-infos nodes info ninfo))
(specs (find-special-variable-nodes nodes ninfo))
(denvs (mapcar #'make-tmp-var specs))
(dalist (mapcar #'cons specs denvs))
(form (convert-let*-body body ninfo kv kf denvs ctx)))
(mapc #'(lambda (v arg info)
     (setf form (convert-let*-arg v arg (cdr (assoc v dalist))
                                  info form ctx)))
 (reverse nodes)
 (reverse args)
 (reverse ilist))
(check-unused-vars (set-difference nodes specs) ninfo ctx)
form))))

The infos list is created by augmenting the original info argument with information about special declarations for the bound variables obtained from the ninfo value that reflects the declarations in the let* body.

⟨special operator conversion 38⟩+≡ (23) ◁ 45 46 ▷

(defun make-let*-infos (nodes info ninfo)
(let ((ilist (list info)))
(dolist (v (butlast nodes) (reverse ilist))
(let* ((vn (var-name v))
(env (info-env ninfo))
(vi (multiple-value-list (variable-information vn env)))

(decls (if (eq (first vi) :special)
           (cons `(special ,vn) (third vi))
         (third vi)))
(ninfo (add-local-vars (list vn) (list v) decls info)))
(setf info ninfo)
(push info ilist)))))

The body conversion uses a continuation with an unbind operation for each special variable.

⟨special operator conversion 38⟩+≡ (23) ◁ 45 46 ▷

(defun convert-let*-body (body info kv kf denvs ctx)
(if denvs
(let ((form kf))
(dolist (de denvs)
(setf form (make-primop 'dynamic-unbind (list de) nil form nil ctx)))
(convert body info (if kf kv t) form ctx))
(convert body info kv kf ctx)))

Argument conversion is simple for non-special variables. For special ones, the form is wrapped in a binding and variable assignment for the special variable.

⟨special operator conversion 38⟩+≡ (23) ◁ 46 46 ▷

(defun convert-let*-arg (v arg denv info form ctx)
(if denv
(let* ((name (var-name v))
(sc (make-const (list name)))
(tc (make-const t))
(nkf (make-primop 'set-symbol-value (list v) nil form name ctx))
(nnkf (make-primop 'dynamic-bind (list sc tc) (list denv) nkf
                   nil ctx)))
(convert arg info v nnkf ctx))
(convert arg info v form ctx)))

3.7.13 LOAD-TIME-VALUE Converter

I still need to figure out how to handle this.

⟨special operator conversion 38⟩+≡ (23) ◁ 46 46 ▷

3.7.14 LOCALLY Converter

The locally converter just converts its body with an augmented environment.

⟨special operator conversion 38⟩+≡ (23) ◁ 46 46 ▷

(define-converter locally (args info kv kf ctx)
(multiple-value-bind (decls body)
          (split-decls-body args nil)
(convert body (add-decls-info decls info) kv kf ctx)))

3.7.15 MACROLET Converter

The macrolet converter adds macro definitions and declarations to the environment and converts the body with the new environment.

⟨special operator conversion 38⟩+≡ (23) ◁ 46 47 ▷

(define-converter macrolet (args info kv kf ctx)
(check-specop-argument-count 'macrolet args 1 0 t)
(let ((env (info-env info)))
  (flet ((mkmacro (x)
           (let ((name (first x))
                 (args (second x))
                 (body (rest (rest x))))
             (list name (parse-macro name args body env)))))
    (multiple-value-bind (decls body)
                         (split-decls-body (rest args) nil)
      (let* ((macs (mapcar #'mkmacro (first args)))
             (dict (info-dict info))
             (ninfo (make-info dict (augment-environment env :macro macs)))
             (nninfo (add-decls-info decls ninfo)))
        (convert body nninfo kv kf ctx))))))

3.7.16 MULTIPLE-VALUE-CALL Converter

The multiple-value-call converter handles the case where there is no form as a funcall. When there are two or more forms, a list of all values is made and the function is applied to the list. With luck the optimizer may eventually be able to do something with the result, but the use with two or more forms seems pretty rare. The primary case when there is only one form is handled by converting the function argument with a continuation that converts the form with, in turn, a continuation that expects its values in the value registers and calls the function with these values.

⟨special operator conversion 38⟩+≡ (23) ◁ 46 47 ▷

(define-converter multiple-value-call (args info kv kf ctx)
(check-specop-argument-count 'multiple-value-call args 1 0 t)
(let ((fun (first args))
      (forms (rest args)))
  (cond
   ((null forms) (convert `(funcall ,fun) info kv kf ctx))
   ((null (rest forms))
    (let* ((fv (make-tmp-var)) ;;****type?
           (vars (if (var-p kv) (list kv) nil))
           (vi (if (and kf (null kv)) t nil))
           (call (make-call fv nil vars kf vi t ctx)))
      (convert fun info fv (convert (first forms) info t call ctx) ctx)))
   (t (let ((vforms (mapcar #'(lambda (x) `(multiple-value-list ,x)) forms)))
        (convert `(apply ,fun (append ,@vforms)) info kv kf ctx))))))

3.7.17 MULTIPLE-VALUE-PROG1 Converter

When there are no additional forms, multiple-value-prog1 is converted by converting its first form. If the expression is not in tail position and does not have a multiple value continuation, it can be converted as a prog1 expression. Special handling is only needed when the expression is in tail position or has a multiple value continuation. In either of these cases the save-values primop is used to bind results of the first form to some variables and the restore-values primop is used to place those values in the value registers again.

⟨special operator conversion 38⟩+≡ (23) ◁ 47 48 ▷

(define-converter multiple-value-prog1 (args info kv kf ctx)
(check-specop-argument-count 'multiple-value-prog1 args 1 0 t)
(let ((first (first args))
      (rest (rest args)))
  (cond
   ((null rest) (convert first info kv kf ctx))
   ((and kf (or (var-p kv) (null kv)))
    (convert `(prog1 ,@args) info kv kf ctx))
   (t (let* ((vars (make-save-values-args))
             (nkf (make-primop 'restore-values vars nil kf nil ctx))
             (restform (convert (cons 'progn rest) info nil nkf ctx))
             (nnkf (make-primop 'save-values nil vars restform nil ctx)))
        (convert first info t nnkf ctx))))))

The save/restore primops save the argument count, the first value, and a list of any remaining values.

⟨special operator conversion 38⟩+≡ (23) ◁ 47 48 ▷

(defun make-save-values-args ()
(list (make-tmp-var "VCOUNT") (make-tmp-var "VAL") (make-tmp-var "VREST")))

3.7.18 NTH-VALUE Converter

The nth-value macro is treated as a special form for efficiency. With good optimization it could probably be made into a macro again. If the value is ignored, then the two arguments are converted with value-ignored continuations. If the expression is in tail position or the value is not ignored, then the count is converted and the body is converted with a continuation that takes its values in the value registers and uses the nth-value primop to extract the appropriate value.

⟨special operator conversion 38⟩+≡ (23) ◁ 48 48 ▷

(define-converter nth-value (args info kv kf ctx)
(check-specop-argument-count 'nth-value args 2 0 nil)
(if (and (not (null kf)) (null kv))
    (let ((nkf (convert (second args) info nil kf ctx)))
      (convert (first args) info nil nkf ctx))
  (let* ((nv (make-tmp-var))
         (vars (if kv (list kv) nil))
         (form (make-primop 'nth-value (list nv) vars kf nil ctx))
         (nkf (convert (second args) info t form ctx)))
    (convert (first args) info nv nkf ctx))))

3.7.19 PROGN Converter

The progn converter converts the final expression with the provided continuation and all other expressions with value-ignored continuations.

⟨special operator conversion 38⟩+≡ (23) ◁ 48 49 ▷

(define-converter progn (args info kv kf ctx)
(check-specop-argument-count 'progn args 0 0 t)
(let* ((rargs (reverse args))
       (val (convert (first rargs) info kv kf ctx)))
  (dolist (a (rest rargs) val)
    (setf val (convert a info nil val ctx)))))

3.7.20 PROGV Converter

A progv expression is converted by first converting the body with a continuation that unbinds the variables. Then the arguments are converted with a standard primop conversion for the dynamic-bind primop using the body as the continuation.

⟨special operator conversion 38⟩+≡ (23) ◁ 48 49 ▷

  (define-converter progv (args info kv kf ctx)
    (check-specop-argument-count 'progv args 2 0 t)
    (let* ((v (make-tmp-var))
           (bargs (list (first args) (second args)))
           (body (cons 'progn (rest (rest args))))
           (nkv (if (null kf) t kv))
           (nkf (make-primop 'dynamic-unbind (list v) nil kf nil ctx))
           (form (convert body info nkv nkf ctx)))
      (convert-standard-primop 'dynamic-bind bargs info v form nil ctx)))

3.7.21 QUOTE Converter

quote expressions are converted as constants.

⟨special operator conversion 38⟩+≡ (23) ◁ 49 49 ▷

  (define-converter quote (args info kv kf ctx)
    (declare (ignore info))
    (check-specop-argument-count 'quote args 1 0 nil)
    (convert-constant (first args) kv kf ctx))

3.7.22 RETURN-FROM Converter

The return-from converter looks up the block name in the environment and converts the value form with a continuation that takes its values in the value registers and executes a return-from

primop.

⟨special operator conversion 38⟩+≡ (23) ◁ 49 49 ▷

  (define-converter return-from (args info kv kf ctx)
    (declare (ignore kv kf))
    (check-specop-argument-count 'return-from args 1 1 nil)
    (let ((name (first args)))
      (check-block-name name 'return-from ctx)
      (let* ((tag (lookup-block name info))
             (nkf (make-primop 'return-from (list tag) nil nil nil ctx)))
        (convert (second args) info t nkf ctx))))

3.7.23 SETQ Converter

The setq converter rewrites multiple assignments into a progn and converts assignments to a symbol macro into setf expressions for macro expansion. Otherwise, the value is converted and assigned. For local variable assignment, the assignment is handled by a setq primop; global assignments use the set-symbol-value primop. For global assignments a warning is issued unless the variable has been proclaimed or declared special.

⟨special operator conversion 38⟩+≡ (23) ◁ 49 50 ▷

(define-converter setq (args info kv kf ctx)
(check-specop-argument-count 'setq args 2 0 t)
(let ((sym (first args))
      (val (second args))
      (rest (rest (rest args))))
  (unless (symbolp sym) (error "argument ~s to SETQ is not a symbol" sym))
  (cond
   ((rest (rest args))
    (convert `(progn (setq ,sym ,val) (setq ,@rest)) info kv kf ctx))
   ((eq (variable-information sym (info-env info)) :symbol-macro)
    (convert `(setf ,sym ,val) info kv kf ctx))
   (t (let* ((v (make-tmp-var))
             (nkf (convert-value v kv kf ctx)))
        (if (local-var-p sym info)
            (let ((var (lookup-var sym info ctx)))
              (convert val info v
                       (make-primop 'setq (list var v) nil nkf nil ctx)
                       ctx))
          (progn
            (unless (special-var-p sym info)
                    (warn-undeclared-global sym ctx))
            (convert val info v
                     (make-primop 'set-symbol-value (list v) nil nkf sym ctx)
                     ctx))))))))

3.7.24 SYMBOL-MACROLET Converter

symbol-macrolet expressions are handled by adding the symbol macro definitions and any supplied declarations to the environment and converting the body with the new environment.

⟨special operator conversion 38⟩+≡ (23) ◁ 49 50 ▷

(define-converter symbol-macrolet (args info kv kf ctx)
(check-specop-argument-count 'symbol-macrolet args 1 0 t)
(let ((binds (canonicalize-bindings 'symbol-macrolet (first args) ctx)))
  (multiple-value-bind (decls body)
                       (split-decls-body (rest args) nil)
    (let* ((nenv (augment-environment (info-env info) :symbol-macro binds))
           (ninfo (make-info (info-dict info) nenv))
           (nninfo (add-decls-info decls ninfo)))
      (convert body nninfo kv kf ctx)))))

3.7.25 TAGBODY Converter

Tagbodies are handled by splitting their bodies into functions that are tail-called. Closures are used. The tagbody primop receives as its argument a closure that is called with one argument, the tag that the go primops can use to throw their continuations to the tagbody loop. The body closure binds the functions corresponding to the tags in a letrec, so the tag is lexically visible to them. The closures could be stack allocated, since they are known to have dynamic extent, but as with blocks the hope is that most tagbodies can be optimized away. The tagbody converter treats its body as a progn ending with nil if it contains no tags.

⟨special operator conversion 38⟩+≡ (23) ◁ 50 51 ▷

(define-converter tagbody (args info kv kf ctx)
(dolist (a args) (unless (consp a) (check-tagbody-tag a 'tagbody ctx)))
(if (find-if #'tagbody-tag-p args)
(convert-tagbody args info kv kf ctx)
(convert `(progn ,@args nil) info kv kf ctx)))

If tags are present, then the conversion is done by convert-tagbody. It creates the functions, creates a letrec that binds the functions and calls the first one, and wraps this letrec in a function that takes the tag as its argument. This function is bound in a letrec with a body that is a tagbody primop with the function as its argument and the supplied continuation.

⟨special operator conversion 38⟩+≡ (23) ◁ 50 51 ▷

(defun convert-tagbody (body info kv kf ctx)
(let* ((split (split-tagbody body))
(tag (make-tmp-var))
(tags (reverse (mapcar #'first split)))
(vars (make-var-list tags ctx))
(ninfo (add-go-tags tags tag vars info))
(svar (make-tmp-var))
(args (make-tagbody-funs (mapcar #'rest split) (reverse vars) ninfo
                         ctx))
(sbody (make-letrec vars args
                    (make-call (first vars) nil nil nil nil nil ctx)
                    ctx))
(sfun (make-func nil (list tag) sbody 'lambda ctx))
(vl (if (var-p kv) (list kv) nil))
(body (make-primop 'tagbody (list svar) vl kf nil ctx)))
(make-letrec (list svar) (list sfun) body ctx)))

The function split-tagbody returns a list of lists of each tag followed by its expressions. The list is returned in reverse order since it needs to be processed bottom-up.

⟨special operator conversion 38⟩+≡ (23) ◁ 51 51 ▷

(defun split-tagbody (body)
(unless (tagbody-tag-p (first body)) (push (gensym) body))
(let ((val nil))
(loop
(let* ((next (member-if #'tagbody-tag-p (rest body))))
(push (ldiff body next) val)
(unless next (return))
(setf body next)))
val))

make-tagbody-funs converts the split bodies to functions starting with the last. Each function other than the last ends with a call to its successor. To help with debugging, the functions use their tags as their names, but only if the tags are interned symbols.

⟨special operator conversion 38⟩+≡ (23) ◁ 51 52 ▷

(defun make-tagbody-funs (bodies vars info ctx)
(let* ((kf (convert-constant nil nil nil ctx))
(body (convert `(progn ,@(first bodies)) info nil kf ctx))
(name (var-name (first vars)))
(iname (if (symbol-package name) name nil))
(args (list (make-func iname nil body 'lambda ctx))))
(do ((bodies (rest bodies) (rest bodies))
(vars vars (rest vars)))

((null bodies))
(let* ((kf (make-call (first vars) nil nil nil nil nil ctx))
(name (var-name (second vars)))
(body (convert `(progn ,@(first bodies)) info nil kf ctx)))
(push (make-func name nil body 'lambda ctx) args)))
args))

3.7.26 THE Converter

The converter for the the special operator checks the type specifier but then ignores it and just converts the value expression.

⟨special operator conversion 38⟩+≡ (23) ◁ 51 52 ▷

(define-converter the (args info kv kf ctx)
(check-specop-argument-count 'the args 2 0 nil)
(let ((type (first args))
(form (second args)))
(check-type-spec type info)
(convert form info kv kf ctx)))

3.7.27 THROW Converter

The throw converter converts its value expression with a multiple value continuation that executes a throw primop. This expression is the continuation body for converting the tag expression.

⟨special operator conversion 38⟩+≡ (23) ◁ 52 52 ▷

(define-converter throw (args info kv kf ctx)
(declare (ignore kv kf))
(check-specop-argument-count 'throw args 2 0 nil)
(let* ((tv (make-tmp-var))
(tform (make-primop 'throw (list tv) nil nil nil ctx))
(nkf (convert (second args) info t tform ctx)))
(convert (first args) info tv nkf ctx)))

3.7.28 UNWIND-PROTECT Converter

unwind-protect uses two closures, one for the body and one for the cleanup forms. The names of these closures are the arguments to the unwind-protect primop. The primop is wrapped in a letrec that binds the closures. The closures could be stack allocated since they are known to have dynamic extent.

⟨special operator conversion 38⟩+≡ (23) ◁ 52

(define-converter unwind-protect (args info kv kf ctx)
(check-specop-argument-count 'unwind-protect args 1 0 t)
(let ((form (first args)))
(if (rest args)
(let* ((bv (make-tmp-var))
(pv (make-tmp-var))
(pform (cons 'progn (rest args)))
(cform (convert form info nil nil ctx))
(cpform (convert pform info nil nil ctx))
(bfun (make-func nil nil cform 'lambda ctx))
(pfun (make-func nil nil cpform 'lambda ctx))
(vl (if (var-p kv) (list kv) nil))

                 (body (make-primop 'unwind-protect (list bv pv) vl kf nil ctx)))
            (make-letrec (list bv pv) (list bfun pfun) body ctx))
        (convert form info kv kf ctx))))

3.8 Error Checking

3.8.1 Error and Warning Messages

The functions in this section are used by the conversion routines and other parts of the compiler for signaling warnings and errors.

Style warnings are raised by issue-style-warning.

⟨error checking 53⟩≡ (23) 53 ▷

  (defun issue-style-warning (string &rest args)
    (warn (make-condition 'style-warning
                          :format-string string
                          :format-arguments args)))

The function warn-undeclared-global issues a warning if a global variable is accessed or modified but the variable has not been proclaimed or declared special. This can be very helpful for debugging but might be irritating if someone uses a coding style in which variables are deliberately left undeclared. It is therefore possible to disable these warnings by setting the public variable *warn-undeclared-globals* to nil. For XLISP-STAT the warning is disabled if the symbol is in the *variables* list. The initial value is nil since use of defproto and other aspects of the object system would produce too many warnings.

⟨error checking 53⟩+≡ (23) ◁ 53 53 ▷

  (export '*warn-undeclared-globals*)
  (defvar *warn-undeclared-globals* nil)
  (defun warn-undeclared-global (sym ctx)
    (declare (ignore ctx))
    (when (and *warn-undeclared-globals*
               #+xlisp-stat (not (member sym user::*variables*)))
          (issue-style-warning
           "the global variable ~s has not been declared special" sym)))

The function check-unused-vars checks a list of variables for ones that are not used (the tag slot is nil) but are not considered ignorable. A warning is issued if any such variables are found.

⟨error checking 53⟩+≡ (23) ◁ 53 53 ▷

  (defun check-unused-vars (vars info ctx)
    (let ((val nil))
      (dolist (v vars)
        (unless (or (var-tag v) (var-ignorable v info)) (push (var-name v) val)))
      (when val (warn-unused-variables val ctx))))

var-ignorable checks whether a variable has its type set to nil, which would be the case if it was declared ignore when it was created, or whether the environment contains an ignore or an ignorable declaration.

⟨error checking 53⟩+≡ (23) ◁ 53 54 ▷

  (defun var-ignorable (v info)
    (or (null (var-type v))
        (let* ((name (var-name v))
               (decls (nth-value 2 (variable-information name (info-env info)))))

      (member (second (assoc 'ignore decls)) '(ignore ignorable)))))

The function warn-unused-variables issues the style warning for unused variables.

⟨error checking 53⟩+≡ (23) ◁ 53 54 ▷

(defun warn-unused-variables (vars ctx)
(declare (ignore ctx))
(let ((v (first vars))
      (rv (rest vars)))
  (issue-style-warning "unused local variable~:[~;s~] ~s~{, ~s~}" rv v rv)))

Similarly, check-unused-funs checks a list of local functions and issues a warning if any have not been used.

⟨error checking 53⟩+≡ (23) ◁ 54 54 ▷

(defun check-unused-funs (vars ctx)
(let ((val nil))
  (dolist (v vars) (unless (var-tag v) (push (var-name v) val)))
  (when val (warn-unused-functions val ctx))))

The style warning for unused functions is issued by warn-unused-functions.

⟨error checking 53⟩+≡ (23) ◁ 54 54 ▷

(defun warn-unused-functions (funs ctx)
(declare (ignore ctx))
(let ((v (first funs))
      (rv (rest funs)))
  (issue-style-warning "unused local function~:[~;s~] ~s~{, ~s~}" rv v rv)))

If a variable is used even though it is covered by an ignore declaration, then a style warning is

issued by warn-ignored-variable-used.

⟨error checking 53⟩+≡ (23) ◁ 54 54 ▷

(defun warn-ignored-variable-used (v ctx)
(declare (ignore ctx))
(issue-style-warning "attempt to access variable ~a declared IGNORE"
                     (var-name v)))

The function check-specop-argument-count checks the arguments to a special operator and signals an error if the argument count does not match the specification.

⟨error checking 53⟩+≡ (23) ◁ 54 54 ▷

(defun check-specop-argument-count (op args nreq nopt restp)
(let ((n (length args))
      (nro (+ nreq nopt)))
  (unless (<= nreq n) (error "too few arguments for ~s" op))
  (unless (or restp (<= n nro)) (error "too many arguments for ~s" op))))

The functions too-few-arguments and too-many-arguments are used to signal arity errors in call expressions.

⟨error checking 53⟩+≡ (23) ◁ 54 55 ▷

(defun too-few-arguments (e m)
(declare (ignore m))
(error "too few arguments for ~s" (var-name (call-fun e))))
(defun too-many-arguments (e m)
(declare (ignore m))
(error "too many arguments for ~s" (var-name (call-fun e))))

check-type-spec is currently only used in the expressions, and doesn’t do anything useful yet. It should be defined properly and used to check other type expressions.

⟨error checking 53⟩+≡ (23) ◁ 54 55 ▷

(defun check-type-spec (type info)
(declare (ignore type info))
;;**** do something useful
t)

3.8.2 Checking Function Calls

The callinfo structure is used to hold information on the arguments expected by a function. lambda-list-callinfo computes the callinfo structure for a lambda list.

⟨error checking 53⟩+≡ (23) ◁ 55 55 ▷

(defstruct (callinfo
          (:type list)
          (:constructor make-callinfo (nreq nopt restp keyp keys other)))
nreq nopt restp keyp keys other)
(defun lambda-list-callinfo (list)
(multiple-value-bind (req opt rest has-key key other)
                     (parse-lambda-list list nil)
  (make-callinfo (length req) (length opt) (if rest t nil)
                 has-key (mapcar #'arginfo-key key) other)))

The function check-call compares a list of argument expressions to a callinfo record. It returns a keyword indicating the type of failure or nil if no problem was found. If the optional argument is true, then keyword arguments are checked for an invalid keyword.

⟨error checking 53⟩+≡ (23) ◁ 55 56 ▷

(defun check-call (args ci &optional (check-keys *strict-keywords*))
(let* ((nreq (callinfo-nreq ci))
       (nro (+ nreq (callinfo-nopt ci)))
       (restp (callinfo-restp ci))
       (keyp (callinfo-keyp ci))
       (n (if (listp args) (length args) args))) ;;**** allow for just argc
  (cond
   ((< n nreq) :too-few)
   ((and (< nro n) (not restp) (not keyp)) :too-many)
   ((and keyp (oddp (- n nro))) :missing-keyval)
   ((and keyp
         (not (callinfo-other ci))
         check-keys

⟨check for an invalid keyword 55⟩)

    :invalid-keyword)
   (t nil))))

Keyword checking goes through the pairs and checks every constant appearing in a keyword position against the allowed keywords. If an :allow-other-keys appears, then the check is stopped. It could be continued if the value is the constant nil, but this seems hardly worth the effort.

⟨check for an invalid keyword 55⟩≡ (55)

(let ((keyargs (nthcdr (if restp (1+ nro) nro) args))
    (keys (callinfo-keys ci))
    (badkey nil))

    (do ((args keyargs (cddr args)))
        ((null args) badkey)
        (let ((k (first args)))
          (when (constantp k)
                (cond
                 ((eq k :allow-other-keys) (return nil)) ;; maybe ok - stop check
                 ((not (member k keys)) (setf badkey t)))))))

For lambda expressions, check-lambda-argument-count computes the callinfo, checks the call, and signals an error if a problem is found.

⟨error checking 53⟩+≡ (23) ◁ 55 56 ▷

  (defun check-lambda-argument-count (fun args ctx)
    (when (null (rest fun)) (error "bad lambda expression: ~s" fun))
    (let ((val (check-call args (lambda-list-callinfo (second fun)))))
      (when val (signal-argument-count-error fun val ctx))))

The error signaling is handled by signal-argument-count-error. This function is used by several other checking functions.

⟨error checking 53⟩+≡ (23) ◁ 56 56 ▷

  (defun signal-argument-count-error (fun which ctx)
    (declare (ignore ctx))
    (case which
          (:too-few (error "too few arguments for ~s" fun))
          (:too-many (error "too many arguments for ~s" fun))
          (:missing-keyval (error "missing keyword value for ~s" fun))
          (:invalid-keyword (error "invalid keyword in call to ~s" fun))
          (t (error "bad call to ~s" fun))))

Argument usage in local calls is checked by check-local-argument-count.

⟨error checking 53⟩+≡ (23) ◁ 56 56 ▷

  (defun check-local-argument-count (fun args info ctx)
    (let ((val (check-call args (local-callinfo fun info))))
      (when val (signal-argument-count-error fun val ctx))))

For global calls, check-global-argument-count checks whether callinfo is available for the function from the registration process. If it is, it is used to check the call and issue a style warning if the call does not match the definition. This is not necessarily an error, since the function might be redefined before use, but a warning is appropriate. If no registered value is found, the system function database is searched to see if the function is a built-in function. Since system functions can be redefined by system code, this check has to be done after the check for a global function. If the function is a system function and the usage is inconsistent with the definition, then an error is signaled. The criterion for when to do strict keyword checking of system functions is based on the fact that SUBRs check strictly but defined functions only do if *strict-keywords* is true. Finally, if no information was found then the call is registered to allow it to be checked against a future definition.

⟨error checking 53⟩+≡ (23) ◁ 56

  (defun check-global-argument-count (fun args info ctx)
    (declare (ignore info))
    (let ((ci (global-callinfo fun)))
      (cond
       (ci (register-global-call fun args ctx)
           (when (check-call args ci)
                 (issue-style-warning "call to ~s does not match definition"

                                    fun)))
     (t (let ((ci (sysfun-callinfo fun)))
          (if ci
              (let* ((check-keys (or *strict-keywords*
                                     (and (fboundp fun)
                                          (typep (symbol-function fun)
                                                 'subr))))
                     (val (check-call args ci check-keys)))
                (when val (signal-argument-count-error fun val ctx)))
            (register-global-call fun args ctx)))))))

3.9 Registering Built-In Functions

The callinfo for system functions is stored in a hash table and retrieved by sysfun-callinfo.

⟨register built-in functions 57⟩≡ (23) 57 ▷

(defparameter *sysfun-callinfo* (make-hash-table))
(defun sysfun-callinfo (fun) (gethash fun *sysfun-callinfo*))

The macro define-sysfun-callinfo allows callinfo for a single function or a list of functions to be registered

⟨register built-in functions 57⟩+≡ (23) ◁ 57 57 ▷

(defmacro define-sysfun-callinfo (name nreq &optional (nopt 0) restp keyp keys
                                       other)
  (if (consp name)
      `(let ((ci (make-callinfo ,nreq ,nopt ,restp ,keyp ',keys ,other)))
         (dolist (s ',name)
           (unless (fboundp s) (warn "built-in function ~s is not defined" s))
           (setf (gethash s *sysfun-callinfo*) ci)))
    `(progn
       (unless (fboundp ',name)
               (warn "built-in function ~s is not defined" ',name))
       (setf (gethash ',name *sysfun-callinfo*)
             (make-callinfo ,nreq ,nopt ,restp ,keyp ',keys ,other))
       ',name)))

3.9.1 Functions with No Required Arguments

⟨register built-in functions 57⟩+≡ (23) ◁ 57 58 ▷

;; **** get-universal-time
(define-sysfun-callinfo
  (get-decoded-time get-internal-real-time get-internal-run-time
 list-all-packages)
  0)
(define-sysfun-callinfo make-pathname
  0 0 nil t (:case :defaults :device :directory :host :name :type :version))
(define-sysfun-callinfo make-hash-table
  0 0 nil t (:rehash-size :rehash-threshold :size :test))
(define-sysfun-callinfo

(+ * /= < <= = > >= append break char-equal char-greaterp char-lessp
char-not-equal char-not-greaterp char-not-lessp char< char<= char= char>
char>= gcd lcm list list* logand logeqv logior logxor max min nconc values
vector y-or-n-p yes-or-no-p)
0 0 t)
;;**** listen nbutlast
(define-sysfun-callinfo
(abort compute-restarts dribble finish-output force-output fresh-line
gensym make-string-output-stream muffle-warning
terpri)
0 1)
;;**** copy-readtable
(define-sysfun-callinfo ( gentemp make-random-state) 0 2)
;;**** read-char-no-hang
(define-sysfun-callinfo
(read read-char read-from-string read-line
read-preserving-whitespace)
0 4)
(define-sysfun-callinfo peek-char 0 5)

3.9.2 Functions with One Required Argument

⟨register built-in functions 57⟩+≡ (23) ◁ 57 60 ▷

;;**** character disassemble fdefinition file-author fill-pointer
;;**** float-digits float-precision float-radix formatter graphic-char-p
;;**** host-namestring inspect integer-decode-float interactive-stream-p
;;**** name-char pathnamep rationalize readtable-case readtablep
;;**** simple-bit-vector-p simple-string-p simple-vector-p sleep
;;**** special-operator-p standard-char-p step stream-element-type
;;**** stream-external-format sxhash vector-pop
(define-sysfun-callinfo
(1+ 1- abs acos acosh alpha-char-p alphanumericp array-dimensions
array-element-type array-rank array-total-size arrayp asin asinh
atanh atom both-case-p boundp caaar caadr caar cadar caddr cadr car
cdaar cdadr cdar cddar cdddr cddr cdr char-code char-downcase char-int
char-upcase characterp cis clrhash code-char compiled-function-p complement
complexp conjugate consp constantp copy-alist copy-list copy-seq
copy-structure cos cosh xlisp::coerce-to-macro delete-file delete-package
denominator directory-namestring eighth endp eval evenp exp fboundp fifth
file-length file-namestring file-write-date find-all-symbols find-package
first floatp fmakunbound fourth function-lambda-expression functionp
get-output-stream-string hash-table-count hash-table-p
hash-table-rehash-size hash-table-rehash-threshold hash-table-size
hash-table-test identity imagpart input-stream-p integer-length integerp
invoke-debugger invoke-restart-interactively isqrt keywordp length
list-length listp logcount lognot lower-case-p make-symbol makunbound
minusp namestring ninth not nreverse null numberp numerator oddp
open-stream-p output-stream-p package-name package-nicknames
package-shadowing-symbols package-use-list package-used-by-list

   packagep phase plusp prin1-to-string princ-to-string probe-file proclaim
   provide random-state-p rational rationalp realp realpart rest restart-name
   reverse second seventh signum sin sinh sixth sqrt streamp string stringp
   symbol-function symbol-name symbol-package symbol-plist symbol-value
   symbolp tan tanh tenth third truename type-of upper-case-p values-list
   vectorp zerop xlisp::specialp xlisp::%copy-struct
   xlisp::byte-code-close)
  1)
(define-sysfun-callinfo (funcall) 1 0 t)
(define-sysfun-callinfo augment-environment
  1 0 nil t (:declare :function :macro :symbol-macro :variable))
(define-sysfun-callinfo close 1 0 nil t (:abort))
(define-sysfun-callinfo (delete-duplicates remove-duplicates)
  1 0 nil t (:from-end :test :test-not :start :end :key))
(define-sysfun-callinfo directory 1 0 nil t nil t)
(define-sysfun-callinfo load
  1 0 nil t (:verbose :print :if-does-not-exist :external-format))
(define-sysfun-callinfo make-array
  1 0 nil t (:element-type :initial-element :initial-contents :adjustable
             :fill-pointer :displaced-to :displaced-index-offset))
(define-sysfun-callinfo (make-list make-string) 1 0 nil t (:initial-element))
(define-sysfun-callinfo (nstring-capitalize nstring-downcase nstring-upcase
                         string-capitalize string-downcase string-upcase)
  1 0 nil t (:start :end))
(define-sysfun-callinfo open
  1 0 nil t (:direction :element-type :if-exists :if-does-not-exist
             :external-format))
(define-sysfun-callinfo parse-integer
  1 0 nil t (:start :end :radix :junk-allowed))
(define-sysfun-callinfo read-sequence 1 0 nil t (:start :end))
(define-sysfun-callinfo (write write-to-string)
  1 0 nil t (:array :base :case :circle :escape :gensym :length :level :lines
             :miser-width :pprint-dispatch :pretty :radix :readably
             :right-margin :stream))
(define-sysfun-callinfo compile-file-pathname 1 0 nil t (:output-file) t)
(define-sysfun-callinfo (delete-duplicates remove-duplicates)
  1 0 nil t (:from-end :test :test-not :start :end :key))

(define-sysfun-callinfo
(- / apply aref array-in-bounds-p array-row-major-index concatenate
error every invoke-restart make-condition mapc mapcan mapcar mapcon
mapl maplist notany notevery signal some warn xlisp::%make-struct)
1 0 t)
;;**** decode-universal-time enough-namestring ensure-directories-exist
;;**** float-sign get-dispatch-macro-character upgraded-array-element-type
;;**** upgraded-complex-part-type
(define-sysfun-callinfo
(apropos apropos-list atan butlast ceiling compile copy-symbol
describe digit-char digit-char-p export fceiling ffloor file-position
find-restart find-symbol float floor fround ftruncate function-information
get-macro-character get-setf-expansion import intern last log logandc1
logandc2 lognand lognor logorc1 logorc2 macro-function macroexpand
macroexpand-1 parse-namestring pathname-device pathname-directory
pathname-host pathname-name pathname-type pathname-version pprint
prin1 princ print random require round shadow shadowing-import
truncate unexport unintern unread-char unuse-package use-package
variable-information wild-pathname-p write-char xlisp::slot-value)
1 1)
(define-sysfun-callinfo (write-line write-string) 1 1 nil t (:start :end))
;;**** make-dispatch-macro-character read-delimited-list set-syntax-from-char
(define-sysfun-callinfo
(make-package make-string-input-stream merge-pathnames read-byte
xlisp::mark-as-special)
1 2)
(define-sysfun-callinfo parse-namestring 1 2 nil t (:start :end :junk-allowed))
(define-sysfun-callinfo read-from-string
1 2 nil t (:start :end :preserve-whitespace))

3.9.3 Functions with Two Required Arguments

⟨register built-in functions 57⟩+≡ (23) ◁ 58 62 ▷

;;**** file-string-length revappend scale-float vector-push
(define-sysfun-callinfo
(xlisp::%set-car xlisp::%set-cdr array-dimension ash char coerce cons
documentation elt eq eql equal equalp expt get-properties ldiff logbitp
logtest maphash mod nreconc nth nthcdr pathname-match-p rem remhash remprop
rename-file row-major-aref rplaca rplacd schar set string-left-trim
string-right-trim string-trim svref tailp write-byte xlisp::%struct-ref
xlisp::%struct-type-p xlisp::push-condition-handlers
xlisp::apply-arg-rotate xlisp::default-structure-slot-value
xlisp::destructure-check-arg xlisp::install-sharp-s-constructor)
2)
(define-sysfun-callinfo (cerror map map-into) 2 0 t)
;;**** assoc-if assoc-if-not member-if-not rassoc-if rassoc-if-not

;;**** subst-if subst-if-not
(define-sysfun-callinfo (member-if sort stable-sort) 2 0 nil t (:key))
;;**** rassoc
(define-sysfun-callinfo
  (adjoin assoc intersection member nintersection nset-difference
   nset-exclusive-or nsublis nunion set-difference set-exclusive-or sublis
   subsetp union)
  2 0 nil t (:key :test :test-not))
(define-sysfun-callinfo (format) 2 0 t)
(define-sysfun-callinfo (count find position)
  2 0 nil t (:from-end :start :end :key :test :test-not))
(define-sysfun-callinfo (count-if count-if-not
                         find-if find-if-not
                         position-if position-if-not)
  2 0 nil t (:from-end :start :end :key))
(define-sysfun-callinfo (delete remove)
  2 0 nil t (:from-end :test :test-not :start :end :count :key))
(define-sysfun-callinfo (delete-if delete-if-not remove-if remove-if-not)
  2 0 nil t (:from-end :start :end :count :key))
(define-sysfun-callinfo fill 2 0 nil t (:start :end))
;;**** (define-sysfun-callinfo make-sequence 2 0 nil t (:initial-element))
(define-sysfun-callinfo xlisp::install-function 2 2)
;;**** (define-sysfun-callinfo merge 4 0 nil t (:key))
;;**** (define-sysfun-callinfo (mismatch search)
;;****  2 0 nil t (:from-end :test :test-not :key :start1 :start2 :end1 :end2))
(define-sysfun-callinfo reduce
  2 0 nil t (:key :from-end :start :end :initial-value))
(define-sysfun-callinfo
  (replace string-equal string-greaterp string-lessp string-not-equal
   string-not-greaterp string-not-lessp string/= string< string<= string=
   string> string>= )
  2 0 nil t (:start1 :end1 :start2 :end2))
;;**** (define-sysfun-callinfo tree-equal 2 0 nil t (:test :test-not))
(define-sysfun-callinfo write-sequence 2 0 nil t (:start :end))
;;**** vector-push-extend
(define-sysfun-callinfo (get getf gethash pairlis rename-package subseq
                         subtypep typep)

  2 1)
(define-sysfun-callinfo set-macro-character 2 2)

3.9.4 Functions with Three or More Required Arguments

⟨register built-in functions 57⟩+≡ (23) ◁ 60

(define-sysfun-callinfo
  (xlisp::%set-elt xlisp::%set-get xlisp::%set-gethash xlisp::%set-nth
   xlisp::%set-svref acons xlisp::%set-rm-aref xlisp::%struct-set
   xlisp::make-macro-lambda-expression xlisp::install-structure-slots)
  3)
(define-sysfun-callinfo (nsubst subst)
  3 0 nil t (:key :test :test-not))
(define-sysfun-callinfo (nsubst-if nsubst-if-not)
  3 0 nil t (:key))
(define-sysfun-callinfo (nsubstitute substitute)
  3 0 nil t (:from-end :test :test-not :start :end :count :key))
(define-sysfun-callinfo (nsubstitute-if nsubstitute-if-not
                         substitute-if substitute-if-not)
  3 0 nil t (:from-end :start :end :count :key))
;;**** (define-sysfun-callinfo translate-pathname 3 0 nil t nil t)
(define-sysfun-callinfo xlisp::%set-aref 3 0 t)
;;**** set-dispatch-macro-character
(define-sysfun-callinfo (parse-macro) 3 1)
#+xlisp-stat
(define-sysfun-callinfo xlisp::add-method 4)
;;**** (define-sysfun-callinfo encode-universal-time 6)

Removing Blocks, Tagbodies, and Cells

Two important optimizations are the removal of unnecessary blocks and tagbodies and the removal of unnecessary cells. A expresions with a return-from continuation can be replaced by tail expressions if they occur in the function creating the block or in functions only reachable by tail calls from the creating function. Similarly, tagbody go expressions reachable only directly or by tail calls can be replaced by tail calls to their continuation functions. Blocks that no longer have any return-from expressions and tagbodies that no longer are used by any go expressions can be replaced by calls to their body functions. This eliminates the need for closures for these functions. Cells can be eliminated if all their uses occur in the defining function or in functions reachable only by tail calls. ⟨cellstags.lsp 63⟩≡

  (in-package "NEWCMP")

⟨call graphs 63⟩

⟨finding tail-only uses 65⟩

⟨removing safe blocks and tagbodies 67⟩

⟨removing safe cells 72⟩

4.1 Computing a Call Graph

Block/tagbody removal and cell removal both require the determination of a call graph.

4.1.1 Call Graph Data Structures

The data structure for holding the call graph is a callgr structure.

⟨call graphs 63⟩≡ (63) 63 ▷

  (defstruct (callgr (:constructor make-callgr (arg-refs-p)))
    functions
    (callee-table (make-hash-table))
    (caller-table (make-hash-table))
    arg-refs-p)

If the arg-refs-p slot is not nil, then references to a function as an argument are entered as calls. Functions and calls are entered with add-callgr-function and add-callgr-call.

CHAPTER 4. REMOVING BLOCKS, TAGBODIES, AND CELLS 64

⟨call graphs 63⟩+≡ (63) ◁ 63 64 ▷

(defun add-callgr-function (fun gr)
  (pushnew fun (callgr-functions gr)))
(defun add-callgr-call (caller callee gr)
  (push callee (gethash caller (callgr-callee-table gr)))
  (push caller (gethash callee (callgr-caller-table gr))))

Callees and callers of a function are retrieved by callgr-callees and callgr-callers.

⟨call graphs 63⟩+≡ (63) ◁ 63 64 ▷

(defun callgr-callees (f gr)
  (gethash f (callgr-callee-table gr)))
(defun callgr-callers (f gr)
  (gethash f (callgr-caller-table gr)))

For debugging purposes, the function show-callgr returns an association list of the function names and the names of their callees.

⟨call graphs 63⟩+≡ (63) ◁ 64 64 ▷

(defun show-callgr (gr)
  (let ((val nil))
    (maphash #'(lambda (x y)
                 (push (cons (func-name x) (mapcar #'func-name y)) val))
             (callgr-callee-table gr))
    val))

4.1.2 Computing the Graph

The call graph for a top level function is computed by compute-callgr. After creating the graph, the graph is filled in by calling fill-callgr and then returned.

⟨call graphs 63⟩+≡ (63) ◁ 64 64 ▷

(defun compute-callgr (e &optional arg-refs-p)
  (let ((gr (make-callgr arg-refs-p)))
    (fill-callgr e e nil gr)
    gr))

The fill-callgr recursively fills in a graph gr by dispatching on the expression type. The function argument fun represents the current function.

⟨call graphs 63⟩+≡ (63) ◁ 64

(defun fill-callgr (e fun env gr)
  (cond
   ((func-p e) ⟨fill-callgr for func expressions 64⟩)
   ((letrec-p e) ⟨fill-callgr for letrec expressions 65⟩)
   ((call-p e) ⟨fill-callgr for call expressions 65⟩)

(t ⟨fill-callgr for other expressions 65⟩)))

Functions are handled by adding an entry for the function to the graph and processing the function body with the function itself as the current function.

⟨fill-callgr for func expressions 64⟩≡ (64)

(add-callgr-function e gr)
(fill-callgr (func-body e) e env gr)

For letrec expressions, the environment is augmented by adding variable/function pairs. Then the function arguments and the body expression are processed with the new environment.

⟨fill-callgr for letrec expressions 65⟩≡ (64)

  (let* ((args (letrec-args e))
         (vars (letrec-vars e))
         (nenv (append (mapcar #'cons vars args) env)))
    (dolist (a args) (fill-callgr a a nenv gr))
    (fill-callgr (letrec-body e) fun nenv gr))

Calls are handled by entering the call in the graph if it is to a local function, processing the arguments if necessary, and then processing the continuation if there is one.

⟨fill-callgr for call expressions 65⟩≡ (64)

  (let ((lfun (cdr (assoc (call-fun e) env)))
        (form (call-form e)))
    (when lfun (add-callgr-call fun lfun gr))
    (when (callgr-arg-refs-p gr)

⟨add argument use references to gr 65⟩)

    (when form (fill-callgr form fun env gr)))

The arguments are processed by fill-callgr-args.

⟨add argument use references to gr 65⟩≡ (65)

  (dolist (a (cexpr-args e))
    (let ((lfun (cdr (assoc a env))))
      (when lfun (add-callgr-call fun lfun gr))))

Finally, all other expressions are handled by processing their arguments and continuations.

⟨fill-callgr for other expressions 65⟩≡ (64)

  (when (callgr-arg-refs-p gr)

⟨add argument use references to gr 65⟩)

  (dolist (c (cexpr-conts e)) (fill-callgr c fun env gr))

4.2 Identifying Tail-Only Uses

Both block/tagbody removal and cell removal need to find out whether one function is equal to another or reachable only by tail calls. This is determined by computing a call graph, collecting information on non-tail use of functions, and then examining the call paths for each pair of functions.

4.2.1 Collecting Non-Tail Use Information

Non-tail use information is held in a list structure. The hash field is used to register definitions of functions used in non-tail position. The go-as-tail field records whether go expressions are to be treated as tail calls. The constructor takes the go-as-tail value to use as an argument.

⟨finding tail-only uses 65⟩≡ (63) 65 ▷

  (defstruct (non-tail-table (:type list)
                             (:constructor make-non-tail-table (go-as-tail)))
    (hash (make-hash-table)) go-as-tail)

A simple predicate is provided by

⟨finding tail-only uses 65⟩+≡ (63) ◁ 65 66 ▷

  (defun non-tail-p (def tbl) (gethash def (non-tail-table-hash tbl)))

Entries are made by mark-non-tail. The arguments are a variable, an environment, and the table. If the variable is associated with a definition in the environment, then the definition is entered as used in non-tail position in the table.

⟨finding tail-only uses 65⟩+≡ (63) ◁ 65 66 ▷

(defun mark-non-tail (var env tbl)
(let ((def (cdr (assoc var env))))
  (when def (setf (gethash def (non-tail-table-hash tbl)) t))))
The function compute-non-tail-table creates a table and calls fill-non-tail-table to fill

the table.

⟨finding tail-only uses 65⟩+≡ (63) ◁ 66 67 ▷

(defun compute-non-tail-table (e go-as-tail)
(let ((tbl (make-non-tail-table go-as-tail)))
  (fill-non-tail-table e nil tbl)
  tbl))
(defun fill-non-tail-table (e env tbl)
(cond
 ((letrec-p e)
  ⟨fill-non-tail-table for letrec expressions 66⟩)
 ((call-p e)
  ⟨fill-non-tail-table for call expressions 66⟩)
 (t ⟨fill-non-tail-table for other expressions 66⟩)))

For letrec expressions a new environment is created and the arguments and body are processed with the new environment.

⟨fill-non-tail-table for letrec expressions 66⟩≡  (66)
(let* ((args (letrec-args e))
     (vars (letrec-vars e))
     (nenv (append (mapcar #'cons vars args) env)))
(dolist (a (letrec-args e)) (fill-non-tail-table a nenv tbl))
(fill-non-tail-table (letrec-body e) nenv tbl))

The arguments in calls are passed to mark-non-tail, which marks them as used in non-tail position if they are local functions. If the continuation form is not null, then the function is marked as well if it is local, and form is processed.

⟨fill-non-tail-table for call expressions 66⟩≡  (66)
(let ((form (call-form e)))
(dolist (a (call-args e)) (mark-non-tail a env tbl))
(when form
      (mark-non-tail (call-fun e) env tbl)
      (fill-non-tail-table form env tbl)))

Other expressions are processed by marking their arguments and processing their continuations. If the go-as-tail field is true, then go expressions are ignored since their function argument is considered to be used in tail position and they have no continuations.

⟨fill-non-tail-table for other expressions 66⟩≡ (66)

(unless (and (non-tail-table-go-as-tail tbl) (primop-eq e 'go))
      (dolist (a (cexpr-args e)) (mark-non-tail a env tbl))
      (dolist (c (cexpr-conts e)) (fill-non-tail-table c env tbl)))

4.2.2 Examining Call Paths

The function safe-use-p examines all call paths from root to fun and returns t if fun and root are identical or all calls on all paths are tail calls; otherwise, it returns nil. If the loc-ok argument is non nil, then non-tail calls are safe as long as they are not to functions of type lambda. This calculation needs a use information table uses and a call graph gr. The algorithm places processed functions in a done list and ones to be processed in a pending list. Initially, done contains only root, and pending contains only fun. The algorithm then loops, returning t if the pending list is empty.

⟨finding tail-only uses 65⟩+≡ (63) ◁ 66

  (defun safe-use-p (fun root uses gr loc-ok)
    (let ((done (list root))
          (pending (list fun)))
      (loop
       (if (null pending)
           (return t)
         ⟨safe-use-p loop step 67⟩))))

The loop step removes one element from the pending list. If the element is not already in the done list, it is checked for not-tail use. If it is used in non-tail position, the algorithm terminates and nil is returned. Otherwise, the element is pushed on the done list and the new pending list is set to the union of the element’s callers and the current pending list.

⟨safe-use-p loop step 67⟩≡ (67)

  (let ((next (pop pending)))
    (unless (member next done)
            (when (and (non-tail-p next uses)
                       (or (not loc-ok) (eq (func-type next) 'lambda)))
                  (return nil))
            (push next done)
            (setf pending (union (callgr-callers next gr) pending))))

4.3 Removing Safe Blocks and Tagbodies

Expressions followed by return-from expressions can be replaced by tail expressions if they occur in the same function as the block tag’s definition or in functions that can only be reached by tail calls. Function uses in go primops are considered tail calls for this purpose. Similarly, uses of go can be replaced by tail calls if they occur in the same function as the tagbody’s tag definition or in functions that can only be reached by tail calls. If all return-from primops for a block have been removed, then the block can be dropped. Similarly if all go’s for a tagbody have been removed, then the tagbody itself can be dropped. Removing inner blocks or tagbodies may make outer ones eligible for removal, so the removal process can be repeated until there are no more changes.

4.3.1 Main Routines

A single pass of this removal process starts by computing a call graph, tail call information, and tag information. The call graph treats all uses as calls, and the tail call information is computed treating function uses in go expressions as tail calls. If there are any tags, then drop-safe-jumps

removes safe uses of return-from or go, and drop-unused-tags removes any block or tagbody

primops that are no longer needed.

⟨removing safe blocks and tagbodies 67⟩≡ (63) 68 ▷

(defun drop-safe-tags-one (e)
  (let ((gr (compute-callgr e t))
        (uses (compute-non-tail-table e t))
        (tags (compute-tags-table e)))
    (if (tags-table-has-tags tags)
        (drop-unused-tags (drop-safe-jumps e e uses tags gr) tags)
      e)))

The main entry point is drop-safe-tags. This repeatedly applies drop-safe-tags-one until there are no more changes. The number of repetitions needed should be at most one plus the deepest nesting level of blocks and tagbodies.

⟨removing safe blocks and tagbodies 67⟩+≡ (63) ◁ 67 68 ▷

(defun drop-safe-tags (e)
  (loop
   (let ((ne (drop-safe-tags-one e)))
     (if (eq e ne)
         (return e)
       (setf e ne)))))

4.3.2 Collecting Tags information

For each tag we need the tag variable, the variable naming the function creating the tag, the function definition, and whether the tag is used of not. This information is held in a list structure defined by

⟨removing safe blocks and tagbodies 67⟩+≡ (63) ◁ 68 68 ▷

(defstruct (tags-table-entry
            (:type list)
            (:constructor make-tags-table-entry (tag fun def)))
  tag fun def used)

These entries are collected in a hash table. Entries are registered under both the tag variable and the function variable.

⟨removing safe blocks and tagbodies 67⟩+≡ (63) ◁ 68 68 ▷

(defun make-tags-table () (make-hash-table))
(defun lookup-tags-table-tag (tag table) (gethash tag table))
(defun lookup-tags-table-fun (fun table) (gethash fun table))

Entries are created by add-tags-table-entry. The arguments are the variable naming the tag’s function, an environment, and the table. The definition is looked up in the environment, and the tag variable is the parameter of the definition.

⟨removing safe blocks and tagbodies 67⟩+≡ (63) ◁ 68 68 ▷

(defun add-tags-table-entry (fun env table)
  (let* ((def (cdr (assoc fun env)))
         (tag (first (func-vars def)))
         (entry (make-tags-table-entry tag fun def)))
    (setf (gethash tag table) entry)
    (setf (gethash fun table) entry)))

A test for whether there are any tags in the table is based on the hash table count.

⟨removing safe blocks and tagbodies 67⟩+≡ (63) ◁ 68 69 ▷

(defun tags-table-has-tags (table) (< 0 (hash-table-count table)))

The function compute-tags-table creates a table and calls fill-tags-table to fill the table.

⟨removing safe blocks and tagbodies 67⟩+≡ (63) ◁ 68 69 ▷

(defun compute-tags-table (e)
(let ((table (make-tags-table)))
  (fill-tags-table e nil table)
  table))

fill-tags-table dispatches on expression type.

⟨removing safe blocks and tagbodies 67⟩+≡ (63) ◁ 69 69 ▷

(defun fill-tags-table (e env table)
(cond
 ((primop-p e)
  ⟨fill-tags-table for primop expressions 69⟩)
 ((letrec-p e)
  ⟨fill-tags-table for letrec expressions 69⟩)

(t ⟨fill-tags-table for other expressions 69⟩)))

For primp expressions, if the expression is a block or tagbody expression then its function variable argument is entered into the table. Then, for all primops, the continuation form is processed if there is one.

⟨fill-tags-table for primop expressions 69⟩≡ (69)

(let ((form (primop-form e)))
(when (or (primop-eq e 'block) (primop-eq e 'tagbody))
      (add-tags-table-entry (first (primop-args e)) env table))
(when form (fill-tags-table (primop-form e) env table)))

letrec expressions are handled by creating a new environment and processing the arguments and body with the new environment.

⟨fill-tags-table for letrec expressions 69⟩≡ (69)

(let* ((args (letrec-args e))
     (vars (letrec-vars e))
     (nenv (append (mapcar #'cons vars args) env)))
(dolist (a args) (fill-tags-table a nenv table))
(fill-tags-table (letrec-body e) nenv table))

All other expressions are handled by processing their continuations.

⟨fill-tags-table for other expressions 69⟩≡ (69)

(dolist (c (cexpr-conts e)) (fill-tags-table c env table))

4.3.3 Replacing Safe Jumps

The function drop-safe-jumps dispatches on expression type.

⟨removing safe blocks and tagbodies 67⟩+≡ (63) ◁ 69 69 ▷

(defun drop-safe-jumps (e fun uses tags gr)
(cond
 ((primop-p e) (drop-safe-jumps-primop e fun uses tags gr))
 ((letrec-p e) (drop-safe-jumps-letrec e fun uses tags gr))
 ((call-p e) (drop-safe-jumps-call e fun uses tags gr))
 (t (drop-safe-jumps-cexpr e fun uses tags gr))))

For primop expressions, go expressions, expressions with safe return-from continuations, and return-from expressions are handled separately.

⟨removing safe blocks and tagbodies 67⟩+≡ (63) ◁ 69 70 ▷

(defun drop-safe-jumps-primop (e fun uses tags gr)
  (let ((args (primop-args e)))
    (cond
     ((primop-eq e 'go)
      ⟨drop-safe-jumps-primop for go expressions 70⟩)
     ((safe-return-from-cont-p e fun uses tags gr)

⟨rewrite expression as a tail expression 70⟩)

     ((primop-eq e 'return-from)

⟨mark tag for return-from expression as used 70⟩)

     (t (drop-safe-jumps-cexpr e fun uses tags gr)))))

Expressions with a safe return-from continuation are recognized by

⟨removing safe blocks and tagbodies 67⟩+≡ (63) ◁ 69 70 ▷

(defun safe-return-from-cont-p (e fun uses tags gr)
  (let ((form (first (cexpr-conts e))))
    (if (and form (primop-eq form 'return-from))
        (let* ((tag (first (primop-args form)))
               (entry (lookup-tags-table-tag tag tags))
               (def (tags-table-entry-def entry)))
          (safe-use-p fun def uses gr nil))
      nil)))

If a go expression is safe to replace, it is replaced by a tail call to the argument function. Otherwise the tagbody tag is marked as used and the expression is returned unchanged.

⟨drop-safe-jumps-primop for go expressions 70⟩≡  (69)
(let* ((tag (first args))
       (entry (lookup-tags-table-tag tag tags))
       (def (tags-table-entry-def entry))
       (ctx (primop-context e)))
  (cond
   ((safe-use-p fun def uses gr nil)
    (make-call (second args) nil nil nil nil nil ctx))
   (t (setf (tags-table-entry-used entry) t)
      e)))

If an expression is followed by a safe return-from expression, then it is rewritten as a tail expression.

⟨rewrite expression as a tail expression 70⟩≡ (69 71)

(remake-cexpr e (cexpr-fun e) (cexpr-args e) nil nil)

Other return-from expressions have their tags marked as used and are returned unchanged.

⟨mark tag for return-from expression as used 70⟩≡ (69)

(let* ((tag (first args))
       (entry (lookup-tags-table-tag tag tags)))
  (setf (tags-table-entry-used entry) t)
  e)

For letrec expressions, the arguments and body are processed and the expression is remade.

⟨removing safe blocks and tagbodies 67⟩+≡ (63) ◁ 70 71 ▷

(defun drop-safe-jumps-letrec (e fun uses tags gr)
  (let ((nargs (mapcar #'(lambda (x) (drop-safe-jumps x x uses tags gr))
                       (letrec-args e)))
        (nbody (drop-safe-jumps (letrec-body e) fun uses tags gr)))
    (remake-cexpr e nil nargs (letrec-vars e) (list nbody))))

Other expressions have their continuations processed and the expression remade.

⟨removing safe blocks and tagbodies 67⟩+≡ (63) ◁ 70 71 ▷

(defun drop-safe-jumps-cexpr (e fun uses tags gr)
(let ((nconts (mapcar #'(lambda (x) (drop-safe-jumps x fun uses tags gr))
                 (cexpr-conts e))))
(remake-cexpr e (cexpr-fun e) (cexpr-args e) (cexpr-vars e) nconts)))

Calls followed by a safe return-from expression are changed to tail calls. Other calls are rewritten using the default method.

⟨removing safe blocks and tagbodies 67⟩+≡ (63) ◁ 71 71 ▷

(defun drop-safe-jumps-call (e fun uses tags gr)
(if (safe-return-from-cont-p e fun uses tags gr)

⟨rewrite expression as a tail expression 70⟩

(drop-safe-jumps-cexpr e fun uses tags gr)))

4.3.4 Removing Unused Blocks and Tagbodies

If a block or tagbody is no longer used, it can be replaced by a call to its argument function. The argument to the call, which is ignored by the function, is nil; a later optimization pass can inline the function call.

The function drop-unused-tags dispatches on expression types.

⟨removing safe blocks and tagbodies 67⟩+≡ (63) ◁ 71

(defun drop-unused-tags (e tags)
(cond
((letrec-p e)
⟨drop-unused-tags for letrec expressions 71⟩)
((or (primop-eq e 'block) (primop-eq e 'tagbody))
⟨drop-unused-tags for block and tagbody expressions 71⟩)

(t ⟨drop-unused-tags for other expressions 72⟩)))

For block or tagbody expressions the continuation is processed and then the argument function’s tag entry is checked to see whether it is marked as used. If it is not, the expression is replaced by a call to the function. Otherwise, the expression is remade. At present, unused value information is not preserved in the block primop. If this were available, the val-ignored flag in the call could be set when appropriate.

⟨drop-unused-tags for block and tagbody expressions 71⟩≡  (71)
(let* ((args (primop-args e))
(vars (primop-vars e))
(form (primop-form e))
(nform (if form (drop-unused-tags form tags) nil))
(nconts (if nform (list nform) nil))
(fun (first args))
(entry (lookup-tags-table-fun fun tags)))
(if (tags-table-entry-used entry)
(remake-cexpr e (primop-fun e) args vars nconts)
(let ((ctx (primop-context e)))
(make-call fun (list (make-const nil)) vars nform nil nil ctx))))

letrec expressions have their arguments and body processed and are remade.

⟨drop-unused-tags for letrec expressions 71⟩≡ (71)

(let ((nargs (mapcar #'(lambda (x) (drop-unused-tags x tags))
              (letrec-args e)))
(nbody (drop-unused-tags (letrec-body e) tags)))

    (remake-cexpr e nil nargs (letrec-vars e) (list nbody)))

Other expressions have their continuations processed and are remade.

⟨drop-unused-tags for other expressions 72⟩≡ (71)

  (let ((nconts (mapcar #'(lambda (x) (drop-unused-tags x tags))
                        (cexpr-conts e))))
    (remake-cexpr e (cexpr-fun e) (cexpr-args e) (cexpr-vars e) nconts))

4.4 Removing Safe Cells

Cells can be removed if they are only used in their defining function or in functions called in tail position. When this is true, the current cell value can be passed to each use site. It is also safe for them to be used but not modified in local functions used in non-tail position. Removing cells involves a partial lambda lifting process.

4.4.1 Identifying Cells for Removal

Information on each cell is collected in a list structure containing the cell name, the function in which the cell was created, and a flag indicating whether any use of the cell makes it not safe for removal. The constructor function takes the cell variable and the defining function as arguments.

⟨removing safe cells 72⟩≡ (63) 72 ▷

  (defstruct (cell-table-entry (:type list)
                               (:constructor make-cell-table-entry (cell fun)))
    cell fun unsafe)

These entries are collected in a structure consisting of a list of all entries and a hash table mapping cells to entries.

⟨removing safe cells 72⟩+≡ (63) ◁ 72 72 ▷

  (defstruct (cell-table (:type list))
    entries (hash (make-hash-table)))
  (defun lookup-cell-table-entry (cell table)
    (gethash cell (cell-table-hash table)))

New entries are created and added to the table by add-cell-table-entry.

⟨removing safe cells 72⟩+≡ (63) ◁ 72 72 ▷

  (defun add-cell-table-entry (cell fun table)
    (let ((entry (make-cell-table-entry cell fun)))
      (setf (gethash cell (cell-table-hash table)) entry)
      (push entry (cell-table-entries table))))

The function compute-cell-table takes an expression, a use information table, and a call graph, creates a cell table, and fills the cell table by calling fill-cell-table.

⟨removing safe cells 72⟩+≡ (63) ◁ 72 73 ▷

  (defun compute-cell-table (e uses gr)
    (let ((table (make-cell-table)))
      (fill-cell-table e e uses gr table)
      table))
  (defun fill-cell-table (e fun uses gr table)
    (cond
     ((primop-p e)

⟨fill-cell-table processing for cell expressions 73⟩ ⟨fill-cell-table for primop continuation forms 73⟩)

     ((letrec-p e)
      ⟨fill-cell-table for letrec expressions 73⟩)

(t ⟨fill-cell-table for other expressions 73⟩)))

The second argument to fill-cell-table is the current function being processed.

Cell primop expressions require some preprocessing. For make-cell expressions, a cell entry for the new cell is added to the table. The current function fun is registered as the defining function for the cell. For set-cell-value expressions, the cell is marked as unsafe unless the current function can only be reached by tail calls from the cell’s defining function. For cell-value expressions, non-tail calls to local functions are allowed, but references that pass through functions needing closures prevent elimination of the cell.

⟨fill-cell-table processing for cell expressions 73⟩≡ (72)

  (case (primop-fun e)
        (make-cell (add-cell-table-entry (first (primop-vars e)) fun table))
        ((cell-value set-cell-value)
         (let* ((cell (first (primop-args e)))
                (entry (lookup-cell-table-entry cell table))
                (loc-ok (eq (primop-fun e) 'cell-value)))
           (unless (safe-use-p fun (cell-table-entry-fun entry) uses gr loc-ok)
                   (setf (cell-table-entry-unsafe entry) t)))))

For all primops, the continuation form needs to be processed if there is one.

⟨fill-cell-table for primop continuation forms 73⟩≡ (72)

  (let ((form (primop-form e)))
    (when form (fill-cell-table form fun uses gr table)))

letrecprimops first have each argument function processed with itself as the current function. Then the body of the expression is processed.

⟨fill-cell-table for letrec expressions 73⟩≡ (72)

  (dolist (a (letrec-args e)) (fill-cell-table a a uses gr table))
  (fill-cell-table (letrec-body e) fun uses gr table)

Other expressions are handled by processing their continuations.

⟨fill-cell-table for other expressions 73⟩≡ (72)

  (dolist (c (cexpr-conts e)) (fill-cell-table c fun uses gr table))

The function find-safe-cells is the main entry for finding cells. It takes an expression and a call graph, computes use and cell information tables, and then returns a list of the cell variables for all cells not marked as unsafe.

⟨removing safe cells 72⟩+≡ (63) ◁ 72 74 ▷

  (defun find-safe-cells (e gr)
    (let* ((uses (compute-non-tail-table e nil))
           (ctab (compute-cell-table e uses gr))
           (entries (cell-table-entries ctab))
           (safe-entries (remove-if #'cell-table-entry-unsafe entries)))
      (mapcar #'cell-table-entry-cell safe-entries)))

4.4.2 Finding Free Cells

Having identified the cells to remove, we now need to work out which functions need the current cell value passed to them. Since cell values may need to be passed through one function to another function that needs them, this is essentially a free variable determination. The algorithm first identifies for each function f the set V_{0}(f) of cells to be dropped that are used directly in f. It then iteratively computes

V_{i}(f) ← V_{i−1}(f) ∪ ( ⋃_{g∈E(f)} V_{i−1}(g))

where E(f) is the set of functions called by f. The iteration continues until V_{i}(f) = V_{i−1}(f) for all f. This is essentially the free variable determination algorithm described in [1, p. 111].

Data Structures

We use a list data structure to hold information for each function. The fields are the function definition and the free and bound cells. The constructor takes the function definition as its argument.

⟨removing safe cells 72⟩+≡ (63) ◁ 73 74 ▷

  (defstruct (free-cell-entry (:type list)
                              (:constructor (make-free-cell-entry (def))))
    def free bound)

These entries are collected in a free-cell-table structure. The fields are a list of the entries, a hash table for mapping definitions to entries, and a list of the eligible cells. The list of cells is required as the argument to the constructor.

⟨removing safe cells 72⟩+≡ (63) ◁ 74 74 ▷

  (defstruct (free-cell-table (:constructor make-free-cell-table (cells)))
    entries (hash (make-hash-table)) cells)
  (defun add-free-cell-entry (entry table)
    (let ((def (free-cell-entry-def entry)))
      (setf (gethash def (free-cell-table-hash table)) entry)
      (push entry (free-cell-table-entries table))))
  (defun lookup-free-cell-entry (def table)
    (gethash def (free-cell-table-hash table)))

Initializing the Free Cell Table

A free-cell-table is initialized by init-free-cell-table. This function takes as arguments the expression e, the current entry, an environment env mapping variables to function definitions, and the table to be initialized. This function just dispatches on the expression type.

⟨removing safe cells 72⟩+≡ (63) ◁ 74 75 ▷

  (defun init-free-cell-table (e entry env table)
    (cond
     ((primop-p e)

⟨init-free-cell-table processing for cell expressions 75⟩

      ⟨init-free-cell-table for primop continuation forms 75⟩)
     ((letrec-p e)
      ⟨init-free-cell-table for letrec expressions 75⟩)
     (t ⟨init-free-cell-table for other expressions 75⟩)))

Cell primop expressions need some preprocessing. For make-cell expressions, the cell, if it is eligible, is entered in the current entry’s bound list. For cell-value and set-cell-value expressions, the cell, if eligible, is entered on the current entry’s free list unless it is bound in the current entry or is already on the free list.

⟨init-free-cell-table processing for cell expressions 75⟩≡ (74)

  (case (primop-fun e)
        (make-cell
         (let ((cell (first (primop-vars e))))
           (when (member cell (free-cell-table-cells table))
                 (push cell (free-cell-entry-bound entry)))))
        ((cell-value set-cell-value)
         (let ((bound (free-cell-entry-bound entry))
               (cell (first (cexpr-args e))))
           (when (and (member cell (free-cell-table-cells table))
                      (not (member cell bound)))
                 (pushnew cell (free-cell-entry-free entry))))))

For all primop expressions, the continuation expression is processed if there is one.

⟨init-free-cell-table for primop continuation forms 75⟩≡ (74)

  (let ((form (primop-form e)))
    (when form (init-free-cell-table form entry env table)))

For letrec expressions, entries are created and added for the new functions, and the environment is augmented with name/definition pairs. The function arguments are processed with their entries and the new environment, and the body is processed with the original entry but the new environment. The entries must be created before any functions are processed since the functions can call each other.

⟨init-free-cell-table for letrec expressions 75⟩≡  (74)
  (let* ((vars (letrec-vars e))
         (args (letrec-args e))
         (nenv (append (mapcar #'cons vars args) env))
         (entries (mapcar #'make-free-cell-entry args)))
    (dolist (e entries) (add-free-cell-entry e table))
    (do ((args args (rest args))
         (entries entries (rest entries)))
        ((or (null args) (null entries)))
        (init-free-cell-table (first args) (first entries) nenv table))
    (init-free-cell-table (letrec-body e) entry nenv table))

For all other expressions, we just process the continuations.

⟨init-free-cell-table for other expressions 75⟩≡ (74)

  (dolist (c (cexpr-conts e)) (init-free-cell-table c entry env table))

Computing the Free Cells Table

The function compute-free-cell-table is the entry point to computing the free cell information for a top level expression. It takes a top level expression and computes a call graph, the cells to be dropped, and an initialized free cells table. It then repeatedly iterates through the functions and modifies free cell entries until there are no more changes.

⟨removing safe cells 72⟩+≡ (63) ◁ 74 76 ▷

(defun compute-free-cell-table (e)
(let* ((gr (compute-callgr e))
     (cells (find-safe-cells e gr))
     (table (make-free-cell-table cells))
     (entry (make-free-cell-entry e)))
(add-free-cell-entry entry table)
(init-free-cell-table e entry nil table)
(let ((funs (callgr-functions gr)))
  (loop
   (let ((changed nil))
     (dolist (fun funs)
       (let ((entry (lookup-free-cell-entry fun table)))

⟨update free tags for entry and set changed if needed 76⟩))

     (unless changed (return)))))
table))

For each entry, any cells free in a callee of entry’s function but not bound in the function are added to entry’s free list. If the free list is changed, the changed flag is set.

⟨update free tags for entry and set changed if needed 76⟩≡ (75)

(let ((free (free-cell-entry-free entry))
  (bound (free-cell-entry-bound entry)))
(dolist (c (callgr-callees (free-cell-entry-def entry) gr))
(dolist (v (free-cell-entry-free (lookup-free-cell-entry c table)))
  (unless (or (member v free) (member v bound))
          (push v free)
          (setf changed t))))
(setf (free-cell-entry-free entry) free))

4.4.3 Removing Cells

Safe cells are removed by drop-safe-cells. First, compute-free-cell-table is used to compute the cell information. If there are cells to be dropped, drop-cells handles the rewriting. Otherwise, the expression is returned unchanged. split-local-functions is used to separate functions used only locally from ones used as closures.

⟨removing safe cells 72⟩+≡ (63) ◁ 75 76 ▷

(defun drop-safe-cells (e)
(let* ((ne (split-local-functions e))
     (table (compute-free-cell-table ne)))
(if (free-cell-table-cells table)
    (drop-cells ne nil nil table)
  ne)))

drop-cells takes as arguments the expression, an environment, a function environment, and the table with the free variable information. It dispatches on the expression type.

⟨removing safe cells 72⟩+≡ (63) ◁ 76 77 ▷

(defun drop-cells (e env fenv table)
(cond
((letrec-p e) (drop-cells-letrec e env fenv table))
((call-p e) (drop-cells-call e env fenv table))
((func-p e) (drop-cells-func e env fenv table))
((primop-p e)
(case (primop-fun e)

 (make-cell (drop-cells-make-cell e env fenv table))
 (cell-value (drop-cells-cell-value e env fenv table))
 (set-cell-value (drop-cells-set-cell-value e env fenv table))
 (t (drop-cells-cexpr e env fenv table))))
(t (drop-cells-cexpr e env fenv table))))

The default method for dropping cells rewrites the continuations, does substitution from the variable environment in the arguments, and returns the remade expression.

⟨removing safe cells 72⟩+≡ (63) ◁ 76 77 ▷

(defun drop-cells-cexpr (e env fenv table)
(let* ((conts (cexpr-conts e))
(nconts (mapcar #'(lambda (x) (drop-cells x env fenv table)) conts))
(nargs (sublis env (cexpr-args e))))
(remake-cexpr e (cexpr-fun e) nargs (cexpr-vars e) nconts)))

letrec expressions are handled by creating a new function environment, processing the functions and the body with the new environment, and returning the remade expression.

⟨removing safe cells 72⟩+≡ (63) ◁ 77 77 ▷

(defun drop-cells-letrec (e env fenv table)
(let* ((vars (letrec-vars e))
(args (letrec-args e))
(nfenv (append (mapcar #'cons vars args) fenv))
(nargs (mapcar #'(lambda (x) (drop-cells x env nfenv table)) args))
(nbody (drop-cells (letrec-body e) env nfenv table)))
(remake-cexpr e nil nargs vars (list nbody))))

Calls have cell values needed by the function prepended to the argument list. Substitutions from the environment are made in the new argument list and the new expression is returned.

⟨removing safe cells 72⟩+≡ (63) ◁ 77 77 ▷

(defun drop-cells-call (e env fenv table)
(let* ((fun (call-fun e))
(args (call-args e))
(vars (call-vars e))
(form (call-form e))
(nconts (if form (list (drop-cells form env fenv table)) nil))
(entry (lookup-free-cell-entry (cdr (assoc fun fenv)) table)))
(if entry
(let* ((free (free-cell-entry-free entry))
      (nargs (append (sublis env free) (sublis env args))))
 (remake-cexpr e fun nargs vars nconts))
(remake-cexpr e (sublis env fun) (sublis env args) vars nconts))))

Functions have their parameter list expanded by prepending any needed cell values. The body is processed with a new environment that maps the cells to the new parameter variables.

⟨removing safe cells 72⟩+≡ (63) ◁ 77 78 ▷

(defun drop-cells-func (e env fenv table)
(let* ((entry (lookup-free-cell-entry e table))
(free (free-cell-entry-free entry))
(fvars (mapcar #'copy-var free))
(nenv (append (mapcar #'cons free fvars) env))
(nform (drop-cells (func-body e) nenv fenv table))
(nvars (append fvars (func-vars e)))
(ne (remake-cexpr e nil nil nvars (list nform))))
(when fvars (incf (func-nreq ne) (length fvars)))
ne))

make-cell expressions for cells to be dropped are replaced by their continuation forms processed with a new environment that associates the cell with its value.

⟨removing safe cells 72⟩+≡ (63) ◁ 77 78 ▷

(defun drop-cells-make-cell (e env fenv table)
  (let ((cell (first (primop-vars e))))
    (if (member cell (free-cell-table-cells table))
        (let* ((val (sublis env (first (primop-args e))))
               (nenv (cons (cons cell val) env)))
          (drop-cells (primop-form e) nenv fenv table))
      (drop-cells-cexpr e env fenv table))))

cell-value references for cells to be dropped are also replaced by their continuation forms processed with an environment that maps the result variable to the current cell value variable.

⟨removing safe cells 72⟩+≡ (63) ◁ 78 78 ▷

(defun drop-cells-cell-value (e env fenv table)
  (let ((cell (first (primop-args e))))
    (if (member cell (free-cell-table-cells table))
        (let ((var (first (primop-vars e)))
              (val (sublis env (cdr (assoc cell env))))
              (form (primop-form e)))
          (cond
           (var (let ((nenv (cons (cons var (sublis env val)) env)))
                  (drop-cells form nenv fenv table)))
           (form (drop-cells form env fenv table))
           (t (let ((ctx (primop-context e)))
                (make-primop 'values (list val) nil nil nil ctx)))))
      (drop-cells-cexpr e env fenv table))))

set-cell-value expressions are handled similarly. The environment for processing their continuations maps the cell to the new value.

⟨removing safe cells 72⟩+≡ (63) ◁ 78

(defun drop-cells-set-cell-value (e env fenv table)
  (let* ((args (primop-args e))
         (cell (first args)))
    (if (member cell (free-cell-table-cells table))
        (let* ((val (sublis env (second args)))
               (nenv (cons (cons cell val) env)))
          (drop-cells (primop-form e) nenv fenv table))
      (drop-cells-cexpr e env fenv table))))

Code Simplification and Optimization

This chapter presents a range of code transformations designed to simplify and optimize the code. ⟨simplify.lsp 79⟩≡

  (in-package "NEWCMP")

⟨drop unused functions 79⟩

⟨substitute functions called only once 80⟩ ⟨eta reduction 85⟩ ⟨alpha copying 87⟩ ⟨code simplification 87⟩ ⟨inline expansion 107⟩ ⟨pushing continuations 111⟩

5.1 Dropping Unused Functions

The function find-dead-functions uses a call graph to identify all functions that are reachable from the top level function. The call graph considers all uses as calls (the second argument to compute-callgr is t). The determination proceeds iteratively, starting with a live set consisting of the top level function and a follow set equal to the initial live set. The loop pops one element off the follow set and examines each of its callees. Unless a callee is already in the live set, it is pushed on the live set and the follow set, unless it is there already. Once the follow set becomes empty, the set of non-live functions is returned. These functions can be removed from the code.

⟨drop unused functions 79⟩≡ (79) 80 ▷

  (defun find-dead-functions (e)
    (let* ((gr (compute-callgr e t))
           (funs (callgr-functions gr))
           (live (list e))
           (follow live))
      (loop
       (let ((f (pop follow)))
         (dolist (c (callgr-callees f gr))
           (unless (member c live)
                   (push c live)
                   (pushnew c follow)))
         (unless follow (return (set-difference funs live)))))))

CHAPTER 5. CODE SIMPLIFICATION AND OPTIMIZATION 80

Unreachable functions are removed by drop-dead-functions. This function computes the dead functions list and, if there are functions to remove, rewrites letrec expressions to remove any functions in the list. If a letrec no longer binds any functions after the removal, it is replaced by its body.

⟨drop unused functions 79⟩+≡ (79) ◁ 79

(defun drop-dead-functions (e)
  (let ((funs (find-dead-functions e)))
    (labels ((drop-funs (e)

⟨drop funs from e 80⟩))

      (if funs (drop-funs e) e))))

⟨drop funs from e 80⟩≡ (80)

(let* ((args (cexpr-args e))
       (vars (cexpr-vars e))
       (conts (cexpr-conts e))
       (nconts (mapcar #'drop-funs conts)))
  (if (letrec-p e)
      (let ((nargs nil)
            (nvars nil))
        (mapc #'(lambda (a v)
                  (unless (member a funs)
                          (push (drop-funs a) nargs)
                          (push v nvars)))
              args vars)
        (setf nargs (nreverse nargs))
        (setf nvars (nreverse nvars))
        (if (null nargs)
            (first nconts)
          (remake-cexpr e nil nargs nvars nconts)))
    (remake-cexpr e (cexpr-fun e) args vars nconts)))

5.2 Substituting Functions Called Only Once

The functions in this section inline calls to functions called only once and not used as an argument. This is what Appel [1] calls β-contraction.

5.2.1 Counting Function Uses

To start off, we need to collect information on the frequency and nature of function use. The information for each function is placed in a list structure. The list contains the function definition, the number of times the function is called, and the number of times the function is used as an argument.

⟨substitute functions called only once 80⟩≡ (79) 80 ▷

(defstruct (usecounts-entry (:type list)
                            (:constructor make-usecounts-entry (def)))
  def (calls 0) (args 0))

These lists are collected in a hash table. The function add-usecounts-entry adds an entry to the table.

⟨substitute functions called only once 80⟩+≡ (79) ◁ 80 81 ▷

(defun add-usecounts-entry (name def table)
  (setf (gethash name table) (make-usecounts-entry def)))

function-counts creates a use counts table, fills it in, and returns it.

⟨substitute functions called only once 80⟩+≡ (79) ◁ 80 81 ▷

(defun function-counts (e)
(let ((table (make-hash-table)))
  (fill-usecounts-table e table)
  table))

Filling the table is done by fill-usecounts-table, which dispatches on expression type.

⟨substitute functions called only once 80⟩+≡ (79) ◁ 81 81 ▷

(defun fill-usecounts-table (e table)
(cond
 ((letrec-p e) (fill-usecounts-table-letrec e table))
 ((call-p e) (fill-usecounts-table-call e table))
 (t (fill-usecounts-table-cexpr e table))))

For letrec expressions, entries are added for each function, and then the functions and the body are processed.

⟨substitute functions called only once 80⟩+≡ (79) ◁ 81 81 ▷

(defun fill-usecounts-table-letrec (e table)
(let ((args (letrec-args e))
      (vars (letrec-vars e)))
  (do ((args args (rest args))
       (vars vars (rest vars)))
      ((or (null args) (null vars)))
      (add-usecounts-entry (first vars) (first args) table))
  (dolist (a args) (fill-usecounts-table a table))
  (fill-usecounts-table (letrec-body e) table)))

For call expressions, if the function has an entry then the entry’s call count is incremented, and then the expression is processed as a generic expression.

⟨substitute functions called only once 80⟩+≡ (79) ◁ 81 81 ▷

(defun fill-usecounts-table-call (e table)
(let ((entry (gethash (call-fun e) table)))
  (when entry (incf (usecounts-entry-calls entry))))
(fill-usecounts-table-cexpr e table))

Generic expressions are processed by incrementing argument use counts for any local function arguments and processing their continuations.

⟨substitute functions called only once 80⟩+≡ (79) ◁ 81 81 ▷

(defun fill-usecounts-table-cexpr (e table)
(dolist (v (cexpr-args e))
  (let ((entry (gethash v table)))
    (when entry (incf (usecounts-entry-args entry)))))
(dolist (x (cexpr-conts e)) (fill-usecounts-table x table)))

The function find-once-called-functions computes a use counts table and then finds all functions that are called once and not used as arguments. The result is returned as an association list of names and definitions.

⟨substitute functions called only once 80⟩+≡ (79) ◁ 81 82 ▷

(defun find-once-called-functions (e)
(let ((table (function-counts e))
      (env nil))
  (maphash #'(lambda (name entry)
               (when (and (= (usecounts-entry-calls entry) 1)

             (= (usecounts-entry-args entry) 0))
        (push (cons name (usecounts-entry-def entry)) env)))
table)
env))

5.2.2 Substituting the Functions

The main entry point is substitute-once-called-functions. This function first splits local functions to insure that all local functions have only required arguments and are called with direct arguments, not with arguments in value registers. Then substitution is carried out in a loop that continues until there are no changes. Each loop iteration first drops dead functions and then finds the once called functions. Dropping dead functions first is essential since it insures that the graph of once called functions is acyclic. Each substitution step is carried out by substitute-once-called, and the result is passed to substitute-values to remove any bind expressions that might have been introduced.

⟨substitute functions called only once 80⟩+≡ (79) ◁ 81 82 ▷

(defun substitute-once-called-functions (e)
(let ((e (split-local-functions e)))
(loop
(let* ((ne (drop-dead-functions e))
(env (find-once-called-functions ne)))
(when env (setf ne (substitute-values (substitute-once-called ne env))))
(if (eq e ne)
(return e)
(setf e ne))))))

substitute-once-called dispatches on expression type.

⟨substitute functions called only once 80⟩+≡ (79) ◁ 82 82 ▷

(defun substitute-once-called (e env)
(cond
((call-p e) (substitute-once-called-call e env))
((letrec-p e) (substitute-once-called-letrec e env))
(t (substitute-once-called-cexpr e env))))

Call expressions for functions to be substituted are handled by substituting in the definition and the continuation and then inlining the call with substitute-call. Other calls are handled as generic expressions.

⟨substitute functions called only once 80⟩+≡ (79) ◁ 82 83 ▷

(defun substitute-once-called-call (e env)
(let ((def (cdr (assoc (call-fun e) env))))
(if def
(let* ((ndef (substitute-once-called def env))
(vars (call-vars e))
(vi (call-val-ignored e))
(ctx (call-context e))
(form (call-form e))
(kv (if form (if vars (first vars) (if vi nil t)) nil))
(kf (if form (substitute-once-called form env) nil)))
(substitute-call ndef (call-args e) kv kf ctx))
(substitute-once-called-cexpr e env))))

For letrec expressions, functions to be replaced are dropped. Substitution is done in the remaining functions and in the body. If there are any functions remaining, then the expression is remade. Otherwise, the new body is returned.

⟨substitute functions called only once 80⟩+≡ (79) ◁ 82 83 ▷

  (defun substitute-once-called-letrec (e env)
    (let ((nargs nil)
          (nvars nil))
      (mapc #'(lambda (a v)
                (unless (assoc v env)
                        (push (substitute-once-called a env) nargs)
                        (push v nvars)))
            (letrec-args e) (letrec-vars e))
      (let ((nbody (substitute-once-called (letrec-body e) env)))
        (if nvars
            (remake-cexpr e nil (nreverse nargs) (nreverse nvars) (list nbody))
          nbody))))

Other expressions are handled by substituting in the continuations and remaking the expression.

⟨substitute functions called only once 80⟩+≡ (79) ◁ 83 83 ▷

  (defun substitute-once-called-cexpr (e env)
    (let ((nconts (mapcar #'(lambda (x) (substitute-once-called x env))
                          (cexpr-conts e))))
      (remake-cexpr e (cexpr-fun e) (cexpr-args e) (cexpr-vars e) nconts)))

5.2.3 Substituting a Call

The details of substituting a call are handled by substitute-call. A bind expression is constructed to bind the function parameters to the arguments. If kf is nil, corresponding to a tail call, then the body of the bind is the function body. Otherwise, a continuation function is constructed and the function body is rewritten to call the continuation in its tail expressions.

⟨substitute functions called only once 80⟩+≡ (79) ◁ 83 83 ▷

  (defun substitute-call (def args kv kf ctx)
    (let* ((fbody (func-body def))
           (bbody (if kf
                      (let* ((fvars (if (var-p kv) (list kv) nil))
                             (kfun (make-func nil fvars kf 'lambda ctx))
                             (k (make-tmp-var))
                             (body (substitute-continuation fbody kv k nil)))
                        (make-letrec (list k) (list kfun) body ctx))
                    fbody)))
      (make-bind (func-vars def) args bbody ctx)))

Adding continuation calls to tail expressions is handled by substitute-continuation. this function decends until it reaches the tail expressions. These are can be either primop expressions or calls, and are rewritten accordingly. A set of funs for which the expression is left unchanged is provided as the final argument. This is used in Section 5.9.

⟨substitute functions called only once 80⟩+≡ (79) ◁ 83 84 ▷

  (defun substitute-continuation (e kv k funs)
    (let ((conts (cexpr-conts e)))
      (if conts
          (let ((nconts (mapcar #'(lambda (x)
                                    (substitute-continuation x kv k funs))

                    conts)))
(remake-cexpr e (cexpr-fun e) (cexpr-args e) (cexpr-vars e) nconts))
(cond
((primop-p e) (substitute-continuation-primop e kv k))
((call-p e) (if (member (call-fun e) funs)
             e
           (substitute-continuation-call e kv k)))
(t (error "expression of type ~s should not be in tail position"
       (type-of e)))))))

Non-local exit primop expressions are left unchanged, and values and values-list tail expressions are handles specially. Other tail primop expressions are remade with a continuation that calls the continuation function. If the continuation function expects the values in the value registers, a values primop is wrapped around the call.

⟨substitute functions called only once 80⟩+≡ (79) ◁ 83 85 ▷

(defun substitute-continuation-primop (e kv k)
(let ((ctx (primop-context e))
(fun (primop-fun e))
(args (primop-args e)))
(case fun
((go return-from throw) e)
(values
 ⟨substitute-continuation-primop for values 84⟩)
(values-list
 ⟨substitute-continuation-primop for values-list 84⟩)
(t (let* ((vl (if (var-p kv) (list (copy-var kv)) nil))
          (evl (if (eq kv t) (list (make-tmp-var)) vl))
          (kcall (make-call k vl nil nil nil nil ctx))
          (form (if (eq kv t)
                    (make-primop 'values evl nil kcall nil ctx)
                  kcall)))
     (remake-cexpr e fun args evl (list form)))))))

For values expressions, if the continuation expects a single value, i.e. if kv is a variable, then the continuation function is called with the first argument to values or with the constant nil if there are no arguments. If kv is nil then the values are ignored and the continuation function is called with no arguments. Otherwise, the continuation function expects the values in the value registers. The expression is remade with a continuation form that calls the continuation function with no arguments.

⟨substitute-continuation-primop for values 84⟩≡  (84)
(cond
((var-p kv)
(let* ((args (primop-args e))
(nargs (list (if args (first args) (make-const nil)))))
(make-call k nargs nil nil nil nil ctx)))
((null kv) (make-call k nil nil nil nil nil ctx))
(t (remake-cexpr e fun args nil
        (list (make-call k nil nil nil nil nil ctx)))))

values-list expressions with a single value continuation are turned into car primop expressions. For the other two continuation forms they are treated like values expressions.

⟨substitute-continuation-primop for values-list 84⟩≡  (84)
(cond

   ((var-p kv)
    (let ((args (primop-args e)))
      (if (null (rest args))
          (let* ((nvars (list (copy-var kv)))
                 (nform (make-call k nvars nil nil nil nil ctx)))
            (make-primop 'car args nvars nform nil ctx))
        (let ((narg (if args (first args) (make-const nil))))
          (make-call k (list narg) nil nil nil nil ctx)))))
   ((null kv) (make-call k nil nil nil nil nil ctx))
   (t (remake-cexpr e fun args nil
                    (list (make-call k nil nil nil nil nil ctx)))))

Tail call expressions are remade with a call to the continuation function as their continuation form.

⟨substitute functions called only once 80⟩+≡ (79) ◁ 84

  (defun substitute-continuation-call (e kv k)
    (let ((fun (call-fun e))
          (args (call-args e))
          (vl (if (var-p kv) (list (copy-var kv)) nil))
          (vi (null kv))
          (ctx (call-context e)))
      (make-call fun args vl (make-call k vl nil nil nil nil ctx) vi nil ctx)))

5.3 Eta Substitution

This code is no longer used—it has been replaced by the inline expansion code of Section 5.7. This code might become useful again once function arguments can be handled.

This transformation corresponds to the η-reduction transformation of lambda calculus,

λx.M(x) → M

if x is not free in M. In the intermediate form the function in a call must be a variable, a constant, or a symbol, so the requirement that x not be free in M amounts to requiring that the function must not be one of the arguments.

There are some restrictions on this transformation that do not apply in the general lambda calculus. Since a definition can impose different optional and rest argument structures, the substitution is only valid for function arguments if the optional and rest argument types are known and match. This means argument functions can only be replaced if they are local. Also, the call must not be a multiple value call.

The code here does not allow argument function replacement at all. In fact, this code should just be subsumed into more general β-expansion code and should be replaced by code that can handle argument substitution for local functions.

The main entry function is eta-reduce. It splits local functions in order to simplify calls, does the substitution by calling eta-subst, and then removes any unused functions. Removal of unused functions is done separately since argument uses of functions are not reduced.

⟨eta reduction 85⟩≡ (79) 86 ▷

  (defun eta-reduce (e)
    (drop-dead-functions (eta-subst (split-local-functions e) nil)))

eta-subst takes an expression and a substitution environment as its arguments and dispatches on the expression type.

⟨eta reduction 85⟩+≡ (79) ◁ 85 86 ▷

(defun eta-subst (e env)
  (cond
   ((letrec-p e) (eta-subst-letrec e env))
   ((call-p e) (eta-subst-call e env))
   (t (eta-subst-cexpr e env))))

For letrec expressions, the environment is augmented by any eligible functions, and the new environment is used to process the functions and the body.

⟨eta reduction 85⟩+≡ (79) ◁ 86 86 ▷

(defun eta-subst-letrec (e env)
  (let ((vars (letrec-vars e))
        (args (letrec-args e)))
    (mapc #'(lambda (v def)

(let ((f ⟨find eta substitution function 86⟩))

                (when f (push (cons v f) env))))
          vars args)
    (let ((nargs (mapcar #'(lambda (x) (eta-subst x env)) args))
          (nbody (eta-subst (letrec-body e) env)))
      (remake-cexpr e nil nargs vars (list nbody)))))

The function to substitute is computed by checking whether the definition satisfies the eligibility criteria. If it does, the call function is returned. Otherwise, nil is returned. There is no check for recursive functions—they don’t cause a problem since the remake in handling call expressions recognizes that the expression is unchanged.

⟨find eta substitution function 86⟩≡ (86)

(let ((body (func-body def)))
  (if (and (call-p body)
           (null (call-form body))
           (not (member (call-fun body) (func-vars def))))
      (if (call-is-mvcall body)
          nil
        (let ((vars (func-vars def))
              (args (call-args body)))
          (if (and (= (length args) (length vars)) (every #'eq args vars))
              (call-fun body)
            nil)))
    nil))

Calls are handled by substituting the function from the environment, substituting in the continuation form, and remaking the expression.

⟨eta reduction 85⟩+≡ (79) ◁ 86 86 ▷

(defun eta-subst-call (e env)
  (let* ((nfun (sublis env (call-fun e)))
         (form (call-form e))
         (nconts (if form (list (eta-subst form env)) nil)))
    (remake-cexpr e nfun (call-args e) (call-vars e) nconts)))

Other expressions are handled by substituting in the continuations and remaking the expression.

⟨eta reduction 85⟩+≡ (79) ◁ 86

(defun eta-subst-cexpr (e env)
  (let ((nconts (mapcar #'(lambda (x) (eta-subst x env)) (cexpr-conts e))))

      (remake-cexpr e (cexpr-fun e) (cexpr-args e) (cexpr-vars e) nconts)))

5.4 Copying with Alpha Conversion

This section presents a utility function alpha-copy for copying an expression tree. The variables bound in the tree are renamed to insure uniqueness. If the optional argument is true, then the the names of the new variables will be unique as well.

The function alpha-copy creates a function for making new variables according to the uniqueness argument and calls alpha-cvt.

⟨alpha copying 87⟩≡ (79) 87 ▷

  (defun alpha-copy (e &optional unique-name)
    (let ((mkvar (if unique-name
                     (let ((count 0))
                       #'(lambda (v)
                           (let ((cv (copy-var v))
                                 (vn (intern (format nil "V-~d" count))))
                             (setf (var-name cv) vn)
                             (incf count)
                             cv)))
                   #'copy-var)))
      (alpha-cvt e nil mkvar)))

alpha-cvt just uses sublis to carry out its substitutions and remakes the expression. Continuations and letrec arguments are handled recursively.

⟨alpha copying 87⟩+≡ (79) ◁ 87

  (defun alpha-cvt (e env mkvar)
    (flet ((nvar (x) (if (var-p x) (funcall mkvar x) x)))
      (let* ((nfun (sublis env (cexpr-fun e)))
             (vars (cexpr-vars e))
             (nvars (mapcar #'nvar vars))
             (nenv (append (mapcar #'cons vars nvars) env))
             (args (cexpr-args e)))
        (flet ((alpha (x) (alpha-cvt x nenv mkvar)))
          (let ((nargs (if (letrec-p e) (mapcar #'alpha args) (sublis env args)))
                (nconts (mapcar #'alpha (cexpr-conts e))))
            (remake-cexpr e nfun nargs nvars nconts))))))

5.5 Simplifier

This section describes a simplification driver that handles operations such as replacing calls by ptimops, constant folding, and dead variable elimination. To allow as much to be done in one pass as possible, variable use counts are maintained. This imposes a strong obligation on the simplification rules: They must accurately maintain these use counts, or at least insure that the maintained count is at least as large as the actual count.

5.5.1 Variable Use Information

Variable use information is recorded in a varinfo list structure. The fields are the the variable’s defining expression and its use count.

⟨code simplification 87⟩≡ (79) 88 ▷

(defstruct (varinfo (:type list) (:constructor make-varinfo (def)))
  def (count 0))

The varinfo records are collected in a hash table

⟨code simplification 87⟩+≡ (79) ◁ 87 88 ▷

(defun add-varinfo (var def table)
  (let ((entry (make-varinfo def)))
    (setf (gethash var table) entry)))
(declaim (inline lookup-varinfo))
(defun lookup-varinfo (var table) (gethash var table))

For debugging, the function show-varinfo-table prints a summary of the table.

⟨code simplification 87⟩+≡ (79) ◁ 88 88 ▷

(defun show-varinfo-table (table)
  (maphash #'(lambda (x y)
               (format t "Var: ~s, count=~d~%" x (varinfo-count y)))
           table))

Variable information is collected by making and filling in a table.

⟨code simplification 87⟩+≡ (79) ◁ 88 88 ▷

(defun compute-varinfo-table (e)
  (let ((table (make-hash-table)))
    (fill-varinfo-table e table)
    table))

The function fill-varinfo-table fills in the table by incrementing use counts for the function, adding variable information entries for all bound variables, and processing the arguments and the continuations. For letrec expressions the arguments are processed recursively; for other expressions variable arguments have their use counts incremented.

⟨code simplification 87⟩+≡ (79) ◁ 88 88 ▷

(defun fill-varinfo-table (e table)
  (flet ((incvc (x)
           (when (var-p x)
                 (incf (varinfo-count (lookup-varinfo x table))))))
    (when (call-p e) (incvc (call-fun e)))
    (dolist (v (cexpr-vars e)) (add-varinfo v e table))
    (if (letrec-p e)
        (dolist (a (cexpr-args e)) (fill-varinfo-table a table))
      (dolist (a (cexpr-args e)) (incvc a)))
    (dolist (c (cexpr-conts e)) (fill-varinfo-table c table))))

5.5.2 Simplification Driver

Main Functions

The main entry point is simplify. This function creates a variable use table, applies the simplification process, and then substitutes variables to eliminate bind expressions.

⟨code simplification 87⟩+≡ (79) ◁ 88 89 ▷

(defun simplify (e)
  (substitute-values (simplify-top-down e nil (compute-varinfo-table e))))

The simplification process proceeds by applying simplify-one-down to each expression in a top down pass. On the way back up the expression is remade and processed by simplify-one-up.

⟨code simplification 87⟩+≡ (79) ◁ 88 89 ▷

  (defun simplify-top-down (e env table)
    (multiple-value-bind (ne nenv)
                         (simplify-one-down e env table)
      (flet ((simp (e) (simplify-top-down e nenv table)))
        (let* ((fun (cexpr-fun ne))
               (nargs (let ((args (cexpr-args ne)))
                        (if (letrec-p ne) (mapcar #'simp args) args)))
               (vars (cexpr-vars ne))
               (nconts (mapcar #'simp (cexpr-conts ne)))
               (nne (remake-cexpr ne fun nargs vars nconts)))
          (dolist (v vars) (setf (varinfo-def (lookup-varinfo v table)) nne))
          (simplify-one-up nne table)))))

The two functions simplify-one-down and simplify-one-up both use a loop to apply the simplification rules to their argument expression. The loops continue until there are no more changes. The difference between the two is that simplify-one-down takes an environment argument for substituting variables. When simplification produces a bind expression, the bindings are added to the environment and processing continues with the bind body. The function returns the environment as a second value for use in processing continuation expressions in the top-down pass.

⟨code simplification 87⟩+≡ (79) ◁ 89 90 ▷

  (defun simplify-one-down (e env table)
    (loop

⟨substitute variables in e from env 90⟩

(let ((ne ⟨apply simplification rules to e 89⟩))

       (cond
        ((eq e ne) (return (values e env)))
        ((bind-p ne)
         (do ((vars (bind-vars ne) (rest vars))
              (args (sublis env (bind-args ne)) (rest args)))
             ((or (null vars) (null args)))
             (push (cons (first vars) (first args)) env))
         (setf e (bind-body ne)))
        (t (setf e ne))))))
  (defun simplify-one-up (e table)
    (loop

(let ((ne ⟨apply simplification rules to e 89⟩))

       (if (eq e ne) (return e) (setf e ne)))))

Simplification rules are applied by dispatching on the expression type. The handlers are presented in the following subsections.

⟨apply simplification rules to e 89⟩≡ (89)

  (cond
   ((call-p e) (simplify-call e table))
   ((primop-p e) (simplify-primop e table))
   ((testop-p e) (simplify-testop e table))
   (t e))

Variable substitution in simplify-one-down is done by substituting in the function and arguments slots and remaking the expression. If the expression has changed, the defining expression for the bound variables is adjusted in the variable information. Only the expression itself is processed. Continuations and functions in letrec expressions are handled by the recursion in

simplify-top-down.

⟨substitute variables in e from env 90⟩≡ (89)

  (let* ((args (cexpr-args e))
         (nargs (subvars args env table))
         (fun (cexpr-fun e))
         (nfun (subvars fun env table)))
    (unless (and (eq fun nfun)
                 (or (eq args nargs) (every #'eq args nargs)))
            (let* ((vars (cexpr-vars e))
                   (conts (cexpr-conts e))
                   (ne (remake-cexpr e nfun nargs vars conts)))
              (dolist (v vars)
                      (setf (varinfo-def (lookup-varinfo v table)) ne))
              (setf e ne))))

The function subvars does the variable replacement and increments the variable use counts. The variables being replaced will no longer be visible and so do not have their counts adjusted. Like sublis, subvars can be applied to a variable or a list (actually a tree) of variables.

⟨code simplification 87⟩+≡ (79) ◁ 89 90 ▷

  (defun subvars (var env table)
    (if (consp var)
        (mapcar #'(lambda (x) (subvars x env table)) var)
      (let ((val (cdr (assoc var env))))
        (cond
         (val (when (var-p val)
                    (incf (varinfo-count (lookup-varinfo var table))))
              val)
         (t var)))))

Call Simplifiers

Call simplification uses two kinds of rules. Generic rules apply to local calls and calls to non-symbol constants. Specific rules apply to global calls to symbols. Rules are represented by functions that take an expression and a variable use table as arguments and return a new expression, or the same expression if they do not apply.

Generic expressions are stored in the variable *generic-call-simplifiers*. A macro is provided for defining new generic simplifiers.

⟨code simplification 87⟩+≡ (79) ◁ 90 90 ▷

  (defparameter *generic-call-simplifiers* nil)
  (defmacro define-generic-call-simplifier (args &rest body)
    `(progn (push #'(lambda ,args ,@body) *generic-call-simplifiers*)
            nil))

Specific simplifiers are stored in a hash table. The entries are lists of rules.

⟨code simplification 87⟩+≡ (79) ◁ 90 91 ▷

  (defparameter *call-simplifiers* (make-hash-table))
  (defun get-call-simplifiers (fun) (gethash fun *call-simplifiers*))
  (defmacro define-call-simplifier (name args &rest body)

    `(progn (push #'(lambda ,args ,@body) (gethash ',name *call-simplifiers*))
            ',name))

The function simplify-call applies the rules. If the call function is a symbol, then specific rules are used; otherwise, the generic rules are used. All available rules are tried until the expression is changed or the rules run out. If there is a change, the new expression is returned. Otherwise, the value is the original expression.

⟨code simplification 87⟩+≡ (79) ◁ 90 91 ▷

  (defun simplify-call (e table)
    (let ((fun (call-fun e)))
      (if (symbolp fun)
          (dolist (s (get-call-simplifiers fun) e)
            (let ((ne (funcall s e table)))
              (unless (eq ne e) (return ne))))
        (dolist (s *generic-call-simplifiers* e)
          (let ((ne (funcall s e table)))
            (unless (eq ne e) (return ne)))))))

Primop Simplifiers

Simplifiers for primop expressions are applied by simplify-primop. This function contains one preliminary transformation that is handled directly: If the continuation is a values form in tail position that simply stores the variables bound by the primop in the value registers, then the primop expression is rewritten as a tail expression. If this preliminary rule does not apply, then the rules registered for the primop are applied until one is found that changes the expression or the rules are exhausted.

⟨code simplification 87⟩+≡ (79) ◁ 91 91 ▷

  (defun simplify-primop (e table)
    (let* ((fun (primop-fun e))
           (args (primop-args e))
           (vars (primop-vars e))
           (form (primop-form e)))

(if ⟨form is values in tail position with matching arguments 91⟩

          (remake-cexpr e fun args nil nil)
        (dolist (s (get-primop-simplifiers fun) e)
          (let ((ne (funcall s e table)))
            (unless (eq e ne) (return ne)))))))

The test for whether the preliminary rule applies rules out values and values-list primop expressions. A sequence of two values expressions in sequence is handled by a specific transformation defined in Section 5.5.6.

⟨form is values in tail position with matching arguments 91⟩≡ (91)

  (and (not (member fun '(values values-list)))
       (primop-p form) (eq (primop-fun form) 'values)
       (null (primop-form form))
       (let ((pargs (primop-args form)))
         (and (= (length vars) (length pargs))
              (every #'eq pargs vars))))

The rules for primops are stored in a hash table. The entries are lists of rules. A macro is provided for defining rules.

⟨code simplification 87⟩+≡ (79) ◁ 91 92 ▷

(defparameter *primop-simplifiers* (make-hash-table))
(defun get-primop-simplifiers (fun) (gethash fun *primop-simplifiers*))
(defmacro define-primop-simplifier (name args &rest body)
  `(progn (push #'(lambda ,args ,@body) (gethash ',name *primop-simplifiers*))
          ',name))

Testop Simplifiers

Simplifiers for testop expressions are applied until one changes the expression or the rules run out.

⟨code simplification 87⟩+≡ (79) ◁ 91 92 ▷

(defun simplify-testop (e table)
  (dolist (s (get-testop-simplifiers (testop-fun e)) e)
    (let ((ne (funcall s e table)))
      (unless (eq e ne) (return ne)))))

The rules are stored in lists in a hash table, and new rules are defined with a macro.

⟨code simplification 87⟩+≡ (79) ◁ 92 92 ▷

(defparameter *testop-simplifiers* (make-hash-table))
(defun get-testop-simplifiers (fun) (gethash fun *testop-simplifiers*))
(defmacro define-testop-simplifier (name args &rest body)
  `(progn (push #'(lambda ,args ,@body) (gethash ',name *testop-simplifiers*))
          ',name))

5.5.3 Some Call Simplifiers

Calls to funcall can be rewritten as calls to the function argument. The variable information entries for the variables defined by the expression are adjusted to reflect the new expression.

⟨code simplification 87⟩+≡ (79) ◁ 92 92 ▷

(define-call-simplifier funcall (e table)
  (let* ((args (call-args e))
         (vars (call-vars e))
         (conts (call-conts e))
         (ne (remake-cexpr e (first args) (rest args) vars conts)))
    (set-varinfo-defs vars table ne)
    ne))
(defun set-varinfo-defs (vars table e)
  (dolist (v vars) (setf (varinfo-def (lookup-varinfo v table)) e)))

Calls to variables bound in symbol-value primop expressions can be rewritten as calls to the symbol. The reference count for the function variable is decremented, and the definition information for variables bound in the expression is adjusted.

⟨code simplification 87⟩+≡ (79) ◁ 92 93 ▷

(define-generic-call-simplifier (e table)
  (let ((entry (lookup-varinfo (call-fun e) table)))
    (if entry
        (let ((def (varinfo-def entry)))

(if (and (primop-p def) (eq (primop-fun def) 'symbol-function))
   (let* ((vars (call-vars e))
          (args (call-args e))
          (conts (call-conts e))
          (ne (remake-cexpr e (primop-data def) args vars conts)))
     (set-varinfo-defs vars table ne)
     (decf (varinfo-count entry))
     ne)
 e))
e)))

Transformations may produce a global call in which the function is a constant. If the constant is a symbol, the call can be transformed to a symbol call. Again variable definition information is adjusted.

⟨code simplification 87⟩+≡ (79) ◁ 92 93 ▷

(define-generic-call-simplifier (e table)
(let ((fun (call-fun e)))
(if (and (const-p fun) (symbolp (const-value fun)))
(let* ((nfun (const-value fun))
    (args (call-args e))
    (vars (call-vars e))
    (conts (call-conts e))
    (ne (remake-cexpr e nfun args vars conts)))
(set-varinfo-defs vars table ne)
ne)
e)))

5.5.4 Converting Calls to Primops

Calls to many global functions can be replaced by primop expressions.

Generic Converters

Most conversions to primop expressions can be handled by a common pattern. This pattern is captured in the function call-to-primop. The arguments are the expression, the variable information table, an argument template, and the name of the primop function to use. The call must be a direct call, not a multiple value call, with arguments that match the template. The definition information of the bound variables is adjusted

⟨code simplification 87⟩+≡ (79) ◁ 93 94 ▷

(defun call-to-primop (e table template fun)
(if (or (call-is-mvcall e) (not (args-match-p (call-args e) template)))
e
(let* ((args (call-args e))
(vars (call-vars e))
(form (call-form e))
(vi (call-val-ignored e))
(ctx (call-context e))

(nvars ⟨make bound variables for the new primop 94⟩) (nform ⟨make continuation form for the new primop 94⟩)

(ne (make-primop fun args nvars nform nil ctx)))
(set-varinfo-defs nvars table ne)
ne)))

Unless the expression is in tail position it will always bind one variable. If the call value was ignored, the variable is not used. If the original call did not bind any variables but its value was not ignored, then the value in the variable is stored in the values registers with a values expression. The reference count of a new variable is adjusted if the variable is used in a values expression.

⟨make bound variables for the new primop 94⟩≡ (93)

  (cond
   (vars vars)
   ((null form) nil)
   (t (let ((v (make-tmp-var)))
        (add-varinfo v e table)
        (list v))))

⟨make continuation form for the new primop 94⟩≡ (93)

  (cond
   ((or (null form) vars vi) form)
   (t (let ((entry (lookup-varinfo (first nvars) table)))
        (incf (varinfo-count entry))
        (make-primop 'values nvars nil form nil ctx))))

The argument template used to determine whether a call can be replaced by a primop can be the symbol t, meaning any argument list matches, an integer representing the length of the argument list, or a list of integers representing possible argument lengths. No error is signaled if there is no match since some functions, such as +, only transform some cases to primops. Argument count checking should be handled by the facilities in the conversion system.

⟨code simplification 87⟩+≡ (79) ◁ 93 94 ▷

  (defun args-match-p (args template)
    (cond
     ((eq template t) t)
     ((numberp template) (= (length args) template))
     ((consp template) (member (length args) template))
     (t nil)))

The macro define-primop-call-simplifier defines a call simplifier that uses this conversion framework. The required arguments are the name of the function to convert and the argument template. If the name of the primop differs from the function name, then it can be provided as an optional third argument.

⟨code simplification 87⟩+≡ (79) ◁ 94 94 ▷

  (defmacro define-primop-call-simplifier (name template &optional (fun name))
    `(define-call-simplifier ,name (e table)
       (call-to-primop e table ',template ',fun)))

Arithmetic Primop Converters

The basic arithmetic operations all allow more than two arguments, but only the two argument cases are converted to primop expressions.

⟨code simplification 87⟩+≡ (79) ◁ 94 95 ▷

  (define-primop-call-simplifier + 2)
  (define-primop-call-simplifier - 2)
  (define-primop-call-simplifier * 2)
  (define-primop-call-simplifier / 2)

The unary minus and unary division operations are converted to special primops.

⟨code simplification 87⟩+≡ (79) ◁ 94 95 ▷

(define-primop-call-simplifier - 1 uminus)
(define-primop-call-simplifier / 1 udiv)

The increment and decrement functions take only one argument.

⟨code simplification 87⟩+≡ (79) ◁ 95 95 ▷

(define-primop-call-simplifier 1+ 1)
(define-primop-call-simplifier 1- 1)

The minimum and maximum functions and the comparison functions all take zero or more arguments, but only the two argument cases are converted.

⟨code simplification 87⟩+≡ (79) ◁ 95 95 ▷

(define-primop-call-simplifier min 2)
(define-primop-call-simplifier max 2)
(define-primop-call-simplifier <  2)
(define-primop-call-simplifier <= 2)
(define-primop-call-simplifier =  2)
(define-primop-call-simplifier /= 2)
(define-primop-call-simplifier >= 2)
(define-primop-call-simplifier >  2)

List Primop Converters

The basic list cell constructor cons, the accessors car and cdr, and their equivalents first and rest are converted to primops when their argument counts are correct.

⟨code simplification 87⟩+≡ (79) ◁ 95 95 ▷

(define-primop-call-simplifier cons 2)
(define-primop-call-simplifier car 1)
(define-primop-call-simplifier first 1 car)
(define-primop-call-simplifier cdr 1)
(define-primop-call-simplifier rest 1 cdr)

The c??r and c???r accessors are also converted.

⟨code simplification 87⟩+≡ (79) ◁ 95 96 ▷

(define-primop-call-simplifier caar 1)
(define-primop-call-simplifier cadr 1)
(define-primop-call-simplifier cdar 1)
(define-primop-call-simplifier cddr 1)
(define-primop-call-simplifier second 1 cadr)
(define-primop-call-simplifier caaar 1)
(define-primop-call-simplifier caadr 1)
(define-primop-call-simplifier cadar 1)
(define-primop-call-simplifier caddr 1)
(define-primop-call-simplifier cdaar 1)
(define-primop-call-simplifier cdadr 1)
(define-primop-call-simplifier cddar 1)
(define-primop-call-simplifier cdddr 1)
(define-primop-call-simplifier third 1 caddr)

Other converted list operations are the assignment functions and the nth function.

⟨code simplification 87⟩+≡ (79) ◁ 95 96 ▷

  (define-primop-call-simplifier xlisp::%set-car 2)
  (define-primop-call-simplifier xlisp::%set-cdr 2)
  (define-primop-call-simplifier rplaca 2)
  (define-primop-call-simplifier rplacd 2)
  (define-primop-call-simplifier xlisp::%set-nth 3)
  (define-primop-call-simplifier nth 2)

Predicate Primop Converters

Several standard predicates are converted.

⟨code simplification 87⟩+≡ (79) ◁ 96 96 ▷

  (define-primop-call-simplifier not 1)
  (define-primop-call-simplifier null 1 not)
  (define-primop-call-simplifier consp 1)
  (define-primop-call-simplifier endp 1)
  (define-primop-call-simplifier eq 2)
  (define-primop-call-simplifier eql 2)
  (define-primop-call-simplifier equal 2)

Vector and Array Primop Converters

Array operations converted to primops include aref with one or two indices.

⟨code simplification 87⟩+≡ (79) ◁ 96 96 ▷

  (define-primop-call-simplifier aref (2 3))
  (define-primop-call-simplifier svref 2)
  (define-primop-call-simplifier elt 2)
  (define-primop-call-simplifier row-major-aref 2)
  (define-primop-call-simplifier xlisp::%set-aref (3 4))
  (define-primop-call-simplifier xlisp::%set-svref 3)
  (define-primop-call-simplifier xlisp::%set-elt 3)
  (define-primop-call-simplifier xlisp::%set-rm-aref 3)

Values Primop Converters

Calls to values are converted as long as they are not multiple value calls. In tail position, a call to values just becomes a values primop expression. In non-tail position, if a variable is bound in the call, then the call is replaced by a bind expression. When values is given no arguments, the value bound to the variable in nil. (The definition information for the variable does not need to be adjusted since it is not used on the way up and the bind is eliminated on the way down.) If the value is ignored, then the call is replaced by its continuation form. The reference counts for the argument variables are decremented. If no variables are bound and the value is not ignored, then a values primop places the arguments in the value registers.

⟨code simplification 87⟩+≡ (79) ◁ 96 97 ▷

(define-call-simplifier values (e table)
(let ((args (call-args e))
(vars (call-vars e))
(form (call-form e))
(ctx (call-context e)))
(cond
((call-is-mvcall e) e)
((null form)
(make-primop 'values args nil nil nil ctx))
(vars
(let* ((nargs (list (if args (first args) (make-const nil)))))
(make-bind vars nargs form ctx)))
((call-val-ignored e)
(dolist (a args)
(let ((entry (lookup-varinfo a table)))
  (when entry (decf (varinfo-count entry)))))
form)
(t (make-primop 'values args nil form nil ctx)))))

A similar transformation is used for values-list. When a single variable is bound by the call, then the call becomes a car expression. When the value is ignored, a values-list expression is still used since a bad argument should signal an error.

⟨code simplification 87⟩+≡ (79) ◁ 96 97 ▷

(define-call-simplifier values-list (e table)
(let ((args (call-args e))
(vars (call-vars e))
(form (call-form e))
(ctx (call-context e)))
(if (or (call-is-mvcall e) (/= (length args) 1))
e
(cond
((null form)
(make-primop 'values-list args nil nil nil ctx))
(vars
(let ((ne (make-primop 'car args vars form nil ctx)))
  (setf (varinfo-def (lookup-varinfo (first vars) table)) ne)
  ne))
((call-val-ignored e)
(make-primop 'values-list args nil form nil ctx))
(t (make-primop 'values-list args nil form nil ctx))))))

Structure Primop Converters

As a quick hack, these use call-to-primop to do the hard work and then fix up the primop.

⟨code simplification 87⟩+≡ (79) ◁ 97 98 ▷

(define-call-simplifier xlisp::%struct-ref (e table)
(let* ((args (call-args e))
 (slot (second args)))
(if (or (call-is-mvcall e)
    (/= (length args) 2)
    (not (and (const-p slot) (typep (const-value slot) 'fixnum))))
e

(let ((ne (call-to-primop e table t 'struct-ref)))
(setf (primop-data ne) (const-value slot))
(setf (primop-args ne) (list (first args)))
ne))))

⟨code simplification 87⟩+≡ (79) ◁ 97 98 ▷

(define-call-simplifier xlisp::%struct-set (e table)
(let* ((args (call-args e))
 (slot (second args)))
(if (or (call-is-mvcall e)
    (/= (length args) 3)
    (not (and (const-p slot) (typep (const-value slot) 'fixnum))))
e
(let ((ne (call-to-primop e table t 'set-struct-ref)))
(setf (primop-data ne) (const-value slot))
(setf (primop-args ne) (list (first args) (third args)))
ne))))

⟨code simplification 87⟩+≡ (79) ◁ 98 98 ▷

(define-call-simplifier xlisp::%struct-type-p (e table)
(let* ((args (call-args e))
 (type (first args)))
(if (or (call-is-mvcall e)
    (/= (length args) 2)
    (not (and (const-p type) (symbolp (const-value type)))))
e
(let ((ne (call-to-primop e table t 'struct-type-p)))
(setf (primop-data ne) (const-value type))
(setf (primop-args ne) (rest args))
ne))))

Other Primop Converters

A few miscellaneous conversions:

⟨code simplification 87⟩+≡ (79) ◁ 98 98 ▷

(define-primop-call-simplifier get 2)
(define-primop-call-simplifier xlisp::%set-get 3)
(define-primop-call-simplifier slot-value (1 2))

5.5.5 Simplifiers For Some Primops

Constant Folding

If all arguments to a primop are constants, then it may be permissible to carry out the computation at compile time. This is done by constant-fold-primop. This function takes the expression to fold as a required argument. A predicate for testing the arguments may be given as a second argument; if it is supplied, constant folding will only occur if all argument values satisfy the predicate. The function to apply to the arguments may be supplied as the third argument; by default it is the function definition of the function symbol in the primop expression.

⟨code simplification 87⟩+≡ (79) ◁ 98 99 ▷

(defun constant-fold-primop (e &optional pred  (fun (primop-fun e)))
  (let ((args (primop-args e)))
    (if (every #'const-p args)
        (let ((vals (mapcar #'const-value args)))
          (if (or (null pred) (every pred vals))
              (wrap-primop-value (make-const (apply fun vals)) e nil)
            e))
      e)))

The result expression is created by wrap-primop-value. Its form depends on the continuation information in the expression being folded.

⟨code simplification 87⟩+≡ (79) ◁ 98 99 ▷

(defun wrap-primop-value (val e table)
  (let ((vars (primop-vars e))
        (form (primop-form e))
        (ctx (primop-context e)))
    (cond
     (vars (make-bind vars (list val) (primop-form e) ctx))
     (form form)
     (t (when (var-p val) (incf (varinfo-count (lookup-varinfo val table))))
        (make-primop 'values (list val) nil nil nil ctx)))))

The macro define-arith-primop-folder defines constant folders for arithmetic operations. Only expressions in which all argument are numeric constants will be folded.

⟨code simplification 87⟩+≡ (79) ◁ 99 99 ▷

(defmacro define-arith-primop-folder (name)
  `(define-primop-simplifier ,name (e table)
     (declare (ignore table))
     (constant-fold-primop e #'numberp)))

The macro define-primop-folder defines constant folders that do not require a pre-test for the arguments.

⟨code simplification 87⟩+≡ (79) ◁ 99 99 ▷

(defmacro define-primop-folder (name)
  `(define-primop-simplifier ,name (e table)
     (declare (ignore table))
     (constant-fold-primop e)))

Constant folders are provided for the basic arithmetic operators and numerical predicates.

⟨code simplification 87⟩+≡ (79) ◁ 99 100 ▷

(define-arith-primop-folder +)
(define-arith-primop-folder -)
(define-arith-primop-folder *)
(define-arith-primop-folder /)
(define-arith-primop-folder min)
(define-arith-primop-folder max)
(define-arith-primop-folder 1+)
(define-arith-primop-folder 1-)
(define-arith-primop-folder <)
(define-arith-primop-folder <=)
(define-arith-primop-folder =)

(define-arith-primop-folder /=)
(define-arith-primop-folder >=)
(define-arith-primop-folder >)

Constant folders can also be defined for basic list accessors. Doing this is, I believe, consistent with ANSI CL, but may produce unexpected results if code mutates constant lists. It might be a good idea to disable these unless constant lists can be made read-only.

⟨code simplification 87⟩+≡ (79) ◁ 99 100 ▷

(define-primop-folder car)
(define-primop-folder cdr)
(define-primop-folder caar)
(define-primop-folder cadr)
(define-primop-folder cdar)
(define-primop-folder cddr)
(define-primop-folder caaar)
(define-primop-folder caadr)
(define-primop-folder cadar)
(define-primop-folder caddr)
(define-primop-folder cdaar)
(define-primop-folder cdadr)
(define-primop-folder cddar)
(define-primop-folder cdddr)

Partial Constant Folding

Some operations can be replaced by potentially more efficient ones if one argument is a constant. Addition expressions where one argument is one can be replaced by increment expressions using

1+.

⟨code simplification 87⟩+≡ (79) ◁ 100 100 ▷

(define-primop-simplifier + (e table)
  (let* ((args (primop-args e))
         (x (first args))
         (y (second args)))
    (cond
     ((and (const-p x) (eql (const-value x) 1))
      (let* ((vars (primop-vars e))
             (conts (primop-conts e))
             (ne (remake-cexpr e '1+ (list y) vars conts)))
        (set-varinfo-defs vars table ne)
        ne))
     ((and (const-p y) (eql (const-value y) 1))
      (let* ((vars (primop-vars e))
             (conts (primop-conts e))
             (ne (remake-cexpr e '1+ (list x) vars conts)))
        (set-varinfo-defs vars table ne)
        ne))
     (t e))))

Similarly, subtractions where the second argument is one can be replaced by 1- primops.

⟨code simplification 87⟩+≡ (79) ◁ 100 101 ▷

  (define-primop-simplifier - (e table)
    (let* ((args (primop-args e))
           (x (first args))
           (y (second args)))
      (if (and (const-p y) (eql (const-value y) 1))
          (let* ((vars (primop-vars e))
                 (conts (primop-conts e))
                 (ne (remake-cexpr e '1- (list x) vars conts)))
            (set-varinfo-defs vars table ne)
            ne)
        e)))

With type information to insure that all arguments are numeric, other optimizations would be possible:

• x + 0 and x × 1 could be replaced by x.

• 0 − x could be replaced by −x.

• For floating point numbers, x + 0.0 and x × 1.0 could also be replaced by x.

Several other conversions are also possible. But these would not be appropriate without the assurance that x is of the appropriate type.

List Accessor Optimizations

If a list cell is constructed and only used as the argument to car, then the result of the car will be the first argument to the cons expression. The function find-car-once-used returns the first argument to a cons if the value of the cons expression is only used once; otherwise it returns nil.

⟨code simplification 87⟩+≡ (79) ◁ 100 101 ▷

  (defun find-car-once-used (var table)
    (if (var-p var)
        (let* ((entry (lookup-varinfo var table))
               (def (varinfo-def entry)))
          (if (and (= (varinfo-count entry) 1)
                   (primop-p def)
                   (eq (primop-fun def) 'cons))
              (first (primop-args def))
            nil))
      nil))

The function find-cdr-once-used does the same for the cdr.

⟨code simplification 87⟩+≡ (79) ◁ 101 102 ▷

  (defun find-cdr-once-used (var table)
    (if (var-p var)
        (let* ((entry (lookup-varinfo var table))
               (def (varinfo-def entry)))
          (if (and (= (varinfo-count entry) 1)
                   (primop-p def)
                   (eq (primop-fun def) 'cons))
              (second (primop-args def))
            nil))
      nil))

car and cdr expression can be simplified to the value of find-car-once-used if there is one. The use count of the list variable is decremented so that the cons expression can be eliminated.

⟨code simplification 87⟩+≡ (79) ◁ 101 102 ▷

(define-primop-simplifier car (e table)
  (let* ((var (first (primop-args e)))
         (car (find-car-once-used var table)))
    (cond
     (car (decf (varinfo-count (lookup-varinfo var table)))
          (wrap-primop-value car e table))
     (t e))))
(define-primop-simplifier cdr (e table)
  (let* ((var (first (primop-args e)))
         (cdr (find-cdr-once-used var table)))
    (cond
     (cdr (decf (varinfo-count (lookup-varinfo var table)))
          (wrap-primop-value cdr e table))
     (t e))))

A similar optimization can be applied to the c??r and c???r forms to produce a car or a cdr expression. The function simplify-cons-cxxr carries out the details. The new argument is the name of the new primop, car or cdr, and the find argument is the find function to use to find the value.

⟨code simplification 87⟩+≡ (79) ◁ 102 102 ▷

(defun simplify-cons-cxxr (e table new find)
  (let* ((var (first (primop-args e)))
         (cxr (funcall find var table)))
    (if cxr
        (let ((form (primop-form e))
              (vars (primop-vars e))
              (ctx (primop-context e)))
          (decf (varinfo-count (lookup-varinfo var table)))
          (when (var-p cxr) (incf (varinfo-count (lookup-varinfo cxr table))))
          (make-primop new (list cxr) vars form nil ctx))
      e)))

The macro define-cxxr-simplifier examines the name of the operation to be handled and produces a simplifier definition that uses the appropriate call to simplify-cons-cxxr.

⟨code simplification 87⟩+≡ (79) ◁ 102 102 ▷

(defmacro define-cxxr-simplifier (name)
  (let* ((str (symbol-name name))
         (n (length str))
         (c (char str (- n 2)))
         (find (if (eql c #\A) 'find-car-once-used 'find-cdr-once-used))
         (new (intern (concatenate 'string (subseq str 0 (- n 2)) "R"))))
    `(define-primop-simplifier ,name (e table)
       (simplify-cons-cxxr e table ',new #',find))))

Using this macro, the simplifier definitions are

⟨code simplification 87⟩+≡ (79) ◁ 102 103 ▷

(define-cxxr-simplifier caar)
(define-cxxr-simplifier cdar)
(define-cxxr-simplifier cadr)
(define-cxxr-simplifier cddr)

(define-cxxr-simplifier caaar)
(define-cxxr-simplifier cdaar)
(define-cxxr-simplifier cadar)
(define-cxxr-simplifier cddar)
(define-cxxr-simplifier caadr)
(define-cxxr-simplifier cdadr)
(define-cxxr-simplifier caddr)
(define-cxxr-simplifier cdddr)

5.5.6 Simplifiers For Values Primops

A values expression followed by a multiple value call can be replaced by a direct call to the arguments of the values expression.

⟨code simplification 87⟩+≡ (79) ◁ 102 103 ▷

(define-primop-simplifier values (e table)
  (let ((form (primop-form e)))
    (if (and (call-p form) (call-is-mvcall form))
        (let* ((fun (call-fun form))
               (args (primop-args e))
               (vars (call-vars form))
               (conts (call-conts form))
               (ne (remake-cexpr form fun args vars conts)))
          (setf (call-is-mvcall ne) nil)
          (set-varinfo-defs vars table ne)
          ne)
      e)))

A values expression can be dropped if it is followed by a values or a values-list expression or by a direct call to a closure. The symbolp test used for a closure is conservative. The dolist expression decrements the use counts of variable arguments to the values expression and returns

form.

⟨code simplification 87⟩+≡ (79) ◁ 103 103 ▷

(define-primop-simplifier values (e table)
  (let ((form (primop-form e)))
     (if (or (primop-eq form 'values)
             (primop-eq form 'values-list)
             (and (call-p form)
                  (not (call-is-mvcall form))
                  (symbolp (call-fun form))))
         (dolist (a (primop-args e) form)
           (let ((entry (lookup-varinfo a table)))
             (when entry (decf (varinfo-count entry)))))
       e)))

If a values-list expression is followed by a multiple value call to values, then the two expressions can be merged into a single values-list expression.

⟨code simplification 87⟩+≡ (79) ◁ 103 104 ▷

(define-primop-simplifier values-list (e table)
  (let ((form (primop-form e)))
    (if (and (call-p form)
             (call-is-mvcall form)
             (eq (call-fun form) 'values))

(let* ((args (primop-args e))
(vars (call-vars form))
(conts (call-conts form))
(nform (if conts (first conts) nil))
(ctx (call-context form))
(ne (make-primop 'values-list args vars nform nil ctx)))
(set-varinfo-defs vars table ne)
ne)
e)))

5.5.7 Simplifiers For Some Testops

If the argument to a simple testop is the result of a not expression, then the testop can use the argument to the not expression with the continuations reversed.

⟨code simplification 87⟩+≡ (79) ◁ 103 104 ▷

(define-testop-simplifier t (e table)
(let* ((arg (first (testop-args e)))
(entry (lookup-varinfo arg table)))
(if entry
(let ((def (varinfo-def entry)))
(if (primop-eq def 'not)
(let ((nargs (primop-args def))
     (nconts (reverse (testop-conts e))))

⟨adjust reference counts for nargs and entry 104⟩

 (remake-cexpr e t nargs nil nconts))
e))
e)))

Reference counts are adjusted by

⟨adjust reference counts for nargs and entry 104⟩≡ (104)

(decf (varinfo-count entry))
(dolist (a nargs)
(when (var-p a)
(let ((entry (lookup-varinfo a table)))
(incf (varinfo-count entry)))))

Simple testop expressions whose arguments are the results of some predicate primops can be merged with the primops. This is only done if the predicate value is only used in the test.

⟨code simplification 87⟩+≡ (79) ◁ 104 105 ▷

(define-testop-simplifier t (e table)
(let* ((arg (first (testop-args e)))
(entry (lookup-varinfo arg table)))
(if (and entry (= (varinfo-count entry) 1))
(let ((def (varinfo-def entry)))
(if (and (primop-p def)
    (member (primop-fun def)
            '(consp eq eql equal #|endp < <= = /= >= >|#)))
(let ((nargs (primop-args def))
     (conts (testop-conts e)))

⟨adjust reference counts for nargs and entry 104⟩

 (remake-cexpr e (primop-fun def) nargs nil conts))
e))
e)))

Tests can be constant-folded if all arguments are constant and satisfy an optional predicate. The details are handled by constant-fold-testop. No attempt is made to adjust the reference counts for variables in the removed continuation.

⟨code simplification 87⟩+≡ (79) ◁ 104 105 ▷

(defun constant-fold-testop (e &optional pred  (fun (testop-fun e)))
(let ((args (testop-args e)))
  (if (every #'const-p args)
      (let ((vals (mapcar #'const-value args)))
        (if (or (null pred) (every pred vals))
            (let ((val (apply fun vals))
                  (conts (testop-conts e)))
              (if val (first conts) (second conts)))
          e))
    e)))

Simplifiers for the individual testops are defined by

⟨code simplification 87⟩+≡ (79) ◁ 105 105 ▷

(define-testop-simplifier t (e table)
(declare (ignore table))
(constant-fold-testop e nil #'identity))
(define-testop-simplifier consp (e table)
(declare (ignore table))
(constant-fold-testop e))
(define-testop-simplifier endp (e table)
(declare (ignore table))
(constant-fold-testop e))
(define-testop-simplifier eq (e table)
(declare (ignore table))
(constant-fold-testop e))
(define-testop-simplifier eql (e table)
(declare (ignore table))
(constant-fold-testop e))
(define-testop-simplifier equal (e table)
(declare (ignore table))
(constant-fold-testop e))

The case testop can be constant-folded if the selector is known at compile time.

⟨code simplification 87⟩+≡ (79) ◁ 105 106 ▷

(define-testop-simplifier case (e table)
(declare (ignore table))
(let ((arg (first (testop-args e))))
  (if (const-p arg)
      (let* ((data (testop-data e))
             (val (const-value arg))
             (i (dotimes (i (length data) i)
                  (let ((entry (aref data i)))
                    (cond
                     ((consp entry) (when (member val entry) (return i)))
                     ((eql val entry) (return i)))))))
        (nth i (testop-conts e)))
    e)))

5.5.8 Dead Variable Elimination

The following macro defines a transformation that removes a primop expression if the expression is not in tail position and its value is not used. Reference counts of any argument variables are decremented.

⟨code simplification 87⟩+≡ (79) ◁ 105 106 ▷

  (defmacro define-drop-dead-primop-simplifier (name)
    `(define-primop-simplifier ,name (e table)
       (flet ((unused (v) (= (varinfo-count (lookup-varinfo v table)) 0)))
         (let ((vars (primop-vars e))
               (form (primop-form e)))
           (cond
            ((or (and vars (every #'unused vars)) (and (null vars) form))
             (dolist (a (primop-args e))
               (when (var-p a)
                     (decf (varinfo-count (lookup-varinfo a table)))))
             (primop-form e))
            (t e))))))

Unused primop expressions can be dropped if they do not have side effects and do not raise errors due to invalid arguments.

⟨code simplification 87⟩+≡ (79) ◁ 106

  (define-drop-dead-primop-simplifier cons)
  (define-drop-dead-primop-simplifier not)
  (define-drop-dead-primop-simplifier consp)
  (define-drop-dead-primop-simplifier eq)
  (define-drop-dead-primop-simplifier eql)
  (define-drop-dead-primop-simplifier equal)
  (define-drop-dead-primop-simplifier symbol-function)

5.5.9 Other Optimizations

Some other possible optimizations to consider:

• Simplify apply calls by splitting out the list if possible and making them into call if the list

     is nil.

• For values-list expressions, split out the list part and make them into values expressions if possible.

   • For values followed by a user (nth-value, get-one-value, load-mvargs) make a bind

expression.

• Make calls to symbol-value and symbol-function into primops if the symbol is known.

5.6 Common Subexpression Elimination

CSE is not implemented yet. It would probably not be very useful until more type information is available.

5.7 Inline Expansion

Two forms of inline expansion are currently done. The first expands small, non-recursive local functions, and the second expands some built-in functions such as mapcar and mapc. These transformations place copies of the functions at call sites; β-contraction then does the actual inlining. To facilitate the transformation, functions are split first.

⟨inline expansion 107⟩≡ (79) 107 ▷

  (defun inline-expand (e)
    (let ((ne (inline-expand-built-ins (split-local-functions e))))
      (substitute-once-called-functions (inline-expand-non-recursives ne nil))))

5.7.1 Expanding Small Non-Recursive Functions

This code places copies of small non-recursive functions at their call sites. If the call site is the first expression in the defining letrec, then no new letrec is inserted. This insures that the code does not change if this is the only call. Expansion is only done in the body of the defining letrec, and functions are only expanded if they do not reference any functions in their defining letrec. For now, only functions with a single body expression are expanded. This insures a code size reduction after β-contraction.

The function inline-expand-non-recursives dispatches on expression type. The second argument env is an association list of names and definitions that can be inlined.

⟨inline expansion 107⟩+≡ (79) ◁ 107 107 ▷

  (defun inline-expand-non-recursives (e env)
    (cond
     ((letrec-p e) (inline-expand-non-recursives-letrec e env))
     ((call-p e) (inline-expand-non-recursives-call e env nil))
     (t (inline-expand-non-recursives-cexpr e env))))

For letrec expressions, the argument functions are processed, eligible functions are added to the environment, and the body is processed with the new environment. If the body is a call, it is processed to not expand any of the functions bound in the letrec in the first expression.

⟨inline expansion 107⟩+≡ (79) ◁ 107 107 ▷

  (defun inline-expand-non-recursives-letrec (e env)
    (let* ((nargs (mapcar #'(lambda (x) (inline-expand-non-recursives x env))
                          (letrec-args e)))
           (vars (letrec-vars e))
           (nenv (make-inline-nonrec-env vars nargs env))
           (body (letrec-body e))
           (nbody (if (call-p body)
                      (inline-expand-non-recursives-call body nenv vars)
                    (inline-expand-non-recursives body nenv))))
      (remake-cexpr e nil nargs vars (list nbody))))

The new environment is constructed by make-inline-nonrec-env. To be eligible for inlining, the body of a function must be of size one, the body’s function, if it is a call, must not be bound in the same letrec, and none of the arguments in the body may be bound in the letrec.

⟨inline expansion 107⟩+≡ (79) ◁ 107 108 ▷

  (defun make-inline-nonrec-env (vars args env)
    (mapc #'(lambda (v a)
              (let ((body (func-body a)))
                (when (and (null (cexpr-conts body))

            (not (member (cexpr-fun body) vars))
            (null (intersection vars (cexpr-args body))))
       (push (cons v a) env))))
vars args)
env)

Calls to eligible functions are expanded by wrapping a letrec with a copy of the function around the call site. Other calls are processed as generic expressions. Expansion is skipped if the function is in the skip list.

⟨inline expansion 107⟩+≡ (79) ◁ 107 108 ▷

(defun inline-expand-non-recursives-call (e env skip)
(let ((def (cdr (assoc (call-fun e) env))))
(if (or (null def) (member (call-fun e) skip))
(inline-expand-non-recursives-cexpr e env)
(let* ((var (make-tmp-var))
(ndef (alpha-copy def))
(args (call-args e))
(vars (call-vars e))
(form (call-form e))
(nform (if form (inline-expand-non-recursives form env) nil))
(ne (remake-cexpr e var args vars (if form (list nform) nil))))
(make-letrec (list var) (list ndef) ne (call-context e))))))

Generic expressions are processed by processing their continuations and remaking the expression.

⟨inline expansion 107⟩+≡ (79) ◁ 108 108 ▷

(defun inline-expand-non-recursives-cexpr (e env)
(let ((nconts (mapcar #'(lambda (x) (inline-expand-non-recursives x env))
           (cexpr-conts e))))
(remake-cexpr e (cexpr-fun e) (cexpr-args e) (cexpr-vars e) nconts)))

5.7.2 Expanding Some Built-In Functions

This code provides a facility for inlining built-in functions. The function to do the inlining dispatches on expression type.

⟨inline expansion 107⟩+≡ (79) ◁ 108 108 ▷

(defun inline-expand-built-ins (e)
(cond
((letrec-p e) (inline-expand-built-ins-letrec e))
((call-p e) (inline-expand-built-ins-call e))
(t (inline-expand-built-ins-cexpr e))))

For letrec expressions the arguments and the body are processed.

⟨inline expansion 107⟩+≡ (79) ◁ 108 108 ▷

(defun inline-expand-built-ins-letrec (e)
(let ((nargs (mapcar #'inline-expand-built-ins (letrec-args e)))
(nbody (inline-expand-built-ins (letrec-body e))))
(remake-cexpr e nil nargs (cexpr-vars e) (list nbody))))

Calls to global functions for which expansions are available have their continuation form processed and are then wrapped in letrec expressions that bind a copy of the expansion at the call site. Other calls are handled as generic expressions.

⟨inline expansion 107⟩+≡ (79) ◁ 108 109 ▷

(defun inline-expand-built-ins-call (e)
  (let ((fun (call-fun e)))
    (if (symbolp fun)
        (let ((def (get-global-inline (call-fun e) (length (call-args e)))))
          (if def
              (let* ((var (make-tmp-var))
                     (args (call-args e))
                     (vars (call-vars e))
                     (form (call-form e))
                     (nconts (if form
                                 (list (inline-expand-built-ins form))
                               nil))
                     (ncall (remake-cexpr e var args vars nconts)))
                (make-letrec (list var) (list def) ncall (call-context e)))
            (inline-expand-built-ins-cexpr e)))
      (inline-expand-built-ins-cexpr e))))

Generic expressions have their continuations expanded and are remade.

⟨inline expansion 107⟩+≡ (79) ◁ 108 109 ▷

(defun inline-expand-built-ins-cexpr (e)
  (let ((nconts (mapcar #'inline-expand-built-ins (cexpr-conts e))))
    (remake-cexpr e (cexpr-fun e) (cexpr-args e) (cexpr-vars e) nconts)))

Inline expansions are stored in the hash table *inline-table*. The entries are association lists of argument counts and expansions.

⟨inline expansion 107⟩+≡ (79) ◁ 109 109 ▷

(defparameter *inline-table* (make-hash-table))

set-inline-definition adds and modifies entries for a particular symbol and argument count. The fun argument should be a lambda expression.

⟨inline expansion 107⟩+≡ (79) ◁ 109 109 ▷

(defun set-inline-definition (name argc fun)
  (let ((entry (assoc argc (gethash name *inline-table*))))
    (if entry
        (setf (cdr entry) fun)
      (push (cons argc fun) (gethash name *inline-table*)))
    name))

The macro define-inline provides a convenient way to define expansions. It is used like defun, but the lambda list must only contain required arguments.

⟨inline expansion 107⟩+≡ (79) ◁ 109 109 ▷

(defmacro define-inline (name args &rest body)
  (when (intersection args lambda-list-keywords)
        (error "only required arguments allowed in inline definitions"))
  `(set-inline-definition ',name ,(length args) '(lambda ,args ,@body)))

Expansions are retrieved with get-global-inline. If the expansion in the table is in intermediate form, then a copy is returned. Otherwise the entry, which should be a lambda expression, is compiled to intermediate form, the compiled version is stored, and a copy of the new entry is returned. Entries are originally stored as lambda expressions since the full compiler might not yet be available when a file containing inline definitions is loaded.

⟨inline expansion 107⟩+≡ (79) ◁ 109 110 ▷

(defun get-global-inline (name argc)
(let ((def (cdr (assoc argc (gethash name *inline-table*)))))
(cond
 ((null def) nil)
 ((cexpr-p def) (alpha-copy def))
 (t (let ((cdef (optimize (compile-front-lambda def name nil nil))))
      (set-inline-definition name argc cdef)
      (alpha-copy cdef))))))

Here are inline definitions for mapcar with one and two arguments. These definitions use endp instead of consp. This makes them more stringent than the internal XLISP versions.

⟨inline expansion 107⟩+≡ (79) ◁ 109 110 ▷

(define-inline mapcar (f x)
(labels ((loop (x v)
         (let ((nv (cons (funcall f (car x)) v))
               (nx (cdr x)))
           (if (endp nx) (nreverse nv) (loop nx nv)))))
(if (endp x) nil (loop x nil))))
(define-inline mapcar (f x y)
(labels ((loop (x y v)
         (let ((nv (cons (funcall f (car x) (car y)) v))
               (nx (cdr x))
               (ny (cdr y)))
           (if (and (endp nx) (endp ny)) (nreverse nv) (loop nx ny nv)))))
(if (or (endp x) (endp y)) nil (loop x y nil))))

Here are analogous definitions for mapc.

⟨inline expansion 107⟩+≡ (79) ◁ 110

(define-inline mapc (f x)
(labels ((loop (x)
         (let ((nx (cdr x)))
           (funcall f (car x))
           (unless (endp nx) (loop nx)))))
(unless (endp x) (loop x))
x))
(define-inline mapc (f x y)
(labels ((loop (x y)
         (let ((nx (cdr x))
               (ny (cdr y)))
           (funcall f (car x) (car y))
           (unless (or (endp nx) (endp ny)) (loop nx ny)))))
(unless (or (endp x) (endp y)) (loop x y))
x))

The code size for these definitions could be reduced, and perhaps the speed improved as well, by defining some special primops for stepping and testing the forms. A primop for nreverse might also help. Suppose we had a function step1 that returns the car, cdr, and a test value for its argument. Then the mapcar inline definition for one argument might be ⟨alternate mapcar inline 110⟩≡

(define-inline mapcar (f x)
(labels ((loop (x v)

               (multiple-value-bind (a nx more)
                                    (step1 x)
                 (let ((nv (cons (funcall f (car x)) v)))
                   (if more (loop nx nv) (nreverse nv))))))
      (if (endp x) nil (loop x nil))))

Making this efficient would require converting the step1 call to a primop that binds three variables, and eliminating some get-optarg expressions. This could involve some optimizations with wider applicability.

Similar added primops would be needed to allow sequence functions like every and some to be inlined.

5.8 Hoisting

Hoisting transformations are not implemented yet. Possible transformations are:

• Boolean short-circuiting, as in Orbit [4].

• Bringing up common expressions in testops.

• Dropping unused variables in functions.

• Raising loop invariants.

• Other hoistings from Appel [1].

5.9 Pushing Continuations into Letrecs

This is needed to make cell elimination possible when things like dolist expressions appear in non-tail position. It represents a simplification in the sense that it strictly reduces the call depth at some points by making some non-tail calls into tail calls without increasing the call depth anywhere.

Suppose a letrec defines functions some of which are referenced in its body. Suppose all those references are as non-tail calls with the same continuation (same in the sense of equality of expressions modulo α-conversion). Then it may be possible to make these non-tail calls into tail calls by pushing the common continuation into the functions. For this to work, all functions defined in the letrec or in the bodies of these functions that can receive the continuation must never be called with another continuation. This is essentially a form of loop-invariant-variable hoisting, but applied to the continuation. (This looks like one of the few cases where real CPS would make things easier.)

5.9.1 Main Routine

To apply this idea to a letrec expression, we need to determine whether there are any eligible functions called from the body, along with their common non-tail continuation. The function find-common-cont does this computation. The continuation must not capture any variables defined in the letrec body. Then we need to carry out a data flow analysis to determine which, if any, functions can have the continuation pushed into them. find-letrec-tail-funs finds these functions. Finally, if there are such functions, the function push-cont-into-letrec pushes the continuation into all the identified functions and turns the entry calls in the body into tail calls.

⟨pushing continuations 111⟩≡ (79) 112 ▷

(defun push-letrec-conts (e)
(let ((vars (cexpr-vars e))
(conts (mapcar #'push-letrec-conts (cexpr-conts e))))
(if(letrec-p e)
(let ((vars (letrec-vars e))
      (args (mapcar #'push-letrec-conts (letrec-args e)))
      (body (first conts)))
  (multiple-value-bind (kv kf entries)
                       (find-common-cont body vars)
    (if (and kf

⟨are the free variables in kf also free in e? 112⟩)

        (let ((cfuns (find-letrec-tail-funs e entries)))
          (if cfuns
              (push-cont-into-letrec e kv kf cfuns)
            (remake-cexpr e nil args vars conts)))
      (remake-cexpr e nil args vars conts))))
(remake-cexpr e (cexpr-fun e) (cexpr-args e) vars conts))))

⟨are the free variables in kf also free in e? 112⟩≡ (111)

(let ((efree nil)
(kfree nil))
(flet ((register (x free)
           (cond
            ((eq x e) (setf efree free))
            ((eq x kf) (setf kfree (remove kv free))))))
(find-freevars e #'register)
(subsetp kfree efree)))

The implementation is rather inefficient in that it involves several passes for each letrec. It might be possible to avoid this and handle several letrec expressions in one pass, but I don’t see how.

5.9.2 Comparing Expressions

To determine whether two function calls have the same continuation expression we need to be able to compare two expressions to see if they are equal modulo renaming of locally bound variables. This is done by alpha-equal. This function takes two expressions e1 and e2 along with an environment env that pairs variables in e1 with their equivalents in e2.

⟨pushing continuations 111⟩+≡ (79) ◁ 111 113 ▷

(defun alpha-equal (e1 e2 env)
(labels ((eqarg (x y env)

⟨are arguments x and y α-equal for env? 113⟩)

   (alpha-equal-lists (el1 el2 env)

⟨are expression lists el1 and el2 α-equal for env? 113⟩)

   (eqargs (al1 al2 env)

⟨are argument lists al1 and al2 α-equal for env? 113⟩))

(and (eq (type-of e1) (type-of e2))
 (eqarg (cexpr-fun e1) (cexpr-fun e2) env)
 (let* ((args1 (cexpr-args e1))
        (args2 (cexpr-args e2))
        (vars1 (cexpr-vars e1))
        (vars2 (cexpr-vars e2))

                  (nenv (append (mapcar #'cons vars1 vars2) env)))
             (and (if (letrec-p e1)
                      (alpha-equal-lists args1 args2 nenv)
                    (eqargs args1 args2 env))

⟨are additional fields in e1 and e2 equal? 113⟩

                  (alpha-equal-lists (cexpr-conts e1) (cexpr-conts e2) nenv))))))

Two arguments are equivalent if they are eq, if both are variables that are eq after possibly substituting the first one from the environment, or if they are both constants with eql values.

⟨are arguments x and y α-equal for env? 113⟩≡ (112)

  (or (eq x y)
      (and (var-p x) (var-p y) (eq (sublis env x) y))
      (and (const-p x) (const-p y)
           (eql (const-value x) (const-value y))))

Two argument lists are equivalent if they are the same length and all argument pairs are equivalent.

⟨are argument lists al1 and al2 α-equal for env? 113⟩≡ (112)

  (do ((al1 al1 (rest al1))
       (al2 al2 (rest al2)))
      ((or (null al1) (null al2)) (and (null al1) (null al2)))
      (unless (eqarg (first al1) (first al2) env) (return nil)))

Two lists of expressions, such as a letrec function list or a list of continuations, are α-equivalent if the lists are the same length and each pair of expressions is equivalent.

⟨are expression lists el1 and el2 α-equal for env? 113⟩≡ (112)

  (do ((el1 el1 (rest el1))
       (el2 el2 (rest el2)))
      ((or (null el1) (null el2)) (and (null el1) (null el2)))
      (unless (alpha-equal (first el1) (first el2) env)
              (return nil)))

Some expression types contain additional fields that must be compared. primop expressions must have identical data fields, call expressions must have identical val-ignored and is-mvcall fields, and func expressions need to have identical types.

⟨are additional fields in e1 and e2 equal? 113⟩≡ (112)

  (or (not (primop-p e1))
      (eql (primop-data e1) (primop-data e2)))
  (or (not (call-p e1))
      (and (eql (call-val-ignored e1) (call-val-ignored e2))
           (eql (call-is-mvcall e1) (call-is-mvcall e2))))
  (or (not (func-p e1))
      (eql (func-type e1) (func-type e2)))

5.9.3 Another Free Variable Determination Routine

We need to do a free variable determination to check that the proposed continuation does not capture any variables defined in the letrec body. This means we need the free variables in the continuation and the free variables in the letrec expression. The find-freevars function collects free variable information and calls a record function with each expression and its free variables as arguments. This function can then enter the information according to its needs.

⟨pushing continuations 111⟩+≡ (79) ◁ 112 114 ▷

(defun find-freevars (e record)
(flet ((free-in-list (list)
   (let ((free nil))
     (dolist (e list free)
       (setf free (append free (find-freevars e record)))))))
(let ((cfree (free-in-list (cexpr-conts e)))

(afree ⟨compute free variables in the arguments of e 114⟩)

  (vars (cexpr-vars e)))
(let ((free (set-difference (union cfree afree) vars)))
(when record (funcall record e free))
free))))

⟨compute free variables in the arguments of e 114⟩≡ (113)

(let ((args (cexpr-args e)))
(if (letrec-p e)
(free-in-list args)
(let ((afree (remove-if-not #'var-p args)))
(if (call-p e)
  (let ((fun (call-fun e)))
    (if (var-p fun)
        (cons fun afree)
      afree))
afree))))

5.9.4 Finding Eligible Entry Points

The function find-common-cont searches the body of the letrec expression e to determine whether all uses of functions in the list funs occur as non-tail calls with the same continuation form in the body (not in functions bound in the body). It seemed easier to write this as a loop that processes a stack of expressions. If the search succeeds, the list starts of the eligible entry points is returned. Otherwise, nil is returned.

⟨pushing continuations 111⟩+≡ (79) ◁ 113 115 ▷

(defun find-common-cont (e funs)
(let ((stack (list e))
(kv nil)
(kf nil)
(starts nil))
(loop
(if (null stack)
 (return (values kv kf starts))
(let* ((next (pop stack))
      (args (cexpr-args next)))

⟨examine next for common continuations 114⟩

 (setf stack (append (cexpr-conts next) stack)))))))

If next is a letrec expression and one of its functions contains a reference to one of funs then we break out of the loop and return nil. For other expressions, we break out of the loop and return nil if one of the arguments is in funs.

⟨examine next for common continuations 114⟩≡ (114) 115 ▷

(when (if (letrec-p next)
  (some #'(lambda (x) (any-uses-p x funs)) args)

          (some #'(lambda (x) (member x funs)) args))
        (return nil))

⟨pushing continuations 111⟩+≡ (79) ◁ 114 116 ▷

  (defun any-uses-p (e funs)
    (flet ((any-uses (x) (any-uses-p x funs))
           (is-one (x) (member x funs)))
      (or (is-one (cexpr-fun e))
          (if (letrec-p e)
              (some #'any-uses (letrec-args e))
            (some #'is-one (cexpr-args e)))
          (some #'any-uses (cexpr-conts e)))))

If next is a call to one of funs and it is a tail call, then we break out of the loop and return nil. If it is a non-tail call and it is the first call we have seen, then we initialize the continuation information. If it is not the first call, then we check the new continuation against the information from the previous call.

⟨examine next for common continuations 114⟩+≡ (114) ◁ 114

  (when (and (call-p next) (member (cexpr-fun next) funs))
        (let ((form (call-form next)))
          (cond
           ((null form) (return nil))

((null kf) ⟨initialize the common continuation information 115⟩) (t ⟨check the common continuation information 115⟩))))

The continuation information consists of kv, which is a variable, t for multiple values, or nil if values are ignored, and a form kf. The function is placed on the starts list.

⟨initialize the common continuation information 115⟩≡ (115)

  (let ((vars (call-vars next))
        (vi (call-val-ignored next)))
    (setf kv (if vars (first vars) (if vi nil t)))
    (setf kf form)
    (pushnew (call-fun next) starts))

A second call’s continuation form must be α-equivalent to the existing one or the loop is broken off and nil is returned. Both continuations must bind variables or have equal kv values. If they both bind a variable, the variable pair is added to the α-comparison environment. If the continuations match, the new function is pushed on the starts list if it is not already there.

⟨check the common continuation information 115⟩≡ (115)

  (let* ((vars (call-vars next))
         (vi (call-val-ignored next))
         (nkv (if vars (first vars) (if vi nil t)))
         (nkf form))
    (if (and (var-p kv) (var-p nkv))
        (unless (alpha-equal kf nkf (list (cons kv nkv)))
                (return nil))
      (unless (and (eq kv nkv) (alpha-equal kf nkf nil))
              (return nil)))
    (pushnew (call-fun next) starts))

5.9.5 Finding the Tail Functions

This approach uses a data flow analysis to find all functions in the letrec that can receive the continuation and makes sure this is the only continuation they can receive. All calls into the functions from the body must be non-tail calls with the same continuation; all the eligible functions are in a list starts. This approach is conservative; it would be possible to allow some functions to be called from the body with other continuations—their calls would remain unchanged.

Data Structures

For each function we need to record its name, the continuations it can receive, and the functions in the expression it calls in tail position. The continuations will be of two types, known or unknown. known corresponds to the continuation provided by the entry functions; unknown represents any other continuation. For the continuation insertion to be possible, all functions bound in the letrec expression or within these functions must either receive only a known or only an unknown continuation.

⟨pushing continuations 111⟩+≡ (79) ◁ 115 116 ▷

  (defstruct (plc-entry (:type list) (:constructor make-plc-entry (name)))
    name conts tail-callees)

These entries need to be collected in a table.

⟨pushing continuations 111⟩+≡ (79) ◁ 116 116 ▷

  (defstruct plc-table entries (hash (make-hash-table)))
  (defun add-plc-entry (name table)
    (let ((entry (make-plc-entry name)))
      (push entry (plc-table-entries table))
      (setf (gethash name (plc-table-hash table)) entry)))
  (defun lookup-plc-entry (name table)
    (gethash name (plc-table-hash table)))

Initializing the Table

The table needs to be set up, filled with entries for the letrec expression’s functions, and initialized. unknown continuation.

⟨pushing continuations 111⟩+≡ (79) ◁ 116 116 ▷

  (defun build-plc-table (e)
    (let ((table (make-plc-table))
          (args (letrec-args e))
          (vars (letrec-vars e)))
      (dolist (v vars) (add-plc-entry v table))
      (init-plc-table-letrec-funs vars args table)
      table))

The initialization process adds entries for additional functions defined within the initial functions, adds tail-callee information, and marks any of the additional functions that are called in non-tail position as receiving an unknown continuation. The init-plc-table function takes as arguments the current expression, e, the table entry for the current function, entry, and the table.

⟨pushing continuations 111⟩+≡ (79) ◁ 116 117 ▷

  (defun init-plc-table (e entry table)
    (cond
     ((letrec-p e) (init-plc-table-letrec e entry table))
     ((call-p e) (init-plc-table-call e entry table))
     (t (init-plc-table-cexpr e entry table))))

letrec expressions are handled by adding entries for their functions, processing the functions, and processing the body.

⟨pushing continuations 111⟩+≡ (79) ◁ 116 117 ▷

(defun init-plc-table-letrec (e entry table)
(let ((args (letrec-args e))
      (vars (letrec-vars e)))
  (dolist (v vars) (add-plc-entry v table))
  (init-plc-table-letrec-funs vars args table)
  (init-plc-table (letrec-body e) entry table)))

The functions are processed with their own entries as the current function entry.

⟨pushing continuations 111⟩+≡ (79) ◁ 117 117 ▷

(defun init-plc-table-letrec-funs (vars args table)
(do ((vars vars (rest vars))
     (args args (rest args)))
    ((or (null args) (null vars)))
    (let ((entry (lookup-plc-entry (first vars) table)))
      (init-plc-table (first args) entry table))))

Calls have their arguments processed like ordinary expressions. Then their function is examined. If a registered function is called in non-tail position, it is given the unknown continuation. If it is called in tail position, it is registered as a tail-callee. Then the continuation form is processed if there is one.

⟨pushing continuations 111⟩+≡ (79) ◁ 117 117 ▷

(defun init-plc-table-call (e entry table)
(init-plc-table-cexpr-args (cexpr-args e) table)
(let* ((fun (call-fun e))
       (form (call-form e))
       (fentry (lookup-plc-entry fun table)))
  (cond
   (form
    (when fentry (pushnew 'unknown (plc-entry-conts entry)))
    (init-plc-table form entry table))
   (t (when fentry (pushnew fun (plc-entry-tail-callees entry)))))))

Other expressions are handled by processing their arguments and their continuations. If a registered function is used as an argument, it is marked as receiving an unknown continuation.

⟨pushing continuations 111⟩+≡ (79) ◁ 117 117 ▷

(defun init-plc-table-cexpr (e entry table)
(init-plc-table-cexpr-args (cexpr-args e) table)
(dolist (c (cexpr-conts e))
  (init-plc-table c entry table)))
(defun init-plc-table-cexpr-args (args table)
(dolist (a args)
  (let ((entry (lookup-plc-entry a table)))
    (when entry (pushnew 'unknown (plc-entry-conts entry))))))

Propagation of Continuation Types

Propagation of continuation information starts by adding known continuations to all entries for functions in starts. Continuation types are then propagated through tail callees in a loop until there are no more changes.

⟨pushing continuations 111⟩+≡ (79) ◁ 117 118 ▷

(defun compute-plc-table (e starts)
(let* ((table (build-plc-table e))
     (entries (plc-table-entries table)))
(dolist (entry entries)
  (when (member (plc-entry-name entry) starts)
        (pushnew 'known (plc-entry-conts entry))))
(loop
 (let ((changed nil))
   (dolist (entry entries)
     (let ((conts (plc-entry-conts entry)))
       (dolist (c (plc-entry-tail-callees entry))
         (let* ((centry (lookup-plc-entry c table))
                (cconts (plc-entry-conts centry)))
           (unless (subsetp conts cconts)
                   (setf changed t)
                   (setf (plc-entry-conts centry)
                         (union conts cconts)))))))
   (unless changed (return))))
table))

Once the information has been propagated, it is examined to make sure that each function that receives a known continuation does not also receive an unknown continuation. The set of functions receiving the known continuation is returned.

⟨pushing continuations 111⟩+≡ (79) ◁ 117 118 ▷

(defun find-letrec-tail-funs (e starts)
(let ((table (compute-plc-table e starts))
    (funs nil))
(dolist (entry (plc-table-entries table) funs)
  (let ((conts (plc-entry-conts entry)))
    (when (member 'known conts)
          (if (member 'unknown conts)
              (return nil)
            (push (plc-entry-name entry) funs)))))))

5.9.6 Inserting the Continuation

Once the funs to receive the continuation represented by kv and kf have been identified, the continuation can be pushed into the functions and the calls in the body can be turned into tail calls.

⟨pushing continuations 111⟩+≡ (79) ◁ 118 119 ▷

(defun push-cont-into-letrec (e kv kf funs)
(let ((kfun (let ((ctx (cexpr-context kf))
                (kvars (if (var-p kv) (list kv) nil)))
            (make-func nil kvars kf 'lambda ctx)))
    (k (make-tmp-var)))
(labels ((pushcont (e)

⟨push continuation into e 119⟩)

         (pushcont-letrec (e)

⟨push continuation into letrec expression e 119⟩))

  (let ((args (mapcar #'pushcont (letrec-args e)))

            (conts (list (drop-conts-from-letrec-body e funs))))
        (remake-cexpr e nil (cons kfun args) (cons k (cexpr-vars e)) conts)))))

Pushing into an expression calls substitute-continuation after descending until there are no more continuations.

⟨push continuation into e 119⟩≡ (118)

(if (letrec-p e)
    (pushcont-letrec e)
  (let ((conts (cexpr-conts e)))
    (if conts
        (remake-cexpr e (cexpr-fun e) (cexpr-args e)
                      (cexpr-vars e) (mapcar #'pushcont conts))
      (substitute-continuation e kv k funs))))

letrec expressions also have the continuation pushed into any functions in the funs.

⟨push continuation into letrec expression e 119⟩≡ (118)

(let* ((args (cexpr-args e))
       (vars (cexpr-vars e))
       (nargs (mapcar #'(lambda (v a)
                          (if (member v funs) (pushcont a) a))
                      vars args))
       (nconts (list (pushcont (letrec-body e)))))
  (remake-cexpr e nil nargs vars nconts))

The function drop-conts-from-letrec-body changes calls to functions in funs in the original letrec body to tail calls.

⟨pushing continuations 111⟩+≡ (79) ◁ 118

(defun drop-conts-from-letrec-body (e funs)
  (labels ((fix-calls (e)
            (if (and (call-p e) (member (call-fun e) funs))
                (remake-cexpr e (call-fun e) (call-args e) nil nil)
              (let ((nconts (mapcar #'fix-calls (cexpr-conts e))))
                (remake-cexpr e (cexpr-fun e) (cexpr-args e) (cexpr-vars e)
                              nconts)))))
    (fix-calls (letrec-body e))))

Lambda and Constant Lifting

This chapter presents two transformation that need to be carried out prior to code generation. The first is lambda lifting. This removes free variables from all functions by passing any free variables they need as additional arguments. When closures are needed, they are constructed as explicit records that contain the free variables and the function (i.e. the code address). The second transformation removes all constants from expression arguments. They are replaced by variables that are bound by primop expressions that load the constant from the constant pool. Functions calls to constant values are converted to symbol calls. ⟨lift.lsp 120⟩≡

  (in-package "NEWCMP")

⟨splitting functions 121⟩ ⟨free variables 126⟩ ⟨lambda lifting 127⟩ ⟨constant lifting 130⟩

6.1 Splitting Functions

Before lambda lifting, an expression needs to be rewritten so that every function falls into one and only one of the following categories:

lambda: An escaping closure. Must only be used as a an argument in a call or a primop. After lambda lifting, these will only be referenced by set-closure-code primops.

local-lambda: A local function called in non-tail position.

tail-lambda: A local function called in tail position.

In addition, local functions must only take required arguments and must only be called with immediate arguments. Calls to local functions originally defined to allow optional and rest argument and multiple value calls to local functions have to be rewritten to provide the appropriate arguments.

A partial form or splitting in which the local-lambda and tail-lambda categories are combined is also useful.

The conversion proceeds recursively. An environment consisting of an association list of (name . data) pairs is maintained. The data consists of a list of the function definition followed by three slots, one for a symbol representing each possible use. When a letrec expression is processed, the environment is augmented by the new functions, and the function definitions and letrec body are processed with the new environment. After processing, the environment is examined and the functions are renamed and rewritten if necessary. When a function use is encountered during processing, an entry in the environment is made and the expression is rewritten if necessary.

6.1.1 Data Structures

The environment entries are represented as a list structure.

⟨splitting functions 121⟩≡ (120) 121 ▷

  (defstruct (spfentry (:type list) (:constructor make-spfentry (name def)))
    name def closure local tail)

The function for looking up definitions is

⟨splitting functions 121⟩+≡ (120) ◁ 121 121 ▷

  (defun lookup-split-functions-def (f env)
    (let ((entry (assoc f env)))
      (if entry (spfentry-def entry) nil)))

The lookup functions for the other values create a value as needed. The definitions of these functions all follow the same pattern that can be expressed with a local macro.

⟨splitting functions 121⟩+≡ (120) ◁ 121 121 ▷

  (macrolet ((define-lookup (name which)
               `(defun ,name (f env)
                  (let ((entry (assoc f env)))
                    (if entry
                        (let ((val (,which entry)))
                          (if val
                              val
                            (let ((nval (spfentry-var entry)))
                              (setf (,which entry) nval)
                              nval)))
                      f)))))
    (define-lookup lookup-split-functions-closure spfentry-closure)
    (define-lookup lookup-split-functions-local spfentry-local)
    (define-lookup lookup-split-functions-tail spfentry-tail))

A function name to use is produced by spfentry-var. The first name requested will be the original function name.

⟨splitting functions 121⟩+≡ (120) ◁ 121 121 ▷

  (defun spfentry-var (entry)
    (let ((name (spfentry-name entry)))
      (if (or (spfentry-closure entry)
              (spfentry-local entry)
              (spfentry-tail entry))
          (copy-var name)
        name)))

6.1.2 Main Functions

The top level function for a full split is split-all-functions. split-local-functions does a

partial split. They each call split-functions with appropriate arguments. split-functions’s arguments are the expression, the environment, and a flag indicating whether the split should be full or partial.

CHAPTER 6. LAMBDA AND CONSTANT LIFTING 122

⟨splitting functions 121⟩+≡ (120) ◁ 121 122 ▷

(defun split-all-functions (e) (split-functions e nil t))
(defun split-local-functions (e) (split-functions e nil nil))
(defun split-functions (e env full)
  (cond
   ((letrec-p e) (split-functions-letrec e env full))
   ((call-p e) (split-functions-call e env full))
   (t (split-functions-cexpr e env full))))

6.1.3 Splitting Functions in letrec Expressions

The split-functions-letrec function starts by creating environment entries for the bound functions, making a new environment, and processing the functions and the letrec body with the new environment.

⟨splitting functions 121⟩+≡ (120) ◁ 121 123 ▷

(defun split-functions-letrec (e env full)
  (let* ((vars (letrec-vars e))
         (args (letrec-args e))
         (frame (mapcar #'make-spfentry vars args))
         (nenv (append frame env))
         (sargs (mapcar #'(lambda (x) (split-functions x nenv full)) args))
         (nbody (split-functions (letrec-body e) nenv full)))
    ⟨split-functions-letrec body 122⟩))

Next, the new function bodies are entered into the def slots of the environment entries in frame. This must be done after processing the bodies to insure that the original definitions are available for processing.

⟨split-functions-letrec body 122⟩≡  (122) 122 ▷
(do ((frame frame (rest frame))
     (sargs sargs (rest sargs)))
    ((or (null frame) (null sargs)))
    (setf (spfentry-def (first frame)) (first sargs)))

Finally the function entries are processed to produce a new set of variables and arguments, and the new letrec expression is created.

⟨split-functions-letrec body 122⟩+≡  (122) ◁ 122
(let ((nargs nil)
      (nvars nil))
  (dolist (entry frame)
    (let ((def (spfentry-def entry))
          (closure (spfentry-closure entry))
          (local (spfentry-local entry))
          (tail (spfentry-tail entry)))

⟨process letrec split-functions entry 122⟩))

  (remake-cexpr e nil (nreverse nargs) (nreverse nvars) (list nbody)))

Processing the entries involves looking at each possible use type in turn. To start off, for a full split if tail is null but the other two are not, then we add a tail reference; the other functions will be rewritten to call the tail-lambda.

⟨process letrec split-functions entry 122⟩≡ (122) 123 ▷

(when (and full (null tail) closure local)
(let ((var (copy-var (spfentry-name entry))))
(setf (spfentry-tail entry) var) ;;**** is this needed?
(setf tail var)))

If there is a tail call to the function, or if a tail reference has been added above, then the function has its arguments and type adjusted, and the modified function and the variable are pushed on their lists.

⟨process letrec split-functions entry 122⟩+≡ (122) ◁ 122 123 ▷

(when tail
(push tail nvars)
(push (fixup-split-function def 'tail-lambda) nargs))

The function fixup-split-function modifies def to have only required arguments and to have the specified type.

⟨splitting functions 121⟩+≡ (120) ◁ 122 123 ▷

(defun fixup-split-function (def newtype)
(let ((nopt (func-nopt def))
(has-rest (func-has-rest def))
(type (func-type def)))
(if (and (= nopt 0) (not has-rest) (eq type newtype))
def
(let ((ndef (copy-func def)))
(incf (func-nreq ndef) (if has-rest (+ nopt 1) nopt))
(setf (func-nopt ndef) 0)
(setf (func-has-rest ndef) nil)
(setf (func-type ndef) newtype)
ndef))))

For a closure we check whether there is also another call. If so, the function is rewritten to call the other function. Otherwise, the function type is adjusted. Then the results are pushed on their lists.

⟨process letrec split-functions entry 122⟩+≡ (122) ◁ 123 124 ▷

(when closure
(push closure nvars)
(let ((other (if full tail local)))
(if other
    (push (wrap-split-function-tail def other 'lambda) nargs)
  (let ((ndef (copy-func def)))
    (setf (func-type ndef) 'lambda)
    (push ndef nargs)))))

Rewriting of the function is handled by wrap-split-function-tail. The new function’s type is type; all other slots in def are preserved.

⟨splitting functions 121⟩+≡ (120) ◁ 123 124 ▷

(defun wrap-split-function-tail (def fun type)
(let ((ndef (copy-func def))
(ctx (func-context def))
(nvars (mapcar #'copy-var (func-vars def))))
(setf (func-type ndef) type)
(setf (func-vars ndef) nvars)
(setf (func-conts ndef) (list (make-call fun nvars nil nil nil nil ctx)))
ndef))

A local function first has its arguments and type adjusted by fixup-split-function. If a tail call is also needed, the function is modified to call the tail function.

⟨process letrec split-functions entry 122⟩+≡ (122) ◁ 123

(when local
(push local nvars)
(let ((ndef (fixup-split-function def 'local-lambda)))
(push (if tail
         (wrap-split-function-tail ndef tail 'local-lambda)
       ndef)
     nargs)))

6.1.4 Rewriting call Expressions

Call arguments need to be adjusted if they refer to closures. If the function is local, then the call may need further adjusting.

⟨splitting functions 121⟩+≡ (120) ◁ 123 124 ▷

(defun split-functions-call (e env full)
(let* ((nargs (mapcar #'(lambda (f) (lookup-split-functions-closure f env))
               (call-args e)))
(form (call-form e))
(nconts (if form (list (split-functions form env full)) nil))
(fun (if (and full (null nconts))
         (lookup-split-functions-tail (call-fun e) env)
       (lookup-split-functions-local (call-fun e) env)))
(def (lookup-split-functions-def (call-fun e) env))
(ne (remake-cexpr e fun nargs (cexpr-vars e) nconts)))
(if def
(if (call-is-mvcall e)
   (rewrite-split-functions-mvcall ne def)
 (rewrite-split-functions-call ne def))
ne)))

A multiple value call to a local function needs to load the arguments from the value registers before making an ordinary call.

⟨splitting functions 121⟩+≡ (120) ◁ 124 124 ▷

(defun rewrite-split-functions-mvcall (e def)
(let* ((nreq (func-nreq def))
(nopt (func-nopt def))
(has-rest (func-has-rest def))
(name (func-name def))
(nvars (mapcar #'copy-var (func-vars def)))
(ne (copy-call e))
(data (list nreq nopt has-rest name)))
(setf (call-is-mvcall ne) nil)
(setf (call-args ne) nvars)
(make-primop 'load-mvargs nil nvars ne data (call-context ne))))

A direct call may need to have missing optional arguments added or a rest argument constructed.

⟨splitting functions 121⟩+≡ (120) ◁ 124 125 ▷

(defun rewrite-split-functions-call (e def)
(let* ((nreq (func-nreq def))
(nopt (func-nopt def))
(has-rest (func-has-rest def))

(nro (+ nreq nopt))
(args (call-args e))
(n (length args)))
(unless (<= nreq n) (too-few-arguments e nreq))
(unless (or (<= n nro) has-rest) (too-many-arguments e nro))
(if (or (< n nro) has-rest)
(let* ((ov (if (< n nro) (make-tmp-var) nil))
(rv (if has-rest
        (if (< nro n) (make-tmp-var) (make-const nil))
      nil))
(oargs (if ov (make-list (- nro n) :initial-element ov) nil))
(rargs (if has-rest (list rv) nil))
(tail (nthcdr nro args))
(head (ldiff args tail))
(nargs (append head oargs rargs))
(ne (copy-call e))
(ctx (primop-context ne)))
(setf (call-args ne) nargs)
(when rv (setf ne (wrap-split-functions-rest ne rv tail ctx)))
(when ov
 (setf ne (make-primop 'load-missing nil (list ov) ne nil ctx)))
ne)
e)))

Rest arguments are constructed by adding cons primops as needed.

⟨splitting functions 121⟩+≡ (120) ◁ 124 125 ▷

(defun wrap-split-functions-rest (e v args ctx)
(if args
(do ((args args (rest args)))
((null (rest args))
(make-primop 'cons (list (first args) (make-const nil)) (list v) e
         nil ctx))
(let ((av (make-tmp-var)))
(setf e (make-primop 'cons (list (first args) av) (list v) e
                  nil ctx))
(setf v av)))
e))

6.1.5 Other Expressions

Other compound expressions have their arguments and continuations adjusted, if necessary. Arguments only need to be changed if they refer to closures.

⟨splitting functions 121⟩+≡ (120) ◁ 125

(defun split-functions-cexpr (e env full)
(let ((nargs (mapcar #'(lambda (f) (lookup-split-functions-closure f env))
        (cexpr-args e)))
(nconts (mapcar #'(lambda (x) (split-functions x env full))
         (cexpr-conts e))))
(remake-cexpr e (cexpr-fun e) nargs (cexpr-vars e) nconts)))

6.2 Find Free Variables

We need a data structure that maps each function to its free variables. In the computation we will also need to find the variables a function binds. The data for each function is stored in an entry defined by

⟨free variables 126⟩≡ (120) 126 ▷

(defstruct (freemap-entry (:type list)
                          (:constructor
                           (make-freemap-entry (def &optional free))))
  def free bound)

The information for all functions is collected into a free map implemented as a hash table.

⟨free variables 126⟩+≡ (120) ◁ 126 126 ▷

(defun make-freemap () (make-hash-table))
(defun add-freemap-entry (entry freemap)
  (setf (gethash (freemap-entry-def entry) freemap) entry))
(defun lookup-freemap-entry (e freemap)
  (gethash e freemap))

The free map needs to be initialized with the free variables directly referenced by each function and the variables bound by each function. This is done by init-freemap.

⟨free variables 126⟩+≡ (120) ◁ 126 126 ▷

(defun init-freemap (e map entry lfuns)
  (if (letrec-p e)
      (init-freemap-letrec e map entry lfuns)
    (init-freemap-cexpr e map entry lfuns)))

For letrec expressions, the function variables are added to the lfuns list and the arguments and body are processed with the new list, nlfuns. The free variables in the argument functions are accumulated in the list afree. Finally the free and bound variables are updated.

⟨free variables 126⟩+≡ (120) ◁ 126 126 ▷

(defun init-freemap-letrec (e map entry lfuns)
  (let* ((vars (cexpr-vars e))
         (nlfuns (append vars lfuns))
         (afree nil))
    (dolist (a (letrec-args e))
      (let ((ae (make-freemap-entry a)))
        (add-freemap-entry ae map)
        (init-freemap a map ae nlfuns)
        (setf afree (union (freemap-entry-free ae) afree))))
    (init-freemap (letrec-body e) map entry nlfuns)
    (let ((free (union afree (freemap-entry-free entry)))
          (bound (freemap-entry-bound entry)))
      (setf (freemap-entry-free entry) (set-difference free vars))
      (setf (freemap-entry-bound entry) (union vars bound)))))

For other expressions, the continuations are processed. Then the free list is updated. Function variables (for calls) are added to the free list if they are not local functions. Variable arguments are added to the free list. Finally, the free list and the bound list of the entry are updated.

⟨free variables 126⟩+≡ (120) ◁ 126 127 ▷

(defun init-freemap-cexpr (e map entry lfuns)
  (let ((vars (cexpr-vars e))

    (args (cexpr-args e))
    (conts (cexpr-conts e))
    (fun (cexpr-fun e)))
(dolist (c conts)
  (init-freemap c map entry lfuns))
(let ((free (freemap-entry-free entry))
      (bound (freemap-entry-bound entry)))
  (when (and (var-p fun) (not (member fun lfuns)))
        (pushnew fun free))
  (dolist (a args)
    (when (var-p a) (pushnew a free)))
  (setf (freemap-entry-free entry) (set-difference free vars))
  (setf (freemap-entry-bound entry) (union vars bound)))))

The function freevars returns a free map for its argument expression. The computation starts by computing a call graph and initializing a free map. We then repeatedly loop through the functions and update the free variables. This continues until there are no changes.

⟨free variables 126⟩+≡ (120) ◁ 126

(defun freevars (e)
(let* ((gr (compute-callgr e))
     (funs (callgr-functions gr))
     (freemap (make-freemap))
     (entry (make-freemap-entry e)))
(add-freemap-entry entry freemap)
(init-freemap e freemap entry nil)
(loop
 (let ((changed nil))
   (dolist (fun funs)
     (let ((entry (lookup-freemap-entry fun freemap)))

⟨update free variables for entry; set changed if needed 127⟩))

   (unless changed (return))))
freemap))

For each entry we loop through all free variables in all callees. If a variable v is not already on the current function’s free list or bound by the function, then it is added to the free list and the changed flag is set.

⟨update free variables for entry; set changed if needed 127⟩≡ (127)

(let* ((free (freemap-entry-free entry))
   (bound (freemap-entry-bound entry)))
(dolist (c (callgr-callees (first entry) gr))
(dolist (v (freemap-entry-free (lookup-freemap-entry c freemap)))
  (unless (or (member v free) (member v bound))
          (push v free)
          (setf changed t))))
(setf (freemap-entry-free entry) free))

6.3 Lambda Lifting

Lambda lifting is done by lambda-lift. This calls lambda-lift-cexpr with the result of freevars as its initial free variables map. It is assumed that function splitting has been carried out.

⟨lambda lifting 127⟩≡ (120) 128 ▷

(defun lambda-lift (e) (lambda-lift-cexpr e nil (freevars e)))

The lambda-lift-cexpr function dispatches to separate handlers for funcs, letrecs, and calls. Other cexprs are handled directly by substituting in their arguments if necessary and processing their continuations.

⟨lambda lifting 127⟩+≡ (120) ◁ 127 128 ▷

  (defun lambda-lift-cexpr (e env map)
    (cond
     ((func-p e) (lambda-lift-func e env map))
     ((letrec-p e) (lambda-lift-letrec e env map))
     ((call-p e) (lambda-lift-call e env map))
     (t (let ((nargs (sublis env (cexpr-args e)))
              (nconts (mapcar #'(lambda (x) (lambda-lift-cexpr x env map))
                              (cexpr-conts e))))
          (remake-cexpr e (cexpr-fun e) nargs (cexpr-vars e) nconts)))))

The func handler lambda-lift-func looks up the function’s free variables in the map, creates new variables, and augments the environment with pairs of free variables and their replacements. The body is processed with the new environment, new function variables are formed from the new free variables followed by the old function variables, and the expression is remade with the new variables and body. Finally, the required argument count is adjusted, if necessary, for the added arguments, and the new expression is returned. For the new VM it may be better to add the free variables at the end of the argument list instead of at the beginning. The new VM will have closure functions responsible for extracting free variables from their closures; with the old VM this is done by the call process. Since the number of free variables is recorded in a function’s nfree slot, this issue could be deferred to the code generation stage.

⟨lambda lifting 127⟩+≡ (120) ◁ 128 128 ▷

  (defun lambda-lift-func (e env map)
    (let* ((entry (lookup-freemap-entry e map))
           (free (if entry (freemap-entry-free entry) nil))
           (fvars (mapcar #'copy-var free))
           (nenv (append (mapcar #'cons free fvars) env))
           (nform (lambda-lift-cexpr (func-body e) nenv map))
           (nvars (append fvars (func-vars e)))
           (ne (remake-cexpr e nil nil nvars (list nform)))
           (nfree (length fvars)))
      (when fvars
            (incf (func-nreq ne) nfree)
            (setf (func-nfree ne) nfree))
      ne))

lambda-lift-letrec uses a separate function to process the environment and the map and to obtain closure-related information. The closure information consists of variable names cvars for the closures, original names clabels, functions cfuns and the combined free variables cfree for any functions needing closures. The functions and body are processed with the new environment and map. The body is then wrapped in set-closure-code expressions and the letrec is remade. Finally, a make-closures is added if needed.

⟨lambda lifting 127⟩+≡ (120) ◁ 128 129 ▷

  (defun lambda-lift-letrec (e env map)
    (let ((args (letrec-args e))
          (vars (letrec-vars e)))
      (multiple-value-bind (nenv cvars clabels cfuns cfree)
                           (lambda-lift-letrec-info args vars env map)
        (let* ((nbody (lambda-lift-cexpr (letrec-body e) nenv map))

               (nargs (mapcar #'(lambda (a) (lambda-lift-func a nenv map)) args))
               (ctx (primop-context e))
               (nnbody (wrap-set-closure-code cvars clabels cfuns nbody ctx))
               (ne (make-letrec vars nargs nnbody ctx)))
          (if cvars
              (if cfree
                  (let* ((scargs (cons (first cvars) cfree))
                         (nne (make-primop 'set-closure-data scargs nil ne
                                           nil (primop-context ne))))
                    (make-primop 'make-closures nil cvars nne (length cfree)
                                 ctx))
                (make-primop 'make-closures nil cvars ne 0 ctx))
            ne)))))

The function lambda-lift-letrec-info computes the new environment and the closure information. It loops through the vars and args. If the function needs a closure (i.e. has type lambda) a variable is created, the new variable, old variable, and function are added to cvars, clabels, and cfuns, respectively, and a pair of the old and new variable is added to the environment nenv. In addition, the free variables are added to a combined free variable set cfree. If the function does not need a closure, a list of the variable and the function’s free variables is added to nenv. The environment is then adjusted to give each closure function its new, possibly expanded, free variables. This is needed when processing the functions. The new environment and the accumulated closure information are returned as multiple values.

⟨lambda lifting 127⟩+≡ (120) ◁ 128 129 ▷

  (defun lambda-lift-letrec-info (args vars env map)
    (let ((nenv env)
          (cvars nil)
          (clabels nil)
          (cfuns nil)
          (cfree nil))
      (do ((vars vars (rest vars))
           (args args (rest args)))
          ((or (null vars) (null args)))
          (let* ((v (first vars))
                 (a (first args))
                 (free (freemap-entry-free (lookup-freemap-entry a map))))
            (if (eq (func-type a) 'lambda)
                (let ((cv (copy-var v)))
                  (push cv cvars)
                  (push v clabels)
                  (push a cfuns)
                  (push (cons v cv) nenv)
                  (setf cfree (union free cfree)))
              (add-freemap-entry (make-freemap-entry v free) map))))
      (dolist (c cfuns) (add-freemap-entry (make-freemap-entry c cfree) map))
      (let ((ncfree (sublis nenv cfree))) ;; in case closures are free
        (values nenv cvars clabels cfuns ncfree))))
   Adding set-closure-code primops to the body is handled by wrap-set-closure-code. It

loops through the variables, labels, and functions. For each triple it places a set-closure-code operation around the body. The primop records the function name as primop data as long as it is an interned symbol; this is used in marking the closure.

⟨lambda lifting 127⟩+≡ (120) ◁ 129 130 ▷

  (defun wrap-set-closure-code (cvars clabels cfuns body ctx)
    (do ((cvars cvars (rest cvars))
         (clabels clabels (rest clabels))
         (cfuns cfuns (rest cfuns)))
        ((or (null cvars) (null clabels) (null cfuns)))
        (let* ((cv (first cvars))
               (lbl (first clabels))
               (name (func-name (first cfuns)))
               (iname (if (symbol-package name) name nil)))
          (setf body
                (make-primop 'set-closure-code (list cv lbl) nil body iname
                             ctx))))
    body)

Call lifting involves prepending free variables of the function to the arguments, substituting the arguments from the environment, and processing the call continuation form if there is one. Local functions will not be called with multiple values.

⟨lambda lifting 127⟩+≡ (120) ◁ 129

  (defun lambda-lift-call (e env map)
    (let* ((fun (call-fun e))
           (nfun (sublis env fun))
           (args (call-args e))
           (vars (call-vars e))
           (form (call-form e))
           (nconts (if form (list (lambda-lift-cexpr form env map)) nil))
           (entry (lookup-freemap-entry fun map))
           (free (if entry (freemap-entry-free entry) nil))
           (nargs (sublis env (append free args))))
      (remake-cexpr e nfun nargs vars nconts)))

6.4 Constant Lifting

Constant lifting replaces all constant arguments with variables bound by load-constant primops that load the constant from the constants table. In addition, functions for calls are examined and constants are replaced by symbols.

The main function for constant lifting is lift-constants; it calls lift-constants-1 with the expression and a nil environment. The environment is used to maintain a mapping of constants to variables bound to them in order to avoid loading the same constant several times within a function. If there are constant arguments, then variables are created for the constants and the expression is wrapped with load-constant primops. If there are no constants, the continuations are processed and the expression is remade. For letrec expressions, the bound functions are processed with a nil environment—constants must be reloaded for each function.

⟨constant lifting 130⟩≡ (120)

  (defun lift-constants (e) (lift-constants-1 e nil))
  (defun lift-constants-1 (e env)
    (flet ((lift-env (x) (lift-constants-1 x env)))

(let ((fun ⟨get lifted function field 131⟩)

            (args (cexpr-args e))
            (vars (cexpr-vars e)))

        (if (some #'const-p args)
            (let ((rargs nil)
                  (cvars nil)
                  (consts nil))

⟨find and make variables for constants to load 131⟩ ⟨wrap e in constant loading expressions 131⟩)

          (let ((nconts (mapcar #'lift-env (cexpr-conts e)))
                (nargs (if (letrec-p e) (mapcar #'lift-constants args) args)))
            (remake-cexpr e fun nargs vars nconts))))))

The function field of a call might be a constant. If the constant value is a symbol, then the constant is replaced by its value. No check is made to insure that constants only appears in call expressions.

⟨get lifted function field 131⟩≡ (130)

  (let ((fun (cexpr-fun e)))
    (if (and (const-p fun) (symbolp (const-value fun)))
        (const-value fun)
      fun))

When constants are present, the argument list is processed. Variables are pushed on the rargs list. Constants for which variables are already available in env are replaced by their variables, which are pushed onto rargs. new constants have a variable created, the variable is pushed onto cvars and rarngs, the value is pushed on consts, and the value/variable pair is pushed on env. The variable is created with the appropriate eql type.

⟨find and make variables for constants to load 131⟩≡ (130)

  (dolist (a args)
    (if (const-p a)
        (let ((v (cdr (flet ((test (x y) (eql (const-value x) (const-value y))))
                        (assoc a env :test #'test)))))
          (if v
              (push v rargs)
            (let* ((sym (gensym "CONST"))
                   (v (make-var sym `(eql ,(const-value a)) nil)))
              (push v cvars)
              (push v rargs)
              (push a consts)
              (push (cons a v) env))))
      (push a rargs)))

After the arguments have been processed, the continuations are processed. This will use the new env value and thus avoid loading constants for the continuations that have already been loaded. The expression is remade with the new continuations and arguments the reverse of rargs. Then a load-constant primop is wrapped around the expression for each variable/constant pair in the cvars and consts lists. The wrapped expression is returned.

⟨wrap e in constant loading expressions 131⟩≡ (130)

  (let* ((nconts (mapcar #'lift-env (cexpr-conts e)))
         (ne (remake-cexpr e fun (nreverse rargs) vars nconts))
         (ctx (cexpr-context ne)))
    (do ((cvars cvars (rest cvars))
         (consts consts (rest consts)))
        ((or (null cvars) (null consts)))
        (let ((vl (list (first cvars)))
              (cv (const-value (first consts))))

CHAPTER 6. LAMBDA AND CONSTANT LIFTING 132

(setf ne (make-primop 'load-constant nil vl ne cv ctx))))
ne)

Code Generation for the Old Machine

This chapter presents a code generator based on the existing byte code engine. A few new opcodes have been added, but otherwise the engine remains substantially unchanged. ⟨gencode.lsp 133⟩≡ 160 ▷

  (in-package "NEWCMP")

⟨register assignment 133⟩

⟨computing frame sizes 141⟩

⟨code representation and emission 142⟩ ⟨main entry point 143⟩ ⟨function code generators 144⟩ ⟨primop code generators 144⟩ ⟨testop code generators 155⟩ ⟨letrec code generators 157⟩ ⟨call code generators 158⟩

7.1 Register Assignment

Register assignment is done by a function regassign. This function takes a cexpr and returns a mapping of variables to register indices. The lookup function is find-register. At the moment the mapping representation is an association list.

⟨register assignment 133⟩≡ (133) 134 ▷

  (defun find-register (v regs)
    (let ((r (cdr (assoc v regs))))
      (unless r (error "can't find register for ~s" v))
      r))

One peculiarity that the assignment process needs to handle is that some primops need a scratch register. The new machine will have separate tail and non-tail opcodes, but the old one does not.

7.1.1 A Simple Version

This simple version implemented by regassign-cexpr just gives each variable in a function its own register. The base argument represents the largest register index already used. A base of zero is used by the top level call and by calls for handling letrec arguments.

⟨simple register assignment 133⟩≡ 134 ▷

  (defun regassign-cexpr (e base regs)
    (if (letrec-p e)
        (dolist (f (letrec-args e))
          (setf regs (regassign-cexpr f 0 regs)))
      (dolist (v (cexpr-vars e))
        (incf base)
        (push (cons v base) regs)))
    (let ((conts (cexpr-conts e)))
      (dolist (c conts regs)
        (setf regs (regassign-cexpr c base regs)))))

The definition of regassign in terms of this function appends an entry for a scratch register.

⟨simple register assignment 133⟩+≡  ◁ 133 134 ▷

  (defun regassign (e)
    (let* ((regs (regassign-cexpr e 0 nil))
           (nr (let ((nr 0)) (dolist (r regs nr) (setf nr (max nr (cdr r)))))))
      (cons (cons 'scratch (+ nr 1)) regs)))

The corresponding definition of find-primop-value-register is

⟨simple register assignment 133⟩+≡  ◁ 134

  (defun find-primop-value-register (e regs)
    (let ((vars (primop-vars e)))
      (find-register (if vars (first vars) 'scratch) regs)))

7.1.2 Register Allocation by Graph Coloring

A more complex version uses graph coloring, as in [2, Chapter 11]. We have, conceptually, an infinite number of “registers”, so spilling is not needed (yet), but we can use an interference graph to decide which of the moves needed for tail calls can be handled by coalescing. Ideally, moves should be prioritized according the the loop nesting level where they occur, but for now all moves are considered equal priority.

Interference Graph Data

We need data structures to represent the interference graph and interference graph nodes. A variable is used to hold the current index for numbering nodes. This variables is bound in regassign. The index is needed to remove some randomness from orderings produced by traversing hash tables.

⟨register assignment 133⟩+≡ (133) ◁ 133 135 ▷

  (defstruct (intgr-node (:constructor new-intgr-node (values register)))
    values register index)
  (defstruct intgr
    (valmap (make-hash-table)) (edges (make-hash-table)) moves)
  (defvar *intgr-node-index*)

The constructor function for nodes is make-intgr-node. The first argument, vals, is a list of values, typically variables, associated with the node. The second argument, graph, specifies the graph to which the new node is to be added. A register can be supplied as an optional third argument. The constructor puts an empty entry in the edges table and enters the node as the node associated with each of the vals in the valmap table. The index field is set from the current value of the global index variable; then the variable in incremented.

⟨register assignment 133⟩+≡ (133) ◁ 134 135 ▷

  (defun make-intgr-node (vals graph &optional register)
    (let ((n (new-intgr-node vals register))
          (valmap (intgr-valmap graph)))
      (setf (intgr-node-index n) *intgr-node-index*)
      (incf *intgr-node-index*)
      (setf (gethash n (intgr-edges graph)) nil)
      (dolist (v vals) (setf (gethash v valmap) n))
      n))

The node associated with a value in a graph can be looked up with find-intgr-node.

⟨register assignment 133⟩+≡ (133) ◁ 135 135 ▷

  (defun find-intgr-node (v graph)
    (gethash v (intgr-valmap graph)))

Edges are added to the graph by add-intgr-edge.

⟨register assignment 133⟩+≡ (133) ◁ 135 135 ▷

  (defun add-intgr-edge (i j graph)
    (pushnew j (gethash i (intgr-edges graph)))
    (pushnew i (gethash j (intgr-edges graph))))

The presence of an edge is tested by intgr-has-edge.

⟨register assignment 133⟩+≡ (133) ◁ 135 135 ▷

  (defun intgr-has-edge (i j graph)
    (member j (gethash i (intgr-edges graph))))

The siblings of a node are returned by intgr-siblings

⟨register assignment 133⟩+≡ (133) ◁ 135 135 ▷

  (defun intgr-siblings (i gr)
    (gethash i (intgr-edges gr)))

The function intgr-delete-node deletes a node and all its incident edges from a graph. This function seems quite time critical for large programs because of the linear searches for deleting the node form its sibling’s edge lists. This is why the destructive delete is used, along with the :count keyword, since it is known that i must appear exactly once in the list. It might be worth exploring using hash tables in place of lists. Speed of access would clearly improve, though the memory cost and the overhead time of creation might be too high.

⟨register assignment 133⟩+≡ (133) ◁ 135 136 ▷

  (defun intgr-delete-node (i gr)
    (let* ((edges (intgr-edges gr))
           (sibs (gethash i edges))
           (valmap (intgr-valmap gr)))
      (remhash i edges)
      (dolist (v (intgr-node-values i)) (remhash v valmap))
      (dolist (s sibs)
        (setf (gethash s edges) (delete i (gethash s edges) :count 1)))))

A list of the nodes in a graph is computed by intgr-graph. Since the node constructor insures that every node has an entry in the edges table, though it may be empty, a maphash on this table produces all the nodes in the graph. It would be possible to maintain a node list in the graph structure, but this increases the cost of the node deletion operation. Caching the list once it is computed is also possible but doesn’t seem worth while. Since the hash table produces an unpredictable order for the nodes, the nodes are sorted in reverse order to their creation. This insures that repeated compilations of the same code will produce identical register assignments; this is essential for debugging the compiler.

⟨register assignment 133⟩+≡ (133) ◁ 135 136 ▷

  (defun intgr-nodes (gr)
    (let ((nodes nil))
      (maphash #'(lambda (x y) (declare (ignore y)) (push x nodes))
               (intgr-edges gr))
      (stable-sort nodes #'(lambda (x y)
                             (> (intgr-node-index x) (intgr-node-index y))))))

For debugging, the function show-intgr returns a representation of the graph.

⟨register assignment 133⟩+≡ (133) ◁ 136 136 ▷

  (defun show-intgr (gr)
    (flet ((show-node (n)
             (mapcar #'(lambda (v) (if (var-p v) v 'primop))
                     (intgr-node-values n))))
      (mapcar #'(lambda (n)
                  (list (show-node n)
                        (mapcar #'show-node (intgr-siblings n gr))))
              (intgr-nodes gr))))

Computing the Interference Graph

The interference graph is computed by fill-intgr-cexpr. letrec expressions are handled separately by fill-intgr-letrec, but other cexprs are handled directly by fill-intgr-cexpr. These functions return the free variables in the expression.

For generic cexprs, fill-intgr-cexpr starts by creating nodes in graph for the variables bound by the expression. These nodes are assigned to the variable nodes. Next, the expression’s continuations are processed and the free variables in the continuations are saved in cfree. The outgoing free variables, assigned to outfree, are the difference between the free variables in cfree and the variables in vars bound by the current expression. The incoming free variables infree are the union of outfree and the variables in args. After setting up these variables in a let*, the function adds interference edges for the nodes with each other and for the nodes with the nodes corresponding to the outfree variables. Finally, some additional processing is carried out for some expressions and infree is returned.

⟨register assignment 133⟩+≡ (133) ◁ 136 138 ▷

  (defun fill-intgr-cexpr (e env graph)
    (if (letrec-p e)
        (fill-intgr-letrec e env graph)
      (let* ((conts (cexpr-conts e))
             (vars (cexpr-vars e))
             (args (cexpr-args e))

(nodes ⟨create and return nodes in graph for vars 137⟩) (cfree ⟨fill graph for conts and find free variables 137⟩)

             (outfree (set-difference cfree vars))
             (fargs (let ((fun (cexpr-fun e)))
                      (if (and (var-p fun) (null (assoc fun env)))
                          (list fun)
                        nil)))

             (infree (union (union fargs args) outfree)))

⟨add interference edges for nodes with each other 137⟩ ⟨add interference edges for nodes and outfree 137⟩ ⟨additional interference graph processing for some special cases 137⟩

        infree)))

The nodes for the variables bound by a cexpr are created by

⟨create and return nodes in graph for vars 137⟩≡ (136)

  (mapcar #'(lambda (v) (make-intgr-node (list v) graph)) vars)

The continuations conts are processed by

⟨fill graph for conts and find free variables 137⟩≡ (136)

  (let ((free nil))
    (dolist (c conts free)
      (let ((cf (fill-intgr-cexpr c env graph)))
        (setf free (union cf free)))))

The result returned by this expression is the union of the free variables in the conts.

The nodes for the variables bound by the cexpr are marked as interfering with each other by looping through successive rests of nodes and for each head adding an edge between the head and each element of the tail.

⟨add interference edges for nodes with each other 137⟩≡ (136)

  (do ((nodes nodes (rest nodes)))
      ((null nodes))
      (let ((n (first nodes)))
        (dolist (i (rest nodes))
          (add-intgr-edge n i graph))))

A double loop over the nodes and the outfree variables is used to add their interference edges. The when test is needed since outfree may include variables bound in letrec expressions and are used in creating closures—these do not need registers and therefore do not have nodes in the interference graph.

⟨add interference edges for nodes and outfree 137⟩≡ (136)

  (dolist (n nodes)
    (dolist (f outfree)
      (let ((fn (find-intgr-node f graph)))
        (when fn (add-intgr-edge n fn graph)))))

Certain cexprs require some additional processing. Some primops need a scratch register, move instructions need to be added for local tail calls (and for all local calls for the new machine), and for escaping functions the parameters have to be assigned to the standard registers used by the calling convention. The criterion used for determining whether a primop needs a scratch register is that it binds no variables. This will include a few cases where a scratch register isn’t really needed, but it keeps things simple.

⟨additional interference graph processing for some special cases 137⟩≡ (136)

  (cond
    ((and (null vars) (primop-p e))

⟨add scratch register for primop e 138⟩)

    ((local-tail-call-p e env)

⟨add moves to graph for local tail call e 138⟩)

    ((escaping-function-p e)

⟨assign registers to nodes for escaping function calling 138⟩))

Scratch registers for primops that need them are provided by adding a node with the expression as the node data. The node interferes with all the outfree variables. Again, the when test is needed since some of the variables in outfree may be variables bound in letrec expressions that do not need registers.

⟨add scratch register for primop e 138⟩≡ (137)

  (let ((s (make-intgr-node (list e) graph)))
    (dolist (f outfree)
      (let ((fn (find-intgr-node f graph)))
        (when fn (add-intgr-edge s fn graph)))))

After register allocation the corresponding scratch register will be stored in the register mapping under the key of the primop expression itself. The definition of find-primop-value-register is therefore

⟨register assignment 133⟩+≡ (133) ◁ 136 138 ▷

  (defun find-primop-value-register (e regs)
    (let ((vars (primop-vars e)))
      (find-register (if vars (first vars) e) regs)))

Tail calls to local functions are recognized by

⟨register assignment 133⟩+≡ (133) ◁ 138 138 ▷

  (defun local-tail-call-p (e env)
    (and (call-p e) (null (call-form e)) (assoc (call-fun e) env)))

The environment allows the function definition to be looked up. Moves for the argument nodes to the parameter nodes are registered by

⟨add moves to graph for local tail call e 138⟩≡ (137)

  (do ((src (call-args e) (rest src))
       (tgt (func-vars (cdr (assoc (call-fun e) env))) (rest tgt)))
      ((or (null src) (null tgt)))
      (push (list (first src) (first tgt) 0) (intgr-moves graph)))

The third element of the moves list is a priority level. For now, all priorities are zero.

For escaping functions, recognized by

⟨register assignment 133⟩+≡ (133) ◁ 138 138 ▷

  (defun escaping-function-p (e)
    (and (func-p e) (member (func-type e) '(lambda local-lambda))))

we can assign registers to their argument nodes.

⟨assign registers to nodes for escaping function calling 138⟩≡ (137)

  (let ((r 1))
    (dolist (n nodes)
      (setf (intgr-node-register n) r)
      (incf r)))

Finally, letrec expressions are handled by adding the bindings to the environment and using this new environment in the processing of the functions and the body. Only free variables from the body are returned since the functions are assumed not to have any (other than labels) due to lambda lifting.

⟨register assignment 133⟩+≡ (133) ◁ 138 139 ▷

  (defun fill-intgr-letrec (e env graph)
    (let* ((args (letrec-args e))
           (vars (letrec-vars e))
           (nenv (append (mapcar #'cons vars args) env)))
      (dolist (a args) (fill-intgr-cexpr a nenv graph))
      (fill-intgr-cexpr (letrec-body e) nenv graph)))

CHAPTER 7. CODE GENERATION FOR THE OLD MACHINE 139

Coalescing Nodes

A pair of non-conflicting nodes is coalesced by intgr-coalesce-nodes. The nodes should be different, should not interfere, and if both have register assignments they should agree.

⟨register assignment 133⟩+≡ (133) ◁ 138 139 ▷

(defun intgr-coalesce-nodes (i j gr)
(when (or (eq i j) (intgr-has-edge i j gr))
(break)
(error "can't coalesce nodes that interfere"))
(let ((i-sibs (intgr-siblings i gr))
(j-sibs (intgr-siblings j gr))
(ri (intgr-node-register i))
(rj (intgr-node-register j))
(vals (append (intgr-node-values i) (intgr-node-values j))))
(when (and ri rj (/= ri rj))
  (error "conflicting register assignments"))
(intgr-delete-node i gr)
(intgr-delete-node j gr)
(let ((n (make-intgr-node vals gr (if ri ri rj))))
(dolist (is i-sibs) (add-intgr-edge n is gr))
(dolist (js j-sibs) (add-intgr-edge n js gr))
n)))

After filling the graph based on variable conflicts, we need to coalesce any nodes that have the same preassigned register. The function coalesce-preassigned-nodes first collects the nodes assigned to each register in an association list alist. Then each group with a common preassigned register is coalesced into a single node.

⟨register assignment 133⟩+≡ (133) ◁ 139 139 ▷

(defun coalesce-preassigned-nodes (gr)
(let ((alist nil))
(dolist (n (intgr-nodes gr))
(let ((r (intgr-node-register n)))
(when r
      (let ((entry (assoc r alist)))
        (if entry
            (push n (rest entry))
          (push (list r n) alist))))))
(dolist (nodes (mapcar #'rest alist))
(let ((i (first nodes)))
(dolist (j (rest nodes))
  (setf i (intgr-coalesce-nodes i j gr)))))))

Moves are coalesced by calling intgr-coalesce-nodes for each eligible pair in the moves list of the graph. The moves are pre-sorted by a priority value.

⟨register assignment 133⟩+≡ (133) ◁ 139 140 ▷

(defun coalesce-intgr-moves (gr)
(let ((moves (stable-sort (intgr-moves gr)
                    #'(lambda (x y) (> (third x) (third y))))))
(dolist (m moves)
(let ((i (find-intgr-node (first m) gr))
    (j (find-intgr-node (second m) gr)))
(unless (or (eq i j) (intgr-has-edge i j gr))
        (intgr-coalesce-nodes i j gr))))))

Coloring the Nodes

The function intgr-color assigns registers to nodes by coloring the graph and then constructs and returns an association list for the variables and other values and the assigned registers.

⟨register assignment 133⟩+≡ (133) ◁ 139 140 ▷

  (defun intgr-color (gr)

⟨assign register ‘‘colors” to graph nodes 140⟩ ⟨create variable/register association list 140⟩)

The nodes are colored by going though the nodes list and for each node without a register assignment choosing the lowest register index not used by a node that interferes with the current node (a sibling node).

⟨assign register ‘‘colors” to graph nodes 140⟩≡ (140)

  (dolist (n (intgr-nodes gr))
    (unless (intgr-node-register n)

(let* ((used ⟨compute list of registers in use 140⟩)

(r ⟨compute smallest index not in used 140⟩))

              (setf (intgr-node-register n) r))))

The registers in use are computed by

⟨compute list of registers in use 140⟩≡ (140)

  (let ((regs nil))
    (dolist (s (intgr-siblings n gr) regs)
      (let ((r (intgr-node-register s)))
        (when r (push r regs)))))

The smallest index of a register not in use is returned by

⟨compute smallest index not in used 140⟩≡ (140)

  (do ((i 1 (+ i 1)))
      ((not (member i used)) i))

The variable/register association list is created by looping through the nodes and the variables and other values represented by each node.

⟨create variable/register association list 140⟩≡ (140)

    (let ((regs nil))
      (dolist (n (intgr-nodes gr) regs)
        (let ((r (intgr-node-register n)))
          (dolist (v (intgr-node-values n))
            (push (cons v r) regs)))))

The regassign function based on graph coloring creates a graph, binds the node index variable to zero, fills the graph, coalesces nodes, moves nodes, and finally colors nodes.

⟨register assignment 133⟩+≡ (133) ◁ 140

  (defun regassign (e)
    (let ((gr (make-intgr))
          (*intgr-node-index* 0))
      (fill-intgr-cexpr e nil gr)
      (coalesce-preassigned-nodes gr)
      (coalesce-intgr-moves gr)
      (intgr-color gr)))

7.2 Computing Frame Sizes

Given a call graph, the frame size computation starts by computing the maximal register index for each function. This is done by find-regmax. This function only follows the body of letrecs, not the function arguments. For other cexprs the maximal register value for bound variables is computed. If the expression is a tail primop, this is combined with the scratch register for the expression. For other cexprs it is passed on to find-regmax-conts along with the list of continuations.

⟨computing frame sizes 141⟩≡ (133) 141 ▷

  (defun find-regmax (e rmax regs)
    (if (letrec-p e)
        (find-regmax (letrec-body e) rmax regs)
      (let* ((vregs (mapcar #'(lambda (x) (find-register x regs))
                            (cexpr-vars e)))
             (nrmax (reduce #'max vregs :initial-value rmax)))
        (if (and (primop-p e) (null (cexpr-vars e)))
            (let* ((sreg (find-register e regs))
                   (nnrmax (if sreg (max sreg nrmax) nrmax)))
              (find-regmax-conts (cexpr-conts e) nnrmax regs))
          (find-regmax-conts (cexpr-conts e) nrmax regs)))))

The find-regmax-conts function takes a list of continuations, a current maximum in rmax, and a register assignment in regs. If there are no more continuations, rmax is returned. Otherwise, find-regmax-conts is called with the maximal register index in the first continuation and the rest of the conts as arguments.

⟨computing frame sizes 141⟩+≡ (133) ◁ 141 141 ▷

  (defun find-regmax-conts (conts rmax regs)
    (if (null conts)
        rmax
      (let ((nrmax (find-regmax (first conts) rmax regs)))
        (find-regmax-conts (rest conts) nrmax regs))))

Frame size computation is done by compute-frame-sizes. This function takes a top-level function and a register assignment as arguments. First a call graph is computed, then the functions in the graph are obtained, and an initial association list of functions and their maximal register indices is computed as env. This list is then adjusted in a loop.

⟨computing frame sizes 141⟩+≡ (133) ◁ 141 142 ▷

  (defun compute-frame-sizes (e regs)
    (let* ((gr (compute-callgr e))
           (funs (callgr-functions gr))
           (env (mapcar #'(lambda (x) (cons x (find-regmax x 0 regs))) funs)))

⟨loop to update the frame sizes 141⟩

      env))

Each iteration of the loop loops over all the funs. For each function f, it then loops through all callees that are tail-lambdas. If the entry for f is not large enough to accommodate the needs of a callee c, then the entry for f is increased. The outer loop is repeated until no entries are changed.

⟨loop to update the frame sizes 141⟩≡ (141)

  (loop
   (let ((changed nil))
     (dolist (f funs)
       (let ((entry (assoc f env)))
         (dolist (c (callgr-callees f gr))

           (when (eq (func-type c) 'tail-lambda)
                 (let ((cmax (cdr (assoc c env))))
                   (when (< (cdr entry) cmax)
                         (setf (cdr entry) cmax)
                         (setf changed t)))))))
     (unless changed (return))))

The result returned by compute-frame-sizes is used as the initial environment in code generation. The lookup function for finding a function’s frame size is therefore

⟨computing frame sizes 141⟩+≡ (133) ◁ 141

  (defun find-frame-size (e env)
    (cdr (assoc e env)))

7.3 Code Representation and Emission

During code generation the result is stored in a list of three elements, the code, the literals, and the labels of escaping functions. Each of these elements is a list that is built up in reverse order. After code generation is complete, they are reversed and returned as the three values of gencode. The code list consists of variables, representing labels, and lists, representing opcodes and arguments.

The function push-instruction pushes an instruction onto the code position of cl.

⟨code representation and emission 142⟩≡ (133) 142 ▷

  (defun push-instruction (inst cl)
    (push inst (first cl)))

Return instructions are emitted by push-return-instruction. This function incorporates a peephole optimization that rewrites value setting followed by a return as a single opcode.

⟨code representation and emission 142⟩+≡ (133) ◁ 142 142 ▷

  (defun push-return-instruction (cl)
    (let ((prev (first (first cl))))
      (case (if (consp prev) (first prev) nil)
            (xlscmp::%set-one-value
             (setf (first (first cl))
                   `(xlscmp::%set-one-value-return 0 ,(second prev))))
            (xlscmp::%set-values
             (setf (first (first cl))
                   `(xlscmp::%set-values-return 0 ,@(rest prev))))
            (xlscmp::%set-values-list
             (setf (first (first cl))
                   `(xlscmp::%set-values-list-return 0 ,(second prev))))
            (t (push-instruction `(xlscmp::%return 0) cl)))))

Labels are emitted by push-label-instruction. Another peephole optimization drops the preceding instruction if it is a goto with the label as its target—the code just falls through.

⟨code representation and emission 142⟩+≡ (133) ◁ 142 143 ▷

  (defun push-label-instruction (label cl)
    (let ((prev (first (first cl))))
      (cond
       ((and (consp prev)
             (eq (first prev) 'xlscmp::%goto)
             (eq (second prev) label))
        (pop (first cl))
        (push-instruction label cl))
       (t (push-instruction label cl)))))

Literal values are looked up and entered by find-literal. If a literal is found, its index is returned. Otherwise, it is entered in the literals position and the index is returned.

⟨code representation and emission 142⟩+≡ (133) ◁ 142 143 ▷

(defun find-literal (lit cl)
(let ((n (length (second cl)))
     (i (position lit (second cl))))
 (if i
     (- n 1 i)
   (progn (push lit (second cl))
          n))))

Labels are represented as var structures. Most labels entered in the code correspond to variables bound in letrec expressions. But new ones are needed for testops, for for catch-related primops, and for the top-level function.

⟨code representation and emission 142⟩+≡ (133) ◁ 143

(defun make-label-var (sym)
(make-var sym t nil))

7.4 Main Entry Point

The main entry point for code generation is gencode. It creates a label for the top-level function, creates an initial data list, does register assignment and frame size determination, and then generates the code. Three values are returned, the code, the literals, and the labels representing entry points of escaping functions.

⟨main entry point 143⟩≡ (133) 143 ▷

(defun gencode (e)
(let* ((mv (make-label-var 'main))
      (cl (list (list mv) nil (list mv)))
      (regs (regassign e))
      (env (compute-frame-sizes e regs)))
 (gencode-cexpr e regs env cl)
 (values (nreverse (first cl))
         (nreverse (second cl))
         (nreverse (third cl)))))

Code generation itself is carried out by gencode-cexpr. This function just dispatches on the expression type.

⟨main entry point 143⟩+≡ (133) ◁ 143

(defun gencode-cexpr (e regs env cl)
(cond
((func-p e)
 (case (func-type e)
       (lambda (gencode-lambda e regs env cl))
       (local-lambda (gencode-local-lambda e regs env cl))
       (tail-lambda (gencode-tail-lambda e regs env cl))))
((primop-p e) (gencode-primop e regs env cl))
((testop-p e) (gencode-testop e regs env cl))
((letrec-p e) (gencode-letrec e regs env cl))
((call-p e) (gencode-call e regs env cl))
(t (error "don't know how to generate code for ~s" e))))

7.5 Function Code Generators

Code generation for escaping functions emits header code and then the body code.

⟨function code generators 144⟩≡ (133) 144 ▷

(defun gencode-lambda (e regs env cl)
  (let* ((nv (length (func-vars e)))
         (nr (find-frame-size e env))
         (ntmp (- nr nv))
         (nreq (func-nreq e))
         (nopt (func-nopt e))
         (have-rest (func-has-rest e)))
    (cond
     (have-rest

⟨emit header code for function with a rest argument 144⟩)

     ((< 0 nopt)

⟨emit header code for function with optional arguments 144⟩)

     (t (push-instruction `(xlscmp::%initialize-0 ,(+ nv 1) 0 ,ntmp) cl)))
    (gencode-cexpr (func-body e) regs env cl)))

The header code for functions with rest arguments is emitted by

⟨emit header code for function with a rest argument 144⟩≡ (144)

(let* ((nreq+1 (+ nreq 1))
       (odefs (make-array nopt :initial-element 'xlscmp::%not-supplied))
       (ol (find-literal odefs cl)))
  (if (= nopt 0)
      (push-instruction `(xlscmp::%initialize 2 ,nreq+1 0 0 ,ntmp) cl)
    (push-instruction `(xlscmp::%initialize 2 ,nreq+1 ,nopt ,ol 0 ,ntmp)
                      cl)))

Header code for functions with only optional arguments is emitted by

⟨emit header code for function with optional arguments 144⟩≡ (144)

(let* ((nreq+1 (+ nreq 1))
       (odefs (make-array nopt :initial-element 'xlscmp::%not-supplied))
       (ol (find-literal odefs cl)))
  (push-instruction `(xlscmp::%initialize 1 ,nreq+1 ,nopt ,ol 0 ,ntmp)
                    cl))

Local functions called in non-tail position can also be handled by gencode-lambda. They will only have required arguments.

⟨function code generators 144⟩+≡ (133) ◁ 144 144 ▷

(defun gencode-local-lambda (e regs env cl)
  (gencode-lambda e regs env cl))

Local functions called in tail position do not require any setup code:

⟨function code generators 144⟩+≡ (133) ◁ 144

(defun gencode-tail-lambda (e regs env cl)
  (gencode-cexpr (func-body e) regs env cl))

7.6 Primop Code Generators

Code generation for primop expressions is based on generators stored in a hash table. A macro is provided for defining new generators.

⟨primop code generators 144⟩≡ (133) 145 ▷

(let ((table (make-hash-table)))
(defun get-primop-generator (op) (gethash op table))
(defun set-primop-generator (op g) (setf (gethash op table) g)))
(defun gencode-primop (e regs env cl)
(let ((g (get-primop-generator (primop-fun e))))
  (unless g (error "can't generate code for primop ~s" (primop-fun e)))
  (funcall g e regs env cl)))
(defmacro define-primop-generator (which args &rest body)
`(progn
   (set-primop-generator ',which #'(lambda ,args ,@body))
   ',which))

Most primops return a single result. The function gencode-primop-cont-1 generates the continuation code for these primops. In non-tail position, the continuation form is processed. In tail position, code is generated to place the single value in the value registers and execute a return.

⟨primop code generators 144⟩+≡ (133) ◁ 144 145 ▷

(defun gencode-primop-cont-1 (e regs env cl)
(let ((form (primop-form e)))
  (if form
      (gencode-cexpr form regs env cl)
    (let ((vr (find-primop-value-register e regs)))
      (push-instruction `(xlscmp::%set-one-value ,vr) cl)
      (push-return-instruction cl)))))

The macro define-simple-primop-generator defines a generator for a primop that returns one value. The macro takes a variable representing the argument registers, a variable representing the value register, and a template for the instruction, and expands to an expression that fills in the template.

⟨primop code generators 144⟩+≡ (133) ◁ 145 145 ▷

(defmacro define-simple-primop-generator (which (aregs vreg) form)
`(define-primop-generator ,which (e regs env cl)
   (let ((,aregs (mapcar #'(lambda (a) (find-register a regs))
                         (primop-args e)))
         (,vreg (find-primop-value-register e regs)))
     (push-instruction ,form cl))
   (gencode-primop-cont-1 e regs env cl)))

A further specialization, represented by define-standard-primop-generator, covers the case where the instruction is a list of an opcode symbol followed by the argument registers and the value register.

⟨primop code generators 144⟩+≡ (133) ◁ 145 145 ▷

(defmacro define-standard-primop-generator (name &optional (symbol name))
`(define-simple-primop-generator ,name (a v) `(,',symbol ,@a ,v)))

7.6.1 Constant Loading Primop

The constant loading primop uses the new xlscmp::%ldconst opcode. Its arguments are a literal index and a value register.

⟨primop code generators 144⟩+≡ (133) ◁ 145 146 ▷

(define-primop-generator load-constant (e regs env cl)
  (let ((ci (find-literal (primop-data e) cl))
        (v (find-primop-value-register e regs)))
    (push-instruction `(xlscmp::%ldconst ,ci ,v) cl)
    (gencode-primop-cont-1 e regs env cl)))

7.6.2 Arithmetic Primop Generators

Three macros are used to define arithmetic primops. The first handles primops with one argument, the second primops with two arguments, and the third handles predicate primops with two arguments. These use existing opcodes that take as their first argument a character index to select the particular operation. The remaining arguments are the argument and value registers.

⟨primop code generators 144⟩+≡ (133) ◁ 145 146 ▷

(defmacro define-arith1-generator (sym char)
  `(define-simple-primop-generator ,sym (a v)
     `(xlscmp::%arith1 ,(char-int ,char) ,@a ,v)))
(defmacro define-arith2-generator (sym char)
  `(define-simple-primop-generator ,sym (a v)
     `(xlscmp::%arith2 ,(char-int ,char) ,@a ,v)))
(defmacro define-arith-pred2-generator (sym char)
  `(define-simple-primop-generator ,sym (a v)
     `(xlscmp::%arith-pred2 ,(char-int ,char) ,@a ,v)))

Code generators for arithmetic operations with two arguments are defined by

⟨primop code generators 144⟩+≡ (133) ◁ 146 146 ▷

(define-arith2-generator + #\+)
(define-arith2-generator - #\-)
(define-arith2-generator * #\*)
(define-arith2-generator / #\/)
(define-arith2-generator min #\m)
(define-arith2-generator max #\M)

Generators for one-argument operations are defined by

⟨primop code generators 144⟩+≡ (133) ◁ 146 146 ▷

(define-arith1-generator uminus #\-)
(define-arith1-generator udiv #\/)
(define-arith1-generator 1+ #\p)
(define-arith1-generator 1- #\m)

Generators for predicate operations are defined by

⟨primop code generators 144⟩+≡ (133) ◁ 146 147 ▷

(define-arith-pred2-generator <  #\<)
(define-arith-pred2-generator <= #\L)
(define-arith-pred2-generator =  #\=)
(define-arith-pred2-generator /= #\#)
(define-arith-pred2-generator >= #\G)
(define-arith-pred2-generator >  #\>)

7.6.3 Values Primop Generators

Storing Values in Value Registers

The values and values-listprimops generate code to write their arguments to the value registers. If used in tail position, code to then execute a return instruction is emitted. Otherwise, the continuation code is processed. Neither primop should bind any arguments.

⟨primop code generators 144⟩+≡ (133) ◁ 146 147 ▷

(define-primop-generator values (e regs env cl)
(let ((aregs (mapcar #'(lambda (a) (find-register a regs)) (primop-args e)))
    (form (primop-form e)))
(push-instruction (if (= (length aregs) 1)
                      `(xlscmp::%set-one-value ,(first aregs))
                    `(xlscmp::%set-values ,(length aregs) ,@aregs))
                  cl)
(if form
    (gencode-cexpr form regs env cl)
  (push-return-instruction cl))))
(define-primop-generator values-list (e regs env cl)
(let ((areg (find-register (first (primop-args e)) regs))
    (form (primop-form e)))
(push-instruction `(xlscmp::%set-values-list ,areg) cl)
(if form
    (gencode-cexpr form regs env cl)
  (push-return-instruction cl))))

Loading Values From Value Registers

The nth-value and get-one-valueprimops load one value from the value registers into a specified register. They are handled as standard primops.

⟨primop code generators 144⟩+≡ (133) ◁ 147 147 ▷

(define-standard-primop-generator nth-value xlscmp::%nth-value)
(define-standard-primop-generator get-one-value xlscmp::%get-one-value)

When more than one value is needed, load-mvargs generates the new xlscmp::%ldmvargs opcode. The arguments are the number of required and optional arguments, an indicator of whether a rest argument is needed, an index for the literal containing default optional argument values, and the registers to take these results.

⟨primop code generators 144⟩+≡ (133) ◁ 147 148 ▷

(define-primop-generator load-mvargs (e regs env cl)
(let* ((data (primop-data e))
     (nreq (first data))
     (nopt (second data))
     (has-rest (if (third data) 1 0))
     (ni (find-literal (fourth data) cl))
     (v (mapcar #'(lambda (x) (find-register x regs)) (primop-vars e))))
(push-instruction `(xlscmp::%ldmvargs ,nreq ,nopt ,has-rest ,ni ,@v) cl)
(gencode-cexpr (primop-form e) regs env cl)))

Saving and Restoring Values

Operations such as multiple-value-prog1 require that values be saved and restored. The corresponding primops are save-values and restore-values. For the current machine, these only use the count argument and just push and pop the appropriate number of values onto and off of the stack.

⟨primop code generators 144⟩+≡ (133) ◁ 147 148 ▷

  (define-primop-generator save-values (e regs env cl)
    (let ((nr (find-register (first (primop-vars e)) regs)))
      (push-instruction `(xlscmp::%push-values ,nr) cl)
      (gencode-cexpr (primop-form e) regs env cl)))
  (define-primop-generator restore-values (e regs env cl)
    (let ((nr (find-register (first (primop-args e)) regs))
          (form (primop-form e)))
      (push-instruction `(xlscmp::%pop-values ,nr) cl)
      (if form
          (gencode-cexpr (primop-form e) regs env cl)
        (push-return-instruction cl))))

7.6.4 Catch-Related Primop Generators

Block and Return-From Generators

The block primop corresponds to the new xlscmp::%new-block opcode. The opcode takes two arguments, a register containing the closure to execute as the body, and a label with the continuation address. The label is redundant, since the continuation address is the next instruction. On the other hand, C/Java code will need a numerical label, so I might as well keep it. But the same argument goes for the return point of non-tail calls; things ought to be consistent.

⟨primop code generators 144⟩+≡ (133) ◁ 148 148 ▷

  (define-primop-generator block (e regs env cl)
    (let ((label (make-label-var 'end))
          (bi (find-register (first (primop-args e)) regs)))
      (push-instruction `(xlscmp::%new-block ,bi ,label) cl)
      (gencode-catch-cont e label regs env cl)))

The continuation is processed by gencode-catch-cont. This function starts by emitting the label. In non-tail position, the value is read into a register if a variable is bound, and then the continuation code is generated. In tail position, a return is generated. This function is used by other catch-related

primops.

⟨primop code generators 144⟩+≡ (133) ◁ 148 149 ▷

  (defun gencode-catch-cont (e label regs env cl)
    (let ((form (primop-form e))
          (var (first (primop-vars e))))
      (push-label-instruction label cl)
      (cond
       (form
        (when var
              (let ((vi (find-register var regs)))
                (push-instruction `(xlscmp::%get-one-value ,vi) cl)))
        (gencode-cexpr form regs env cl))
       (t (push-return-instruction cl)))))

The return-from primop just uses the old xlscmp::%throw-return-from opcode. Its argu-

ment is the register containing the catch tag.

⟨primop code generators 144⟩+≡ (133) ◁ 148 149 ▷

(define-primop-generator return-from (e regs env cl)
(declare (ignore env))
(let ((ti (find-register (first (primop-args e)) regs)))
  (push-instruction `(xlscmp::%throw-return-from ,ti) cl)))

Tagbody and Go Generators

The tagbody primop uses the new xlscmp::%new-tagbody opcode. The arguments are a closure register and a continuation label.

⟨primop code generators 144⟩+≡ (133) ◁ 149 149 ▷

(define-primop-generator tagbody (e regs env cl)
(let ((label (make-label-var 'end))
      (bi (find-register (first (primop-args e)) regs)))
  (push-instruction `(xlscmp::%new-tagbody ,bi ,label) cl)
  (gencode-catch-cont e label regs env cl)))

The go primop uses the new xlscmp::%new-go opcode. The arguments are a tag register and a register containing the continuation closure.

⟨primop code generators 144⟩+≡ (133) ◁ 149 149 ▷

(define-primop-generator go (e regs env cl)
(declare (ignore env))
(let* ((args (primop-args e))
       (ti (find-register (first args) regs))
       (label (find-register (second args) regs)))
  (push-instruction `(xlscmp::%new-go ,ti ,label) cl)))

Catch and Throw Generators

catch uses the new xlscmp::%new-catch opcode and throw uses the old xlscmp::%throw opcode.

catch has a tag and a closure argument. Otherwise, these are very similar to the block codes.

⟨primop code generators 144⟩+≡ (133) ◁ 149 149 ▷

(define-primop-generator catch (e regs env cl)
(let ((label (make-label-var 'end))
      (ti (find-register (first (primop-args e)) regs))
      (ci (find-register (second (primop-args e)) regs)))
  (push-instruction `(xlscmp::%new-catch ,ti ,ci ,label) cl)
  (gencode-catch-cont e label regs env cl)))
(define-primop-generator throw (e regs env cl)
(declare (ignore env))
(let ((ti (find-register (first (primop-args e)) regs)))
  (push-instruction `(xlscmp::%throw ,ti) cl)))

Errset Generator

The errset primop uses the new xlscmp::%new-errset opcode. The opcode takes a closure, a print flag, and a continuation label as arguments.

⟨primop code generators 144⟩+≡ (133) ◁ 149 150 ▷

(define-primop-generator errset (e regs env cl)
(let ((label (make-label-var 'end))
    (bi (find-register (first (primop-args e)) regs))
    (vi (find-register (second (primop-args e)) regs)))
(push-instruction `(xlscmp::%new-errset ,bi ,vi ,label) cl)
(gencode-catch-cont e label regs env cl)))

Unwind-Protect Generator

unwind-protect uses the new opcode xlscmp::%new-unwind-protect. It takes two closures, the

body and the protect code, and a continuation label as arguments.

⟨primop code generators 144⟩+≡ (133) ◁ 149 150 ▷

(define-primop-generator unwind-protect (e regs env cl)
(let ((label (make-label-var 'end))
    (bi (find-register (first (primop-args e)) regs))
    (vi (find-register (second (primop-args e)) regs)))
(push-instruction `(xlscmp::%new-unwind-protect ,bi ,vi ,label) cl)
(gencode-catch-cont e label regs env cl)))

7.6.5 Closure Primop Generators

Closure records using a shared environment are created by a make-closures primop before a letrec. The size of the environment record is contained in the primop’s data field. The data are then filled in by set-closure-data. Two separate steps are needed in case the environment captures some of the closures. The entry points are filled in in the body of the letrec, where they are visible, by set-closure-code primops. This replaces the Y combinator contortions in the old approach.

The creation primop make-closures uses xlscmp::%make-closures. The arguments are the

environment size, the number of closures, and the registers for the new closures.

⟨primop code generators 144⟩+≡ (133) ◁ 150 150 ▷

(define-primop-generator make-closures (e regs env cl)
(let* ((vr (mapcar #'(lambda (x) (find-register x regs)) (primop-vars e)))
     (na (primop-data e))
     (nv (length vr)))
(push-instruction `(xlscmp::%make-closures ,na ,nv ,@vr ) cl)
(gencode-cexpr (primop-form e) regs env cl)))
The set-closure-dataprimop uses xlscmp::%set-closure-data to fill the environment. Clo-

sures allocated in the same letrec share their environment, so only one closure needs to be filled in.

⟨primop code generators 144⟩+≡ (133) ◁ 150 151 ▷

(define-primop-generator set-closure-data (e regs env cl)
(let* ((args (primop-args e))
     (ci (find-register (first args) regs))
     (ar (mapcar #'(lambda (x) (find-register x regs)) (rest args)))
     (na (length ar)))
(push-instruction `(xlscmp::%set-closure-data ,ci ,na ,@ar ) cl)
(gencode-cexpr (primop-form e) regs env cl)))

set-closure-code enters the closure’s code label with xlscmp::%set-closure-code. This

opcode also installs a name for the closure.

⟨primop code generators 144⟩+≡ (133) ◁ 150 151 ▷

(define-primop-generator set-closure-code (e regs env cl)
(let* ((args (primop-args e))
     (cr (find-register (first args) regs))
     (label (second args))
     (li (find-literal (primop-data e) cl)))
(push-instruction `(xlscmp::%set-closure-code ,cr ,label ,li) cl)
(gencode-cexpr (primop-form e) regs env cl)))

7.6.6 Dynamic Binding Primop Generators

Dynamic binding uses two new opcodes that, conceptually at least, use a register to pass the old dynamic environment that is restored on unbinding.

⟨primop code generators 144⟩+≡ (133) ◁ 151 151 ▷

(define-primop-generator dynamic-bind (e regs env cl)
(let* ((args (primop-args e))
     (sr (find-register (first args) regs))
     (vr (find-register (second args) regs))
     (er (find-register (first (primop-vars e)) regs)))
(push-instruction `(xlscmp::%new-dynamic-bind ,sr ,vr ,er) cl)
(gencode-cexpr (primop-form e) regs env cl)))
(define-primop-generator dynamic-unbind (e regs env cl)
(let ((form (primop-form e))
    (er (find-register (first (primop-args e)) regs)))
(push-instruction `(xlscmp::%new-dynamic-unbind ,er) cl)
(if form
    (gencode-cexpr form regs env cl)
  (push-return-instruction cl))))

7.6.7 Structure Primop Generators

Structure reference, assignment, and predicate primops are almost standard primops that could be handled with the standard macros. They can’t quite though, because they encode their offsets and structure type tag as direct arguments or literals, respectively.

⟨primop code generators 144⟩+≡ (133) ◁ 151 152 ▷

(define-primop-generator struct-ref (e regs env cl)
(let ((si (find-register (first (primop-args e)) regs))
    (i (primop-data e))
    (v (find-primop-value-register e regs)))
(push-instruction `(xlscmp::%struct-op ,si 0 ,i ,v) cl)
(gencode-primop-cont-1 e regs env cl)))
(define-primop-generator set-struct-ref (e regs env cl)
(let ((si (find-register (first (primop-args e)) regs))
    (i (primop-data e))
    (ni (find-register (second (primop-args e)) regs))
    (v (find-primop-value-register e regs)))
(push-instruction `(xlscmp::%struct-op ,si 1 ,i ,ni ,v) cl)

(gencode-primop-cont-1 e regs env cl)))
(define-primop-generator struct-type-p (e regs env cl)
(let ((si (find-register (first (primop-args e)) regs))
    (ti (find-literal (primop-data e) cl))
    (v (find-primop-value-register e regs)))
(push-instruction `(xlscmp::%struct-op ,si 2 ,ti ,v) cl)
(gencode-primop-cont-1 e regs env cl)))

7.6.8 Symbol Primop Generators

The symbol-value primop is also almost standard, but its symbol is stored as a literal. The same is true for the assignment operation and for symbol-function.

⟨primop code generators 144⟩+≡ (133) ◁ 151 152 ▷

(define-primop-generator symbol-value (e regs env cl)
(let ((si (find-literal (primop-data e) cl))
    (r (find-primop-value-register e regs)))
(push-instruction `(xlscmp::%symval ,si ,r) cl))
(gencode-primop-cont-1 e regs env cl))
(define-primop-generator symbol-function (e regs env cl)
(let ((si (find-literal (primop-data e) cl))
    (r (find-primop-value-register e regs)))
(push-instruction `(xlscmp::%symfun ,si ,r) cl))
(gencode-primop-cont-1 e regs env cl))
(define-primop-generator set-symbol-value (e regs env cl)
(let ((ci (find-literal (primop-data e) cl))
    (v (find-register (first (primop-args e)) regs))
    (r (find-primop-value-register e regs)))
(push-instruction `(xlscmp::%set-symval ,ci ,v ,r) cl)
(gencode-primop-cont-1 e regs env cl)))

The property access and modification primops are standard and are handled by the standard macro.

⟨primop code generators 144⟩+≡ (133) ◁ 152 152 ▷

(define-standard-primop-generator get xlscmp::%get)
(define-standard-primop-generator xlscmp::%set-get)

Argument Primop Generators

Missing optional arguments for local calls are loaded by load-missing. A predicate is also available.

⟨primop code generators 144⟩+≡ (133) ◁ 152 152 ▷

(define-standard-primop-generator xlscmp::%supplied-p)
(define-standard-primop-generator load-missing xlscmp::%ldnotsupp)

Optional arguments are accessed with get-optarg. The new opcode xlscmp::%get-optarg takes the argument register, the default literal, the value register, and the register for the supplied indicator as arguments.

⟨primop code generators 144⟩+≡ (133) ◁ 152 153 ▷

(define-primop-generator get-optarg (e regs env cl)
  (let ((a (find-register (first (primop-args e)) regs))
        (d (find-literal (primop-data e) cl))
        (v (find-register (first (primop-vars e)) regs))
        (s (find-register (second (primop-vars e)) regs)))
    (push-instruction `(xlscmp::%get-optarg ,a ,d ,v, s) cl)
    (gencode-cexpr (primop-form e) regs env cl)))

Keyword arguments are first processed by applying make-keyargs to a rest argument. Again the opcode is new; it only copies the rest argument. The individual arguments are processed by get-keyarg, which also takes a literal argument specifying the keyword but is otherwise analogous to get-optarg. check-last-keyarg checks the remaining keyword arguments. The opcode arguments are the keyword argument list and a flag indicating whether other keys are allowed.

⟨primop code generators 144⟩+≡ (133) ◁ 152 153 ▷

(define-primop-generator make-keyargs (e regs env cl)
  (let ((a (find-register (first (primop-args e)) regs))
        (v (find-register (first (primop-vars e)) regs)))
    (push-instruction `(xlscmp::%make-keyargs ,a ,v) cl)
    (gencode-cexpr (primop-form e) regs env cl)))
(define-primop-generator get-keyarg (e regs env cl)
  (let ((a (find-register (first (primop-args e)) regs))
        (k (find-literal (first (primop-data e)) cl))
        (d (find-literal (second (primop-data e)) cl))
        (v (find-register (first (primop-vars e)) regs))
        (s (find-register (second (primop-vars e)) regs)))
    (push-instruction `(xlscmp::%get-keyarg ,a ,k ,d ,v ,s) cl)
    (gencode-cexpr (primop-form e) regs env cl)))
(define-primop-generator check-last-keyarg (e regs env cl)
  (let ((a (find-register (first (primop-args e)) regs))
        (d (if (primop-data e) 1 0)))
    (push-instruction `(xlscmp::%check-last-keyarg ,a ,d) cl)
    (gencode-cexpr (primop-form e) regs env cl)))

List Cell Primops

Code generators cons, for car and cdr primops and their assignment counterparts are defined by

⟨primop code generators 144⟩+≡ (133) ◁ 153 153 ▷

(define-standard-primop-generator cons xlscmp::%cons)
(define-standard-primop-generator car xlscmp::%car)
(define-standard-primop-generator cdr xlscmp::%cdr)
(define-standard-primop-generator xlscmp::%set-car)
(define-standard-primop-generator xlscmp::%set-cdr)
(define-standard-primop-generator rplaca xlscmp::%rplaca)
(define-standard-primop-generator rplacd xlscmp::%rplacd)

The macro define-cxr-generator defines code generators for c??r and c???r primops.

⟨primop code generators 144⟩+≡ (133) ◁ 153 154 ▷

(defmacro define-cxr-generator (name n x)
  `(define-simple-primop-generator ,name (a v)
     (list 'xlscmp::%cxr ,n ,x (first a) v)))

The c??r generators are defined by

⟨primop code generators 144⟩+≡ (133) ◁ 153 154 ▷

(define-cxr-generator caar 2 #b11)
(define-cxr-generator cadr 2 #b10)
(define-cxr-generator cdar 2 #b01)
(define-cxr-generator cddr 2 #b00)

and the c???r generators by

⟨primop code generators 144⟩+≡ (133) ◁ 154 154 ▷

(define-cxr-generator caaar 3 #b111)
(define-cxr-generator caadr 3 #b110)
(define-cxr-generator cadar 3 #b101)
(define-cxr-generator caddr 3 #b100)
(define-cxr-generator cdaar 3 #b011)
(define-cxr-generator cdadr 3 #b010)
(define-cxr-generator cddar 3 #b001)
(define-cxr-generator cdddr 3 #b000)

Generators for nth and its assignment counterpart are defined by

⟨primop code generators 144⟩+≡ (133) ◁ 154 154 ▷

(define-standard-primop-generator nth xlscmp::%nth)
(define-standard-primop-generator xlscmp::%set-nth)

Array Primop Generators

The aref and set-aref primops can be used with one or two indices. Code for these cases is generated by

⟨primop code generators 144⟩+≡ (133) ◁ 154 154 ▷

(define-simple-primop-generator aref (a v)
  (case (length a)
    (2 `(xlscmp::%aref1 ,@a ,v))
    (3 `(xlscmp::%aref2 ,@a ,v))
    (t (error "wrong argument count for ~s" 'aref))))
(define-simple-primop-generator xlscmp::%set-aref (a v)
  (case (length a)
    (3 `(xlscmp::%set-aref1 ,@a ,v))
    (4 `(xlscmp::%set-aref2 ,@a ,v))
    (t (error "wrong argument count for ~s" 'xlscmp::%set-aref))))

The row-major-aref and svref primops and their assignment operators are handled as stan-

dard primops.

⟨primop code generators 144⟩+≡ (133) ◁ 154 154 ▷

(define-standard-primop-generator row-major-aref xlscmp::%aref1)
(define-standard-primop-generator xlisp::%set-rm-aref xlscmp::%set-aref1)
(define-standard-primop-generator svref xlscmp::%svref)
(define-standard-primop-generator xlscmp::%set-svref)

Other Primop Generators

Cell constructor, accessor and mutator primops are handled as standard primops.

⟨primop code generators 144⟩+≡ (133) ◁ 154 155 ▷

(define-standard-primop-generator make-cell xlscmp::%make-cell)
(define-standard-primop-generator cell-value xlscmp::%cell-value)
(define-standard-primop-generator set-cell-value xlscmp::%set-cell-value)

A number of simple predicates are also handled as standard primops.

⟨primop code generators 144⟩+≡ (133) ◁ 154 155 ▷

(define-standard-primop-generator not xlscmp::%not)
(define-standard-primop-generator consp xlscmp::%consp)
(define-standard-primop-generator endp xlscmp::%endp)
(define-standard-primop-generator eq xlscmp::%eq)
(define-standard-primop-generator eql xlscmp::%eql)
(define-standard-primop-generator equal xlscmp::%equal)

The sequence accessor elt and its assignment operator are also standard primops.

⟨primop code generators 144⟩+≡ (133) ◁ 155 155 ▷

(define-standard-primop-generator elt xlscmp::%elt)
(define-standard-primop-generator xlscmp::%set-elt)

slot-value can be used with one or two arguments; the two-argument version assigns a new value to the slot.

⟨primop code generators 144⟩+≡ (133) ◁ 155

(define-simple-primop-generator slot-value (a v)
  (case (length a)
    (1 `(xlscmp::%slot-value ,(first a) ,v))
    (2 `(xlscmp::%set-slot-value ,(first a) ,(second a) ,v))))

7.7 Testop Code Generators

Testop generation is also handled by dispatch from a hash table.

⟨testop code generators 155⟩≡ (133) 155 ▷

(let ((table (make-hash-table)))
  (defun get-testop-generator (op) (gethash op table))
  (defun set-testop-generator (op g) (setf (gethash op table) g)))

The dispatching function is gencode-testop.

⟨testop code generators 155⟩+≡ (133) ◁ 155 155 ▷

(defun gencode-testop (e regs env cl)
  (let ((g (get-testop-generator (testop-fun e))))
    (unless g (error "can't generate code for testop ~s" (testop-fun e)))
    (funcall g e regs env cl)))

The macro define-testop-generator defines testop generators.

⟨testop code generators 155⟩+≡ (133) ◁ 155 155 ▷

(defmacro define-testop-generator (which args &rest body)
  `(progn
     (set-testop-generator ',which #'(lambda ,args ,@body))
     ',which))

Simple testops have only two continuations, a consequent and an alternative. Their code generation is handled by the macro define-simple-testop-generator. All the opcodes use dispatching on a selector, the index argument to the macro.

⟨testop code generators 155⟩+≡ (133) ◁ 155 156 ▷

(defmacro define-simple-testop-generator (name symbol index)
  `(define-testop-generator ,name (e regs env cl)
     (let ((a (mapcar #'(lambda (x) (find-register x regs)) (testop-args e))))
       (multiple-value-bind (labels label-conts)
                            (make-testop-labels-conts (testop-conts e)
                                                      regs env)
         (let ((tvar (first labels))
               (evar (second labels)))
           (push-instruction `(,',symbol ,,index ,tvar ,evar ,@a) cl)
           (dolist (lc label-conts)
             (push-label-instruction (first lc) cl)
             (gencode-cexpr (second lc) regs env cl)))))))

The function make-testop-labels-conts creates a list of labels for the continuations along with a list of label/code lists for continuations that require additional code. If a continuation tail calls a local function and its arguments are already in place, so the call can just be compiled to a goto, then the label for the continuation is the function’s label and no additional code is needed. Otherwise, a new label is generated and the label/code pair is added.

⟨testop code generators 155⟩+≡ (133) ◁ 155 156 ▷

(defun make-testop-labels-conts (conts regs env)
  (let ((labels nil)
        (rlc nil))
    (dolist (c conts (values (nreverse labels) (nreverse rlc)))
      (cond
       ((and (call-p c)
             (not (call-is-mvcall c))
             (null (call-form c))
             (let ((def (cdr (assoc (call-fun c) env))))
               (and def
                    (every #'(lambda (x y)
                               (= (find-register x regs)
                                  (find-register y regs)))
                           (call-args c)
                           (func-vars def)))))
        (push (call-fun c) labels))
        (t (let ((lab (make-label-var (gensym 'test))))
             (push lab labels)
             (push (list lab c) rlc)))))))

There are four testops taking one argument.

⟨testop code generators 155⟩+≡ (133) ◁ 156 156 ▷

(define-simple-testop-generator t xlscmp::%test-1 0)
(define-simple-testop-generator consp xlscmp::%test-1 1)
(define-simple-testop-generator xlscmp::%supplied-p xlscmp::%test-1 2)
(define-simple-testop-generator endp xlscmp::%test-1 3)

There are three equality testops.

⟨testop code generators 155⟩+≡ (133) ◁ 156 156 ▷

(define-simple-testop-generator eq xlscmp::%test-2 0)
(define-simple-testop-generator eql xlscmp::%test-2 1)
(define-simple-testop-generator equal xlscmp::%test-2 2)

Finally, there are six arithmetic testops.

⟨testop code generators 155⟩+≡ (133) ◁ 156 157 ▷

(define-simple-testop-generator = xlscmp::%test-arith-2 (char-int #\=))
(define-simple-testop-generator /= xlscmp::%test-arith-2 (char-int #\#))
(define-simple-testop-generator < xlscmp::%test-arith-2 (char-int #\<))
(define-simple-testop-generator > xlscmp::%test-arith-2 (char-int #\>))
(define-simple-testop-generator <= xlscmp::%test-arith-2 (char-int #\L))
(define-simple-testop-generator >= xlscmp::%test-arith-2 (char-int #\G))

The case testop should have a data item consisting of a vector with n items and a list of continuations with n + 1 items. The vector of case labels is installed as a constant. This is a departure from the original xlscmp::%case opcode, so there is a new opcode called xlscmp::%ncase.

⟨testop code generators 155⟩+≡ (133) ◁ 156

(define-testop-generator case (e regs env cl)
  (let ((ci (find-literal (testop-data e) cl))
        (r (find-register (first (testop-args e)) regs))
        (conts (testop-conts e)))
    (multiple-value-bind (labels label-conts)
                         (make-testop-labels-conts conts regs env)
      (push-instruction `(xlscmp::%ncase ,r ,ci ,@labels) cl)
      (dolist (lc label-conts)
        (push-label-instruction (first lc) cl)
        (gencode-cexpr (second lc) regs env cl)))))

7.8 Letrec Code Generators

The generator for letrec expressions is gencode-letrec.

⟨letrec code generators 157⟩≡ (133)

(defun gencode-letrec (e regs env cl)
  (let ((vars (letrec-vars e))
        (args (letrec-args e)))

⟨push letrec bindings onto env 157⟩

    (gencode-cexpr (letrec-body e) regs env cl)

⟨generate code for letrec’s funcitons 157⟩))

The code for pushing the bindings on the environment is

⟨push letrec bindings onto env 157⟩≡ (157)

(do ((vars vars (rest vars))
     (args args (rest args)))
    ((or (null vars) (null args)))
    (push (cons (first vars) (first args)) env))

The functions bound in the letrec are processed by

⟨generate code for letrec’s funcitons 157⟩≡ (157)

(do ((vars vars (rest vars))
     (args args (rest args)))
    ((or (null vars) (null args)))
    (push-label-instruction (first vars) cl)
    (gencode-cexpr (first args) regs env cl))

7.9 Call Generators

7.9.1 Core Call Code Generation

The old compiler uses twelve opcodes for function calls. These correspond to three different function sources (symbol, variable, and local), two argument sources (inline and multiple value) and two call types (non-tail and tail). In addition, calls to continuations are mapped to goto’s.

The new compiler uses all four symbol call opcodes and all four variable call opcodes. The two settings differ in how the function argument is determined and the opcodes used but are otherwise similar. Therefore the code emission for symbol functions is done by

⟨emit code for calls to functions passed as symbols 158⟩≡ (159)

(gencode-call-1 e regs env cl (find-literal fun cl)
'xlscmp::%call 'xlscmp::%save-call
'xlscmp::%mvcall 'xlscmp::%save-mvcall)

and

⟨emit code for calls to functions passed as constants 158⟩≡ (159)

(let ((val (const-value fun)))
(unless (or (symbolp val) (functionp val))
(error "~s is not a valid function" val))
(gencode-call-1 e regs env cl (find-literal val cl)
  'xlscmp::%call 'xlscmp::%save-call
  'xlscmp::%mvcall 'xlscmp::%save-mvcall))

and for functions passed in variables by

⟨emit code for calls to functions passed as variables 158⟩≡ (159)

(gencode-call-1 e regs env cl (find-register fun regs)
'xlscmp::%vcall 'xlscmp::%save-vcall
'xlscmp::%mvvcall 'xlscmp::%save-mvvcall)

The common code emission code for these two cases is in gencode-call-1.

⟨call code generators 158⟩≡ (133) 159 ▷

(defun gencode-call-1 (e regs env cl f csym scsym mcsym smcsym)
(let* ((form (call-form e))
(args (call-args e))
(na (if (consp args) (length args) 0))
(v (let ((vars (call-vars e)))
(if (and (consp vars) (= (length vars) 1))
  (find-register (first vars) regs)
0)))
(a (if (consp args)
(mapcar #'(lambda (x) (find-register x regs)) args)
nil)))
(if (null form)
(if (call-is-mvcall e)
(push-instruction `(,mcsym ,f 0) cl)
(push-instruction `(,csym ,f 0 ,na ,@a) cl))
(progn
(if (call-is-mvcall e)
(push-instruction `(,smcsym ,f ,v) cl)
(push-instruction `(,scsym ,f ,v ,na ,@a) cl))
(gencode-cexpr form regs env cl)))))

Non-tail calls to local functions must be to local-lambda functions. In addition, the arguments must come inline, not from multiple value registers (multiple value calls are assumed to have been transformed to inline calls at the call site; similarly, optional or rest arguments are assumed to have been transformed appropriately at the call site, but this cannot be used to advantage with the old virtual machine). Non-tail calls to local functions can thus also be handled by the common code in gencode-call-1, but only one of the opcodes will actually be used.

⟨emit code for non-tail call of local function 159⟩≡ (159)

  (gencode-call-1 e regs env cl fun nil 'xlscmp::%save-lcall nil nil)

Finally, tail calls to local functions must be to tail-lambda functions. These are handled by moving the arguments into the appropriate registers and jumping to the function address.

⟨emit code for tail call of local function 159⟩≡ (159)

  (let* ((fval (cdr (assoc fun env)))
         (aregs (mapcar #'(lambda (x) (find-register x regs))
                        (call-args e)))
         (vregs (mapcar #'(lambda (x) (find-register x regs))
                        (func-vars fval))))
    (gencode-move aregs vregs cl)
    (push-instruction `(xlscmp::%goto ,fun) cl))

The driver function code for generating call code is gencode-call.

⟨call code generators 158⟩+≡ (133) ◁ 158 159 ▷

  (defun gencode-call (e regs env cl)
    (let ((fun (call-fun e)))
      (cond
       ((symbolp fun)

⟨emit code for calls to functions passed as symbols 158⟩)

       ((const-p fun)

⟨emit code for calls to functions passed as constants 158⟩)

       ((and (var-p fun) (null (assoc fun env)))

⟨emit code for calls to functions passed as variables 158⟩)

       ((and (var-p fun) (eq (func-type (cdr (assoc fun env))) 'local-lambda))

⟨emit code for non-tail call of local function 159⟩)

       ((and (var-p fun) (eq (func-type (cdr (assoc fun env))) 'tail-lambda))

⟨emit code for tail call of local function 159⟩)

       (t (error "don't know how to handle the call ~s" e)))))

7.9.2 Register Moving Code for Local Tail Calls

Register moving for local tail calls uses two phases. The first phase emits copying code for moves in which the target register’s contents is not needed by any other moves. Since more moves may become eligible once some moves have been processed, this has to be done recursively until no more copies are possible.

⟨call code generators 158⟩+≡ (133) ◁ 159 160 ▷

  (defun gencode-move-copy (pairs from cl)
    (let ((npairs nil)
          (changed nil))
      (dolist (p pairs)
        (cond
         ((member (cdr p) from) (push p npairs))
         (t (push-instruction `(xlscmp::%copy ,(car p) ,(cdr p)) cl)
            (setf changed t))))

    (if changed
        (gencode-move-copy npairs (mapcar #'first npairs) cl)
      npairs)))

Once no more copies are possible, every target is also a source. Therefore we have a permutation to perform. For each move pair with source not equal to target a swap is performed. In addition, the move using the current pair’s target as a source is found, and that move’s source is replaced by the current pair’s source, since that is where the required value is after the swap. This requires adding the opcode xlscmp::%swap.

⟨call code generators 158⟩+≡ (133) ◁ 159 160 ▷

(defun gencode-move-swap (pairs cl)
  (do ((pairs pairs (rest pairs)))
      ((null pairs))
      (let ((p (first pairs)))
        (unless (= (car p) (cdr p))
                (let ((q (find (cdr p) pairs :key #'car)))
                  (unless (null (rest pairs))
                          (setf (car q) (car p)))
                  (push-instruction `(xlscmp::%swap ,(car p) ,(cdr p)) cl))))))

The function to emit the move code is gencode-move

⟨call code generators 158⟩+≡ (133) ◁ 160

(defun gencode-move (from to cl)
  (let* ((pairs (mapcar #'cons from to))
         (spairs (gencode-move-copy pairs from cl)))
    (gencode-move-swap spairs cl)))

7.10 A Simple Front End

A simple front end for use in test code:

⟨gencode.lsp 133⟩+≡  ◁ 133

(defun cmpl1 (e)
  (multiple-value-bind (code lits)
                       (gencode e)
    (let* ((labels (remove-if-not #'var-p code))
           (pairs (mapcar #'(lambda (x) (cons x (gensym (var-name x))))
                          labels))
           (c (sublis pairs code)))
      (list c lits (first c)))))
(defun cmpl (e) (byte-code-close (xlscmp::assemble (cmpl1 e))))
(defun pcmpl (e) (pprint (cmpl1 e)))

Compiler Top Level

This chapter presents two files. The first contains the definitions of the external interface functions, compile and compile-file. The second defines the package and functions for building and loading the system.

8.1 Compiler Interface

⟨toplevel.lsp 161⟩≡

  (in-package "NEWCMP")

⟨public variables 164⟩

⟨private variables 169⟩

⟨macros 162⟩

⟨private functions 161⟩

⟨public functions 163⟩

8.1.1 Compiler Components

The compiler can be divided into three parts. The front end converts Lisp source to the intermediate representation. The middle is the optimizer. The back end converts the optimized intermediate representation to executable code.

The front end can be given a lambda expression or a general expression. General expressions are just wrapped in a lambda expression with no arguments. This corresponds to the nonstandard evaluation rule for code. The front end for lambda expressions calls the converter, then adds cells and applies value substitution to remove any bind expressions the converter might have introduced.

⟨private functions 161⟩≡ (161) 161 ▷

  (defun compile-front-form (e env)
    (compile-front-lambda `(lambda () ,e) nil env (make-context e)))
  (defun compile-front-lambda (fun name env ctx)
    (substitute-values
     (add-cells
      (convert-lambda name fun (make-info nil env) nil nil ctx))))

The optimizer attempts to drop tags and cells, substitute functions, push continuations into letrec expressions, and then applies simplification rules. Finally, inline expansion is attempted. This is repeated until the code no longer changes or a fixed limit on the number of passes is reached.

CHAPTER 8. COMPILER TOP LEVEL 162

⟨private functions 161⟩+≡ (161) ◁ 161 162 ▷

(defun optimize (e)
(dotimes (i 5 e)
(let ((ne (inline-expand
      (simplify
       (drop-safe-cells
        (substitute-once-called-functions
         (push-letrec-conts
          (substitute-once-called-functions
           (drop-safe-tags e)))))))))
(when (eq e ne) (return e))
(setf e ne))))

The back end applies closure conversion (function splitting), constant lifting and lambda lifting, generates code, and assembles the code. The pre-assembly portion is split out to aid in debugging.

⟨private functions 161⟩+≡ (161) ◁ 161 162 ▷

(defun compile-back-1 (e)
(let ((ee (lambda-lift (lift-constants (split-all-functions e)))))
(multiple-value-bind (code lits)
                (gencode ee)
(let* ((labels (remove-if-not #'var-p code))
    (pairs (mapcar #'(lambda (x) (cons x (gensym (var-name x))))
                   labels))
    (c (sublis pairs code)))
(list c lits (first c))))))
(defun compile-back (e)
(xlscmp::assemble (compile-back-1 e)))

The compilation process requires some special variables to be bound appropriately. This is handled by the macro

⟨macros 162⟩≡ (161)

(defmacro with-compiler-environment (&rest body)
`(let ((xlisp::*simplify-setf* nil)
(xlisp::*cmp-setf* nil)
(xlisp::*cmp-structs* nil)
(xlisp::*cmp-macros* nil)   ;;**** remove eventually?
(xlisp::*cmp-specials* nil) ;;**** remove eventually?
(xlisp::*global-environment* xlisp::*global-environment*)
(*global-calls* nil)
(*global-callinfo* nil)
(*inline-definitions* nil))
,@body))

Two useful debugging functions:

⟨private functions 161⟩+≡ (161) ◁ 162 163 ▷

(defun pcvt (e)
(let ((f (if (lambda-expression-p e) e `(lambda () ,e))))
(with-compiler-environment
(optimize (compile-front-lambda f nil nil (make-context f))))))
(defun pcmp (e) (compile-back-1 (pcvt e)))

8.1.2 The COMPILE Function

The compile function takes a symbol and an optional function or lambda expression as arguments. It compiles the function and installs it in the symbol, if the symbol is not nil. A handler-bind is used to record any conditions that are signaled; these are used to construct the second and third values of the function. The handler returns, thus allowing other handlers to process the condition.

⟨public functions 163⟩≡ (161) 164 ▷

  (defun compile (f &optional (fun (symbol-function f)))
    (let ((conditions nil))
      (handler-bind ((condition #'(lambda (c) (push c conditions))))
        (multiple-value-bind (cfun flam)
                             (compile-function f fun)
          (let ((warns (if conditions t nil))
                (errs (not (every #'style-warning-p conditions))))
            (if f
                (let ((def (if (or *save-lambda-expressions* (inline-p f nil))
                               flam
                             nil)))
                  (values (xlisp::install-function f cfun def nil) warns errs))
              (values cfun warns errs)))))))

The predicate style-warning-p recognizes style warnings; if style warnings occur, the second value is true. If there are other kinds of conditions, the third value is true.

⟨private functions 161⟩+≡ (161) ◁ 162 163 ▷

  (defun style-warning-p (c) (typep c 'style-warning))

Compiling of a lambda expression is carried out by compile-lambda-expression. If the lambda expression is a macro, (i.e. the first entry is macro instead of lambda) then the expression is rewritten, and after compilation the function is marked as a macro. The compilation is carried out with the compiler environment wrapper and using the current global environment.

⟨private functions 161⟩+≡ (161) ◁ 163 163 ▷

  (defun compile-lambda-expression (fun name)
    (with-compiler-environment
     (let* ((macrop (eq (first fun) 'macro))
            (fun (if macrop (cons 'lambda (rest fun)) fun))
            (env xlisp::*global-environment*)
            (cfun (byte-code-close
                   (compile-back
                    (optimize
                     (compile-front-lambda fun name env (make-context fun)))))))
       (if macrop (coerce-to-macro cfun) cfun))))

The core of compile is in compile-function. If takes a symbol and a function as arguments. If the function is already compiled, it is returned. If it is an uncompiled closure (function or macro) its lambda expression is compiled; an error is signaled if the closure has a non-null environment. If the function is a lambda expression, it is compiled. The lambda expression, if available, is returned as a second value.

⟨private functions 161⟩+≡ (161) ◁ 163 166 ▷

  (defun compile-function (f fun)
    (cond
     ((or (typep fun 'subr) (typep fun 'fsubr) (compiled-function-p fun))
      (values fun nil))
     ((typep fun 'closure)

    (multiple-value-bind (flam env fname)
                         (function-lambda-expression fun)
      (when env (error "COMPILE can only compile top level definitions"))
      (values (compile-lambda-expression flam (if f f fname)) flam)))
   ((and (consp fun) (eq (first fun) 'lambda))
    (values (compile-lambda-expression fun f) fun))
   (t (error "bad argument type -- ~s" fun))))

8.1.3 The COMPILE-FILE Function

The compile-file functions uses several standard public variables and two nonstandard variables. The standard variables are the default values for the :verbose and :print keyword arguments,

⟨public variables 164⟩≡ (161) 164 ▷

(defvar *compile-verbose* t)
(defvar *compile-print* t)

and variables for holding pathnames,

⟨public variables 164⟩+≡ (161) ◁ 164 164 ▷

(defvar *compile-file-pathname*)
(defvar *compile-file-truename*)

These symbols are all exported from the XLISP package.

The two nonstandard variable, exported from the compiler package, control whether full package qualifiers are printed with symbols when writing the .fsl file and whether lambda expressions are to be saved in compiled functions.

⟨public variables 164⟩+≡ (161) ◁ 164

(export '(*compile-print-symbol-package* *save-lambda-expressions*))
(defvar *compile-print-symbol-package* nil)
(defvar *save-lambda-expressions* nil)

The function compile-file takes a file and a number of keyword arguments. One non-standard keyword argument allows the name of the temporary file used by the compiler to be set. Compilation writes to the temporary file and only renames the temporary file to the final output file after the full compilation process has been completed. A number of variables are bound, and then the file is processed. As in compile, a handler-bind is used to keep track of any conditions that are signaled.

⟨public functions 163⟩+≡ (161) ◁ 163 169 ▷

(defun compile-file (file &key
                          (output-file (merge-pathnames ".fsl" file))
                          (temporary-file (merge-pathnames "cmptmp.fsl" file))
                          (load nil)
                          (print *compile-print*)
                          (verbose *compile-verbose*)
                          ((:print-symbol-package sp) ;;**** do this cleaner
                           *compile-print-symbol-package*))
  (let* ((*package* *package*)
         (*readtable* *readtable*)
         (iname (merge-pathnames ".lsp" file))
         (*compile-file-pathname* iname)
         (*compile-file-truename* (truename iname))
         (conditions nil)
         (eof (list 'eof)))
    (handler-bind ((condition #'(lambda (c) (push c conditions))))

        (with-compiler-environment
          (with-open-file (in iname)
            (with-open-file (out temporary-file :direction :output)

⟨initiate file processing 165⟩

              (do ((e (read in nil eof) (read in nil eof)))
                  ((eq e eof))

⟨process expression e 165⟩))) ⟨wrap up file processing and return values 165⟩))))

Initial file processing involves printing a message and emitting code to check the fsl version information on loading.

⟨initiate file processing 165⟩≡ (?? 164)

  (when verbose
        (format t "~&; compiling file ~s~%" iname)
        (force-output))
  (let ((major xlisp::*fsl-major-version*)
        (minor xlisp::*fsl-minor-version*))
    (print-compiled-form `(xlisp::check-fsl-version ,major ,minor)
                         out sp))

Wrapup involves printing summary information on used and unused functions, renaming the temporary output file, loading the file if requested, and returning the values.

⟨wrap up file processing and return values 165⟩≡ (?? 164)

  (when verbose (check-function-usage))
  (rename-file temporary-file output-file)
  (when load (load output-file))
  (values (truename output-file)
          (if conditions t nil)
          (not (every #'style-warning-p conditions)))

Each expression is processed by printing a message if print is true, compiling and emitting code, and printing a closing message. Compilation is done inside a handler-case that traps errors. When an error occurs, a message is written to the error output, and the original expression is written to the output file.

⟨process expression e 165⟩≡ (164)

  (when print
        (let ((*print-level* 2)
              (*print-length* 3))
          (format t "~&; compiling ~s ... " e)
          (force-output)))
  (handler-case

⟨compile and emit code for e 165⟩

   (error (c)
          (format *error-output* "~&Compiler error: ~a~%" c)
          (print-compiled-form e out sp)))
  (when print
        (format t "done~%")
        (force-output))

Compiling a single expression is handled in a way that insures that a single expression is printed for each expression read. This way common literals can be handled by circle printing/reading. To do this, an initial progn expression is created as outstuff, new expressions are added to its body by compile-one, and the result is printed. The progn is stripped if it is not needed. Compilation is done in the current global environment.

⟨compile and emit code for e 165⟩≡ (165)

(let ((outstuff (list 'progn)))
(compile-one e nil xlisp::*global-environment* outstuff)
(case (length outstuff)
(1 nil)
(2 (print-compiled-form (second outstuff) out sp))
(t (print-compiled-form outstuff out sp))))

The function print-compiled-form prints the form argument to stream in a readable form with the appropriate setting of the package printing option.

⟨private functions 161⟩+≡ (161) ◁ 163 166 ▷

(defun print-compiled-form (form stream sp)
(let ((*print-readably* t)
(*print-symbol-package* sp))
(format stream "~s~%" form)))

New expressions are added to the current output form with

⟨private functions 161⟩+≡ (161) ◁ 166 166 ▷

(defun accumulate-compiled-form (form outstuff)
(rplacd (last outstuff) (list form)))

The function compile-one handles compilation of top-level expressions. This involves recursively processing certain forms whose body forms are considered to be at top level (e.g. progn, locally), and also processing certain forms at top level that benefit from special handling (e.g.

defun).

⟨private functions 161⟩+≡ (161) ◁ 166 166 ▷

(defun compile-one (e compile-time-too env stream)
(setq e (expand-one e env))
(case (first e)
(progn
  (dolist (e (rest e)) (compile-one e compile-time-too env stream)))
(defun

⟨compile-one for defun expressions 167⟩)

(macrolet
 ⟨compile-one for macrolet expressions 167⟩)
(eval-when
 ⟨compile-one for eval-when expressions 168⟩)
(locally
 ⟨compile-one for locally expressions 168⟩)
(symbol-macrolet
 ⟨compile-one for symbol-macrolet expressions 168⟩)
(t (if compile-time-too (eval e))
   (compile-form e env stream))))

expand-one is a version of macroexpand that leaves the macros selected for special processing unexpanded.

⟨private functions 161⟩+≡ (161) ◁ 166 167 ▷

(defun expand-one (e env)
(loop
(if (member (first e) '(progn macrolet eval-when defun)) (return e))
(multiple-value-bind (ee flag) (expand-expression-1 e env)
(if flag
 (setq e ee)
(return e)))))

The function compile-form handles the default case. This version is very simple; it might be possible to reduce the size of the .fsl file by special handling of certain forms (as is done in the old compiler).

⟨private functions 161⟩+≡ (161) ◁ 166 169 ▷

(defun compile-form (e env stream)
(let ((cform (compile-back (optimize (compile-front-form e env)))))
(accumulate-compiled-form cform stream)))

defun expressions are handled separately in order to insure that recursive calls of the function to itself become local calls. The defined function is registered as a global function before compilation. The test for a notinline declaration isn’t quite right since it doesn’t allow for local declarations to prevent inlining the recursive call. The function also has its definition registered for inlining. If the definition registered is not nil, then the use of labels will prevent inline cascading for a recursive function. But some care is still needed in the inlining process to protect against inline cascading due to mutually recursive functions.

⟨compile-one for defun expressions 167⟩≡ (166)

(let* ((name (second e))
(db (xlisp::split-declarations (rest (rest (rest e)))))
(decls (first db))
(b (second db))
(doc (third db))
(def (if (or *save-lambda-expressions* (inline-p name env))
         `(lambda ,(third e) ,@decls ,@b)
       nil))
(denv (if def (if (eq env xlisp::*global-environment*) nil t) nil))
(fexpr (if (not-inline-p name env)
           `(lambda ,(third e) ,@decls ,@b)
         `(labels ((,name ,(third e) ,@decls ,@b)) #',name))))
(register-global-fun name (third e))
(register-inline-definition name def)
(let* ((cexpr (compile-back (optimize (compile-front-form fexpr env))))
  (cform (if doc
             `(progn
                (xlisp::%set-get ',name 'function-documentation ,doc)
                (xlisp::install-function ',name ,cexpr ',def ,denv))
           `(xlisp::install-function ',name ,cexpr ',def ,denv))))
(accumulate-compiled-form cform stream)))

macrolet expressions are handled by adding their macros to the environment and then processing the body as a top level form.

⟨compile-one for macrolet expressions 167⟩≡ (?? 166)

(flet ((mkmacro (x)
         (let ((name (first x))
               (args (second x))
               (body (rest (rest x))))
           (list name (parse-macro name args body env)))))
(multiple-value-bind (decls body)
                    (split-decls-body (rest (rest e)) nil)
 (let* ((macs (mapcar #'mkmacro (second e)))
        (nenv (augment-environment env :macro macs))
        (nnenv (augment-environment nenv :declare decls)))
   (compile-one body compile-time-too nnenv stream))))

eval-when expressions are handled in accordance with the current compile-time-too setting.

⟨compile-one for eval-when expressions 168⟩≡ (?? 166)

(let* ((sits (second e))
       (body `(progn ,@(rest (rest e))))
       (lt (or (member 'load sits) (member :load-toplevel sits)))
       (ct (or (member 'compile sits)
               (member :compile-toplevel sits)))
       (ex (or (member 'eval sits) (member :execute sits))))
  (cond
   ((or (and lt ct)
        (and lt (not ct) ex compile-time-too))
    (compile-one body t env stream))
   ((or (and lt (not ct) (not compile-time-too))
        (and lt (not ct) (not ex)))
    (compile-one body nil env stream))
   ((or (and (not lt) ct)
        (and (not lt) (not ct) ex compile-time-too))
    (eval body))))

For locally expressions, the body is processed with an environment augmented by any declarations.

⟨compile-one for locally expressions 168⟩≡ (166)

(multiple-value-bind (decls body)
                     (split-decls-body (rest e) nil)
  (let ((nenv (augment-environment env :declare decls)))
    (compile-one body compile-time-too nenv stream)))

Similarly, symbol-macrolet expressions have their body processed with an environment augmented by the symbol macro definitions and declarations provided.

⟨compile-one for symbol-macrolet expressions 168⟩≡  (166)
(check-specop-argument-count 'symbol-macrolet (rest e) 1 0 t)
(check-bindings 'symbol-macrolet (second e))
(multiple-value-bind (decls body)
                     (split-decls-body (rest (rest e)) nil)
  (let* ((nenv (augment-environment env :symbol-macro (second e)))
         (nnenv (augment-environment nenv :declare decls)))
    (compile-one body compile-time-too nnenv stream)))

8.1.4 An Alternative Approach

An alternative approach might be to try to make one single code unit per compiled file (or per compilation unit, which might consist of several files). This has several possible advantages:

• It allows global calls to be made local if declarations permit.

• It may make C/Java code generation easier.

• It allows constants to be merged.

The simple approach doesn’t quite work because, at the moment at least,

• regassign is too slow (quadratic?)

Nevertheless, this is worth pursuing.

8.1.5 The COMPILE-FILE-PATHNAME Function

The function compile-file-pathname returns the name of the output file used by compile-file.

⟨public functions 163⟩+≡ (161) ◁ 164

  (defun compile-file-pathname (file &key
                                     (output-file (merge-pathnames ".fsl" file))
                                     &allow-other-keys)
    output-file)

8.1.6 Checking Definitions Against Calls

This section provides a simple mechanism for issuing warnings when global functions defined within the file are used incompatibly or conflict with system functions.

The variable *global-calls* holds information about calls to global functions not seen yet. The variable *global-callinfo* holds lambda list information for functions that have been defined. These variables are bound by the with-compiler-environment macro.

⟨private variables 169⟩≡ (161) 171 ▷

  (defvar *global-calls*)
  (defvar *global-callinfo*)

Lambda list information for a registered function is retrieved by global-callinfo. A call to this function marks the function’s entry as used.

⟨private functions 161⟩+≡ (161) ◁ 167 169 ▷

  (defun global-callinfo (fun)
    (if (boundp '*global-callinfo*)
        (let ((entry (assoc fun *global-callinfo*)))
          (cond
           (entry (setf (second entry) t) (third entry))
           (t nil)))
      nil))

If a global function is not already registered, a call to it results in an entry being placed in the *global-calls* list. The entries consist of a list of the name followed by the argument counts of the calls. If and when the function is registered, its definition is compared to these argument counts. If a call is made to a registered function, then the use flag of the function’s entry is set.

⟨private functions 161⟩+≡ (161) ◁ 169 169 ▷

  (defun register-global-call (fun args ctx)
    (declare (ignore ctx))
    (when (and (boundp '*global-callinfo*) (boundp '*global-calls*))
          (let ((entry (assoc fun *global-callinfo*)))
            (if entry
                (setf (second entry) t)
              (let ((entry (assoc fun *global-calls*)))
                (if entry
                    (pushnew (length args) (rest entry))
                  (push (list fun (length args)) *global-calls*)))))))

Registering a global function involves a number of checking steps before the function information is entered.

⟨private functions 161⟩+≡ (161) ◁ 169 170 ▷

(defun register-global-fun (fun args)
  (let ((ci (lambda-list-callinfo args))
        (sys-ci (sysfun-callinfo fun))
        (old-ci (global-callinfo fun))
        (used nil))

⟨check whether there is a conflict with a system function 170⟩ ⟨check for conflicts with previous definitions 170⟩ ⟨check definition against previous uses 170⟩

    (when (boundp '*global-callinfo*)
          (let ((entry (assoc fun *global-callinfo*)))
            (if entry
                (setf (third entry) ci)
              (push (list fun used ci) *global-callinfo*))))))

First we check that the function does not redefine a system function and issue a warning if it does. In addition, the warning indicates when there is a conflict with the system function’s call information.

⟨check whether there is a conflict with a system function 170⟩≡ (169)

(when sys-ci
      (issue-style-warning "redefining built-in function ~s~
                            ~@[ with incompatible arguments~]"
                           fun (not (callinfo-equal ci sys-ci))))

Next we check for previous definitions and issue a warning if the call information for the two definitions are not consistent.

⟨check for conflicts with previous definitions 170⟩≡ (169)

(when (and old-ci (not (callinfo-equal ci old-ci)))
      (issue-style-warning "redefining function ~s ~
                            with incompatible arguments"
                           fun))

Finally, if uses of the function have been recorded, we check whether they are consistent with the definition and issue a warning if they are not. The uses variable is set to t if there are uses recorded.

⟨check definition against previous uses 170⟩≡ (169)

(when (and (null old-ci) (boundp '*global-calls*))
      (let ((entry (assoc fun *global-calls*)))
        (when entry
              (dolist (n (rest entry))
                (when (check-call n ci)
                      (issue-style-warning "definition of ~s is not ~
                                            compatible with earlier calls"
                                           fun)
                      (return)))
              (setf used t)
              (setf *global-calls* (remove entry *global-calls*)))))

The comparison of callinfo records is done by callinfo-equal. The equal pretest is used for efficiency. If it fails, the components are compared. A subset equality test is used on the keys since order does not matter.

⟨private functions 161⟩+≡ (161) ◁ 169 171 ▷

(defun callinfo-equal (x y)
  (or (equal x y)

(and (eql (callinfo-nreq x) (callinfo-nreq y))
(eql (callinfo-nopt x) (callinfo-nopt y))
(eql (callinfo-restp x) (callinfo-restp y))
(eql (callinfo-keyp x) (callinfo-keyp y))
(let ((xk (callinfo-keys x))
      (yk (callinfo-keys y)))
  (and (subsetp xk yk) (subsetp yk xk)))
(eql (callinfo-other x) (callinfo-other y)))))

At the end of the file compilation, we can check the two global call information variables to determine if there were any functions defined but not used, or any functions used but not defined.

⟨private functions 161⟩+≡ (161) ◁ 170 171 ▷

(defun check-function-usage ()
(let ((unused (mapcar #'first (remove-if #'second *global-callinfo*)))
(used (mapcar #'first *global-calls*)))
(when unused
(format t "~&; Functions defined but not used: ~{~s ~}~%"
       (remove-duplicates unused)))
(when used
(format t "~&; Functions used but not defined: ~{~s ~}~%"
       (remove-duplicates used)))))

8.1.7 Registering Inline Information

This section provides some code to support inlining functions. The variable *inline-definitions* is used to hold definitions obtained from processing the current file.

⟨private variables 169⟩+≡ (161) ◁ 169

(defvar *inline-definitions* nil)

Definitions are registered by calling register-inline-definition. For functions defined without an active inline declaration the definition will be nil; this prevents an old definition from being used for inlining.

⟨private functions 161⟩+≡ (161) ◁ 171 171 ▷

(defun register-inline-definition (name def)
(push (cons name def) *inline-definitions*))

The function get-inline-definition returns the currently available global definition for name, if one is available. It looks in the *inline-definitions* and then in the symbol’s function definition, if there is one. This function does not check whether inlining is permitted or whether the name currently has a lexical function binding.

⟨private functions 161⟩+≡ (161) ◁ 171

(defun get-inline-definition (name)
(let ((entry (assoc name *inline-definitions*)))
(if entry
(rest entry)
(if (fboundp name)
(let ((fun (symbol-function name)))
 (multiple-value-bind (def env)
                      (function-lambda-expression fun)
   (if env nil def)))
nil))))

8.2 Loading and Building the System

The file newcmp.lsp defines the system package, some compilation utilities, and some symbols. It starts out with some additional entries in the XLISP package. These are the style-warning condition and the public symbols of the compiler system. ⟨newcmp.lsp 172⟩≡ 172 ▷

(in-package "XLISP")
(export 'style-warning)
(define-condition style-warning (simple-warning))
(export '(compile compile-file compile-file-pathname
          *compile-verbose* *compile-print*
          *compile-file-pathname* *compile-file-truename*))

The old definitions of compile and compile-file are preserved, just in case.

⟨newcmp.lsp 172⟩+≡  ◁ 172 172 ▷

(unless (fboundp 'old-compile)
        (setf (symbol-function 'old-compile) #'compile))
(unless (fboundp 'old-compile-file)
        (setf (symbol-function 'old-compile-file) #'compile-file))
(export '(old-compile old-compile-file))

The new compiler’s package is defined and entered by

⟨newcmp.lsp 172⟩+≡  ◁ 172 172 ▷

(defpackage "NEWCMP" (:use "XLISP"))
(in-package "NEWCMP")

The base names of the files to be loaded are stored in a variable.

⟨newcmp.lsp 172⟩+≡  ◁ 172 172 ▷

(defparameter *newcmp-files*
  '("environ" "intermed" "convert" "simplify" "cellstags" "lift"
    "gencode" "toplevel"))

Functions for loading and compiling the system are defined.

⟨newcmp.lsp 172⟩+≡  ◁ 172 173 ▷

(defun load-newcmp (&optional lspfiles)
  (if lspfiles
      (dolist (f *newcmp-files*) (load (merge-pathnames f ".lsp")))
    (dolist (f *newcmp-files*) (load f))))
(defun cmp-newcmp (&key (load t) (time t) (all t))
  (labels ((fsl-up-to-date (file)
             (let ((lspfile (merge-pathnames file ".lsp"))
                   (fslfile (merge-pathnames file ".fsl")))
               (and (probe-file lspfile)
                    (probe-file fslfile)
                    (< (file-write-date lspfile) (file-write-date fslfile)))))
           (make (file)
             (unless (and (not all) (fsl-up-to-date file))
                     (if time
                         (time (compile-file file :load load))
                       (compile-file file :load load)))))

(let ((*warn-undeclared-globals* t))
  (if time
      (time (dolist (f *newcmp-files*) (make f)))
    (dolist (f *newcmp-files*) (make f))))))

A function to run the test files is provided by

⟨newcmp.lsp 172⟩+≡  ◁ 172 173 ▷

(defun test-newcmp ()
(dolist (f *newcmp-files*)
(let ((tf (merge-pathnames ".test" f)))
  (when (probe-file tf) (load tf)))))

Finally, loading the file loads the whole system.

⟨newcmp.lsp 172⟩+≡  ◁ 173

(load-newcmp)

Environment Management

This chapter presents some modifications to the environment access and modification functions in the distribution. The main purpose of the modifications is to add handling of declaration information. Declaration handling should be consistent with ANSI CL as described in the HyperSpec [5]. The description in Steele [7] is rather different in terms of the scope of declarations.

⟨environ.lsp 174⟩≡

  (in-package "XLISP")

⟨variables 174⟩

⟨proclamations 174⟩

⟨environment 175⟩

⟨modifications 180⟩

9.1 Proclamations

The function proclaim and the macro declaim register global declarations.

⟨proclamations 174⟩≡ (174) 174 ▷

  (export '(proclaim declaim))

For now, proclaim only registers special, inline, and notinline proclamations; all others are ignored. Eventually optimize declarations may also be recorded.

⟨proclamations 174⟩+≡ (174) ◁ 174 174 ▷

  (defun proclaim (decl)
    (case (first decl)
          (special (dolist (s (rest decl)) (mark-as-special s)))
          (inline (dolist (s (rest decl)) (proclaim-inline s t)))
          (notinline (dolist (s (rest decl)) (proclaim-inline s nil)))))

The declaim macro expands into proclaims wrapped in an eval-when. For now, no attempt is made to restrict the effect to the compilation environment.

⟨proclamations 174⟩+≡ (174) ◁ 174 175 ▷

  (defmacro declaim (&rest args)
    (when args
          `(eval-when (:compile-toplevel :load-toplevel :execute)
                      ,@(mapcar #'(lambda (x) `(proclaim ',x)) args))))

Global inline information is maintained in a hash table. The first element of an entry is one of the symbols inline or notinline. The second element can be something stored by the compiler.

⟨variables 174⟩≡ (174) 175 ▷

  (defvar *inline-table* (make-hash-table))

⟨proclamations 174⟩+≡ (174) ◁ 174

  (defun proclaim-inline (s inline)
    (let ((val (if inline 'inline 'notinline))
          (entry (gethash s *inline-table*)))
      (if entry
          (setf (first entry) val)
        (setf (gethash s *inline-table*) (list val nil)))))

9.2 Augmenting and Querying the Environment

9.2.1 Environment Structure

The XLISP interpreter represents its environments for macro expansion as a cons cell with the variable environment in the car field and the function environment in the cdr field. Each of these environments is a list of frames, and each frame is a list of (name

. value) pairs.

To add local symbol macros, I use the convention that a pair of the form (x . :symbol-macro) that is followed by a pair (:symbol-macro . form) means that form is the expansion of x. To support local symbol macros in the interpreter, the routines xlxgetvalue and xlsetvalue have been modified to look for this structure. Global symbol macros are stored as the :symbol-value property of a symbol. Symbol macros cannot be used for variables proclaimed special; global symbol macros can only be used for variables that are unbound.

The only declarations I pay attention to at this point are special, ignore/ignorable and type declarations for variables, and inline/notinline and ftype declarations for functions.

Macros like defvar and defmacro store information needed during compilation in the compiler environment, *global-environment*. For compatibility with the old compiler, they also still

maintain *cmp-specials* and *cmp-macros*.

⟨variables 174⟩+≡ (174) ◁ 174

  (defvar *global-environment* nil)

The function augment-environment provides the external interface for modifying environments.

The functions variable-information and function-information are used to query the environ-

ment.

⟨environment 175⟩≡ (174) 175 ▷

  (export '(augment-environment variable-information function-information))

These functions were specified in Steele [7] but seem to have been dropped. This implementation is close to the description in Steele, with one departure necessitated by the addition of the ignorable declaration.

9.2.2 Augmenting the Environment

The function augment-environment returns a new environment based on an old one and information provided in keyword arguments. It does some consistency checking to insure that symbols are not used both as variables and symbol macros or as functions and macros.

CHAPTER 9. ENVIRONMENT MANAGEMENT 176

⟨environment 175⟩+≡ (174) ◁ 175 176 ▷

(defun augment-environment (env &key
                              variable symbol-macro function macro declare)
(when (intersection variable (mapcar #'first symbol-macro))
      (error "adding some symbols as variables and as symbol macros"))
(when (intersection function (mapcar #'first macro))
      (error "adding some symbols as functions and macros"))
(setf env (augment-environment-variable variable env))
(setf env (augment-environment-symbol-macro symbol-macro env))
(setf env (augment-environment-function function env))
(setf env (augment-environment-macro macro env))
(setf env (augment-environment-declare declare env))
env)

Variables are added by placing a new frame in the variable environment. Before doing so, the variables are checked to insure that none were proclaimed special.

⟨environment 175⟩+≡ (174) ◁ 175 176 ▷

(defun augment-environment-variable (vars env)
(dolist (v vars)
  (when (special-variable-p v)
        (error "can't make lexical binding for the special variable ~s" v)))
(if vars
    (let ((frame (mapcar #'list vars)))
      (cons (cons frame (car env)) (cdr env)))
  env))

The check for a special proclamation is done by

⟨environment 175⟩+≡ (174) ◁ 176 176 ▷

(defun special-variable-p (sym)
(or (specialp sym)
    (first (get-vdecls sym *global-environment*))
    (and (boundp '*cmp-specials*) (member sym *cmp-specials*))))

Symbol macros are added to the environment by augment-environment-symbol-macro. Again a preliminary pass checks that none of the variables has been proclaimed special.

⟨environment 175⟩+≡ (174) ◁ 176 176 ▷

(defun augment-environment-symbol-macro (smacs env)
(dolist (sm smacs)
  (let ((v (first sm)))
    (when (special-variable-p v)
          (error "can't make lexical binding for the special variable ~s"
                 v))))
(if smacs
    (let ((frame nil))
      (dolist (s smacs)
        (push (cons :symbol-macro (second s)) frame)
        (push (cons (first s) :symbol-macro) frame))
      (cons (cons frame (car env)) (cdr env)))
  env))
Functions are added with augment-environment-function

⟨environment 175⟩+≡ (174) ◁ 176 177 ▷

(defun augment-environment-function (funs env)
(if funs
    (cons (car env) (cons (mapcar #'list funs) (cdr env)))

  env))

and macros with

⟨environment 175⟩+≡ (174) ◁ 176 177 ▷

(defun augment-environment-macro (macs env)
(flet ((mkmac (x) (cons (first x) (coerce-to-macro (second x)))))
  (if macs
      (cons (car env) (cons (mapcar #'mkmac macs) (cdr env)))
    env)))

Adding declarations is a bit more complex. The declarations that are used pertain either to variables or functions. Each adds an entry to a frame in the corresponding environment. Each declaration type is handled separately. To allow the declarations to accumulate, I add new empty function and variable frames to the environment; the code for the individual declarations pushes information on the appropriate frame. At the end, frames that were not used are stripped off again.

⟨environment 175⟩+≡ (174) ◁ 177 177 ▷

(defun augment-environment-declare (decls env)
(setf env (cons (cons nil (car env)) (cons nil (cdr env))))
(dolist (d decls)
  (case (first d)
        (special (add-special-decls (rest d) env))
        ((ignore ignorable) (add-ignore-decls (first d) (rest d) env))
        (type (add-type-decls (second d) (rest (rest d)) env))

(⟨type shorthand 177⟩

         (add-type-decls (first d) (rest d) env))
        ((inline notinline) (add-inline-decls (first d) (rest d) env))
        (ftype (add-ftype-decls (second d) (rest (rest d)) env))))
(when (null (car (car env))) (pop (car env)))
(when (null (car (cdr env))) (pop (cdr env)))
(if (or (car env) (cdr env)) env nil))

⟨type shorthand 177⟩≡ (177)

(array atom bignum bit bit-vector character compiled-function
complex cons double-float fixnum float function hash-table integer
keyword list long-float nil null number package pathname
random-state ratio rational readtable sequence short-float
signed-byte simple-array simple-bit-vector simple-string
simple-vector single-float standard-char stream string symbol t
unsigned-byte vector extended-character real)

The declaration entries are of the form (:declare x . info) where x is the symbol for which information is being added and the form of info depends on whether it is a variable or a function declaration. An entry for a symbol is retrieved from a frame by get-decls-frame. If a binding for the symbol is encountered before a declaration entry, then a default entry form is returned.

⟨environment 175⟩+≡ (174) ◁ 177 178 ▷

(defun get-decls-frame (v frame dflt)
(dolist (entry frame)
  (cond
   ((and (eq (first entry) :declare) (eq (second entry) v))
    (return (rest (rest entry))))
   ((eq (first entry) v) (return dflt)))))

Variable information is searched for frame by frame, and a default form is returned if no entry is found. The declaration information for variables consists of a list of three elements, a special flag, an ignore value, and a type specification. The default special flag and ignore values are nil; the default type is t.

⟨environment 175⟩+≡ (174) ◁ 177 178 ▷

(defun get-vdecls (v env)
  (dolist (frame (car env) '(nil nil t))
    (let ((val (get-decls-frame v frame '(nil nil t))))
      (when val (return val)))))

Function information consists of a list of two elements, the inline value and a type specification. For function information, the default form when no entry is found differs from the form when a binding without declarations is found. The default form for a global binding without local declarations looks up the inline information in the global inline table.

⟨environment 175⟩+≡ (174) ◁ 178 178 ▷

(defun get-fdecls (v env)
  (dolist (frame (cdr env) (list (first (gethash v *inline-table*)) t))
    (let ((val (get-decls-frame v frame '(nil t))))
      (when val (return val)))))

Declarations are added to the environment by adding a new entry that merges the new values with values from an existing entry. Special declarations are added with

⟨environment 175⟩+≡ (174) ◁ 178 178 ▷

(defun add-special-decls (vars env)
  (dolist (v vars)
    (let ((decls (get-vdecls v env)))
      (push `(:declare ,v t ,@(rest decls)) (car (car env))))))

Type declarations are added as

⟨environment 175⟩+≡ (174) ◁ 178 178 ▷

(defun add-type-decls (type vars env)
  (dolist (v vars)
    (let* ((decls (get-vdecls v env))
           (ntype (combine-types (third decls) type)))
      (push `(:declare ,v ,(first decls) ,(second decls) ,ntype)
            (car (car env))))))

A combined type specifier is created with

⟨environment 175⟩+≡ (174) ◁ 178 178 ▷

(defun combine-types (a b)
  (flet ((wrap (x) (if (and (consp x) (eq (first x) 'and)) (rest x) (list x))))
    (cond
     ((eq a t) b)
     ((eq b t) a)
     (t (cons 'and (append (wrap a) (wrap b)))))))

ignore or ignorable declarations put their respective symbols in the ignore field of the information.

⟨environment 175⟩+≡ (174) ◁ 178 179 ▷

(defun add-ignore-decls (which vars env)
  (dolist (v vars)
    (let* ((decls (get-vdecls v env)))
      (push `(:declare ,v ,(first decls) ,which ,(third decls))
            (car (car env))))))

For functions, ftype declarations are handled much like variable type declarations.

⟨environment 175⟩+≡ (174) ◁ 178 179 ▷

(defun add-ftype-decls (type vars env)
(dolist (v vars)
  (let* ((decls (get-fdecls v env))
         (ntype (combine-types (second decls) type)))
    (push `(:declare ,v ,(first decls) ,ntype) (car (cdr env))))))

inline and notinline declarations are handled like variable ignore declarations by placing their symbol in the inline slot.

⟨environment 175⟩+≡ (174) ◁ 179 179 ▷

(defun add-inline-decls (which vars env)
(dolist (v vars)
  (let ((decls (get-fdecls v env)))
    (push `(:declare ,v ,which ,(second decls)) (car (cdr env))))))

9.2.3 Querying the Environment

The information on a variable in an environment is returned by variable-information.

⟨environment 175⟩+≡ (174) ◁ 179 179 ▷

(defun variable-information (sym &optional (env *global-environment*))
(multiple-value-bind (found value extra)
                     (get-environment-entry sym (first env))
 (let* ((dinfo (get-vdecls sym env))
        (special (or (first dinfo) (special-variable-p sym)))

(decls ⟨convert dinfo to variable declaration information 179⟩))

   (cond
    (found
     (if (and (eq value :symbol-macro) (eq (car extra) :symbol-macro))
         (values :symbol-macro t decls)
       (values (if special :special :lexical) t decls)))
    ((constantp sym) (values :constant nil decls))
    (special (values :special nil decls))
    ((nth-value 1 (global-symbol-macro sym))
     (values :symbol-macro nil decls))
    (t (values nil nil decls))))))

The declaration information in dinfo is converted to an alist with type and ignore entries. The ignore entry differs from the one specified in Steele [7] since the ignorable declaration needs to be accommodated. I chose to modify it along the lines of the inline entry for function information.

⟨convert dinfo to variable declaration information 179⟩≡ (179)

(let ((decls nil))
(unless (eq (third dinfo) t)
        (push `(type ,(third dinfo)) decls))
(when (second dinfo) (push `(ignore ,(second dinfo)) decls))
decls)

Function information is returned by

⟨environment 175⟩+≡ (174) ◁ 179

(defun function-information (sym &optional (env *global-environment*))
(flet ((macrop (f) (and (or (typep f 'byte-code-closure) (typep f 'closure))
                        (not (functionp f))))
       (global-frame-p (f) (or (member f (cdr *global-environment*))

                        (eq f *cmp-global-macros*)
                        (and (boundp '*cmp-macros*)
                             (eq f *cmp-macros*)))))
(multiple-value-bind (found value extra frame)
                (get-environment-entry sym (rest env))
(declare (ignore extra))
(let* ((dinfo (get-fdecls sym env))

(decls ⟨convert dinfo to function declaration information 180⟩))

(cond
(found
 (if (macrop value)
     (values :macro (not (global-frame-p frame)) nil)
   (values :function t decls)))
((fboundp sym)
 (let ((fun (symbol-function sym)))
   (cond
    ((macrop fun) (values :macro nil nil))
    ((typep fun 'fsubr) (values :special-operator nil decls))
    (t (values (if (functionp fun) :function nil) nil decls)))))
(t (values nil nil decls)))))))

The declaration information in dinfo is converted to an alist with entries inline and ftype.

⟨convert dinfo to function declaration information 180⟩≡ (179)

(let ((decls nil)
(inline (first dinfo))
(type (second dinfo)))
(unless (member type '(function t))
 (push `(ftype ,type) decls))
(when inline (push `(inline ,inline) decls)))

9.3 Modifications to Some Functions and Macros

A few functions and macros from common3.lsp need to be modified to support the new environment handling approach.

This new definition of split-declarations simplifies the previous one by dropping warnings for special declarations.

⟨modifications 180⟩≡ (174) 180 ▷

(defun split-declarations (x)
(flet ((head-is-declaration (x)
  (and (consp (first x)) (eq (first (first x)) 'declare)))
(head-is-docstring (x) (and (stringp (first x)) (consp (rest x)))))
(do ((decls nil)
(body x (rest body))
(doc nil))
(nil)
(cond
((head-is-declaration body) (push (first body) decls))
((head-is-docstring body) (setf doc (first body)))
(t (return (list (nreverse decls) body doc)))))))

These redefinitions of defvar and defparameter add the special declaration to the global environment used by the compiler. For compatibility, they also add it to *cmp-specials*.

⟨modifications 180⟩+≡ (174) ◁ 180 181 ▷

(define-special-form-macro defvar (var &optional (value nil have-val) doc)
`(progn
(eval-when (:compile-toplevel)

⟨add special declaration for var to global environment 181⟩)

(mark-as-special ',var)
,@(if have-val `((unless (boundp ',var) (set ',var ,value))))
,@(if doc `((%set-get ',var 'variable-documentation ,doc)))
',var))
(define-special-form-macro defparameter (var value &optional doc)
`(progn
(eval-when (:compile-toplevel)

⟨add special declaration for var to global environment 181⟩)

(mark-as-special ',var)
(set ',var ,value)
,@(if doc `((%set-get ',var 'variable-documentation ,doc)))
',var))

⟨add special declaration for var to global environment 181⟩≡ (180)

(when (boundp '*cmp-specials*)
 (pushnew ',var *cmp-specials*))
(setf *global-environment*
 (augment-environment *global-environment*
                      :declare '((special ,var))))

Similarly, defmacro needs to add its macro the the global environment.

⟨modifications 180⟩+≡ (174) ◁ 180 181 ▷

(define-special-form-macro defmacro (f args &rest body &environment env)
(multiple-value-bind (fexpr doc)
                  (make-macro-lambda-expression f args body)
`(progn
  (eval-when (:compile-toplevel)

⟨add macro to global environment 181⟩)

  ,@(if doc `((%set-get ',f 'function-documentation ,doc)))
  (install-function ',f (coerce-to-macro ,fexpr)))))

⟨add macro to global environment 181⟩≡ (181)

(push (cons ',f (coerce-to-macro ,fexpr)) *cmp-macros*)
,(let ((macro (parse-macro f args body env)))
`(setf *global-environment*
     (augment-environment *global-environment*
                          :macro '((,f ,macro)))))

defun does not need to be modified since it is handled directly by the compiler top level.

defmeth needs to be redefined for two reasons, both having to do with suppressing warnings. To avoid warnings when the self variable is not used, an ignorable declaration is added. To avoid warnings about the object not being declared special, a symbol-value form is used if the object is a symbol representing a global (non-lexical) variable.

⟨modifications 180⟩+≡ (174) ◁ 181 182 ▷

#+xlisp-stat
(define-special-form-macro defmeth (ob sym args &rest body &environment env)
(let* ((db (split-declarations body))
    (decls (cons '(declare (ignorable self)) (first db)))

         (b (second db))
         (doc (third db))
         (fexpr `#'(lambda ,(cons 'self args) ,@decls (block ,sym ,@b)))
         (obform (if (and (symbolp ob)
                          (not (eq (variable-information ob env) :lexical)))
                     `(symbol-value ',ob)
                   ob)))
    `(progn
       (xlisp::add-method ,obform ',sym ,fexpr ,doc)
       ',sym)))

def also needs to be redefined to avoid warnings. It turns out that the previous definition would use setf and so would “work” for local variables, but the modification to *variables* made no sense. Just in case someone needs this I’ll preserve it but issue a warning.

⟨modifications 180⟩+≡ (174) ◁ 181

#+xlisp-stat
(defmacro def (symbol value &environment env)
"Syntax: (def var form)
VAR is not evaluated and must be a symbol.  Assigns the value of FORM to
VAR and adds VAR to the list *VARIABLES* of def'ed variables. Returns VAR.
If VAR is already bound and the global variable *ASK-ON-REDEFINE*
is not nil then you are asked if you want to redefine the variable."
  (cond
   ((eq (variable-information symbol env) :lexical)
    (warn "DEF should not be used for the local variable ~s" symbol)
    `(progn (setf ,symbol ,value) ',symbol))
   (t `(unless (and *ask-on-redefine*
                    (boundp ',symbol)
                    (not (y-or-n-p "Variable has a value. Redefine?")))
               (pushnew ',symbol *variables*)
               (setf (symbol-value ',symbol) ,value)
               ',symbol))))

Bibliography

[1] Andrew W. Appel. Compiling with Continuations. Cambridge University Press, New York, 1992.

[2] Andrew W. Appel. Modern Compiler Implementation in C: Basic Techniques. Cambridge University Press, New York, 1997.

[3] Cormac Flanagan, Amr Sabry, Bruce F. Duba, and Matthias Felleisen. The escence of compiling with continuations. In Proceedings of the ACM SIGPLAN ’93 Conference on Programming Language Design and Implementation, volume 28, pages 237–247, June 1993.

[4] D. A. Krantz, R. Kelsey, J. A. Rees, P. Hudak, J. Philbin, and N. I. Adams. Orbit: An optimizing compiler for Scheme. In Proc. Symp. on Compiler Construction, volume 21 of ACM SIGPLAN Notices, pages 219–223, 1986.

[5] Kent Pitman. Common Lisp HyperSpec. WWW, 1996.

[6] Amr Sabry and Matthias Felleisen. Reasoning about programs in continuations-passing style. In Proceedings of the 1992 ACM Conference on Lisp and Functional Programming, pages 288–298, June 1992.

[7] Guy L. Steele. Common Lisp the Language. Digital Press, Burlington, MA., 2nd edition, 1990.