flite-0.1.1: Flite/CompileBackend.lhs
========================
REDUCERON MEMO 22
Compiling F-lite to C
Matthew N, 30 April 2009
========================
This memo defines a compiler from supercombinators to portable C. It
is intended as a back-end to the F-lite implementation. The aim is to
run F-lite programs on an FPGA soft-core, such as the Microblaze.
> module Flite.CompileBackend where
> import Data.List
Heap layout
-----------
A node is a tagged pointer, storable in a single word of memory.
> nodeType = "typedef unsigned long Node;"
The least-significant bit of a node is a tag stating whether the node
is an AP, containing a pointer to an application (a sequence of nodes)
on the heap, or an OTHER, containing something else.
typedef enum {AP = 0, OTHER = 1} Tag;
The 2nd least-significant bit of a node is a flag stating whether or
not the node is the final node of an application.
> macros = unlines
> [ "#define isFinal(n) ((n) & 2)"
> , "#define clearFinal(n) ((n) & (~2))"
> , "#define setFinal(n) ((n) | 2)"
> , "#define markFinal(n,final) ((final) ? setFinal(n) : clearFinal(n))"
If a node is an AP, its remaining 30 bits is a word-aligned heap
address.
> , "#define getAP(n) ((Node *) ((n) & (~3)))"
If the node is an OTHER, its 3rd least-significant bit contains a
sub-tag stating whether the the node is an INT or a FUN.
typedef enum {INT = 0, FUN = 1} Subtag;
If a node is an INT, its remaining 29-bits is an unboxed integer.
> , "#define getINT(n) (((signed long) n) >> 3)"
If a node is a FUN, its remaining 29-bits contains a 6-bit arity and a
23-bit function identifier.
> , "#define getARITY(n) (((n) >> 3) & 63)"
> , "#define getFUN(n) ((n) >> 9)"
More precisely:
> , "#define isAP(n) (((n) & 1) == 0)"
> , "#define isINT(n) (((n) & 5) == 1)"
> , "#define isFUN(n) (((n) & 5) == 5)"
> , "#define makeAP(a,final) ((unsigned long) (a) | ((final) << 1))"
> , "#define makeINT(i,final) (((i) << 3) | ((final) << 1) | 1)"
> , "#define makeFUN(arity,f,final) " ++
> "(((f) << 9) | ((arity) << 3) | ((final) << 1) | 5)"
> , "#define arity(n) (isFUN(n) ? getARITY(n) : 1)"
> ]
Update records
--------------
An update record is a pair containing a stack pointer (to detect when
a head normal form has been reached) and a heap pointer (stating where
to write the head normal form).
> updateType = "typedef struct { Node *s; Node *h; } Update;"
Registers
---------
> registers = unlines
> [ "Node top;" {- top of stack -}
> , "Node *sp;" {- stack pointer -}
> , "Node *hp;" {- heap pointer -}
> , "Node *tsp;" {- to-space pointer -}
> , "Update *usp;" {- update-stack pointer -}
> , "unsigned int dest;" {- destination address for computed jumps -}
> ]
Swapping
--------
The following code swaps the top two elements of the stack. It is
used in the evaluation of strict primitive functions.
> swapCode = unlines
> [ "{"
> , " Node tmp;"
> , " tmp = top;"
> , " top = sp[-1];"
> , " sp[-1] = tmp;"
> , "}"
> ]
Unwinding
---------
Unwinding copies an application from the heap onto the stack, and
pushes an update record onto the update stack.
> unwindCode = unlines
> [ "{"
> , " Node *p;"
> , " p = getAP(top);"
> , " usp++; usp->s = sp; usp->h = p;"
> , " for (;;) {"
> , " top = *p++;"
> , " if (isFinal(top)) break;"
> , " *sp++ = top;"
> , " }"
> , "}"
> ]
Updating
--------
The following code determines if a normal form has been reached, and
if so, performs an update.
> updateCode = unlines
> [ "{"
> , " unsigned int args, ari;"
> , " Node *base;"
> , " Node *p;"
> , " ari = arity(top);"
> , " if (sp - ari < stack) goto EXIT;"
> , " DO_UPDATE:"
> , " args = ((unsigned int) (sp - usp->s));"
> , " if (ari > args && usp > ustack) {"
> , " base = hp;"
> , " p = sp - args;"
> , " while (p < sp) *hp++ = clearFinal(*p++);"
> , " *hp++ = setFinal(top);"
> , " *(usp->h) = makeAP(base, 1);"
> , " usp--;"
> , " goto DO_UPDATE;"
> , " }"
> , "}"
> ]
Evaluation driver
-----------------
Evalution proceeds depedning on the element on top of the stack.
> evalCode = unlines
> [ "EVAL:"
> , "if (isAP(top)) {"
> , unwindCode
> , " goto EVAL;"
> , "}"
> , "else {"
> , " EVAL_OTHER:"
> , " if (hp > heapFull) collect();"
> , updateCode
> , " if (isFUN(top)) {"
> , " dest = getFUN(top);"
> , " goto CALL;"
> , " }"
> , " else {"
> , swapCode
> , " goto EVAL;"
> , " }"
> , "}"
> ]
Abstract syntax of source code
------------------------------
The body of a function is a list of identifier/application pairs. The
first element in the list contains the spine application of the
function.
> type Binding = (Id, App)
> type Body = [Binding]
An application is a list of nodes.
> type App = [Node]
> data Node
> = VAR Id {- variable reference -}
> | ARG Int {- argument reference -}
> | FUN Arity Id {- function identifier -}
> | INT Int {- integer -}
> deriving Show
> type Id = String
A function definition consists of an identifier, an arity, and a body.
> type Defn = (Id, Arity, Body)
> type Arity = Int
For example, the F-lite function definition
s f g x = f x (g x);
is represented in abstract syntax as follows.
("s", 3, [ ("v0", [ARG 0, ARG 2, VAR "v1"])
, ("v1", [ARG 1, ARG 2])
])
A data constructor consists of identifier, an arity, and an index.
> type Cons = (Id, Arity, Index)
> type Index = Int
A program consists of a list of constuctors and a list of function
definitions.
> type Program = ([Cons], [Defn])
Function calling
----------------
Each function body is implemented as a case alternative in a large
switch statement. To jump to the code for a function, place the
function's identifier in the 'dest' register and then 'goto CALL'.
This double jump is not very efficient, but its not obvious how to do
any better in C.
> switchCode (cs, ds) = unlines
> [ "CALL:"
> , "switch (dest)"
> , "{"
> , prims -- primitive definitions
> , constrs cs -- constructor definitions
> , defns ds -- function definitions
> , "}"
> ]
Constructor compilation
-----------------------
Each constructor C used in the program is treated as a function with
the following definition.
Ci v1 ... vn f = (f+i) v1 ... vn f
where i is the index of the constructor, n is the artiy of the
constructor, and (f+i) represents the function occuring i definitions
after the definition of f in the program code. It is assumed that
case alternatives occur contiguously, ordered by index. For example,
the F-lite program
rev acc Nil = acc;
rev acc (Cons x xs) = rev (Cons x acc) xs;
is transformed down to
rev acc xs = xs revCons acc;
revCons x xs acc = rev (Cons x acc) xs;
revNil acc = acc;
if Cons has index 0 and Nil has index 1.
(See Memo 13 for a more detailed explanation of how constructors and
case expressions are treated.)
> cons :: Cons -> String
> cons (f, n, i) = unlines
> [ "case " ++ fun f ++ ":"
> , "{"
> , "dest = getFUN(sp[-" ++ show (n+1) ++ "]) + " ++ show i ++ ";"
> , "goto CALL;"
> , "}"
> , "break;"
> ]
NB. No update is required because a case expression is not a normal form.
> constrs :: [Cons] -> String
> constrs = concatMap cons
Function compilation
--------------------
> arg :: Int -> String
> arg i = "ARG_" ++ show i
> var :: Id -> String
> var v = "VAR_" ++ v
Map F-lite primitives to suitable C identifiers.
> fun :: Id -> String
> fun "(+)" = "PRIM_PLUS"
> fun "(-)" = "PRIM_MINUS"
> fun "(<=)" = "PRIM_LEQ"
> fun "(==)" = "PRIM_EQ"
> fun "(/=)" = "PRIM_NEQ"
> fun "emit" = "PRIM_EMIT"
> fun "emitInt" = "PRIM_EMITINT"
> fun "_|_" = "PRIM_UNDEFINED"
> fun f = "FUN_" ++ f
> declareArgs :: Int -> String
> declareArgs n = unlines $ map save [1..n]
> where save i = "Node " ++ arg i ++ " = sp[-" ++ show i ++ "];"
> declareLocals :: String
> declareLocals = "Node *base = hp;"
> type Locs = [(Id, Int)]
> node :: String -> Locs -> String -> Node -> String
> node r vs final (INT i) =
> r ++ " = makeINT(" ++ show i ++ "," ++ final ++ ");"
> node r vs final (ARG i) =
> r ++ " = markFinal(" ++ arg (i+1) ++ "," ++ final ++ ");"
> node r vs final (VAR v) =
> r ++ " = makeAP(base+" ++ offset ++ "," ++ final ++ ");"
> where offset = show $ lookupVar v vs
> node r vs final (FUN n f) =
> r ++ " = makeFUN(" ++ show n ++ "," ++ fun f ++ "," ++ final ++ ");"
> lookupVar v vs = case lookup v vs of { Nothing -> error msg ; Just i -> i }
> where msg = error ("Unknown identifier '" ++ v ++ "'")
> app :: Locs -> App -> String
> app vs app = unlines $ zipWith (node "*hp++" vs) finals app
> where finals = map (const "0") (init app) ++ ["1"]
> spine :: Locs -> App -> String
> spine vs ns = unlines
> [ unlines $ map (node "*sp++" vs "0") (init ns)
> , node "top" vs "0" (last ns)
> ]
> varLocs :: Body -> Locs
> varLocs body = zip vs (scanl (+) 0 (map length apps))
> where (vs, apps) = unzip body
> body :: App -> Body -> String
> body s b = unlines
> [ concatMap (app vs . snd) b
> , spine vs s
> , "goto EVAL;"
> ] where vs = varLocs b
> defn :: Defn -> String
> defn (f, n, bs) = unlines
> [ "case " ++ fun f ++ ":"
> , "{"
> , declareArgs n
> , declareLocals
> , "sp -= " ++ show n ++ ";"
> , body (snd s) b
> , "}"
> , "break;"
> ]
> where s:b = [(v, reverse a) | (v, a) <- bs]
> defns :: [Defn] -> String
> defns = concatMap defn
Primitives
----------
> primIds :: [Id]
> primIds =
> [ "(+)" , "(-)" , "(<=)" , "(==)", "(/=)", "emit", "emitInt", "_|_" ]
Apply primitive arithmetic operator to 2nd and 3rd stack elements;
store result in top.
> arithPrim :: Id -> String -> String
> arithPrim p op = unlines
> [ "case " ++ fun p ++ ":"
> , "{"
> , "top = makeINT(getINT(sp[-1]) " ++ op ++ " getINT(sp[-2]),0);"
> , "sp -= 2;"
> , "goto EVAL;"
> , "}"
> , "break;"
> ]
Ditto for boolean operator.
> boolPrim :: Id -> String -> String
> boolPrim p op = unlines
> [ "case " ++ fun p ++ ":"
> , "{"
> , "top = (getINT(sp[-1]) " ++ op ++ " getINT(sp[-2])) ? "
> ++ "makeFUN(1," ++ fun "True" ++ ",0) "
> ++ ": makeFUN(1," ++ fun "False" ++ ",0);"
> , "sp -= 2;"
> , "goto EVAL;"
> , "}"
> , "break;"
> ]
Print the second stack element.
> emitPrim :: Id -> String -> String
> emitPrim p format = unlines
> [ "case " ++ fun p ++ ":"
> , "{"
> , "top = sp[-2];"
> , "printf(\"" ++ format ++ "\", getINT(sp[-1]));"
> , "sp -= 2;"
> , "goto EVAL;"
> , "}"
> , "break;"
> ]
> undefPrim :: String
> undefPrim = unlines
> [ "case " ++ fun "_|_" ++ ":"
> , "{"
> , "printf(\"ERROR: bottom!\\n\");"
> , "goto EXIT;"
> , "}"
> , "break;"
> ]
> prims :: String
> prims = unlines
> [ arithPrim "(+)" "+"
> , arithPrim "(-)" "-"
> , boolPrim "(<=)" "<="
> , boolPrim "(==)" "=="
> , boolPrim "(/=)" "!="
> , emitPrim "emit" "%c"
> , emitPrim "emitInt" "%i"
> , undefPrim
> ]
Garbage collection
------------------
> copyAPCode = unlines
> [ "Node *copyAP(Node *src) {"
> , " Node n;"
> , " Node *from = src;"
> , " Node *dst = tsp;"
> , " n = *from;"
> , " if (isAP(n)) {"
> , " Node *loc = getAP(n);"
> , " if (loc >= toSpace && loc < toSpaceEnd) return loc;"
> , " }"
> , " do {"
> , " n = *from++; *tsp++ = n;"
> , " } while (! isFinal(n));"
> , " *src = (Node) dst;"
> , " return dst;"
> , "}"
> ]
> copyCode = unlines
> [ "void copy() {"
> , " Node n;"
> , " Node *low = toSpace;"
> , " while (low < tsp) {"
> , " n = *low;"
> , " if (isAP(n)) {"
> , " Node *loc = copyAP(getAP(n));"
> , " *low = markFinal((Node) loc, isFinal(n));"
> , " }"
> , " low++;"
> , " }"
> , "}"
> ]
> collectCode = unlines
> [ "void collect () {"
> , " Node n;"
> , " Node *p1;"
> , " Update *p2;"
> , " Update *p3;"
> , " tsp = toSpace;"
> , " p1 = stack;"
> , " while (p1 < sp) {"
> , " n = *p1;"
> , " if (isAP(n)) *p1 = (Node) copyAP(getAP(n));"
> , " p1++;"
> , " }"
> , " if (isAP(top)) top = (Node) copyAP(getAP(top));"
> , " copy();"
> , " p2 = ustack+1;"
> , " p3 = ustack;"
> , " while (p2 <= usp) {"
> , " n = *(p2->h);"
> , " if (isAP(n) && getAP(n) >= toSpace && getAP(n) <= toSpaceEnd) {"
> , " p3++;"
> , " p3->s = p2->s;"
> , " p3->h = getAP(n);"
> , " }"
> , " p2++;"
> , " }"
> , " usp = p3;"
> , " hp = tsp;"
> , " p1 = toSpace; toSpace = heap; heap = p1;"
> , " p1 = toSpaceEnd; toSpaceEnd = heapEnd; heapEnd = p1;"
> , " p1 = toSpaceFull; toSpaceFull = heapFull; heapFull = p1;"
> , "}"
> ]
Global variables
----------------
We need to store the beginning and end address of each memory
partition, to detect termination and exhaustion.
> globals :: String
> globals = unlines
> [ "Node *heap;"
> , "Node *heapEnd;"
> , "Node *heapFull;"
> , "Node *toSpace;"
> , "Node *toSpaceEnd;"
> , "Node *toSpaceFull;"
> , "Node *stack;"
> , "Node *stackEnd;"
> , "Update *ustack;"
> , "Update *ustackEnd;"
> ]
Memory allocation
-----------------
> allocate :: Int -> Int -> String
> allocate heapSize stackSize = unlines
> [ "heap = (Node *) malloc(sizeof(Node) * " ++ show heapSize ++ ");"
> , "hp = heap;"
> , "heapEnd = heap + " ++ show heapSize ++ ";"
> , "heapFull = heapEnd - 1000;"
> , "toSpace = (Node *) malloc(sizeof(Node) * " ++ show heapSize ++ ");"
> , "tsp = toSpace;"
> , "toSpaceEnd = toSpace + " ++ show heapSize ++ ";"
> , "toSpaceFull = toSpaceEnd - 1000;"
> , "stack = (Node *) malloc(sizeof(Node) * " ++ show stackSize ++ ");"
> , "sp = stack;"
> , "stackEnd = stack + " ++ show stackSize ++ ";"
> , "ustack = (Update *) malloc(sizeof(Update) * " ++ show stackSize ++ ");"
> , "usp = ustack;"
> , "ustackEnd = ustack + " ++ show stackSize ++ ";"
> ]
Program compilation
-------------------
> funIds :: Program -> [String]
> funIds (cs, ds) = map first cs ++ map first ds
> where first (x, y, z) = x
> declareFuns :: Program -> String
> declareFuns p =
> unlines $ [def f i | (f, i) <- zip (primIds ++ funIds p) [0..]]
> where def f i = "#define " ++ fun f ++ " " ++ show i
> program :: Program -> String
> program p = unlines
> [ "#include <stdio.h>"
> , "#include <stdlib.h>"
> , nodeType
> , updateType
> , macros
> , declareFuns p
> , registers
> , globals
> , copyAPCode
> , copyCode
> , collectCode
> , "int main(void) {"
> , allocate 8000000 1000000
> , "dest = " ++ fun "main" ++ ";"
> , switchCode p
> , evalCode
> , "EXIT:"
> , "return 0;"
> , "}"
> ]