© '98 Thomas Mahler
|
pLISP © '98 Thomas Mahler |
If a function takes more than 2 or 3 arguments, the size of the compiled code will grow and the computation will be slower than for a unary or binary function.
There has been lots of research on variable abstraction algorithms that don't
produce output growing with the number of args.
Our System provides support for several well known algorithms but is ready
for experimentation with different algorithms, as the abstraction and optimization algorithms
are passed as higher order function parameter. (see definition of cf for details)
My own research showed that the smallest Code must not be also the fastest:
The algorithm babstr is suboptimal regarding output size, but the object code
is much faster than that of Cabstr.
Thus the main compile function cf assumes babstr as default.
Algorithms are taken from 'A. Diller, Compiling functional languages' and 'S.L. Peyton Jones, The Implementation of Functional Programming Languages' exact references are given in comments at the respective algorithms below.
see the Combinator Lisp homepage for details on the concepts: http://www.techno.net/pcl/tm/plisp
usage: (cf 'my-fun) compiles lambda body to combinator machine code.
note: function must be quoted: 'my-fun !
uncompile: (uncompile 'my-fun) restores original definition of my-fun
You can play with compiling, uncompiling and executing some simple functions in the file basics.html
// define some minor functions used within the compiler
(define or
(lambda (x y)
(if x
1
(if y 1 0))))
(define and
(lambda (x y)
(if x
(if y 1 0)
0)))
(define consp
(lambda (x)
(not (atomp x))))
(define member
(lambda (x list)
(if (null list)
0
(if (equal x (car list))
1
(member x (cdr list))))))
// build a leftside concatenated bintree from a lisp expr. (rightside concatenated)
// this definition is not used, as it has the same semantics as the mktree primitive
(define tree
(lambda (expr)
(if (atomp expr)
expr
(if (null (cdr expr))
(tree (car expr))
(cons (tree (nfirst (-1 (length expr)) expr)) (tree (car (last expr)))) ))))
// compile any lisp expr
(define c
(lambda (term)
(cc (mktree term))))
// compile and optimize an existing function and replace the original definition
// fun should be qouted, e.g. (cf 'fac)
(define cf
(lambda (fun algorithm optimization) // algorithm may be nil or babstr or cabstr or any valid bracket abstraction
(if (consp fun)
'(error: please use 'fun to pass the function quoted)
(if (not (equal (car (eval fun)) 'lambda)) // be careful to compile only lambda expressions
(cons 'error: (cons fun '(is not a lambda expression !!)))
(progn
(if (null algorithm)
(setq algorithm babstr) // default is babstr
nil
)
(if (null optimization)
(setq optimization optcs) // default optimization
nil
)
(set (implode (append (explode fun) '(_ s a v e))) (eval fun))
(set fun (cons 'ccsubr_ (ropt (c (eval fun)) optimization))) ))))) // replace definition with compiled code
// use (uncompile 'my-fun) to restore original lambda definition of function
// function must be quoted !!
(define uncompile
(lambda (fun old val)
(if (consp fun)
'(error: fun has to be quoted)
(progn
(setq old (implode (append (explode fun) '(_ s a v e))))
(setq val (eval old))
(if (not (equal val '_UNDEFINED_))
(progn
(set fun val) // get original definition
(set old '_UNDEFINED_) // delete _save definition
val)
(cons 'error: (cons fun '(has no saved definition))))))))
// Compile a bintree representation of a lambda term to Combinatory logic bintree
(define cc
(lambda (term)
(if (numberp term)
term
(if (atomp term)
term
(if (equal (car (car term)) 'lambda)
(cc (rabstr algorithm (cdr (car term)) (cdr term)))
(cons (cc (car term)) (cc (cdr term))) )))))
// aabstr implements bracket abstraction algorithm A
// from A. Diller "Compiling functional languages", P. 93f.
(define aabstr
(lambda (var body)
(if (null body)
nil
(if (numberp body)
(cons 'K body)
(if (atomp body)
(if (equal body var)
'I
(cons 'K body) )
(cons (cons 'S (aabstr var (car body))) (aabstr var (cdr body))) )))))
// babstr implements bracket abstraction algorithm B
// from A. Diller "Compiling functional languages", P. 96
(define babstr
(lambda (var body)
(if (null body)
nil
(if (numberp body)
(cons 'K body) // just body will also work !
(if (atomp body)
(if (equal body var) // [x]x => I
'I
(cons 'K body) // [x]E => K E
)
(if (and (equal var (cdr body)) (not (treemem var (car body))))
// Ex => E
(car body)
(if (treemem var (cdr body)) // ...X
(if (treemem var (car body)) // XY
// XY => S([x]X)([x]Y)
(cons (cons 'S (babstr var (car body))) (babstr var (cdr body)))
// EX => B E ([x]X)
(cons (cons 'B (car body)) (babstr var (cdr body)))
)
// ...F
(if (treemem var (car body))
// XF => C([x]X)F
(cons (cons 'C (babstr var (car body))) (cdr body))
// EF => K EF
(cons 'K body)
)
)
)
)
)
)
)
)
// cabstr implements Bracket abstraction algorithm C
// from A. Diller "Compiling functional languages", p.98
(define cabstr
(lambda (var body)
(if (null body)
nil
(if (numberp body)
(cons 'K body) // just body will also work !
(if (atomp body)
(if (equal body var) // [x]x => I
'I
(cons 'K body) // [x]E => K E
)
(if (and (equal var (cdr body)) (not (treemem var (car body))))
// Ex => E
(car body)
(if (treemem var (cdr body)) // ...X
(if (treemem var (car body)) // XY
(if (and (consp (car body)) (not (treemem var (car (car body)))))
// E X Y => S' E ([x]X) ([x]Y)
(cons (cons (cons 'S1 (car (car body))) (cabstr var (cdr (car body)))) (cabstr var (cdr body)) )
// XY => S([x]X)([x]Y)
(cons (cons 'S (cabstr var (car body))) (cabstr var (cdr body)))
)
// ...EX
(if (consp (car body))
// E F X => B' E F ([x]X)
(cons (cons (cons 'B1 (car (car body))) (cdr (car body))) (cabstr var (cdr body)) )
// EX => B E ([x]X)
(cons (cons 'B (car body)) (cabstr var (cdr body)))
)
// in case we omit B optimization: //(cons (cons 'B (car body)) (cabstr var (cdr body)))
)
// ...F
(if (treemem var (car body))
// ...XF
(if (and (consp (car body)) (not (treemem var (car (car body)))))
// EXF => C' E ([x]X) F
(cons (cons (cons 'C1 (car (car body))) (cabstr var (cdr (car body)))) (cdr body) )
// XF => C([x]X)F
(cons (cons 'C (cabstr var (car body))) (cdr body))
)
// EF => K EF
(cons 'K body)
)
)
)
)
)
)
)
)
// csabstr implements Bracket abstraction algorithm CS
// from A. Diller "Compiling functional languages", p.98
// following ideas mentioned in S.L. Peyton Jones
// "The Implementation of Functional Programming Languages", p.272ff
//
(define csabstr
(lambda (var body)
(if (null body)
nil
(if (numberp body)
(cons 'K body) // just body will also work !
(if (atomp body)
(if (equal body var) // [x]x => I
'I
(cons 'K body) // [x]E => K E
)
(if (and (equal var (cdr body)) (not (treemem var (car body))))
// Ex => E
(car body)
(if (treemem var (cdr body)) // ...X
(if (treemem var (car body)) // XY
(if (and (consp (car body)) (not (treemem var (car (car body)))))
// E X Y => S' E ([x]X) ([x]Y)
(cons (cons (cons 'S1 (car (car body))) (csabstr var (cdr (car body)))) (csabstr var (cdr body)) )
// XY => S([x]X)([x]Y)
(cons (cons 'S (csabstr var (car body))) (csabstr var (cdr body)))
)
// ...EX
//(if (consp (car body))
// // E F X => B' E F ([x]X)
// (cons (cons (cons 'B1 (car (car body))) (cdr (car body))) (cabstr var (cdr body)) )
// // EX => B E ([x]X)
// (cons (cons 'B (car body)) (cabstr var (cdr body)))
//)
(cons (cons 'B (car body)) (csabstr var (cdr body)))
)
// ...F
(if (treemem var (car body))
// ...XF
(if (and (consp (car body)) (not (treemem var (car (car body)))))
// EXF => C' E ([x]X) F
(cons (cons (cons 'C1 (car (car body))) (csabstr var (cdr (car body)))) (cdr body) )
// XF => C([x]X)F
(cons (cons 'C (csabstr var (car body))) (cdr body))
)
// EF => K EF
(cons 'K body)
)
)
)
)
)
)
)
)
// (tree item tree) returns 1 if item is in tree, 0 else
(define treemem
(lambda (x tree)
(if (null tree) 0
(if (atomp tree)
(equal x tree)
(or (treemem x (car tree)) (treemem x (cdr tree)))))))
// recursive abstraction of bound variables from a lambda term
(define rabstr
(lambda (algorithm vars body) // algorithm may be any bracket abstraction like cabstr or babstr
(if (null vars)
body
(if (atomp vars)
(algorithm vars body)
(rabstr algorithm (car vars)
(algorithm (cdr vars) body))))))
// It may interesting to experiment with different ways of compiling object code,
// say directly with babstr or with aabstr + opta.
// optimize compiled Combinator Code from algorithm A (aabstr)
// Optimisation rule according to Diller P. 96, (7.10) - (7.13)
(define opta
(lambda (expr)
(if (atomp expr) expr
(if (and (equal (spine expr) 'S) (= (length (lastack expr nil)) 2)) // expr is like (S x y)
(if (equal (car (cdr (car expr))) 'K) // (S (K e) ...)
(if (equal (cdr expr) 'I) // (S (K e) I) -> e
(cdr (cdr (car expr)))
(if (equal (car (cdr expr)) 'K) // (S (K e1) (K e2)) -> (K (e1 e2))
(cons 'K (cons (cdr (cdr (car expr))) (cdr (cdr expr))))
(cons (cons 'B (cdr (cdr (car expr)))) (cdr expr)) // (S (K e1) e2) -> (B e1 e2)
)
)
(if (equal (car (cdr expr)) 'K) // (S e1 (K e2)) -> (C e1 e2)
(cons (cons 'C (cdr (car expr))) (cdr (cdr expr)))
expr
)
)
expr
)
)
)
)
// optimize compiled Combinator Code from algorithm B
// Optimisation rule according to Diller P. 98, (7.15) - (7.17)
(define optb
(lambda (expr)
(if (atomp expr)
expr
(if (equal (car (car expr)) 'S) // S N M
(if (equal (car (cdr (car expr))) 'B) // S (B P Q) R => S' P Q R
(cons (cons (cons 'S1 (cdr (car (cdr (car expr))))) (cdr (cdr (car expr)))) (cdr expr))
expr
)
(if (and (equal (car (car expr)) 'C) (equal (car (cdr (car expr))) 'B) ) // C (B P Q) R => C' P Q R
(cons (cons (cons 'C1 (cdr (car (cdr (car expr))))) (cdr (cdr (car expr)))) (cdr expr))
(if (and (equal (car (car expr)) 'B) (consp (cdr (car expr)))) // B (P Q) R => B' P Q R
(cons (cons (cons 'B1 (car (cdr (car expr)))) (cdr (cdr (car expr)))) (cdr expr))
expr
)
)
)
)
)
)
// optimize compiled Combinator Code from algorithm B
// Optimisation rule according to Diller P. 98, (7.15) - (7.17) + p.102
(define optcs
(lambda (expr)
(if (atomp expr)
expr
(if (equal (car (car expr)) 'S) // S N M
(if (equal (car (cdr (car expr))) 'B) // S (B P Q) R => S' P Q R
(cons (cons (cons 'S1 (cdr (car (cdr (car expr))))) (cdr (cdr (car expr)))) (cdr expr))
expr
)
(if (and (equal (car (car expr)) 'C) (equal (car (cdr (car expr))) 'B) ) // C (B P Q) R => C' P Q R
(cons (cons (cons 'C1 (cdr (car (cdr (car expr))))) (cdr (cdr (car expr)))) (cdr expr))
(if (and (equal (car (car expr)) 'B) (equal (car (car (cdr expr))) 'B) ) // B P (B Q R) => B* P Q R
(cons (cons (cons 'B* (cdr (car expr))) (cdr (car (cdr expr)))) (cdr (cdr expr)))
expr
)
)
)
)
)
)
// recursive optimisation, calls optimization algorithm on any subtree
(define ropt
(lambda (expr fun) // fun is the chosen optimization opta, or optb
(if (atomp expr) expr
(fun (cons (ropt (car expr) fun) (ropt (cdr expr) fun))))))
// compute spine to leftmost combinator
(define spine
(lambda (expr)
(if (atomp expr) expr
(spine (car expr)))))
// compute left-ancestors-stack
(define lastack
(lambda (expr stack)
(if (atomp expr)
stack
(lastack (car expr) (cons expr stack)))))
// demo function acc. to Diller, P. 102
// this function may be used as an indicator for output size of different
// compiling algorithms:
(define update (lambda (f x y z) (if (eq z x) y (f z))))