Strictness Analysis featuring Template Haskell
Abstract interpretationベースの正格性解析(とlet-to-case transformation)をコンパイラに直接手を入れず、template haskell使って実装したぜheheという論文。
Strictness Analysis and let-to-case Transformation using Template Haskell
http://www.cs.ioc.ee/tfp-icfp-gpce05/tfp-proc/30num.pdf
割とwktkしながら読んだけど、実用に使うというよりは、ある機能を実装して実験したいけど、GHC自体に手を入れるのはめんどくさいという時に使えるかもしれないという程度っぽい
論文のコードを適当に補ったり改変したもの。とりあえず、absEval関数(論文のstrict関数)がメインで、論文のFigure3を忠実にHaskellで書いただけ
{-# OPTIONS -fth #-}
module AbsInt where
import Language.Haskell.TH
import Data.List(lookup)
import Data.Maybe(fromJust)
-- basic data types
data StrictAnnot = Bot | Top deriving (Eq,Show)
data AbsVal = B StrictAnnot | F [StrictAnnot] | FB Int deriving (Eq,Show)
instance Ord StrictAnnot where
Bot <= Top = True
Top <= Bot = False
_<=_ = True
lub, glb :: AbsVal -> AbsVal -> AbsVal
lub (B Bot) val2 = val2
lub val1 (B Bot) = val1
lub (F xs) (F ys) = F (zipWith max xs ys)
lub _ _ = B Top
glb (F xs) (F ys) = F (zipWith min xs ys)
glb (B Top) val2 = val2
glb val1 (B Top)= val1
glb _ _ = (B Bot)
-- Environment
type AbsEnv = [(Name , (Maybe AbsVal))]
emptyEnv::AbsEnv
emptyEnv = []
getEnv :: Name -> AbsEnv -> AbsVal
getEnv name env = case lookup name env of
Just ret -> (fromJust ret)
addEnv :: (Name,AbsVal) -> AbsEnv -> AbsEnv
addEnv (name,val) env = (name,Just val):env
extendEnv :: AbsEnv -> [Name] -> AbsEnv
extendEnv env names = (map (\n->(n,Nothing)) names)++env
combines :: AbsEnv -> AbsEnv -> (AbsEnv,Bool)
combines env1 env2 =
case env1 of
[] -> (env2,False)
(e:es) -> if (lookup (fst e) env2) == Nothing
then aux False $ combines es (e:env2)
else aux True $ combines es env2
where
aux b1 (env,b2) = (env , b1 || b2)
-- sub routines
isRecursiveFun ::[Dec] -> Bool
isRecursiveFun decs = False --嘘！
splitDecs :: [Dec] -> ([Name] , [Exp])
splitDecs = unzip.(map splitDec)
splitDec :: Dec -> (Name,Exp) --適当
splitDec (ValD (VarP name) (NormalB exp) decs) =
(name,LetE decs exp)
splitDec (FunD name [Clause pats (NormalB body) decs]) =
(name , LetE decs (LamE pats body))
addEnvPat :: AbsVal -> [Pat] -> AbsEnv -> AbsEnv
addEnvPat v pats env =
(map aux pats)++env
where
aux p = case p of (VarP n) -> (n,Just v)
-- main routines
absEval :: Exp -> AbsEnv -> AbsVal
absEval e env =
case e of
(LitE lit) -> B Top
(InfixE (Just e1) e (Just e2)) -> glb (absEval e1 env) (absEval e2 env)
(VarE s) -> getEnv s env
(CondE e1 e2 e3) -> glb (absEval e1 env) (lub (absEval e2 env) (absEval e3 env))
(LamE [VarP s] e) ->
let B b = aux e (addEnv (s,B Bot) env) in
case (absEval e (addEnv (s,B Top) env)) of
B b1 -> F (b:[])
F bs -> F (b:bs)
(ConE c) -> B Top
(AppE (ConE c) e) -> absEval e env
(AppE e1 e2) -> if (isCon e1)
then lub (absEval e1 env) (absEval e2 env)
else absApply (absEval e1 env) (absEval e2 env)
(LetE ds e) -> absEval e (absFix ds env)
(CaseE e ms) ->
let se = absEval e env
l = caseAux ms se env
in (glb se (foldr lub (B Bot) l))
where
aux::Exp -> AbsEnv -> AbsVal
aux (LamE ((VarP s):[]) e) env = aux e (addEnv (s,B Top) env)
aux e env = absEval e env
isCon e = case e of {(ConE s)->True;otherwise->False}--必要性がわからん
caseAux ms se env = map (caseAlt se env) ms
caseAlt abs env m =
case m of
Match (ConP con ps) (NormalB e) [] -> absEval e (addEnvPat abs ps env)
Match (VarP x) (NormalB e) [] -> absEval e (addEnvPat abs [VarP x] env)
absApply::AbsVal -> AbsVal -> AbsVal
absApply (FB n) a | n==1 = B Bot
| n > 1 = FB (n-1)
absApply (F xs) (B b) =
let h = head xs
tl = tail xs in
if (h == Top || b == Top)
then if (tl==[]) then (B Top) else F tl
else if (tl==[]) then (B Bot) else (FB (length tl))
absFix:: [Dec] -> AbsEnv -> AbsEnv
absFix [] env = env
absFix ds env =
let
(varns,es) = splitDecs ds
init = extendEnv env varns
f (env', cont) =
let aes = map (flip absEval env') es
pairs = zipWith (\l r -> (l,Just r)) varns aes
in
(combines env' pairs)
fixPoint g (env,b) =
if b
then (let (env',b') = g (env,b) in (fixPoint g (env',b')))
else env
in
fixPoint f (init ,True)
strict :: ExpQ -> AbsEnv -> ExpQ
strict eq env =
do {e <- eq ;
return (toExp(absEval e env))}
where
toExp v = case v of
(B Top) -> (ConE (mkName "Top")) --暫定
(B Bot) -> (ConE (mkName "Bot")) --同上
(F ls) -> (AppE (ConE (mkName "F")) (ListE (map (toExp.B) ls)))
(FB n) -> (AppE (ConE (mkName "FB")) (LitE (IntPrimL (toInteger n))))
-- let-to-case transformation
letToCase :: Exp -> AbsEnv -> Exp
letToCase (LetE ds e) env =
if (isRecursiveFun ds)
then
let (vs,es) = splitDecs ds
env' = foldr (\n e -> addEnv (n,B Top) e) env vs
te' = letToCase e env'
in (LetE ds te')
else
case (head ds) of
ValD (VarP x) (NormalB e') [] ->
let te' = letToCase e' env
te = letToCase e (addEnv (x, B Top) env)
ds' = ValD (VarP x) (NormalB te') []
F bs = absEval (LamE [VarP x] te) env
in if (head bs) == Bot
then (CaseE te' [Match (VarP x) (NormalB te) []])
else (LetE [ds'] te)
letToCase otherexp env = otherexp
transf :: ExpQ -> AbsEnv -> IO Exp
transf e env = runQ $ e>>=(\x -> return $ letToCase x env)
q1 = [| \x-> \y -> 3*x |]
q2 = [| let a=1 in let b=2 in a+b |]で、本体。q1,q2はMainの方で定義したいけど、それやると怒られるんだよなー。理不尽
{-# OPTIONS -fth #-}
--to compile,ghc --make -O main.hs
module Main where
import AbsInt
main =
do{
putStrLn (show $(strict q1 emptyEnv)) ;
e <- (transf q2 emptyEnv);
putStrLn (show e)
}適当な箇所
・isRecursiveFunはlet式が再帰的定義になってるかどうか判定することになってるけど、書くのがめんどくさかったので常にFalseを返すという、やる気のなさ。
・splitDecは多少ましだけど、網羅的でない
・生のHaskell式をExp型の値に変換する方法がわからん([|*|]だと、ExpQになる)
・あと、これは論文がそうなってるんだけど、ラムダ式は一引数しか扱えない(\x->\y->3*xはOKだけど、\x y -> 3*xはOUT)。ここらへんは、まあどうとでもなる話だけど、他にも抜けがあるかもしれない
やる気がないというのもさりながら、template Haskellは、deSugarされる前のhaskell構文をできるだけ忠実に扱おうとしてるので、不必要に複雑。基本になる型はExpだけど、PatとかMatchとかDecとか把握しないといけない。そんなに覚えられないよ(覚える必要はないが)！そこらへんいくと、GHC Coreの方は大分シンプル。けど、GHC Coreはユーザが手軽に触れるようにはなってない。HyloFusionかFixed Point PromotionでもTemplate haskellで書いてみるかなぁ
あとTemplate Haskellって、templateの片鱗も見えない
