Haskell＋タグレスな型付きDSLで楽々！C言語コード生成

関数型プログラミング言語とコード生成

HaskellやOCamlなどはコンパイラなどの言語処理系の実装を得意としている。さすがに日常的にコンパイラを実装している人はそう多くないと思うけど、例えばコード自動生成はすぐ試せる割に効き目が大きく、仕事を効率化する方法としてぜひ試してみたい選択肢だ。

今回は、Haskellの言語内DSLからC言語のコードを生成する方法（の一つ）を簡単に紹介する。 この方法で、Haskell上のEDSLを使って (1) C言語のソースコードを生成でき、 (2) Haskellの式として評価できる。 このように、わざわざパーサを書かなくても、コンビネータを適当に作ればすぐにDSLを作ってしまえるのも、関数型言語の魅力かもしれない。

taglessな方法

ただし、ちょっと他と違う方法を試す。 OlegさんのサイトにTyped Tagless Interpretations という記事があり、そこで紹介されている方法を追いかける。 バリアント型/代数的データ型を使わず(=tagless)に、型付きのDSLのインタプリタを実装しよう、という内容だ。 そもそも、言語を実装するには、抽象構文木を表現するバリアント型を作るのが普通なのだが、この方法ではバリアントのような具体的な中間表現を使わないという点に特徴がある。

このエントリ末尾のコードを見てほしい。 対象言語の抽象構文木が型クラスで表現されており、 GADTやバリアント型を使っていないことに注目。 同様のコードはOCamlでも書ける。 シグネチャで構文を定義し、モジュールで変換方法を、 ファンクタでDSLの項を書くことになる。

特に「型付きの」DSLをGADT抜きで実装できている点が面白い。GADTにより、対象言語の型情報をうまくHaskell （ないしOCaml）の型システムと結びつけて扱うことができ、型安全なインタプリタないしコンパイラを作ることができるが、taglessな方法では中間表現を経由しないためにそもそもGADTが必要ない。

C言語の構文解析ライブラリ language-c-quote

C言語のコード生成にはlanguage-c-quoteというライブラリを使っている (cabal install language-c-quoteでインストールできる)。 以前紹介したLanguage.Cとは別もので、こちらは[cexp| … |] という構文でC言語のコード片を書くことができる QuasiQuotationの機能を備えており、コード生成が多少やりやすくなっている。

議論

中間表現を経由しないのはメリットだと思う。

• 処理速度の向上（？） パターンマッチのオーバーヘッドがない。
  • 中間表現を排した分、空間効率は良いのだろうと思う。
  • しかしHaskellの場合、最適化がないと辞書渡しのオーバーヘッドが別に加わることになる。OCamlも同様。時間効率が具体的にどうなのかよくわからない…
• HOASのexotic termの問題がない。 言語内のbinderの表現に Higher Order Abstract Syntax (HOAS) を使っているが、 型表現がパラメトリックなので、exotic termがそもそも作れないようになっている。

一方デメリットは…あるのかよくわからない。一見、中間表現を排しているので、項の構造を調べるのが困難な気がしないでもないけれど、例えばOlegさんの論文には項の大きさを計る方法が載っていたり、特に難しいことはないような感じもする。

• 部分評価器 (partial evaluator) の例では、インタプリタとコンパイラの結果の両方を保持しているのが非効率といえなくもない、かな…（わからない）

コード

(ワンライナーを駆使しているのは見逃してほしい…)

