diff --git a/Brainfuck.hs b/Brainfuck.hs new file mode 100644 --- /dev/null +++ b/Brainfuck.hs @@ -0,0 +1,105 @@ +-- | Brainfuck: backend of /super-cool-graph-machine/. No serious work is done here. +-- +-- Cost model of BF. +-- +-- * All instructions are executed in a common constant duration. +-- +-- * Input command requires unknown latency in addition to it. +module Brainfuck where +import Control.Monad +import Data.Array.IO +import Data.Char +import Data.Word + +import Util + + + + + + +-- | Original brainfuck + loop construct. +data BF=BF [BFInst] + +data BFInst + =BFPInc + |BFPDec + |BFVInc + |BFVDec + |BFBegin + |BFEnd + |BFInput + |BFOutput + |BFLoop [BFInst] -- ^ a little bit high-level construct + +instance Show BF where + show (BF is)=concatMap show is + +instance Show BFInst where + show BFPInc=">" + show BFPDec="<" + show BFVInc="+" + show BFVDec="-" + show BFBegin="[" + show BFEnd="]" + show BFInput="," + show BFOutput="." + show (BFLoop ss)="["++concatMap show ss++"]" + + +pprint bf=unlines $ sepC 80 $ show bf + +sepC :: Int -> [a] -> [[a]] +sepC w xs + |null rs = [r] + |otherwise = r:sepC w rs + where (r,rs)=splitAt w xs + +-- | Assume /standard/ environment. That is +-- +-- * [0,+inf) address space +-- +-- * Each cell consists of a byte which represents Z256. +-- +-- * Moving into negative address immediately causes an error. +interpret :: BF -> IO () +interpret (BF is)=newArray (0,1000) 0 >>= evalBF (detectLoop is) 0 + +evalBF :: [BFInst] -> Int -> IOUArray Int Word8 -> IO () +evalBF [] ptr arr=return () +evalBF (BFPInc:is) ptr arr=do + pmax<-liftM snd $ getBounds arr + if ptr>=pmax + then getElems arr >>= newListArray (0,pmax*2+1) . (++replicate (pmax+1) 0) >>= evalBF is (ptr+1) + else evalBF is (ptr+1) arr +evalBF (BFPDec:is) ptr arr=evalBF is (ptr-1) arr +evalBF (BFVInc:is) ptr arr=readArray arr ptr >>= writeArray arr ptr . (+1) >> evalBF is ptr arr +evalBF (BFVDec:is) ptr arr=readArray arr ptr >>= writeArray arr ptr . (+(-1)) >> evalBF is ptr arr +evalBF (BFInput:is) ptr arr=getChar >>= writeArray arr ptr . fromIntegral . ord >> evalBF is ptr arr +evalBF (BFOutput:is) ptr arr=readArray arr ptr >>= putChar . chr . fromIntegral >> evalBF is ptr arr +evalBF is0@(BFLoop ss:is) ptr arr=do + flag<-readArray arr ptr + if flag==0 then evalBF is ptr arr else evalBF (ss++is0) ptr arr + + +detectLoop is=pprog is + + +-- PROG=EXPR* +-- EXPR=PRIM|BEGIN EXPR* END + +pprog []=[] +pprog is=let (t,is')=takeOne is in t:pprog is' + +takeOne (BFBegin:is)=let (ts,is')=ploop is in (BFLoop ts,is') +takeOne (BFEnd:_)=error "missing Begin" +takeOne (i:is)=(i,is) + +ploop []=error "missing End" +ploop (BFEnd:is)=([],is) +ploop is=let (t,is')=takeOne is in let (ts,is'')=ploop is' in (t:ts,is'') + + + + + diff --git a/Core.hs b/Core.hs new file mode 100644 --- /dev/null +++ b/Core.hs @@ -0,0 +1,391 @@ +-- | parametric variable: +-- Partially type-annotated +-- * kind-inference -> possible kind error +-- Fully-kind-annotated -> throw away kind +-- * type-inference -> possible type error +-- Fully-type-annotated +-- +-- * type-inference +-- +-- * uniquify +-- +-- * dependency-analysis(convert letrec to let) +-- +-- * MFE-detection +-- +-- * lambda lifting +-- +-- are done in Core language +module Core where +import Control.Arrow +import Control.Monad.Writer +import Data.Ord +import Data.Char +import Data.List +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Foldable as F +import Data.Sequence((><),(|>),(<|)) +import qualified Data.Sequence as Q + +import Util as U hiding(Pack) +import qualified Util as U +import GMachine + +type LocHint=String + + +data Core=Core [CrData] [CrProc] +data CrData=CrData CrName [CrName] [(CrName,[(Bool,CrType)])] deriving(Show) +data CrProc=CrProc CrName [CrName] CrExpr deriving(Show) + + +library=M.fromList + [("undefined",[UError "undefined"]) + ,("addByteRaw",f AAdd) + ,("subByteRaw",f ASub) + ,("cmpByteRaw",f CCmp) + ,("seq",[PushArg 1,Push 0,Reduce RAny,Update 1,Pop 1,PushArg 2,Slide 3]) + ] + where f op=[PushArg 2,PushArg 2,Arith op,Slide 3] + + + +-- | Rename all variables to be unique in each 'CrProc'. +uniquify :: Core -> Core +uniquify (Core ds ps)=Core ds $ map (uniquifyP m0 r0) ps + where + r0="" + m0=M.fromList $ zip gs gs + gs=concatMap (\(CrData _ _ cons)->map fst cons) ds++map (\(CrProc n _ _)->n) ps + +uniquifyP :: M.Map CrName CrName -> String -> CrProc -> CrProc +uniquifyP m r (CrProc n as e)=CrProc n (map (m' M.!) as) $ uniquifyE m' r e + where m'=bind r m as + +uniquifyE :: M.Map CrName CrName -> String -> CrExpr -> CrExpr +uniquifyE m r (CrVar v)=CrVar $ M.findWithDefault (error $ "uniquifyE:"++v) v m +uniquifyE m r (CrApp e0 e1)=CrApp (uniquifyE m n1 e0) (uniquifyE m n2 e1) + where [n1,n2]=branch 2 r +uniquifyE m r (CrCstr t es)=CrCstr t $ zipWith (uniquifyE m) ns es + where ns=branch (length es) r +uniquifyE m r (CrCase e cs)=CrCase (uniquifyE m n e) (zipWith f cs ns) + where + n:ns=branch (length cs+1) r + f (tag,vs,e) n=let m'=bind r m vs in (tag,map (m' M.!) vs,uniquifyE m' n e) +uniquifyE m r (CrLet flag bs e)=CrLet flag (zipWith f bs ns) (uniquifyE m' n e) + where + m'=bind r m $ map fst bs + n:ns=branch (length bs+1) r + f (v,e) n=(m' M.! v,uniquifyE (if flag then m' else m) n e) +uniquifyE m r (CrLm vs e)=CrLm (map (m' M.!) vs) $ uniquifyE m' r e + where m'=bind r m vs +uniquifyE m r e@(CrByte _)=e + +branch :: Int -> String -> [String] +branch n r=map ((r++) . (:[])) ss + where ss=take n $ iterate succ 'a' + +bind :: String -> M.Map CrName CrName -> [CrName] -> M.Map CrName CrName +bind r m vs=M.union (M.fromList $ zip vs vs') m + where vs'=map ((++r) . (++"_")) vs + + + + + + + +liftLambdaW :: Core -> Core +liftLambdaW (Core ds ps)=Core ds $ concatMap liftLambda ps + + +liftLambda :: CrProc -> [CrProc] +liftLambda (CrProc n args e)=CrProc n args e':ps + where (e',ps)=runWriter (liftl ("_l_"++n) e) + + +liftl :: String -> CrExpr -> Writer [CrProc] CrExpr +liftl n e0@(CrLm as e)=do + liftl (n++"_") e >>= post . CrProc n (fvs++as) + return $! multiApp (CrVar n) $ map CrVar fvs + where fvs=S.toList $ S.filter (not . isUpper . head) $ freeVar e0 +liftl n (CrLet flag bs e)=liftM2 (CrLet flag) (mapM f bs) (liftl (n++"_") e) + where f (v,e)=liftM (\x->(v,x)) $ liftl (n++"_"++v) e +liftl n (CrCase e cs)=liftM2 CrCase (liftl (n++"_") e) (mapM f cs) + where f (t,vs,e)=liftM (\x->(t,vs,x)) $ liftl (n++"_"++t) e +liftl n (CrApp e0 e1)=liftM2 CrApp (liftl n e0) (liftl (n++"_") e1) +liftl n (CrCstr tag es)=liftM (CrCstr tag) (zipWithM f es [0..]) + where f e k=liftl (n++"_"++show k) e +liftl n e=return e + +post :: a -> Writer [a] () +post=tell . (:[]) + + +freeVar :: CrExpr -> S.Set CrName +freeVar e=collectV e `S.difference` collectB e + +collectB :: CrExpr -> S.Set CrName +collectB (CrApp e0 e1)=collectB e0 `S.union` collectB e1 +collectB (CrLet _ bs e)=S.fromList (map fst bs) `S.union` (S.unions $ map collectB $ e:map snd bs) +collectB (CrCase e cs)=S.fromList (concatMap snd3 cs) `S.union` (S.unions $ map collectB $ e:map thr3 cs) +collectB (CrLm as e)=S.fromList as `S.union` collectB e +collectB _=S.empty + +collectV :: CrExpr -> S.Set CrName +collectV (CrVar x)=S.singleton x +collectV (CrApp e0 e1)=collectV e0 `S.union` collectV e1 +collectV (CrLet _ bs e)=S.unions $ map collectV $ e:map snd bs +collectV (CrCase e cs)=S.unions $ map collectV $ e:map thr3 cs +collectV (CrLm as e)=collectV e +collectV (CrByte _)=S.empty +collectV e=error $ "collectV: "++show e + + + +multiApp :: CrExpr -> [CrExpr] -> CrExpr +multiApp=foldl CrApp + + + + +optimize (Core ds ps)=Core ds (map (\(CrProc n as e)->CrProc n as $ optLetVar e) ps) + +-- | If rhs of let binder is a variable, remove it from let. +optLetVar (CrLet False bs e) + |null bsN = e' + |otherwise = CrLet False bsN e' + where + e'=optLetVar $ replaceVar t e + t=M.fromList $ map (second $ \(CrVar x)->x) bsS + isVar (CrVar _)=True + isVar _=False + (bsS,bsN)=partition (isVar . snd) bs +optLetVar (CrLet True bs e)=CrLet True bs $ optLetVar e +optLetVar (CrApp e0 e1)=CrApp (optLetVar e0) (optLetVar e1) +optLetVar (CrCase e cs)=CrCase (optLetVar e) (map (\(tag,vs,e)->(tag,vs,optLetVar e)) cs) +optLetVar e=e + + +replaceVar :: M.Map CrName CrName -> CrExpr -> CrExpr +replaceVar t (CrVar x)=CrVar $ M.findWithDefault x x t +replaceVar t (CrApp e0 e1)=CrApp (replaceVar t e0) (replaceVar t e1) +replaceVar t (CrCase e cs)=CrCase (replaceVar t e) (map (\(tag,vs,e)->(tag,vs,replaceVar t e)) cs) +replaceVar t (CrLet f bs e)=CrLet f (map (second $ replaceVar t) bs) $ replaceVar t e +replaceVar t e=e + + + + + +compile :: Core -> Process (M.Map String [GMCode]) +compile (Core ds ps)=return $ M.union library $ M.fromList (map (compileP m) (ps++pds)) + where + m=M.fromList cons + (pds,cons)=unzip $ concatMap convertData ds + + +-- | Convert one data declaration to procs and cons. +convertData :: CrData -> [(CrProc,(String,Int))] +convertData (CrData _ _ cs)=zipWith convertDataCon [0..] cs + +-- | Int argument is a tag, not an arity +convertDataCon :: Int -> (CrName,[(Bool,CrType)]) -> (CrProc,(String,Int)) +convertDataCon t (name,xs)=(CrProc name (map snd args) exp,(name,t)) + where + exp=foldr (\v e->multiApp (CrVar "seq") [v,e]) con $ map (CrVar . snd) sarg + con=CrCstr t $ map (CrVar . snd) args + sarg=filter (fst . fst) args + args=zip xs $ stringSeq "#d" + + + +-- | Resolve default clause in 'Case' and 'uniquify'. +simplify :: Core -> Process Core +simplify (Core ds ps)=return $ liftLambdaW $ optimize $ uniquify $ Core ds $ map (smplP table) ps + where + table=M.fromList $ concatMap (mkP . map snd) $ groupBy (equaling fst) $ concatMap conCT ds + mkP xs=map (\x->(fst x,S.fromList xs)) xs + +conCT :: CrData -> [(CrName,(CrName,Int))] +conCT (CrData n _ xs)=zip (repeat n) (map (second length) xs) + +smplP :: M.Map String (S.Set (String,Int)) -> CrProc -> CrProc +smplP t (CrProc name args expr)=CrProc name args $ smplE t expr + +smplE :: M.Map String (S.Set (String,Int)) -> CrExpr -> CrExpr +smplE t (CrApp e0 e1)=CrApp (smplE t e0) (smplE t e1) +smplE t (CrCstr tag es)=CrCstr tag $ map (smplE t) es +smplE t (CrLet f bs e)=CrLet f (map (second $ smplE t) bs) $ smplE t e +smplE t (CrLm vs e)=CrLm vs $ smplE t e +smplE t (CrCase ec cs) + |null cocs = CrCase (smplE t ec) $ nrmcons + |length cocs==1 = CrCase (smplE t ec) $ cocons (thr3 $ head cocs)++nrmcons + |otherwise = error "smplE: more than 2 defaults!" + where + (cocs,nrmcs)=partition (null . fst3) cs + + nrmcons=map (\(x,y,z)->(x,y,smplE t z)) nrmcs + cocons x=map (\(c,n)->(c,replicate n "",smplE t x)) $ F.toList s + s=S.difference (M.findWithDefault (error "smplE") (fst $ head cons) t) (S.fromList cons) + cons=filter (not . null . fst) $ map (\(x,y,_)->(x,length y)) cs +smplE t x=x + + + +-- | Compile one super combinator to 'GMCode' +-- +-- requirement: +-- +-- * must not contain lambda +-- +compileP :: M.Map String Int -> CrProc -> (String,[GMCode]) +compileP mc (CrProc name args expr)= + (name,F.toList $ compileE mc mv expr> M.Map String GMCode -> CrExpr -> Q.Seq GMCode +compileE mc mv (CrApp e0 e1)=(compileE mc mv e1 >< compileE mc (shift mv 1) e0) |> MkApp +compileE mc mv (CrVar v)=Q.singleton $ maybe (PushSC v) id $ M.lookup v mv +compileE mc mv (CrByte x)=Q.singleton $ PushByte x +compileE mc mv (CrCstr t es)= + concatS (zipWith (compileE mc) (map (shift mv) [0..]) (reverse es)) |> Pack t (length es) +compileE mc mv (CrCase ec cs)=compileE mc mv ec |> Reduce RAny |> Case (map f cs) + where + f (con,vs,e)=(M.findWithDefault (error $ "cE:not found:"++con) con mc + ,F.toList $ + (UnPack (length vs) <| + compileE mc (insMV $ reverse vs) e) |> + Slide (length vs) + ) + insMV vs=M.union (M.fromList $ zip vs (map Push [0..])) $ shift mv $ length vs +compileE mc mv (CrLet False bs e)= + concatS (zipWith (compileE mc) (map (shift mv) [0..]) (map snd $ reverse bs)) >< + compileE mc mv' e >< + Q.fromList [Slide n] + where + n=length bs + mv'=M.union (M.fromList $ zip (map fst bs) (map Push [0..])) $ shift mv n +compileE mc mv (CrLet True bs e)= + Q.fromList [Alloc n] >< + concatS (map (compileE mc mv' . snd) $ reverse bs) >< + compileE mc mv' e >< + Q.fromList [Slide n] + where + n=length bs + mv'=M.union (M.fromList $ zip (map fst bs) (map Push [0..])) $ shift mv n +compileE mc mv (CrLm _ _)=error "compileE: lambda must be lifted beforehand" + +concatS :: [Q.Seq a] -> Q.Seq a +concatS=foldr (><) Q.empty + +shift :: M.Map String GMCode -> Int -> M.Map String GMCode +shift m d=M.map f m + where + f (Push n)=Push $ n+d + f (PushArg n)=PushArg $ n+d + + + +-- | Pretty printer for 'Core' +pprint :: Core -> String +pprint (Core ds ps)=compileSB $ Group $ intersperse EmptyLine $ map pprintData ds++map pprintProc ps + + +pprintData :: CrData -> SBlock +pprintData (CrData name xs cons)=Group + [Line $ Span [Prim "data",Prim name] + ,Indent $ Group $ zipWith cv cons ("=":repeat "|")] + where cv (name,xs) eq=Line $ Span [U.Pack [Prim eq,Prim name],Prim $ show $ length xs] + +pprintProc :: CrProc -> SBlock +pprintProc (CrProc n as e)=Group + [Line $ U.Pack [Span $ map Prim $ n:as,Prim "="] + ,Indent $ pprintExpr e] + +pprintExpr :: CrExpr -> SBlock +pprintExpr (CrCase e as)=Group + [Line $ Span [Prim "case",pprintExprI e,Prim "of"] + ,Indent $ Group $ map cv as] + where + cv (con,vs,e)=Group [Line $ Span $ Prim con:map Prim vs++[Prim "->"],Indent $ pprintExpr e] +pprintExpr (CrLet flag binds e)=Group + [Line $ Prim $ if flag then "letrec" else "let" + ,Indent $ Group $ map (\(v,e)->Line $ Span [Prim v,Prim "=",pprintExprI e]) binds + ,Line $ Prim "in" + ,Indent $ pprintExpr e] +pprintExpr x=Line $ pprintExprI x + + +pprintExprI :: CrExpr -> IBlock +pprintExprI (CrLm ns e)=U.Pack $ + [U.Pack [Prim "\\",Span $ map Prim ns] + ,U.Pack [Prim "->",pprintExprI e]] +pprintExprI (CrVar x)=Prim x +pprintExprI (CrCase e as)=Span $ + [Span [Prim "case",pprintExprI e,Prim "of"],Span $ map cv as] + where + cv (con,vs,e)=Span [Span $ Prim con:map Prim vs,Prim "->",pprintExprI e,Prim ";"] +pprintExprI (CrLet flag binds e)=Span $ + [Span $ (Prim $ if flag then "letrec" else "let"):map cv binds + ,Prim "in" + ,pprintExprI e] + where cv (v,e)=U.Pack [Prim v,Prim "=",pprintExprI e,Prim ";"] +pprintExprI (CrApp e0 e1)=U.Pack [Prim "(",Span [pprintExprI e0,pprintExprI e1],Prim ")"] +pprintExprI (CrByte n)=Prim $ show n +-- pprintExpr f (Cr +pprintExprI e=error $ "pprintExprI:"++show e + + + + + + +{- +checkKind :: [CrData CrKind] -> Maybe [(CrName,CrKind)] +checkKind []=Just [] +checkKind (CrData name vars cons)=Nothing +-} + + + +-- | kind +data CrKind + =CrKiApp CrKind CrKind -- ^ left associative application of types + |CrKiX -- ^ the kind of proper types, /*/ + +instance Show CrKind where + show (CrKiApp k0 k1)="("++show k0++") -> ("++show k1++")" + show CrKiX="*" + +-- | type +data CrType + =CrTyApp CrType CrType + |CrTyVar CrName -- ex.: x,y,z + |CrTyCon CrName -- ex.: #A,#L,#T,#Byte,Integer + +instance Show CrType where + show (CrTyApp t0 t1)="("++show t0++") -> ("++show t1++")" + show (CrTyVar x)=x + show (CrTyCon x)=x + +-- | expression +data CrExpr + =CrLm [CrName] CrExpr + |CrApp CrExpr CrExpr + |CrLet Bool [(CrName,CrExpr)] CrExpr -- ^ rec? + |CrCstr Int [CrExpr] + |CrCase CrExpr [(String,[CrName],CrExpr)] + |CrVar CrName + |CrByte Int + deriving(Show) + + +-- | identifier +type CrName=String + + + diff --git a/Front.hs b/Front.hs new file mode 100644 --- /dev/null +++ b/Front.hs @@ -0,0 +1,512 @@ +-- | Frontend: Haskell -> 'CoreP' desugarer +-- +-- design policy: minimize the amount of code +-- +-- [0. 'collectModules' :: IO \[Hs\]] +-- Parse necesarry modules. +-- +-- [1. 'WeakDesugar' :: Hs -> Hs] +-- Shallow desugaring (including unguarding, if removal) +-- +-- [2. 'MidDesugar' :: Hs -> Hs] +-- A little bit deep desugaring (where -> let, pattern(PatBind,Lambda) -> case, merge FunBinds) +-- Introduces dummy variables +-- +-- [3. 'mergeModules' :: \[Hs\] -> Hs] +-- Resolve all name references and make them 'UnQual'. +-- Unknown identifiers are detected in this process. +-- +-- [4. 'sds' :: Hs -> 'CoreP'] +-- Explicit pattern matching +-- +-- Dummy variable naming convention: +-- +-- * #aa_2... : arguments ('HsMatch') +-- +-- * #xa_1... : pattern matching +module Front where +import Control.Arrow +import Control.Exception +import Control.Monad +import Control.Monad.Error +import Data.Char +import Data.Either +import Data.List +import Data.Maybe +import qualified Data.Map as M +import qualified Data.Set as S +import Language.Haskell.Parser +import Language.Haskell.Syntax +import System.Directory +import System.FilePath.Posix + +import Util +import Core hiding(multiApp) + + +-- | Necessary information for translating module name to 'FilePath'. +data ModuleEnv=ModuleEnv [FilePath] + +compile :: [HsModule] -> Process Core +compile ms=return $ sds $ mergeModules $ map (mds . wds) ms + +-- | Search all necesarry modules and parse them all (if possible). +-- If an parser error occurs, parse as many other files as possible to report further errors. +collectModules :: ModuleEnv -> String -> IO (Process [HsModule]) +collectModules env mod=do + x<-aux env (S.singleton mod) M.empty + let (ls,rs)=partitionEithers $ M.elems x + if null ls + then return $ return $ rs + else return $ throwError $ concat ls + + +aux :: ModuleEnv + -> S.Set String -- ^ modules to be parsed + -> M.Map String (Either [CompileError] HsModule) -- ^ already parsed module + -> IO (M.Map String (Either [CompileError] HsModule)) -- ^ all modules +aux env s m=case S.minView s of + Nothing -> return m + Just (s0,s') -> do x<-parseModule1 env s0 + aux env (flip S.difference (M.keysSet m) $ S.union s' $ S.fromList $ either (const []) collectDep x) (M.insert s0 x m) + + + +parseModule1 :: ModuleEnv -> String -> IO (Either [CompileError] HsModule) +parseModule1 env mod=do + x<-modToPath env mod + case x of + Nothing -> return $ Left [CompileError "frontend" "" ("module "++mod++" not found\n")] + Just ph -> do x<-readFile ph + case parseModuleWithMode (ParseMode ph) x of + ParseFailed loc msg -> return $ Left [CompileError "frontend" (show loc) msg] + ParseOk x -> return $ Right x + + +collectDep :: HsModule -> [String] +collectDep (HsModule _ _ _ is _)="Prelude":map (uM . importModule) is + where uM (Module x)=x + +-- | convert module name to full file path. +modToPath :: ModuleEnv -> String -> IO (Maybe FilePath) +modToPath (ModuleEnv dirs) name= + handle (\(SomeException _)->return Nothing) $ liftM Just $ firstM doesFileExist $ map ((name++".hs")) dirs + +-- | Returns first element which satisfies the predicate. +firstM :: Monad m => (a -> m Bool) -> [a] -> m a +firstM f []=fail "firstM: not found" +firstM f (x:xs)=do + e<-f x + if e then return x else firstM f xs + + + + +-- | /strong/ desugar +-- Replaces all implicit pattern matching with explicit cases. +-- Explicit modification of SrcLoc for error reporting in later process. +sds :: HsModule -> Core +sds (HsModule _ _ _ _ decls)=Core (map convDataDecl ds) (map convFunDecl fs) + where + ds=filter isDataDecl decls + fs=filter isFunBind decls + + + + + + +isDataDecl (HsDataDecl _ _ _ _ _ _)=True +isDataDecl _=False + +isFunBind (HsFunBind _)=True +isFunBind _=False + +isPatBind (HsPatBind _ _ _ _)=True +isPatBind _=False + + +convDataDecl :: HsDecl -> CrData +convDataDecl (HsDataDecl loc ctx (HsIdent name) vars cons derv)= + CrData name [] $ map convDataCon cons + +convDataCon :: HsConDecl -> (CrName,[(Bool,CrType)]) +convDataCon (HsConDecl loc (HsIdent name) ts)=(name,map f ts) + where f (HsBangedTy ty)=(True,convType ty) + f (HsUnBangedTy ty)=(False,convType ty) + +convFunDecl :: HsDecl -> CrProc +convFunDecl (HsFunBind [HsMatch loc (HsIdent n) args (HsUnGuardedRhs e) []]) + =CrProc n (map f args) (convExp e) + where + f (HsPVar (HsIdent x))=x + f x=error $ show x + + +convDecl d=error $ "convDecl:ERROR:"++show d + +convExp :: HsExp -> CrExpr +convExp (HsLambda loc as e)=CrLm (map f as) (convExp e) + where + f (HsPVar (HsIdent x))=x +convExp (HsVar (UnQual (HsIdent x)))=CrVar x +convExp (HsApp e0 e1)=CrApp (convExp e0) (convExp e1) +convExp e@(HsCase _ _)=convFullCase e +-- convExp (HsLit (HsInt n))=error "convExp: int"-- CrA (h,Nothing) $ CrInt $ fromIntegral n +convExp (HsLit (HsInt n))=CrByte $ fromIntegral n +convExp (HsLit (HsChar ch))=CrByte $ fromIntegral $ ord ch +convExp (HsLet bs e)=CrLet True (map (toVP . convFunDecl) bs) (convExp e) + where + toVP (CrProc v [] e)=(v,e) + toVP (CrProc v as e)=(v,CrLm as e) +-- convExp h (HsExpTyeSig +convExp e=error $ "ERROR:convExp:"++show e + + +convType :: HsType -> CrType +convType (HsTyVar (HsIdent x))=CrTyVar x +convType (HsTyCon (UnQual (HsIdent x)))=CrTyCon x +convType (HsTyApp t0 t1)=CrTyApp (convType t0) (convType t1) +convType t=error $ "convType: "++show t + + +-- | Convert 'HsCase'(desugared) to 'CrExpr' +-- +-- Sort 'HsAlt's by constructor and use 'procPartialCase' for each constructor. +-- +-- One of the following: +-- +-- * HsAlt (HsPApp ... +-- +-- * HsAlt (HsPVar ... +convFullCase :: HsExp -> CrExpr +convFullCase (HsCase e as)=case md of + Nothing -> CrCase (convExp e) cs + Just (v,f) -> CrLet False [(v,convExp e)] $ CrCase (CrVar v) $ ("",[],convExp f):cs + where + cs=mapMaybe cv $ M.assocs $ M.map (second $ map $ second $ convExp) mn + + (mn,md)=sortAlts as + cv (cons,(arity,cs))=let vs=take arity $ stringSeq "#x" + in do{x<-convSeqCase (liftM (convExp . snd) md) (map CrVar vs) cs; return (cons,vs,x)} + + + + +-- | Transform case of multiple vars. Note that constructors are already removed by 'procFullCase'. +-- +-- example: +-- +-- > case v1 v2 v3 of +-- > p11 p12 p13 -> e1 +-- > p21 p22 p23 -> e2 +-- > _ -> fail +-- +-- to +-- +-- > case v1 v2 v3 of +-- > p11 p12 p13 -> e1 +-- > _ -> case v1 v2 v3 of +-- > p21 p22 p23 -> e2 +-- > _ -> fail +convSeqCase :: Maybe CrExpr -> [CrExpr] -> [([HsPat],CrExpr)] -> Maybe CrExpr +convSeqCase fail vs []=fail +convSeqCase fail vs ((ps,e):as)=return $ convAndCase (convSeqCase fail vs as) e (zip vs ps) + +-- | Transform multiple vars to +-- +-- >case v1 v2 v3 of +-- > p1 u2 p3 -> succ +-- +-- to +-- +-- >case v1 of +-- > p1 -> let u2=v2 in +-- > case v3 of +-- > p3 -> succ +-- > _ -> fail(other 'HsAlt') +-- > _ -> fail(other 'HsAlt') +-- +convAndCase :: Maybe CrExpr -> CrExpr -> [(CrExpr,HsPat)] -> CrExpr +convAndCase fail succ []=succ +convAndCase fail succ ((v,pat):cs)=case pat of + HsPVar (HsIdent p) -> + CrLet False [(p,v)] next + HsPApp (UnQual (HsIdent n)) args -> + let das=take (length args) $ stringSeq "#x" + in CrCase v $ maybe [] (\x->[("",[],x)]) fail++[(n,das,convAndCase fail next $ zip (map CrVar das) args)] + where + next=convAndCase fail succ cs + + +-- | Sort ['HsAlt'] by constructors. +sortAlts :: [HsAlt] -> (M.Map String (Int,[([HsPat],HsExp)]),Maybe (String,HsExp)) +sortAlts []=(M.empty,Nothing) +sortAlts ((HsAlt loc pat (HsUnGuardedAlt e) []):as)= + case pat of + HsPApp (UnQual (HsIdent n)) args -> + (M.insertWith merge n (length args,[(args,e)]) mn,md) + HsPVar (HsIdent v) -> (M.empty,Just (v,e)) + x -> error $ "sortAlts:"++show x + where + merge (n0,xs0) (n1,xs1)=if n0==n1 then (n0,xs0++xs1) else error $ "Unmatched arity@"++show loc + (mn,md)=sortAlts as + + + +showLoc :: SrcLoc -> LocHint +showLoc (SrcLoc file line col)=concat [file,":",show line,":",show col,":"] +-- convExp (HsCase e as)=CrCase + + + + + + + + + + +-- | Merge 'HsModule's. TODO: implement qualification resolver. +mergeModules :: [HsModule] -> HsModule +mergeModules ms=HsModule (SrcLoc "" 0 0) (Module "") Nothing [] (concatMap f ms) + where f (HsModule _ _ _ _ decls)=decls + + +-- | /medium/ desugaring +-- +-- * introduces dummy variables +-- +-- * 'HsPat' is handled manually(not via 'mds'). +-- +-- You might find that 'HsLambda','HsPatBind'->'HsCase' conversion here duplicates 'sds'. +-- But they're completely different because 'sds' considers evaluation sequence of 'HsAlt's. +class MidDesugar a where + mds :: a -> a + +instance MidDesugar HsModule where + mds (HsModule loc mod exp imp ds)=HsModule loc mod exp imp (eliminatePBind $ map mds ds) + +instance MidDesugar HsDecl where + mds (HsFunBind ms)=mergeMatches $ map mds ms + mds (HsPatBind loc pat (HsUnGuardedRhs e) decls) + =HsPatBind loc pat (HsUnGuardedRhs $ mds $ moveDecls e decls) [] + mds d=d + +instance MidDesugar HsExp where + mds (HsCase e als)=HsCase (mds e) (map mds als) + mds (HsLet decls e)=HsLet (eliminatePBind $ map mds decls) (mds e) + mds (HsLambda loc ps e)=eliminatePLambda $ HsLambda loc ps (mds e) + mds e=e + +instance MidDesugar HsMatch where + mds (HsMatch loc name ps (HsUnGuardedRhs e) decls) + =HsMatch loc name ps (HsUnGuardedRhs $ mds $ moveDecls e decls) [] + +instance MidDesugar HsAlt where + mds (HsAlt loc pat (HsUnGuardedAlt e) decls) + =HsAlt loc pat (HsUnGuardedAlt $ mds $ moveDecls e decls) [] + + +-- | Generate let with given decls and 'HsExp' +moveDecls :: HsExp -> [HsDecl] -> HsExp +moveDecls e []=e +moveDecls e ds=HsLet ds e + + +-- | Merge multiple 'HsMatch' in HsFunBind into one. +mergeMatches :: [HsMatch] -> HsDecl +mergeMatches []=error "Front: mergeMatches: empty [HsMatch] found!" +-- mergeMatches [m]=HsFunBind [m] +mergeMatches ms=HsFunBind [HsMatch loc0 n0 (map HsPVar args) (HsUnGuardedRhs expr) []] + where + HsMatch loc0 n0 ps0 _ _=head ms + args=map (HsIdent . ("#a"++) . show) [0..length ps0-1] + expr=HsCase (multiApp (stdTuple $ length args) $ map (HsVar . UnQual) args) $ map genAlt ms + + genAlt (HsMatch loc _ ps (HsUnGuardedRhs e) [])=HsAlt loc (wds $ HsPTuple ps) (HsUnGuardedAlt e) [] + +-- | Eliminate pattern matching in lambda arguments. +eliminatePLambda :: HsExp -> HsExp +eliminatePLambda (HsLambda loc ps e)=HsLambda loc (map fst vars) (f (map snd vars) e) + where + cat :: HsPat -> HsName -> (HsPat,Maybe (HsExp,HsPat)) + cat p@(HsPVar v) _=(p,Nothing) + cat p r=(HsPVar r,Just (HsVar (UnQual r),p)) + + vars=zipWith cat ps (map HsIdent $ stringSeq "#x") + + f :: [Maybe (HsExp,HsPat)] -> HsExp -> HsExp + f [] e=e + f (Nothing:vs) e=f vs e + f ((Just (v,p)):vs) e=HsCase v [HsAlt loc p (HsUnGuardedAlt $ f vs e) []] + + +-- | Eliminate 'HsPatBind' +-- x:xs=f +-- -> +-- #t0=f +-- x=case #t0 of x:xs -> x +-- xs=case #t0 of x:xs -> x +-- +eliminatePBind :: [HsDecl] -> [HsDecl] +eliminatePBind ds=concat $ zipWith (convertPBind True) (stringSeq "#x") $ map convSimple ds + + +-- | Convert obvious 'HsPatBind' to 'HsFunBind' +convSimple :: HsDecl -> HsDecl +convSimple (HsPatBind loc (HsPVar n) rhs [])=HsFunBind [HsMatch loc n [] rhs []] +convSimple d=d + +-- | Convert 'HsPatBind' to ['HsFunBind'] recursively. +-- operation: +-- +-- from: T x y=z +-- +-- to: #=z; x=case # of T x y -> x; y=case # of T x y -> y +-- +convertPBind :: Bool -> String -> HsDecl -> [HsDecl] +convertPBind _ _ (HsPatBind loc (HsPVar n) rhs [])=[HsFunBind [HsMatch loc n [] rhs []]] +convertPBind flag prefix (HsPatBind loc p0@(HsPApp n args) rhs []) + |flag = pre:concat (zipWith3 f vars p0s args) + |otherwise = concat (zipWith3 f vars p0s args) + where + pre=HsFunBind [HsMatch loc (HsIdent prefix) [] rhs []] + + vars=map (((prefix++"_")++) . show) [0..] + p0s=map (HsPApp n) $ change1 (map (HsPVar . HsIdent) vars) args + + f _ _ p@(HsPVar (HsIdent n))=[genDecl n p0] + f v p0' p=genDecl v p0':convertPBind False v (HsPatBind loc p (HsUnGuardedRhs (stdVar v)) []) + + genDecl :: String -> HsPat -> HsDecl + genDecl v p=HsFunBind [HsMatch loc (HsIdent v) [] (HsUnGuardedRhs e) []] + where e=HsCase (stdVar prefix) [HsAlt loc p (HsUnGuardedAlt (stdVar v)) []] + +convertPBind _ prefix x=[x] + + +-- | Literally convert 'HsPat' to 'HsExp'. +pat2con :: HsPat -> Maybe HsExp +pat2con (HsPVar n)=return $ HsVar (UnQual n) +pat2con (HsPApp n vs)=liftM (multiApp $ HsVar n) (mapM pat2con vs) +pat2con HsPWildCard=Nothing + + + + + + + +-- | /weak/ desugaring +class WeakDesugar a where + wds :: a -> a + +instance WeakDesugar HsModule where + wds (HsModule loc mod exp imp ds)=HsModule loc mod exp imp (map wds ds) + +instance WeakDesugar HsDecl where + wds (HsFunBind ms)=HsFunBind $ map wds ms + wds (HsPatBind loc pat rhs decls)=HsPatBind loc (wds pat) (wds rhs) (map wds decls) + wds (HsTypeSig loc ns ty)=HsTypeSig loc ns ty + wds (HsDataDecl loc [] n vs cdecls [])=HsDataDecl loc [] n vs cdecls [] + wds (HsDataDecl _ _ _ _ _ _)=error "WeakDesugar: HsDataDecl: context/deriving is not supported" + wds (HsInfixDecl loc assoc lv ops)=HsInfixDecl loc assoc lv ops + +instance WeakDesugar HsExp where + wds (HsApp e0 e1)=HsApp (wds e0) (wds e1) + wds (HsInfixApp e0 op e1)=HsApp (HsApp (wds $ opToExp op) (wds e0)) (wds e1) + wds (HsNegApp e)=HsApp (HsVar (UnQual (HsIdent "negate"))) e + wds (HsParen e)=wds e + wds (HsLeftSection e op)=HsApp (opToExp op) (wds e) + wds (HsRightSection op e)=HsApp (HsApp (HsVar (UnQual (HsIdent "flip"))) (opToExp op)) (wds e) + wds (HsIf c e0 e1)=HsCase (wds c) + [HsAlt wdsDummySrc (HsPApp (UnQual (HsIdent "True" )) []) (HsUnGuardedAlt (wds e0)) [] + ,HsAlt wdsDummySrc (HsPApp (UnQual (HsIdent "False")) []) (HsUnGuardedAlt (wds e1)) []] + wds (HsCase e als)=HsCase (wds e) (map wds als) + wds (HsLet decls e)=HsLet (map wds decls) (wds e) + wds (HsLambda loc ps e)=HsLambda loc (map wds ps) (wds e) + wds (HsEnumFrom e)=HsApp (stdVar "enumFrom") (wds e) + wds (HsEnumFromTo e0 e1)=HsApp (HsApp (stdVar "enumFromTo") (wds e0)) (wds e1) + wds (HsEnumFromThen e0 e1)=HsApp (HsApp (stdVar "enumFromThen") (wds e0)) (wds e1) + wds (HsEnumFromThenTo e0 e1 e2)=HsApp (HsApp (HsApp (stdVar "enumFromThen") (wds e0)) (wds e1)) (wds e2) + wds (HsCon f)=wds $ HsVar f + wds (HsVar (Special HsCons))=stdVar "XCons" + wds (HsVar (UnQual (HsSymbol v)))=HsVar (UnQual (HsIdent v)) + wds (HsVar v)=HsVar v + wds (HsTuple es)=multiApp (stdTuple $ length es) (map wds es) + wds (HsList es)=foldr (\x y->multiApp (stdVar "XCons") [wds x,y]) (stdVar "XNil") es + wds (HsLit (HsString s))=wds $ HsList $ map (HsLit . HsChar) s + wds l@(HsLit _)=l + wds e=error $ "WeakDesugar:unsupported expression:"++show e + +instance WeakDesugar HsMatch where + wds (HsMatch loc name ps rhs decls)=HsMatch loc (wds name) (map wds ps) (wds rhs) (map wds decls) + + +instance WeakDesugar HsName where + wds (HsSymbol x)=HsIdent x + wds n=n + +instance WeakDesugar HsQName where + wds (Qual mod n)=Qual mod (wds n) + wds (UnQual n)=UnQual (wds n) + wds (Special sc)=UnQual $ HsIdent n + where n=case sc of + HsUnitCon->"XT0" + HsListCon-> "XNil" + HsFunCon-> "XApp" + HsTupleCon n-> "XT"++show n + HsCons-> "XCons" + +instance WeakDesugar HsPat where + wds (HsPInfixApp p0 q p1)=HsPApp (wds q) [wds p0,wds p1] + wds (HsPParen p)=wds p + wds (HsPList ps)=foldr (\x y->HsPApp c [x,y]) n $ map wds ps + where c=UnQual (HsIdent "XCons"); n=HsPApp (UnQual $ HsIdent "XNil") [] + wds (HsPTuple ps)=HsPApp (UnQual (HsIdent $ "XT"++show (length ps))) (map wds ps) + wds (HsPApp n ps)=HsPApp (wds n) (map wds ps) + wds (HsPVar n)=HsPVar $ wds n + wds (HsPWildCard)=HsPWildCard +-- wds p=p + wds p=error $ "WeakDesugar:unsupported HsPat:"++show p + + +instance WeakDesugar HsAlt where + wds (HsAlt loc pat al decls)=HsAlt loc (wds pat) (wds al) (map wds decls) + +-- | Only HsUnGuardedAlt will remain. +instance WeakDesugar HsGuardedAlts where + wds (HsUnGuardedAlt e)=HsUnGuardedAlt $ wds e + wds (HsGuardedAlts als)=HsUnGuardedAlt $ wds $ unguardG (\(HsGuardedAlt _ c e)->(c,e)) als + +-- | Only HsUnGuardedRhs will remain. +instance WeakDesugar HsRhs where + wds (HsUnGuardedRhs e)=HsUnGuardedRhs $ wds e + wds (HsGuardedRhss rs)=HsUnGuardedRhs $ wds $ unguardG (\(HsGuardedRhs _ c e)->(c,e)) rs + + +-- | Generic unguarding routine (nested if generation) +unguardG :: (a -> (HsExp,HsExp)) -> [a] -> HsExp +unguardG _ []=HsVar $ UnQual $ HsIdent "undefined" +unguardG f (x:xs)=let (cond,exp)=f x in HsIf cond exp $ unguardG f xs + +wdsDummySrc=SrcLoc "" 0 0 + + + +stdVar :: String -> HsExp +stdVar=HsVar . UnQual . HsIdent + +stdTuple :: Int -> HsExp +stdTuple=stdVar . ("XT"++) . show + +opToExp :: HsQOp -> HsExp +opToExp (HsQVarOp n)=HsVar n +opToExp (HsQConOp n)=HsCon n + +multiApp :: HsExp -> [HsExp] -> HsExp +multiApp=foldl HsApp + + + diff --git a/GMachine.hs b/GMachine.hs new file mode 100644 --- /dev/null +++ b/GMachine.hs @@ -0,0 +1,711 @@ +-- | GMachine +-- reference: Implementing Functional Languages: a tutorial +-- +-- GC is executed every 256 allocation. +module GMachine where +import Control.Arrow +import Control.Monad +import Control.Monad.State +import Control.Monad.Identity +import Data.Ord +import Data.Char +import Data.List +import Data.Maybe +import qualified Data.Map as M +import qualified Data.Set as S + +import Util as U hiding(Pack) +import qualified Util as U +import SRuntime +import SAM + + +data GFCompileFlag=GFCompileFlag + {addrSpace :: Int -- ^ bytes + } + + +-- | Compile 'GMCode's to SAM +-- +-- See my blog (japanese) for overview of operational model. +-- +-- Heap frame of size k with n-byte address: +-- +-- * 1 B: size of this frame +-- +-- * 1 B: GC tag +-- +-- * k B: payload +-- +-- * n B: id of this frame +-- +-- * 1 B: size of this frame +-- +-- Heap frame of size k with n-byte address: +-- +-- Is it a good idea to remove GC tag, and attach it only when GC is running? +-- (PRO:normally faster,CON:slower gcTransfer) +-- +-- +-- Heap payload: +-- +-- You can return from anywhere on stack to origin, but not from heap. +compile :: M.Map String [GMCode] -> Process SAM +compile m + |codeSpace>1 = error "GM->SAM: 255+ super combinator is not supported" + |heapSpace>1 = error "GM->SAM: 2+ byte addresses are not supported" + |M.notMember "main" m = error "GM->SAM: entry point not found" + |otherwise = return $ SAM (ss++hs) (library++dispatcher++procs) + where + t=M.fromList $ ("main",2):zip (filter (/="main") $ M.keys m) [3..] + + -- code generation + library=genLibrary $ S.toList $ S.unions $ map (S.unions . map collectConArity) $ M.elems m + procs=map (uncurry $ compileProc t) $ M.assocs m + dispatcher=[exec $ M.assocs t] + + -- layout configuration + codeSpace=ceiling $ log (fromIntegral $ M.size m+2)/log 256 + heapSpace=1 + ss=map (("S"++) . show) [0..heapSpace-1] + hs=["Hp","Hs"] + +collectConArity :: GMCode -> S.Set Int +collectConArity (Pack _ n)=S.singleton n +collectConArity (Case cs)=S.unions $ map (S.unions . map collectConArity . snd) cs +collectConArity _=S.empty + + + +simplify :: M.Map String [GMCode] -> Process (M.Map String [GMCode]) +simplify=return . M.map elimBase . elimReduce . removeLoneSC + +removeLoneSC :: M.Map String [GMCode] -> M.Map String [GMCode] +removeLoneSC m=M.filterWithKey (\k _->S.member k col) m + where col=rlscAux m S.empty (S.singleton "main") + +rlscAux :: M.Map String [GMCode] -> S.Set String -> S.Set String -> S.Set String +rlscAux m col front + |S.null front = col + |otherwise = rlscAux m col' (S.difference new col') + where + col'=S.union col front + new=S.unions $ map (S.unions . map collectDepSC . find) $ S.toList front + find x=M.findWithDefault (error $ "rlscAux:"++show x) x m + + +collectDepSC :: GMCode -> S.Set String +collectDepSC (PushSC x)=S.singleton x +collectDepSC (Case cs)=S.unions $ map (S.unions . map collectDepSC . snd) cs +collectDepSC _=S.empty + + +-- | Optmize away /base/ cases like following. +-- +-- * Case with 1 clause +-- +-- * Pop 0 +-- +-- * Slide 0 (in fact, successive 'Slide's form a 'Monoid') +elimBase :: [GMCode] -> [GMCode] +elimBase []=[] +elimBase (Slide 0:xs)=elimBase xs +elimBase (Slide n:Slide m:xs)=elimBase $ Slide (n+m):xs +elimBase (Case cs:xs) + |length cs<=1 = elimBase $ (snd $ head cs)++xs + |otherwise = Case (map (second elimBase) cs):elimBase xs +elimBase (Pop 0:xs)=elimBase xs +elimBase (x:xs)=x:elimBase xs + + +-- | Separate ['GMCode'] at 'Reduce'. +elimReduce :: M.Map String [GMCode] -> M.Map String [GMCode] +elimReduce=M.fromList . concatMap f . M.assocs + where f (n,xs)=aux n [] xs + + +aux :: String -> [GMCode] -> [GMCode] -> [(String,[GMCode])] +aux n cs []=[(n,reverse cs)] +aux n cs (Reduce _:xs)=(n,reverse cs++[PushSC n',Swap]):aux n' [] xs + where n'=n++"_" +aux n cs (Case as:xs) + |null rs = aux n (Case as:cs) xs + |otherwise = (n,reverse $ Case as'':cs):rs + where + as'=map (\(k,x)->(k,aux (n++"_d"++show k) [] $ x++xs)) as + as''=map (second $ snd . head) as' + rs=concatMap (tail . snd) as' +aux ns cs (x:xs)=aux ns (x:cs) xs + + + + +-- | Thin wrapper of 'compileCodeBlock' +compileProc :: M.Map String Int -> String -> [GMCode] -> SProc +compileProc m name cs=SProc ("!"++name) [] $ contWith m Origin cs [] + + +data MPos + =HeapA + |StackA + |StackT + |Origin + deriving(Show,Eq) + +fPos :: GMCode -> MPos +fPos (PushByte _)=HeapA +fPos (PushSC _)=HeapA +fPos MkApp=HeapA +fPos (Pack _ _)=HeapA +fPos Swap=StackT +fPos (Push _)=StackA +fPos (Slide _)=StackT +fPos (PushArg _)=StackT +fPos (Case _)=StackT +fPos (UnPack _)=StackA +fPos (Update _)=StackT +fPos (Pop _)=StackT +fPos (GMachine.Alloc _)=fPos $ PushByte 0 +fPos (Arith _)=StackT +fPos (UError _)=StackA -- any position will do, actually. +fPos x=error $ show x + + +-- requirement: HeapA +newFrame :: Int -> [Int] -> (Pointer -> [Stmt]) -> [Stmt] +newFrame tag xs post= + [Comment $ unwords ["nf",show tag,show xs] + ,SAM.Alloc "addr" + ,Inline "#heapNewHp" ["addr"] + ,Clear (Memory "Hp" $ size-2) + ,Move (Register "addr") [Memory "Hp" $ size-2] + ,Delete "addr" + ,Val (Memory "Hp" 0) size + ,Clear (Memory "Hp" 1),Val (Memory "Hp" 1) 0 -- GC tag + ,Clear (Memory "Hp" 2),Val (Memory "Hp" 2) tag -- node tag + ]++ + concatMap set (zip [3..] xs)++ + [Clear (Memory "Hp" $ size-1),Val (Memory "Hp" $ size-1) size + ,Clear (Memory "Hp" size) -- next frame + ]++ + post (Memory "Hp" $ size-2) + where + size=5+length xs + set (ix,v)=[Clear (Memory "Hp" ix),Val (Memory "Hp" ix) v] + +-- | Compile 'GMCode's from given 'MPos' to 'Stmt's, followed by 'Origin' returning code. +contWith :: M.Map String Int -> MPos -> [GMCode] -> [Stmt] -> [Stmt] +contWith m Origin [] ss=ss +contWith m HeapA [] ss=ss++[Inline "#heap1Hp" []] +contWith m StackA [] ss=ss++[Inline "#stack1S0" []] +contWith m StackT [] ss=ss++[Inline "#stack1S0" []] +contWith m prev xs@(x:_) ss=ss++transition prev (fPos x)++[Comment (show x)]++compileCode m xs + +-- TODO: come up with good abstraction +transition :: MPos -> MPos -> [Stmt] +transition x y + |x==y = [] + |x==Origin && y==StackT = [Inline "#stackTopS0" []] + |x==Origin = [] + |x==StackA && y==StackT = [Inline "#stackTopS0" []] + |x==StackA && y==Origin = [Inline "#stack1S0" []] + |x==StackA && y==HeapA = [Inline "#stack1S0" []] + |x==StackT && y==StackA = [] + |x==StackT && y==Origin = [Inline "#stack1S0" []] + |x==StackT && y==HeapA = [Inline "#stack1S0" []] + |x==HeapA && y==StackT = [Inline "#heap1Hp" [],Inline "#stackTopS0" []] + |x==HeapA = [Inline "#heap1Hp" []] + +-- | Compile a single 'GMCode' to a procedure. StackA|HeapA -> StackA|HeapA +compileCode :: M.Map String Int -> [GMCode] -> [Stmt] +compileCode m (PushByte x:is)= -- constTag x + contWith m StackT is $ newFrame constTag [x] $ \pa-> + [SAM.Alloc "addr" + ,Copy pa [Register "addr"] + ,Inline "#heap1Hp" [] + ,Inline "#stackNewS0" [] + ,Move (Register "addr") [Memory "S0" 0] + ,Delete "addr" + ] +compileCode m (PushSC k:is)= -- scTag sc + contWith m StackT is $ newFrame scTag [m M.! k] $ \pa-> + [SAM.Alloc "addr" + ,Copy pa [Register "addr"] + ,Inline "#heap1Hp" [] + ,Inline "#stackNewS0" [] + ,Move (Register "addr") [Memory "S0" 0] + ,Delete "addr" + ] +compileCode m (MkApp:is)= -- appTag ap0 ap1 + contWith m HeapA is $ newFrame appTag [0,0] $ \pa-> + [SAM.Alloc "addr" + ,Copy pa [Register "addr"] + ,Inline "#heap1Hp" [] + ,Inline "#stackNewS0" [] + ,SAM.Alloc "tr1" + ,Move (Memory "S0" (-1)) [Register "tr1"] + ,SAM.Alloc "tr2" + ,Move (Memory "S0" (-2)) [Register "tr2"] + ,Copy (Register "addr") [Memory "S0" (-2)] + ,Locate (-2) + ,Inline "#stack1S0" [] + ,Inline "#heapRefHp" ["addr"] + ,Delete "addr" + ,Move (Register "tr1") [Memory "Hp" 3] + ,Delete "tr1" + ,Move (Register "tr2") [Memory "Hp" 4] + ,Delete "tr2" + ] +compileCode m (Pack t 0:is)= + contWith m StackT is $ newFrame structTag [t] $ \pa-> + [SAM.Alloc "addr" + ,Copy pa [Register "addr"] + ,Inline "#heap1Hp" [] + ,Inline "#stackNewS0" [] + ,Move (Register "addr") [Memory "S0" 0] + ,Delete "addr" + ] +compileCode m (Pack t n:is)= -- stTag t x1...xn + contWith m HeapA is $ newFrame structTag (t:replicate n 0) $ \pa-> + [SAM.Alloc "addr" + ,Copy pa [Register "addr"] + ,Inline "#heap1Hp" [] + ,Inline "#stackNewS0" [] + ]++ + concatMap (\n->let r="tr"++show n in [SAM.Alloc r,Move (Memory "S0" $ negate n) [Register r]]) [1..n]++ + [Copy (Register "addr") [Memory "S0" $ negate n] + ,Locate $ negate n + ,Inline "#stack1S0" [] + ,Inline "#heapRefHp" ["addr"] + ,Delete "addr" + ]++ + concatMap (\n->let r="tr"++show n in [Move (Register r) [Memory "Hp" $ n+3],Delete r]) [1..n] +compileCode m (UnPack 0:is)=contWith m StackT is $ + [Inline "#stackNewS0" [] + ,Clear (Memory "S0" (-1)) + ,Locate (-2) + ] +compileCode m (UnPack n:is)=contWith m StackA is $ -- the last item becomes top + [Inline "#stackNewS0" [] + ,SAM.Alloc "saddr" + ,Move (Memory "S0" (-1)) [Register "saddr"] + ,Locate (-2) + ,Inline "#stack1S0" [] + ,Inline "#heapRefHp" ["saddr"] + ,Delete "saddr" + ]++ + map (SAM.Alloc . ("tr"++) . show) [1..n]++ + map (\x->Copy (Memory "Hp" $ 3+x) [Register $ "tr"++show x]) [1..n]++ + [Inline "#heap1Hp" [] + ,Inline "#stackNewS0" [] + ]++ + map (\x->Move (Register $ "tr"++show x) [Memory "S0" $ x-1]) (reverse [1..n])++ + map (Delete . ("tr"++) . show) [1..n] +compileCode m (Swap:is)=contWith m StackT is $ + [SAM.Alloc "temp" + ,Move (Memory "S0" 0) [Register "temp"] + ,Move (Memory "S0" (-1)) [Memory "S0" 0] + ,Move (Register "temp") [Memory "S0" (-1)] + ,Delete "temp" + ] +compileCode m (Push n:is)=contWith m StackT is $ + [Inline "#stackNewS0" [] + ,Copy (Memory "S0" $ negate $ n+1) [Memory "S0" 0] + ] +compileCode m (Slide n:is)=if n<=0 then error "Slide 0" else contWith m StackT is $ + [Clear (Memory "S0" $ negate n) + ,Move (Memory "S0" 0) [Memory "S0" $ negate n] + ]++ + map (Clear . Memory "S0" . negate) [1..n-1]++ + [Locate $ negate n] +compileCode m (PushArg n:is)=contWith m StackT is $ + [SAM.Alloc "aaddr" + ,Copy (Memory "S0" $ negate n) [Register "aaddr"] + ,Inline "#stack1S0" [] + ,Inline "#heapRefHp" ["aaddr"] + ,Delete "aaddr" + ,SAM.Alloc "arg" + ,Copy (Memory "Hp" 4) [Register "arg"] + ,Inline "#heap1Hp" [] + ,Inline "#stackNewS0" [] + ,Move (Register "arg") [Memory "S0" 0] + ,Delete "arg" + ] +compileCode m (Case cs:is)=contWith m Origin is $ + [SAM.Alloc "saddr" + ,Copy (Memory "S0" 0) [Register "saddr"] + ,Inline "#stack1S0" [] + ,Inline "#heapRefHp" ["saddr"] + ,Delete "saddr" + ,SAM.Alloc "tag" + ,Copy (Memory "Hp" 3) [Register "tag"] + ,Dispatch "tag" $ map (second $ flip (contWith m HeapA) []) cs + ,Delete "tag" + ] +compileCode m (Update n:is)=contWith m HeapA is $ + [SAM.Alloc "to" + ,Move (Memory "S0" 0) [Register "to"] + ,Locate (-1) + ,SAM.Alloc "from" + ,Copy (Memory "S0" $ 1-n) [Register "from"] + ,Inline "#stack1S0" [] + -- rewrite stack + ,While (Memory "S0" 0) + [Inline "#rewriteS0" ["from","to"] + ,Locate 1 + ] + ,Locate (-1) + ,Inline "#stack1S0" [] + -- rewrite heap + ,While (Memory "Hp" 0) + [SAM.Alloc "ntag" + ,Copy (Memory "Hp" 2) [Register "ntag"] + ,Dispatch "ntag" + [(appTag, + [Locate 3 + ,Inline "#rewriteHp" ["from","to"] + ,Locate 1 + ,Inline "#rewriteHp" ["from","to"] + ,Locate 3 + ]) + ,(scTag, + [Locate 6]) + ,(constTag, + [Locate 6]) + ,(structTag, + [SAM.Alloc "size" + ,Copy (Memory "Hp" 0) [Register "size"] + ,Val (Register "size") (-6) + ,Locate 4 + ,While (Register "size") + [Inline "#rewriteHp" ["from","to"] + ,Locate 1 + ,Val (Register "size") (-1) + ] + ,Delete "size" + ,Locate 2 + ]) + ] + ,Delete "ntag" + ] + ,Delete "from" + ,Delete "to" + ] +compileCode m (Pop n:is)=contWith m StackT is $ + concat $ replicate n [Clear (Memory "S0" 0),Locate (-1)] +compileCode m (GMachine.Alloc n:is)=compileCode m $ replicate n (PushByte 0)++is + +compileCode m (UError s:_)=Clear ptr:concatMap (\d->[Val ptr d,Output ptr]) ds + where + ds=head ns:zipWith (-) (tail ns) ns + ns=map ord s + ptr=Memory "S0" 0 +compileCode m (Arith op:is)=contWith m StackT is $ + [SAM.Alloc "x" + ,SAM.Alloc "y" + ,Move (Memory "S0" 0) [Register "x"] + ,Move (Memory "S0" (-1)) [Register "y"] + ,Locate (-2) + ,Inline "#stack1S0" [] + ,Inline "#heapRefHp" ["x"] + ,Copy (Memory "Hp" 3) [Register "x"] + ,Inline "#heap1Hp" [] + ,Inline "#heapRefHp" ["y"] + ,Delete "y" + ,SAM.Alloc "temp" + ,Copy (Memory "Hp" 3) [Register "temp"] + ]++ + f (Register "temp") (Register "x") op++ + [Delete "temp" + ,SAM.Alloc "addr" + ,Inline "#heapNewHp" ["addr"] + ,Clear (Memory "Hp" 0) ,Val (Memory "Hp" 0) 6 + ,Clear (Memory "Hp" 1) ,Val (Memory "Hp" 1) 0 + ,Clear (Memory "Hp" 2) ,Val (Memory "Hp" 2) $ tag op + ,Clear (Memory "Hp" 3) ,Move (Register "x") [Memory "Hp" 3] ,Delete "x" + ,Clear (Memory "Hp" 4) ,Copy (Register "addr") [Memory "Hp" 4] + ,Clear (Memory "Hp" 5) ,Val (Memory "Hp" 5) 6 + ,Clear (Memory "Hp" 6) + ,Inline "#heap1Hp" [] + ,Inline "#stackNewS0" [] + ,Move (Register "addr") [Memory "S0" 0] + ,Delete "addr" + ] + where + tag CCmp=structTag + tag _=constTag + f from to AAdd=[While from [Val from (-1),Val to 1]] + f from to ASub=[While from [Val from (-1),Val to (-1)]] + f from to CCmp= + [SAM.Alloc "t" + ,Val (Register "t") 1 + ,While (Register "t") + [SAM.Alloc "s" + ,Copy from [Register "s"] + ,Val (Register "t") 1 + ,While (Register "s") + [Clear (Register "s") + ,Val (Register "t") (-1) + ] + ,Copy to [Register "s"] + ,While (Register "s") + [Clear (Register "s") + ,Val (Register "t") (-1) + ] + ,Val (Register "s") 1 + ,While (Register "t") + [Clear (Register "t") + ,Val (Register "s") (-1) + ] + ,Move (Register "s") [Register "t"] + ,Delete "s" + ,Val from (-1) + ,Val to (-1) + ] + ,Val from 1 + ,Val to 1 + ,While from [Clear from,Val (Register "t") 1] + ,While to [Clear to,Val (Register "t") 2] + ,Move (Register "t") [to] -- 0:EQ 1:from>to 2:to last packed +-- +-- Note2: 'PushArg' counts from top=0 +data GMCode + =Slide Int -- ^ pop 1st...nth items + |Update Int -- ^ replace all reference to the nth address to 0th address. + |Pop Int -- ^ remove n items + |Push Int + |PushSC String + |Alloc Int + |Swap -- ^ used for implementing 'elimReduce' + |Reduce RHint -- ^ reduce stack top to WHNF + -- function + |MkApp -- ^ function must be pushed after arguments. then use this. + |PushArg Int + -- data structure + |Pack Int Int + |Case [(Int,[GMCode])] + |UnPack Int + -- arithmetic + |PushByte Int + |Arith ArithOp + -- error + |UError String -- ^ output the given string with undefined consequence + deriving(Show) + +data ArithOp + =AAdd + |ASub + |CCmp + deriving(Show) + +data RHint + =RByte + |RE + |RAny + deriving(Show) + +pprint :: M.Map String [GMCode] -> String +pprint=compileSB . Group . intersperse EmptyLine . map (uncurry pprintGMF) . M.assocs + +pprintGMF :: String -> [GMCode] -> SBlock +pprintGMF name cs=Group + [Line $ U.Pack [Prim name,Prim ":"] + ,Indent $ Group $ map pprintGMC cs + ] + +pprintGMC :: GMCode -> SBlock +pprintGMC (Case cs)=Group + [Line $ Prim "Case" + ,Indent $ Group $ map (f . first show) $ sortBy (comparing fst) cs + ] + where f (label,xs)=Group [Line $ Span [Prim label,Prim "->"],Indent $ Group $ map pprintGMC xs] +pprintGMC c=Line $ Prim $ show c + + +-- | G-machine state for use in 'interpretGM' +type GMS=State GMInternal +type GMST m a=StateT GMInternal m a + +data GMInternal=GMInternal{stack::Stack,heap::Heap} deriving(Show) +data GMNode + =App Address Address + |Const Int + |Struct Int [Address] + |Combinator String + deriving(Show) + +type Stack=[Address] +type Heap=M.Map Address GMNode + +newtype Address=Address Int deriving(Show,Eq,Ord) + + + + + +interpret :: M.Map String [GMCode] -> IO () +interpret fs=evalStateT (evalGM False fs []) (makeEmptySt "main") + +interpretR :: M.Map String [GMCode] -> IO () +interpretR fs=evalStateT (evalGM True fs []) (makeEmptySt "main") + +makeEmptySt :: String -> GMInternal +makeEmptySt entry=runIdentity $ execStateT (alloc (Combinator entry) >>= push) $ GMInternal [] M.empty + + +-- | Interpret a single combinator and returns new combinator to be executed. +evalGM :: Bool -> M.Map String [GMCode] -> [GMCode] -> GMST IO () +evalGM fl fs []=do + st<-get + liftIO $ putStrLn $ "GMi: aux:\n"++showState st + + node<-refStack 0 >>= refHeap + + case node of + App a0 a1 -> push a0 >> evalGM fl fs [] + Combinator x -> evalGM fl fs (fs M.! x) + _ -> do x<-isRootNode + if x + then case node of + Struct 0 [f] -> do + pop + x<-liftIO (liftM ord getChar) + alloc (Const x) >>= push >> push f >> evalGM fl fs [MkApp] + Struct 1 [x,k] -> do + pop + refHeap x >>= (liftIO . putChar . unConst) + push k + evalGM fl fs [] + Struct 2 [] -> pop >> return () + else when fl $ do{[e,c]<-popn 2; Combinator x<-refHeap c; push e; evalGM fl fs (fs M.! x)} + where unConst (Const x)=chr x + +evalGM fl fs (Reduce _:xs)=evalGM fl fs [] >> evalGM fl fs xs +evalGM fl fs (Push n:xs)= + refStack n >>= push >> evalGM fl fs xs +evalGM fl fs (PushArg n:xs)=do + App _ arg<-refStack n >>= refHeap + push arg + evalGM fl fs xs +evalGM fl fs (MkApp:xs)=do + [s0,s1]<-popn 2 + alloc (App s0 s1) >>= push + evalGM fl fs xs +evalGM fl fs (Pack t n:xs)=do + ss<-popn n + alloc (Struct t ss) >>= push + evalGM fl fs xs +evalGM fl fs (PushSC n:xs)=do + alloc (Combinator n) >>= push + evalGM fl fs xs +evalGM fl fs (Slide n:xs)=do + x<-pop + popn n + push x + evalGM fl fs xs +evalGM fl fs (PushByte x:xs)=alloc (Const x) >>= push >> evalGM fl fs xs +evalGM fl fs (Case cs:xs)=do + Struct t _<-refStack 0 >>= refHeap + maybe (error $ "GMi: Case:"++show t) (evalGM fl fs . (++xs)) $ lookup t cs +evalGM fl fs (UnPack n:xs)=do + Struct _ cs<-pop >>= refHeap + when (length cs/=n) (error $ "GMi: UnPack arity error") + mapM_ push cs + evalGM fl fs xs +evalGM fl fs (Swap:xs)=popn 2 >>= mapM_ push >> evalGM fl fs xs +evalGM fl fs (Pop n:xs)=popn n >> evalGM fl fs xs +evalGM fl fs (Update n:xs)=do + t<-pop + f<-refStack $ n-1 + modify $ \(GMInternal st hp)->GMInternal (map (fS f t) st) (M.map (fH f t) hp) + evalGM fl fs xs + where + fS f t x|x==f = t + |otherwise = x + fH f t (App x y)=App (fS f t x) (fS f t y) + fH f t (Struct tag xs)=Struct tag $ map (fS f t) xs + fH _ _ x=x +evalGM fl fs (GMachine.Alloc n:xs)=evalGM fl fs $ replicate n (PushByte 0)++xs +evalGM fl fs (Arith op:xs)=do + Const x<-pop >>= refHeap + Const y<-pop >>= refHeap + case op of + AAdd -> alloc (Const $ (x+y) `mod` 256) >>= push + ASub -> alloc (Const $ (x-y) `mod` 256) >>= push + CCmp -> alloc (Struct (if x==y then 0 else if x>= push + evalGM fl fs xs +evalGM _ _ x=error $ "evalGM: unsupported: "++show x + + + + +showState :: GMInternal -> String +showState g=unlines $ + unwords (map show st):map (\(k,v)->show k++":"++show v) (M.assocs hp) + where GMInternal st hp=GMachine.gc g + + +-- | do not modify pointers +gc :: GMInternal -> GMInternal +gc (GMInternal st hp)=GMInternal st hp' + where + hp'=M.filterWithKey (\k _ ->S.member k ns) $ hp + ns=S.unions $ map (collect hp) st + + +collect heap addr=S.insert addr $ + case heap M.! addr of + App a0 a1 -> S.union (collect heap a0) (collect heap a1) + Struct _ as -> S.unions $ map (collect heap) as + _ -> S.empty + + +refHeap :: Monad m => Address -> GMST m GMNode +refHeap addr=liftM ((M.!addr) . heap) get + +refStack :: Monad m => Int -> GMST m Address +refStack n=liftM ((!!n) . stack) get + +isRootNode :: Monad m => GMST m Bool +isRootNode=do + n<-liftM (length . stack) get + return $ n==1 + + +push :: Monad m => Address -> GMST m () +push addr=do + GMInternal st h<-get + put $ GMInternal (addr:st) h + +alloc :: Monad m => GMNode -> GMST m Address +alloc n=do + GMInternal st h<-get + let addr=if M.null h then Address 0 else let Address base=fst $ M.findMax h in Address (base+1) + put $ GMInternal st $ M.insert addr n h + return addr + +pop :: Monad m => GMST m Address +pop=do + GMInternal (s:ss) h<-get + put $ GMInternal ss h + return s + +popn :: Monad m => Int -> GMST m [Address] +popn=flip replicateM pop + + + + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2009 Daiki Handa +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,163 @@ +-- | Create a chain based on given arguments and run it. +-- +-- Overall development policy: +-- +-- * If you seek /elegant/ abstraction, you will get /elephant/ abstraction. +-- +-- * All intermediate-languages should be interpretable in 'IO' monad with exactly same behavior, +-- or at least have such semantics. +-- +-- * Interpreters should not try to optimize, use simplest implementation while keeping the order low. +-- +-- See the source of 'help' for detailed description\/specification of features. +module Main where +import Control.Monad +import System.Environment +import System.FilePath.Posix +import System.IO +import qualified Paths_hs2bf + +import Util +import qualified Front +import qualified Core +import qualified GMachine +import qualified SAM +import qualified SCGR +import qualified Brainfuck + + +main=execCommand =<< liftM parseArgs getArgs + +-- | Complete description of /hs2bf/ behavior +data Command + =ShowMessage String + |Interpret Option String + |Compile Option String + +data Language + =LangCore String + |LangGM String + |LangSAM String + |LangBF + deriving(Show,Eq,Ord) + +-- | All /global options/ +data Option=Option + {addrSpace :: Int + ,verbose :: Bool + ,debug :: Bool + ,tolang :: Language + } + +-- | Parse arguments to 'Command'. Note this is a total function. +parseArgs :: [String] -> Command +parseArgs []=ShowMessage $ version++"\n"++help +parseArgs ("-v":_)=ShowMessage version +parseArgs ("--version":_)=ShowMessage version +parseArgs ("-h":_)=ShowMessage $ version++"\n"++help +parseArgs ("--help":_)=ShowMessage $ version++"\n"++help +parseArgs ("--run":n:as)=Interpret (parseOption as) n +parseArgs ("--make":n:as)=Compile (parseOption as) n +parseArgs _=ShowMessage "Invalid command. See 'hs2bf --help' for usage." + + + +parseOption :: [String] -> Option +parseOption []=Option{addrSpace=2,verbose=True,debug=False,tolang=LangBF} +parseOption (term:xs)=case term of + '-':'S':'c':xs -> o{tolang=LangCore xs} + '-':'S':'g':xs -> o{tolang=LangGM xs} + '-':'S':'s':xs -> o{tolang=LangSAM xs} + "-Sb" -> o{tolang=LangBF} + _ -> error $ "unknown option:"++term + where o=parseOption xs + + + + + +execCommand :: Command -> IO () +execCommand (ShowMessage x)=putStrLn x +execCommand (Interpret opt from)=partialChain opt from $ + (error "Core interpreter is not implemented" + ,error "Core interpreter is not implemented" + ,f GMachine.interpret + ,f GMachine.interpretR + ,f SAM.interpret + ,f SAM.interpret + ,f Brainfuck.interpret + ) + where + f g=runProcessWithIO (\x->setio >> g x) + setio=hSetBuffering stdin NoBuffering >> hSetBuffering stdout NoBuffering +execCommand (Compile opt from)=partialChain opt from $ + (f Core.pprint + ,f Core.pprint + ,f GMachine.pprint + ,f GMachine.pprint + ,f SAM.pprint + ,f SAM.pprint + ,f Brainfuck.pprint + ) + where f g=runProcessWithIO (putStr . g) + +partialChain opt from (c0,c1,g0,g1,s0,s1,b)=do + dir<-Paths_hs2bf.getDataDir + let (mod,env)=analyzeName from dir + xs<-Front.collectModules env mod + let cr =xs >>= Front.compile + cr' =cr >>= Core.simplify + gm =cr' >>= Core.compile + gm' =gm >>= GMachine.simplify + sam =gm' >>= GMachine.compile + sam'=sam >>= SAM.simplify + bf =sam' >>= SAM.compile + case tolang opt of + LangCore "" -> c0 cr + LangCore "s" -> c1 cr' + LangGM "" -> g0 gm + LangGM "r" -> g1 gm' + LangSAM "" -> s0 sam + LangSAM "f" -> s1 sam' + LangBF -> b bf + +version :: String +version="Haskell to Brainf**k Compiler: version 0.5" + +help :: String +help=unlines $ + ["Usage: hs2bf " + ,"" + ,"command:" + ," --help: show help" + ," --version: show version" + ," --run