{-# LANGUAGE QuasiQuotes, UndecidableInstances, GADTs, RankNTypes, TypeSynonymInstances, FlexibleInstances, 
KindSignatures, TypeFamilies, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, 
NoMonomorphismRestriction #-}

-- requires GHC>7 (Haskell platform of the current version will suffice)
-- cabal install language-c-quote hashtables

import Prelude hiding (sum)
import Data.Maybe
import Control.Monad
import Control.Monad.ST
import qualified Data.HashTable.ST.Basic as HT
import Language.C.Syntax
import Language.C.Syntax as C
import Language.C.Quote.GCC {- quasiquote! -}
import Data.Loc
import Data.Symbol

type D = Double

--------------------
-- our purely-functional DSL
--------------------

-- unary and binary operators in our DSL
data Op1 = Neg deriving Show
data Op2 = Plus | Minus | Mult | Divi deriving Show

-- 'tagless' representation of the language
class Lang (e :: * -> *) (array :: * -> *) | e -> array, array -> e where
  -- | e1 `op` e2
  binOp :: Op2 -> e D -> e D -> e D
  -- | op e1
  unOp :: Op1 -> e D -> e D
  -- | iter from to init body -- evaluate the 'body', and accumulate it for (to-from+1) times
  iter :: e Int -> e Int -> e D -> (e Int -> e D -> e D) -> e D
  -- | constant of type Int
  int :: Integer -> e Int
  -- | constant of type double
  double :: D -> e D
  -- | let-binding in the target language
  let_ :: String -> e a -> (e a -> e b) -> e b
  -- | index-based array access (yet not be implemented) 
  at :: e Int -> e (array x) -> e x

{-
Above tagless representation is much similar to the type declaration in GADT, 
which should be like following:
data Lang t where
  BinOp :: Op2 -> Lang D -> Lang D -> Lang D
  UnOp :: Op1 -> Lang D -> Lang D
  Iter :: Lang Int -> Lang Int -> Lang D -> (Lang Int -> Lang D -> Lang D) -> Lang D
  Int :: Integer -> Lang Int
  Double :: D -> Lang D
  Let :: String -> Lang a -> (Lang a -> Lang b) -> Lang b
  At :: Lang Int -> Lang (Array x) -> Lang x
-}

--------------------
-- SYNOPSIS
--------------------

-- add x for ten times
tenTimes x = 
  iter (int 1) (int 10) (double 0.0) (\_ acc-> binOp Plus acc x)
  -- literally, this can be read as 
  -- 'foldl (+) 0.0 $ take 10 $ repeat x' in Haskell,
  -- or 'double accum=0.0; for(int i=0; i<=10; i++) { accum += x; } return accum;' in C

-- 
ex1 = tenTimes (tenTimes (double 1.0))

-- Try this:

-- Evaluate it in Haskell:
---- runHaskell ex1
---- ===> 100.0

-- Generate C Code:
---- genCCode (tenTimes (tenTimes (double 1.0)))
---- ===> (evaluated into the code below)
{-
{
    double accum0 = 0.0;
    
    for (int i0 = 1; i <= 10; i0++) {
        double accum1 = 0.0;
        
        for (int i1 = 1; i <= 10; i1++) {
            ;
            accum1 = accum1 + 1.0;
        }
        ;
        accum0 = accum0 + accum1;
    }
    accum0;
}
-}

--------------------
-- Lesson 1. Evaluate everything in Haskell
--------------------

newtype H x = H x
liftH f (H x) = H (f x)
liftH2 f (H x) (H y) = H (f x y)

toHBinOp :: Op2 -> H D -> H D -> H D
toHBinOp Plus = liftH2 (+)
toHBinOp Minus = liftH2 (-)
toHBinOp Mult = liftH2 (*)
toHBinOp Divi = liftH2 (/)

toHUnOp :: Op1 -> H D -> H D
toHUnOp Neg = liftH pred

instance Lang H [] where
  binOp = toHBinOp
  unOp = toHUnOp
  iter (H from) (H to) (H init) f = 
    if from>to then H (init) 
    else let acc = f (H from) (H init) in iter (H (from+1)) (H to) acc f
  int = H . fromInteger
  double = H
  let_ _ x f = f x
  at = liftH2 (flip (!!))

runHaskell :: H a -> a
runHaskell (H x) = x




--------------------
-- Lesson 2. C code generation
--------------------

-- preparation for embedding typed terms into untyped world
class UntypedLang e where
  binOpU :: Op2 -> e -> e -> e
  unOpU :: Op1 -> e -> e
  iterU :: e -> e -> e -> (e -> e -> e) -> e
  atU :: e -> e -> e
  intU :: Integer -> e
  doubleU :: Double -> e
  letU :: String -> e -> (e -> e) -> e

newtype Untyped t z = U {unU::t}
data Dummy a

instance UntypedLang t => Lang (Untyped t) Dummy where
  binOp op (U e1) (U e2) = U $ binOpU op e1 e2
  unOp op (U e) = U $ unOpU op e
  iter (U e1) (U e2) (U e3) f = U $ iterU e1 e2 e3 (\x y -> unU $ f (U x) (U y))
  at (U e1) (U e2) = U $ atU e1 e2
  int i = U $ intU i
  double d = U $ doubleU d
  let_ s (U e) f = U $ letU s e (\x -> unU $ f (U x))


-- my own Q monad for generating fresh names
newtype Q a = Q (forall s. HT.HashTable s String Int -> ST s a)

instance Monad Q where
  Q f >>= g = Q (\ht -> f ht >>= (\x -> case g x of Q g' -> g' ht))
  return a = Q (\_ -> return a)

runQ :: Q a -> a
runQ (Q m) = runST $ do ht <- HT.new; m ht

newName :: String -> Q String
newName str = Q (\ht -> do
    cnt <- liftM (fromMaybe 0) $ HT.lookup ht str
    HT.insert ht str (cnt+1)
    return $ str ++ show cnt
  )

makeVar :: String -> Exp
makeVar str = Var (Id str noSrcLoc) noSrcLoc



-- mapping operators in our DSL into ones in C
toCBinOp :: Op2 -> BinOp
toCBinOp Plus = C.Add
toCBinOp Minus = C.Sub
toCBinOp Mult = C.Mul
toCBinOp Divi = C.Div

toCUnOp :: Op1 -> UnOp
toCUnOp Neg = C.Negate

-- generate C code!!
instance UntypedLang (Q ([BlockItem],Exp)) where
  -- The pair (stmts, exp) :: ([BlockItem], Exp) is the code that first execute C statements 'stmts' then evaluate 'exp'
  -- Although things are provided as 'UntypedLang', the translation should be type-safe.
  -- since terms are firstly typed using typeful constructor functions of 'Lang', then are embedded into untyped world.
  binOpU op e1 e2 = do (s1,x1) <- e1; (s2,x2) <- e2; return (s1++s2,BinOp (toCBinOp op) x1 x2 noSrcLoc)
  unOpU op e1 = do (s1,x1) <- e1; return (s1,UnOp (toCUnOp op) x1 noSrcLoc)
  iterU from to init body = do
    (sf,f) <- from;
    (st,t) <- to;
    (si,i) <- init;
    cntvar <- newName "i";
    accumvar <- newName "accum";
    let (cntvar_, accumvar_) = (makeVar cntvar, makeVar accumvar)
    (sb,body') <- body (return ([],cntvar_)) (return ([],accumvar_))
    return (sf++st++si++ [
      BlockDecl [cdecl|
        double $id:accumvar = $(i);
      |], BlockStm [cstm|
      for(int $id:cntvar = $(f) ; i <= $(t) ; $(cntvar_)++) {
        $items:sb;
        $accumvar_ = $(body');
      }
      |] ], accumvar_)
  intU i = return ([], [cexp| $int:i |])
  doubleU d = return ([], [cexp| $double:(toRational d) |])
  atU idx_ arr_ = do (sidx,idx) <- idx_; (sarr,arr) <- arr_; return (sidx++sarr, [cexp| $arr[$idx] |])
  letU varname exp_ body_ = do
    var <- newName varname;
    (se,exp) <- exp_;
    let assign = BlockDecl [cdecl| double $id:var = $exp; |]
    (sb,body) <- body_ (return ([],makeVar var));
    return (se++[assign]++sb,body)

genCCode :: Untyped (Q ([BlockItem],Exp)) a -> Stm
genCCode (U expr) = runQ block
  where
    block :: Q Stm
    block = do (items,exp) <- expr; return (Block (items++[BlockStm (Exp (Just exp) noSrcLoc)]) noSrcLoc)