hs2bf (empty) → 0.6
raw patch · 13 files changed
+3619/−0 lines, 13 filesdep +arraydep +basedep +containerssetup-changed
Dependencies added: array, base, containers, directory, filepath, haskell-src, mtl
Files
- Brainfuck.hs +105/−0
- Core.hs +391/−0
- Front.hs +512/−0
- GMachine.hs +711/−0
- LICENSE +25/−0
- Main.hs +163/−0
- SAM.hs +604/−0
- SCGR.hs +46/−0
- SRuntime.hs +703/−0
- Setup.hs +3/−0
- Util.hs +157/−0
- hs2bf.cabal +25/−0
- test/Prelude.hs +174/−0
+ Brainfuck.hs view
@@ -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'')+++++
+ Core.hs view
@@ -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><Q.fromList [Update $ n+1,Pop n])+ where+ n=length args+ mv=M.fromList $ zip args (map PushArg [1..])++compileE :: M.Map String Int -> 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+++
+ Front.hs view
@@ -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 "<whole>" 0 0) (Module "<whole>") 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 "<WeakDesugar>" 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+++
+ GMachine.hs view
@@ -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<from+ ,Delete "t"+ ]+ +++++++-- | G-machine intstruction+--+-- Note1: 'MkApp' 'Pack' ordering: first pushed -> 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<y then 1 else 2) []) >>= 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+++++
+ LICENSE view
@@ -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.+
+ Main.hs view
@@ -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>"+ ,""+ ,"command:"+ ," --help: show help"+ ," --version: show version"+ ," --run <module> <option>*: interpret <module>"+ ," --make <module> <option>*: compile <module>"+ ,""+ ,"option:"+ ," -o <file> : output path (stdout if omitted)"+ ," -Sc : to Core code"+ ," -Scs: to Core code (simplified)"+ ," -Sg : to GMachine"+ ," -Sgr: to GMachine (simplified)"+ ," -Ss : to SAM"+ ," -Ssf: to SAM (most simplified)"+-- ," -Sr : to SCGR" -- not implemented+ ," -Sb : to BF"+ ," --addr n : use n byte for pointer arithmetic"+ ," --debug : include detailed error message (this will make the program a LOT larger)"+ ,""+ ,"examples:"+ ," hs2bf --make path/to/App.hs -o app : compile App.hs to bf"+ ," hs2bf --run Main -Sm : compile module Main to GMachine code and interpret it"+ ]++++++analyzeName :: String -> FilePath -> (String,Front.ModuleEnv)+analyzeName n lib=(takeBaseName n,Front.ModuleEnv [dirPrefix++takeDirectory n,lib])+ where dirPrefix=if isAbsolute n then "" else "./"++
+ SAM.hs view
@@ -0,0 +1,604 @@+-- | Sequential Access Machine+--+-- This language makes implementation of various features easier by providing common C-like syntax.+--+-- Later this will be converted to very abstract graph representation and heavy optimization is+-- applied there (rule-based, mathematically-sound). It will be directly converted to BF.+--+-- This is the last language where direct debugging is possible.+--+--+-- Choice between 'Memory' and 'Locate'+--+-- * 'Memory' is for local operation(in a frame), and you can expect it to be heavily optimzied.+-- (Why not use 'Locate' manually? - special register optimization is possible for 'Memory')+--+-- * 'Locate' causes permanent change, and should be used for moving between frames+-- by not-predetermined amount.+--+-- * So in principle, you should minimize use of 'Locate', and use 'Memory' instead.+--+-- Multi-byte support direction:+--+-- * multiplication etc. is supported in this layer (manually)+--+-- * 'Val' 'Dispatch' 'Clear' 'While' 'Alloc' 'Delete' 'Move' should be expanded by a new 'Pointer'+--+-- * Difference from Integer support in Prelude: fixed size+module SAM where+import Control.Arrow+import Control.Monad+import Control.Monad.State+import Data.Char+import Data.Either+import Data.Graph+import Data.List+import Data.Maybe+import Data.Ord+import Data.Word+import qualified Data.Map as M+import qualified Data.Set as S+import Numeric+import Text.Printf++import Util+import SCGR+import Brainfuck+++compile :: SAM -> Process SCGR+compile (SAM _ [SProc _ [] ss])=return $ BF $ soptBF $ concatMap compileS ss++soptBF []=[]+soptBF xs=case head xs of+ BFPInc -> sopAux 0 xs+ BFPDec -> sopAux 0 xs+ BFVInc -> sovAux 0 xs+ BFVDec -> sovAux 0 xs+ BFLoop s -> BFLoop (soptBF s):xs'+ BFInput -> BFInput:xs'+ BFOutput -> BFOutput:xs'+ where xs'=soptBF $ tail xs++sopAux n (BFPInc:xs)=sopAux (n+1) xs+sopAux n (BFPDec:xs)=sopAux (n-1) xs+sopAux n xs=dP n++soptBF xs++sovAux n (BFVInc:xs)=sovAux (n+1) xs+sovAux n (BFVDec:xs)=sovAux (n-1) xs+sovAux n xs=dV n++soptBF xs++compileS (Move p ps)=compileS $ While p $ Val p (-1):map (flip Val 1) ps+compileS (While (Memory _ d) ss)=concat+ [dP d+ ,[BFLoop $ concat [dP (negate d),concatMap compileS ss,dP d]]+ ,dP (negate d)]+compileS (Val (Memory _ d) v)=concat [dP d,dV v,dP $ negate d]+compileS (Input (Memory _ d))=dP d++[BFInput]++dP (negate d)+compileS (Output (Memory _ d))=dP d++[BFOutput]++dP (negate d)+compileS (Locate d)=dP d+++dP x=replicateZ x BFPDec BFPInc+dV x=replicateZ x BFVDec BFVInc+++replicateZ x m p+ |x==0 = []+ |x>0 = replicate x p+ |x<0 = replicate (negate x) m++++-- | Apply this before 'SAM.compile'+--+-- * 'flatten': expand all inline calls+--+-- * 'desugar': 'Dispatch' -> 'While' 'Clear' -> 'Move' 'Copy' -> 'Move'+-- (don't expand 'Move' here, since they are good for later optimization)+--+-- * 'foldMemory': allocate registers+simplify :: SAM -> Process SAM+simplify s=+ checkSAM "SAM" s >>= return . flatten "^" >>=+ checkSAM "SAM:flat" >>= return . desugar >>=+ checkSAM "SAM:desugar" >>= return . allocateRegister >>=+ checkSAM "SAM:ralloc" >>= return . foldMemory >>=+ checkSAM "SAM:folded"+++-- | no register access+foldMemory :: SAM -> SAM+foldMemory (SAM rs [SProc name [] ss])=SAM [""] [SProc name [] $ map (foldMS (length rs) rs) ss]++foldMS n m (Move p ps)=Move (foldMP n m p) (map (foldMP n m) ps)+foldMS n m (While p ss)=While (foldMP n m p) (map (foldMS n m) ss)+foldMS n m (Val p d)=Val (foldMP n m p) d+foldMS n m (Locate d)=Locate $ n*d+foldMS n m (Input p)=Input (foldMP n m p)+foldMS n m (Output p)=Output (foldMP n m p)++foldMP n m (Memory r x)=Memory "" $ (fromJust $ elemIndex r m)+x*n+++-- | /very bad/ register allocator+allocateRegister :: SAM -> SAM+allocateRegister (SAM rs [SProc name [] ss])+ |rs' `eqRS` [] = SAM (rs++["R"]) [SProc name [] $ concat sss]+ |otherwise = error $ "allocateRegister: leaking register: "++show rs'+ where (rs',sss)=mapAccumL allocateRS [] ss++allocateRS :: [Maybe RegName] -> Stmt -> ([Maybe RegName],[Stmt])+allocateRS rs (Alloc r)=case elemIndex Nothing rs of+ Nothing -> (rs++[Just r],[])+ Just ix -> (mapAt ix (const $ Just r) rs,[])+allocateRS rs (Delete r)=case elemIndex (Just r) rs of+ Just ix -> (mapAt ix (const Nothing) rs,[Move (Memory "R" ix) []])+ Nothing -> error $ "allocateRS: deleting unknown register: "++r+allocateRS rs (Move p ps)=(rs,[Move (allocateRP rs p) (map (allocateRP rs) ps)])+allocateRS rs (While p ss)+ |eqRS rs rs' = (rs,[While (allocateRP rs p) $ concat sss])+ |otherwise = error "allocateRS: unmatched register scope in while"+ where (rs',sss)=mapAccumL allocateRS rs ss+allocateRS rs (Val p d)=(rs,[Val (allocateRP rs p) d])+allocateRS rs (Input p)=(rs,[Input (allocateRP rs p)])+allocateRS rs (Output p)=(rs,[Output (allocateRP rs p)])+{-+allocateRS rs (Locate d)+ |d/=0 = (rs',mv++[Locate d])+ |d==0 = (rs,[])+ where+ rs'=map (\ix->lookup (ix-d) table') area+ table'=map (snd3 &&& thr3) table+ area=[0..maximum (map snd3 table)-d-1]+ + mv=map (\(fr,to,_)->Move (Memory "R" fr) [Memory "R" to]) table+ table=repackRS S.empty (map (second fromJust) $ filter (isJust . snd) $ zip [0..] rs) d+-}+-- just works (TM)+allocateRS rs (Locate d)+ |d>0 = (rs,mvPos++[Locate d])+ |d<0 = (rs,mvNeg++[Locate d])+ |d==0 = (rs,[])+ where+ mvPos=reverse mvNeg+ mvNeg=map (gen . fst) $ filter (isJust . snd) $ zip [0..] rs+ gen ix=Move (Memory "R" ix) [Memory "R" $ ix+d]++-- | repack registers as densely as possible without causing collision+repackRS :: S.Set Int -> [(Int,RegName)] -> Int -> [(Int,Int,RegName)]+repackRS _ [] d=[]+repackRS al rs d+ |S.null cand = error "repackRS: unknown situation" -- what to do? (this is actually possible)+ |not $ S.null nocost = allocate (S.findMin nocost) (S.findMin nocost)+ |otherwise = allocate (fst $ head rs) (S.findMin cand)+ where+ allocate fr to=(fr,to,maybe undefined id $ lookup fr rs):rs'+ where rs'=repackRS (S.insert to al) (filter ((/=fr) . fst) rs) d+ + nocost=S.intersection cand from+ cand=S.fromList [d..d+length rs-1] S.\\ al+ from=S.fromList $ map fst rs++++eqRS :: [Maybe RegName] -> [Maybe RegName] -> Bool+eqRS [] []=True+eqRS (Nothing:xs) []=eqRS xs []+eqRS [] (Nothing:ys)=eqRS [] ys+eqRS (x:xs) (y:ys)=(x==y) && (xs `eqRS` ys)+eqRS _ _=False+++++allocateRP :: [Maybe RegName] -> Pointer -> Pointer+allocateRP rs (Memory x d)=Memory x d+allocateRP rs (Register r)+ =maybe (error $ "allocateRP: non-allocated register: "++r) (Memory "R") $ elemIndex (Just r) rs+++++desugar :: SAM -> SAM+desugar (SAM rs [SProc name [] ss])=SAM rs [SProc name [] ss']+ where+ ss'=[Alloc "_dt"]++concatMap desugarStmt ss++[Delete "_dt"]++desugarStmt :: Stmt -> [Stmt]+desugarStmt (Dispatch r cs)=concatMap desugarStmt $ expandDispatch r $ sortBy (comparing fst) cs+desugarStmt (While ptr ss)=[While ptr $ concatMap desugarStmt ss]+desugarStmt (Clear ptr)=[Move ptr []]+desugarStmt (Copy p ps)=[Alloc "_ct",Move p [Register "_ct"],Move (Register "_ct") (p:ps),Delete "_ct"]+desugarStmt (Comment _)=[]+desugarStmt s=[s]++-- | Case numbers must be sorted in ascending order.+-- _dt must be 0 before and after dispatch+-- r must be 0 after dispatch+expandDispatch r []=error "expandDispatch: empty dispatch"+expandDispatch r [(n,e)]+ |abs n<3 = [Val (Register r) $ negate n]++e+ |otherwise = [Clear (Register r)]++e+expandDispatch r ((n0,e0):cs)=+ [Val (Register "_dt") 1+ ,Val (Register r) (negate $ n0)+ ,While (Register r) $+ Val (Register "_dt") (-1):+ expandDispatch r (map (\(n,e)->(n-n0,e)) cs)+ ,While (Register "_dt") $+ Val (Register "_dt") (-1):e0+ ]++++-- | Sequential Access Machine+data SAM=SAM [Region] [SProc] deriving(Show)++data SProc=SProc ProcName [RegName] [Stmt] deriving(Show)++procName :: SProc -> ProcName+procName (SProc name _ _)=name++-- | Statement set of SAM.+--+-- Operations with 'RegName' in their arguments changes scope+data Stmt+ =Locate Int -- ^ ptr+=n+ |While Pointer [Stmt]+ |Val Pointer Int+ |Alloc RegName+ |Delete RegName+ |Move Pointer [Pointer]+ |Copy Pointer [Pointer] -- ^ syntax sugar of 'Move'+ |Clear Pointer -- ^ syntax sugar of Move p []+ |Dispatch RegName [(Int,[Stmt])] -- ^ in case alts, given RegName will be out of scope. This instruction is erratic in many ways...+ |Inline ProcName [RegName]+ |Input Pointer+ |Output Pointer+ |Comment String -- ^ one-line comment+ deriving(Show)++data Pointer+ =Register RegName+ |Memory Region Int++instance Show Pointer where+ show (Register x)=x+ show (Memory region n)+ |n==0 = "$"++region+ |n>0 = "$"++region++"+"++show n+ |n<0 = "$"++region++show n++type Region=String+type ProcName=String+type RegName=String+++++pprint :: SAM -> String+pprint (SAM rs ps)=compileSB $ Group+ [Line $ Span $ map Prim rs+ ,EmptyLine+ ,EmptyLine+ ,Group $ intersperse EmptyLine $ map pprintSP ps+ ]++pprintSP :: SProc -> SBlock+pprintSP (SProc name args st)=Group+ [Line $ Span [Prim "pr",Pack $ Prim name:darg]+ ,Indent $ Group $ map pprintStmt st+ ]+ where+ darg|null args = []+ |otherwise = [Prim "/",Span $ map Prim args]++pprintStmt :: Stmt -> SBlock+pprintStmt (While ptr ss)=Group $+ [Line $ Span [Prim "while",Prim $ show ptr]+ ,Indent $ Group $ map pprintStmt ss]+pprintStmt (Dispatch n cs)=Group $+ [Line $ Span [Prim "dispatch",Prim n]+ ,Indent $ Group $ map (f . first show) cs+ ]+ where f (l,ss)=Group [Line $ Prim l,Indent $ Group $ map pprintStmt ss]+pprintStmt s=Line $ Span $ case s of+ Val p n -> [Prim "val",Prim $ show p,Prim $ show n]+ Alloc n -> [Prim "alloc",Prim n]+ Delete n -> [Prim "delete",Prim n]+ Move d ss -> Prim "move":map (Prim . show) (d:ss)+ Copy d ss -> Prim "copy":map (Prim . show) (d:ss)+ Locate n -> [Prim "locate",Prim $ show n]+ Inline n rs -> map Prim ("inline":n:rs)+ Clear r -> [Prim "clear",Prim $ show r]+ Input p -> [Prim "in",Prim $ show p]+ Output p -> [Prim "out",Prim $ show p]+ Comment s -> [Prim "--",Prim s]+++++++-- | Flatten procedures from given root.+flatten :: ProcName -> SAM -> SAM+flatten root (SAM rs ps)+ |not $ null cycles = error $ "flatten: dependency cycles:\n"++unlines (map unwords cycles)+ |otherwise = SAM rs [m2p root $ foldl expandProc (ps2m ps) vs]+ where+ (cycles,vs)=partitionEithers $ map f $ stronglyConnComp $ map procNode ps+ f (AcyclicSCC x)=Right x+ f (CyclicSCC xs)=Left xs++ ps2m=M.fromList . map (\(SProc name args ss)->(name,(args,ss)))+ m2p r m=uncurry (SProc r) $ m M.! r++++-- | Construct a node for procedure dependecy graph+procNode :: SProc -> (ProcName,ProcName,[ProcName])+procNode (SProc n args ss)=(n,n,S.toList $ S.unions $ map stmtDep ss)++-- | Collect 'Inline'd procedures from 'Stmt'+stmtDep :: Stmt -> S.Set ProcName+stmtDep (While _ ss)=S.unions $ map stmtDep ss+stmtDep (Dispatch _ cs)=S.unions $ map stmtDep $ concatMap snd cs+stmtDep (Inline n _)=S.singleton n+stmtDep _=S.empty++-- | Expand the given proc in the map non-recursively.+expandProc :: M.Map ProcName ([RegName],[Stmt]) -> ProcName -> M.Map ProcName ([RegName],[Stmt])+expandProc m r=M.adjust (second $ expandStmts m) r m++expandStmts :: M.Map ProcName ([RegName],[Stmt]) -> [Stmt] -> [Stmt]+expandStmts m=concatMap (expandStmt m)++expandStmt :: M.Map ProcName ([RegName],[Stmt]) -> Stmt -> [Stmt]+expandStmt m (Inline n rsP)=map (replaceStmt f) ss+ where+ (rsC,ss)=M.findWithDefault (error $ "flattenProc:unknown proc "++n) n m+ f reg=case lookup reg $ zip rsC rsP of+ Just rsp -> rsp+ Nothing -> n++"/"++reg+expandStmt m (While p ss)=[While p $ expandStmts m ss]+expandStmt m (Dispatch p cs)=[Dispatch p $ map (second $ expandStmts m) cs]+expandStmt _ s=[s]+++-- | Apply register name transformation.+replaceStmt :: (RegName -> RegName) -> Stmt -> Stmt+replaceStmt f (While ptr ss)=While (replacePtr f ptr) $ map (replaceStmt f) ss+replaceStmt f (Dispatch n cs)=Dispatch (f n) $ map (second (map $ replaceStmt f)) cs+replaceStmt f (Val p n)=Val (replacePtr f p) n+replaceStmt f (Alloc n)=Alloc $ f n+replaceStmt f (Delete n)=Delete $ f n+replaceStmt f (Clear p)=Clear $ replacePtr f p+replaceStmt f (Move p ps)=Move (replacePtr f p) (map (replacePtr f) ps)+replaceStmt f (Copy p ps)=Copy (replacePtr f p) (map (replacePtr f) ps)+replaceStmt f (Inline n ss)=error "replaceStmt: Inline: re-check expansion order"+replaceStmt f (Input p)=Input (replacePtr f p)+replaceStmt f (Output p)=Output (replacePtr f p)+replaceStmt _ s=s++replacePtr :: (RegName -> RegName) -> Pointer -> Pointer+replacePtr f (Register x)=Register $ f x+replacePtr _ p=p++++++-- | 'NRM' instance for use in 'checkProc'+type NMRE a=NMR String String a++-- | Just a wrapper of 'checkProc' for 'SAM'. No additional checks.+checkSAM :: String -> SAM -> Process SAM+checkSAM loc s@(SAM x procs)+ |null errors = return s+ |otherwise = throwError errors+ where+ errors=map (\(pos,msg)->CompileErrorN loc msg pos) $ snd $ runNMR $ mapM_ checkProc procs+++-- | Find static erros in a 'SProc'.+-- +-- What's being done here is usual variable scope analysis. But the data dependecy graph will be a+-- DAG, not tree.+--+-- * unknown registers+--+-- * unmatched register in 'While' and 'Dispatch'+--+-- TODO:+--+-- * 'Alloc' or 'Delete' of argument registers+--+-- * modification of flag register in 'Dispatch'+checkProc :: SProc -> NMRE ()+checkProc (SProc name args ss)=within ("proc "++name) $ do+ let rs=S.fromList args+ when (S.size rs/=length args) $ report "duplicate arguments"+ rs'<-checkStmt ss rs+ when (rs/=rs') $ report $ "leaking registers: "++unwords (S.toList $ rs' S.\\ rs)+++checkStmt :: [Stmt] -> S.Set RegName -> NMRE (S.Set RegName)+checkStmt [] rs=return rs+checkStmt ((While ptr ss):xs) rs=do+ within "while flag" $ checkPointer ptr rs+ rs'<-within "while body" $ checkStmt ss rs+ when (rs/=rs') $ within "while" $ report $ "leaking registers: "++unwords (S.toList $ rs' S.\\ rs)+ checkStmt xs rs+checkStmt ((Dispatch n cs):xs) rs=do+ unless (S.member n rs) $ within "dispatch header" $ report $ "unknown register:"++show n+ let integrity rsB=when (rsB/=rs) $ report $ "leaking registers:"++unwords (S.toList $ rsB S.\\ rs)+ forM_ cs (\(n,ss)->within ("dispatch clause "++show n) $ checkStmt ss rs >>= integrity)+ checkStmt xs rs+checkStmt ((Alloc n):xs) rs=do+ when (S.member n rs) $ report $ "duplicated allocation of "++n+ checkStmt xs $ S.insert n rs+checkStmt ((Delete n):xs) rs=do+ unless (S.member n rs) $ report $ "deleting unallocated register "++n+ checkStmt xs $ S.delete n rs+checkStmt ((Move p ps):xs) rs=mapM_ (\x->within "move" $ checkPointer x rs) (p:ps) >> checkStmt xs rs+checkStmt ((Copy p ps):xs) rs=mapM_ (\x->within "copy" $ checkPointer x rs) (p:ps) >> checkStmt xs rs+checkStmt ((Val p _):xs) rs=within "val" (checkPointer p rs) >> checkStmt xs rs+checkStmt ((Clear p):xs) rs=within "clear" (checkPointer p rs) >> checkStmt xs rs+checkStmt ((Inline name ns):xs) rs=do+ let s=S.fromList ns+ unless (s `S.isSubsetOf` rs) $ within ("inline "++name) $ report $ "unknown registers: " ++unwords (S.toList $s S.\\ rs)+ checkStmt xs rs+checkStmt ((Input p):xs) rs=within "input" (checkPointer p rs) >> checkStmt xs rs+checkStmt ((Output p):xs) rs=within "output" (checkPointer p rs) >> checkStmt xs rs+checkStmt (_:xs) rs=checkStmt xs rs+++checkPointer :: Pointer -> S.Set RegName -> NMRE ()+checkPointer (Register x) rs=unless (S.member x rs) $ within "pointer" $ report $ "unknown register: "++x+checkPointer _ rs=return ()++++-- | Interpreter of 'SAM', usable for all phases.+interpret :: SAM -> IO ()+interpret=runProcessWithIO f . checkSAM "SAMi"+ where f (SAM rs procs)=let ptb0=M.fromList $ map (procName &&& id) procs+ mtb0=(M.fromList $ zip rs $ repeat minit)+ st0=SAMInternal ptb0 mtb0 M.empty 0+ in evalStateT (enterProc "^" []) st0++data SAMInternal=SAMInternal+ {procTable :: M.Map ProcName SProc+ ,memTable :: MemTable+ ,regTable :: RegTable+ ,pointer :: Int+ }++type MemTable=M.Map Region FlatMemory+type RegTable=M.Map ProcName (M.Map RegName Word8,M.Map RegName (ProcName,RegName))++type SAMST=StateT SAMInternal+++enterProc :: ProcName -> [(ProcName,RegName)] -> SAMST IO ()+enterProc name args=do+ liftIO $ putStrLn $ "entering:"++name+ dumpRegisters+ dumpMemory+ + ptb<-liftM procTable get+ rtb<-liftM regTable get+ let SProc _ rs ss=M.findWithDefault (error $ "SAMi: procedure not found: "++name) name ptb+ when (length rs/=length args) $ error $ "SAMi: procedure arity error: "++show (name,rs,args) + when (M.member name rtb) $ error $ "SAMi: re-entring to precedure: "++name+ + let rtb'=M.insert name (M.empty,M.fromList $ zipWith (\org to->(to,uncurry (reduceReg rtb) org)) args rs) rtb+ modify (\x->x{regTable=rtb'})+ execStmts name ss+ modify (\x->x{regTable=M.delete name $ regTable x})+ liftIO $ putStrLn $ "leaving:"++name++dumpMemory :: SAMST IO ()+dumpMemory=do+ t<-liftM memTable get+ p<-liftM pointer get+ let maxAddr=max 0 $ maximum (map msize $ M.elems t)-1+ ss=map (\x->dumpMemoryBetween p t (x*w,(x+1)*w-1)) [0..maxAddr `div` w]+ liftIO $ putStr $ unlines ss+ where w=30++dumpMemoryBetween :: Int -> MemTable -> (Int,Int) -> String+dumpMemoryBetween p t (a0,a1)=unlines $ map dumpKey ks+ where+ ks=M.keys t+ head=maximum $ map length ks+ dumpKey k=printf ("%"++show head++"s|") k++dump (t M.! k)+ dump fm=concatMap (\x->showAddr x $ mread fm x) [a0..a1]+ showAddr a v=(if a==p then ">" else " ")++(printf "%02s" $ showHex v "")++dumpRegisters :: SAMST IO ()+dumpRegisters=do+ r<-liftM regTable get+ let ss=map (uncurry dumpRegisterP) $ M.assocs r+ liftIO $ putStr $ concat ss++dumpRegisterP :: ProcName -> (M.Map RegName Word8,M.Map RegName (ProcName,RegName)) -> String+dumpRegisterP proc (m0,m1)=unlines $ ("in "++proc++":"):rs+ where+ rs=(map (\(n,v)->" "++n++": "++showHex v "") $ M.assocs m0)+++ (map (\(n,a)->" "++n++" -> "++show a) $ M.assocs m1)++ +execStmts p=mapM_ (\x->execStmt p x >> liftIO (putStrLn (p++" "++(take 50 $ show x))) >> dumpRegisters >> dumpMemory >> liftIO (putStrLn ""))++execStmt p (Alloc r)=modifyRT $ M.adjust (first $ M.insert r 0) p+execStmt p (Delete r)=modifyRT $ M.adjust (first $ M.delete r) p+execStmt p (Inline n rs)=enterProc n (zip (repeat p) rs)+execStmt p (Val ptr d)=liftM (+fromIntegral d) (readPtr p ptr) >>= writePtr p ptr+execStmt p s0@(While ptr ss)=do+ x<-readPtr p ptr+ when (x/=0) $ execStmts p ss >> execStmt p s0+execStmt p (Move ptr ptrs)=forM (ptr:ptrs) (readPtr p) >>= zipWithM_ (\ptr x->writePtr p ptr x) (ptr:ptrs) . f+ where f (x:xs)=0:map (+x) xs+execStmt p (Copy ptr ptrs)=forM (ptr:ptrs) (readPtr p) >>= zipWithM_ (\ptr x->writePtr p ptr x) ptrs . f+ where f (x:xs)=map (+x) xs+execStmt p (Locate d)=modifyPointer (+d)+execStmt p (Dispatch r cs)=do+ x<-readPtr p (Register r)+ writePtr p (Register r) 0+ let caluse=lookup (fromIntegral x) cs+ maybe (error $ "SAMi: dispatch:"++show (x,r,p)) (execStmts p) caluse+execStmt p (Clear ptr)=writePtr p ptr 0+execStmt p (Input ptr)=liftIO getChar >>= writePtr p ptr . fromIntegral . ord+execStmt p (Output ptr)=readPtr p ptr >>= liftIO . putChar . chr . fromIntegral+execStmt p (Comment _)=return ()++++readPtr :: Monad m => ProcName -> Pointer -> SAMST m Word8+readPtr p (Memory r d)=do+ dp<-liftM pointer get+ when (dp+d<0) $ error $ "readPtr: invalid op:"++show (p,r,dp,d)+ liftM (flip mread (dp+d) . (M.! r) . memTable) get+readPtr p (Register r)=liftM (flip (flip readReg p) r . regTable) get+++writePtr :: Monad m => ProcName -> Pointer -> Word8 -> SAMST m ()+writePtr p (Memory r d) x=do+ dp<-liftM pointer get+ when (dp+d<0) $ error $ "writePtr: invalid op:"++show (p,r,dp,d)+ modifyMT $ M.adjust (flip (flip mwrite (dp+d)) x) r+writePtr p (Register r) x=modifyRT (\t->writeReg t p r x)+++++readReg :: RegTable -> ProcName -> RegName -> Word8+readReg t p r=(fst (t M.! p')) M.! r'+ where (p',r')=reduceReg t p r++writeReg :: RegTable -> ProcName -> RegName -> Word8 -> RegTable+writeReg t p r x=M.adjust (first $ M.insert r' x) p' t+ where (p',r')=reduceReg t p r+++reduceReg :: RegTable -> ProcName -> RegName -> (ProcName,RegName)+reduceReg t p r+ |M.member r org = (p,r)+ |otherwise = alias M.! r+ where (org,alias)=t M.! p++++modifyRT :: Monad m => (RegTable -> RegTable) -> SAMST m ()+modifyRT f=modify $ \x->x{regTable=f $ regTable x}++modifyMT :: Monad m => (MemTable -> MemTable) -> SAMST m ()+modifyMT f=modify $ \x->x{memTable=f $ memTable x}++modifyPointer :: Monad m => (Int -> Int) -> SAMST m ()+modifyPointer f=modify $ \x->x{pointer=g $ pointer x}+ where g x=let y=f x in if x<0 then error $ "modifyPointer: invalid pos: "++show y else y++
+ SCGR.hs view
@@ -0,0 +1,46 @@+-- | Super-cool-graph-representation (this module is not used now)+--+-- There are 3 goals in optimization:+--+-- * Code size+--+-- * Memory usage+--+-- * Speed+--+-- And there are practically 3 types of optimization:+--+-- * -code +speed : o+--+-- * +code -speed : o+--+-- * -code +mem -speed : x (this is what you do when hand-writing /hello world/ in BF)+module SCGR where++import Util+import Brainfuck++{-+data SCGR=SCGR [Node]++data Node+ =Frame Int+ |Trans Point [Point]+ |Cycle Point XXX+ |Const Point Int++data Point=Point+ +++compile :: SCGR -> Process BF+compile scgr=return undefined+-}+++type SCGR=BF++compile :: SCGR -> Process BF+compile=return++
+ SRuntime.hs view
@@ -0,0 +1,703 @@+module SRuntime where+import Data.List++import SAM++appTag=0+scTag=1+constTag=2+structTag=3+++genLibrary :: [Int] -> [SProc]+genLibrary ns=concat+ [genStackLib "S0" -- primary address stack+ ,genStackLib "Hp" -- frontier stack in GC+ ,genHeapLib "Hp" -- primiary heap+ ,genHeapLib "Hs" -- secondary heap for GC+ ,genGCLib ns+ ,[rootProc,setupMemory,mainLoop,eval,evalApp,evalSC,evalConst,evalStr,evalE]+ ,[isEqual,rewrite "S0",rewrite "Hp"]+ ]++rootProc :: SProc+rootProc=SProc "^" []+ [Inline "%setupMemory" []+ ,Inline "%mainLoop" []+ ]+++setupMemory :: SProc+setupMemory=SProc "%setupMemory" []+ [Locate 1+ ,Val (Memory "S0" 0) 1 -- frame addr+ ,Val (Memory "Hp" 0) 6 -- frame size+ ,Val (Memory "Hp" 1) 0 -- GC tag+ ,Val (Memory "Hp" 2) scTag+ ,Val (Memory "Hp" 3) sc+ ,Val (Memory "Hp" 4) 1 -- frame addr+ ,Val (Memory "Hp" 5) 6 -- frame size+ ]+ where sc=2 -- main++mainLoop :: SProc+mainLoop=SProc "%mainLoop" []+ [Alloc "sc" -- 0:halt 1:cont-eval *:exec+ ,Val (Register "sc") 1+ ,While (Register "sc")+ [Inline "%eval" ["sc"]+ ,Inline "%exec" ["sc"]+ ]+ ,Delete "sc"+ ]++-- | Eval. Must be on address 1. /sc/ must be 1 on entry.+--+-- * halt: sc:=0+--+-- * eval: sc:=1+--+-- * exec: sc:=2-255+--+-- this function calls 'evalApp', 'evalSC', 'evalStr' and evalConst after aligning with heap frame.+eval :: SProc+eval=SProc "%eval" ["sc"]+ [Inline "#stack1S0" []+ ,Inline "#stackTopS0" []+ ,Alloc "addr"+ ,Copy (Memory "S0" 0) [Register "addr"]+ ,Inline "#stack1S0" []+ ,Inline "#heapRefHp" ["addr"]+ ,Delete "addr"+ ,Alloc "tag"+ ,Copy (Memory "Hp" 2) [Register "tag"]+ ,Dispatch "tag"+ [(appTag,[Inline "%evalApp" []])+ ,(scTag,[Inline "%evalSC" ["sc"]])+ ,(constTag,[Inline "%evalConst" ["sc"]])+ ,(structTag,[Inline "%evalStr" ["sc"]])+ ]+ ,Delete "tag"+ ]++evalApp=SProc "%evalApp" []+ [Alloc "addr"+ ,Copy (Memory "Hp" 3) [Register "addr"]+ ,Inline "#heap1Hp" []+ ,Inline "#stackNewS0" []+ ,Move (Register "addr") [Memory "S0" 0]+ ,Delete "addr"+ ,Inline "#stack1S0" []+ ]++evalSC=SProc "%evalSC" ["sc"]+ [Val (Register "sc") (-1)+ ,Copy (Memory "Hp" 3) [Register "sc"]+ ,Inline "#heap1Hp" []+ ]++evalConst=SProc "%evalConst" ["sc"]+ [Inline "#heap1Hp" []+ ,Inline "#stackTopS0" []+ ,While (Memory "S0" (-1)) -- non-root frame -> get sc+ [Val (Register "sc") (-1) -- sc:=0+ ,Alloc "addr"+ ,Move (Memory "S0" (-1)) [Register "addr"]+ ,Move (Memory "S0" 0) [Memory "S0" (-1)] -- move exp to top+ ,Locate (-1)+ ,Inline "#stack1S0" []+ ,Inline "#heapRefHp" ["addr"]+ ,Delete "addr"+ ,Copy (Memory "Hp" 3) [Register "sc"]+ ,Inline "#heap1Hp" []+ ]+ ]++evalStr=SProc "%evalStr" ["sc"]+ [Inline "#heap1Hp" []+ ,Inline "#stackTopS0" []+ ,Alloc "root"+ ,Val (Register "root") 1+ ,While (Memory "S0" (-1)) -- non-root frame -> get sc+ [Val (Register "sc") (-1) -- sc:=0+ ,Val (Register "root") (-1)+ ,Alloc "addr"+ ,Move (Memory "S0" (-1)) [Register "addr"]+ ,Move (Memory "S0" 0) [Memory "S0" (-1)] -- move exp to top+ ,Locate (-1)+ ,Inline "#stack1S0" []+ ,Inline "#heapRefHp" ["addr"]+ ,Delete "addr"+ ,Copy (Memory "Hp" 3) [Register "sc"]+ ,Inline "#heap1Hp" []+ ]+ ,While (Register "root")+ [Val (Register "root") (-1)+ ,Inline "#stackTopS0" []+ ,Alloc "addr"+ ,Copy (Memory "S0" 0) [Register "addr"]+ ,Inline "#stack1S0" []+ ,Inline "#heapRefHp" ["addr"]+ ,Delete "addr"+ ,Inline "%evalE" ["sc"]+ ]+ ,Delete "root"+ ]++-- sc must be 1 on entry+evalE=SProc "%evalE" ["sc"]+ [Alloc "stag"+ ,Copy (Memory "Hp" 3) [Register "stag"]+ ,Dispatch "stag"+ [(0, -- input f+ [Alloc "faddr"+ ,Copy (Memory "Hp" 4) [Register "faddr"]+ -- construct app frame: [7,gcTag,appTag,f,aaddr+1,aaddr,7]+ ,Alloc "aaddr"+ ,Inline "#heapNewHp" ["aaddr"]+ ,Val (Memory "Hp" 0) 7+ ,Clear (Memory "Hp" 1),Val (Memory "Hp" 1) 0+ ,Clear (Memory "Hp" 2),Val (Memory "Hp" 2) appTag+ ,Clear (Memory "Hp" 3),Move (Register "faddr") [Memory "Hp" 3]+ ,Delete "faddr"+ ,Clear (Memory "Hp" 4),Clear (Memory "Hp" 5),Clear (Memory "Hp" 6)+ ,Copy (Register "aaddr") [Memory "Hp" 4,Memory "Hp" 5]+ ,Val (Memory "Hp" 4) 1+ ,Val (Memory "Hp" 6) 7+ ,Clear (Memory "Hp" 7) -- mark new frame+ -- construct const frame: [6,gcTag,constTag,input,aaddr+1,6]+ ,Locate 7+ ,Clear (Memory "Hp" 1)+ ,Clear (Memory "Hp" 2)+ ,Clear (Memory "Hp" 3)+ ,Clear (Memory "Hp" 4)+ ,Val (Memory "Hp" 0) 6+ ,Val (Memory "Hp" 1) constTag+ ,Copy (Register "aaddr") [Memory "Hp" 4],Val (Memory "Hp" 4) 1+ ,Val (Memory "Hp" 5) 6+ ,Input (Memory "Hp" 3)+ ,Clear (Memory "Hp" 6) -- mark new frame+ -- pop and push aaddr+ ,Inline "#heap1Hp" []+ ,Inline "#stackTopS0" []+ ,Clear (Memory "S0" 0)+ ,Move (Register "aaddr") [Memory "S0" 0]+ ,Delete "aaddr"+ ,Inline "#stack1S0" []+ ])+ ,(1, -- output x k [8,gcTag,structTag,1,X,K,addr,8]+ [Alloc "xaddr"+ ,Alloc "kaddr"+ ,Copy (Memory "Hp" 4) [Register "xaddr"]+ ,Copy (Memory "Hp" 5) [Register "kaddr"]+ -- refer and output x+ ,Inline "#heap1Hp" []+ ,Inline "#heapRefHp" ["xaddr"]+ ,Delete "xaddr"+ ,Output (Memory "Hp" 3)+ -- replace stack top+ ,Inline "#heap1Hp" []+ ,Inline "#stackTopS0" []+ ,Clear (Memory "S0" 0)+ ,Move (Register "kaddr") [Memory "S0" 0]+ ,Delete "kaddr"+ ,Inline "#stack1S0" []+ ])+ ,(2, -- halt+ [Val (Register "sc") (-1) -- sc:=0+ ,Inline "#heap1Hp" []+ ,Inline "#stackTopS0" []+ ,Clear (Memory "S0" 0)+ ])+ ]+ ,Delete "stag"+ ]++-- | Must be on address 1. /sc/ will be 1 or 0.+exec :: [(String,Int)] -> SProc+exec xs=SProc "%exec" ["sc"]+ [Alloc "cont"+ ,While (Register "sc")+ [Comment "run GC before executing SC"+ ,Alloc "sct"+ ,Copy (Register "sc") [Register "sct"]+ ,Val (Register "sct") (-1)+ ,While (Register "sct")+ [Clear (Register "sct")+ ,Inline "#gc" []+ ]+ ,Delete "sct"+ ,Comment "execute SC"+ ,Dispatch "sc" $ (1,[]):map f xs+ ,Val (Register "cont") 1+ ]+ ,While (Register "cont")+ [Val (Register "sc") 1+ ,Val (Register "cont") (-1)+ ]+ ,Delete "cont"+ ]+ where f (str,n)=(n,[Inline ("!"++str) []])++++-- | Generate heap libraries for given region.+genHeapLib :: String -> [SProc]+genHeapLib r=map ($r) [heap1,heapNew,heapNew_,heapTop,heapRef]++-- | Return to address 1. Must be aligned with a heap frame.+heap1 :: String -> SProc+heap1 r=SProc ("#heap1"++r) []+ [While (Memory r (-1))+ [Alloc "cnt"+ ,Copy (Memory r (-1)) [Register "cnt"]+ ,While (Register "cnt")+ [Val (Register "cnt") (-1)+ ,Locate (-1)+ ]+ ,Delete "cnt"+ ]+ ]++-- | Move to where a new heap frame would be and write the address to addr. Must be aligned with frame.+-- The first size field is 0, but others are undefined.+heapNew :: String -> SProc+heapNew r=SProc ("#heapNew"++r) ["addr"]+ [While (Memory r 0)+ [Alloc "cnt"+ ,Copy (Memory r 0) [Register "cnt"]+ ,While (Register "cnt")+ [Val (Register "cnt") (-1)+ ,Locate 1]+ ,Delete "cnt"+ ]+ ,Copy (Memory r (-2)) [Register "addr"]+ ,Val (Register "addr") 1+ ]++-- | Move to where a new heap frame would be. Must be aligned with frame.+-- The first size field is 0, but others are undefined.+heapNew_ :: String -> SProc+heapNew_ r=SProc ("#heapNew_"++r) []+ [While (Memory r 0)+ [Alloc "cnt"+ ,Copy (Memory r 0) [Register "cnt"]+ ,While (Register "cnt")+ [Val (Register "cnt") (-1)+ ,Locate 1]+ ,Delete "cnt"+ ]+ ]++-- | Move to where the heap top. Must be aligned with frame.+heapTop :: String -> SProc+heapTop r=SProc ("#heapTop"++r) []+ [While (Memory r 0)+ [Alloc "cnt"+ ,Copy (Memory r 0) [Register "cnt"]+ ,While (Register "cnt")+ [Val (Register "cnt") (-1)+ ,Locate 1]+ ,Delete "cnt"+ ]+ ,Alloc "cnt"+ ,Copy (Memory r (-1)) [Register "cnt"]+ ,While (Register "cnt")+ [Val (Register "cnt") (-1)+ ,Locate (-1)+ ]+ ,Delete "cnt"+ ]++-- | Move to the frame pointed by addr. addr will be 0. Must be aligned.+heapRef :: String -> SProc+heapRef r=SProc ("#heapRef"++r) ["addr"]+ [Val (Register "addr") (-1)+ ,While (Register "addr")+ [Val (Register "addr") (-1)+ ,Alloc "cnt"+ ,Copy (Memory r 0) [Register "cnt"]+ ,While (Register "cnt")+ [Val (Register "cnt") (-1)+ ,Locate 1+ ]+ ,Delete "cnt"+ ]+ ]++++-- | Generate all stack utiltiy functions for given region.+genStackLib r=map ($r) [stack1,stackNew,stackTop]++-- | Return to address 1. Must be on stack($S\/=0).+stack1 :: String -> SProc+stack1 r=SProc ("#stack1"++r) []+ [While (Memory r (-1)) [Locate (-1)]]++-- | Move to stack new.+stackNew :: String -> SProc+stackNew r=SProc ("#stackNew"++r) []+ [While (Memory r 0) [Locate 1]]++-- | Move to stack top.+stackTop :: String -> SProc+stackTop r=SProc ("#stackTop"++r) []+ [While (Memory r 1) [Locate 1]]++++-- | Generate GC library from constructor arities.+genGCLib :: [Int] -> [SProc]+genGCLib ns=[gc,gcTransfer,gcMark ns,gcCopy ns,gcIndex,gcRewrite ns,resolve]++-- | Origin -> Origin: Run packing GC.+gc :: SProc+gc=SProc "#gc" []+ [Inline "#gcTransfer" []+ ,Inline "#gcMark" []+ ,Inline "#gcCopy" []+ ,Inline "#gcIndex" []+ ,Inline "#gcRewrite" []+ ]++-- | Copy everything as is from Hp to Hs.+gcTransfer :: SProc+gcTransfer=SProc "#gcTransfer" []+ [While (Memory "Hp" 0)+ [Alloc "cnt"+ ,Copy (Memory "Hp" 0) [Register "cnt"]+ ,While (Register "cnt")+ [Clear (Memory "Hs" 0)+ ,Move (Memory "Hp" 0) [Memory "Hs" 0]+ ,Val (Register "cnt") (-1)+ ,Locate 1+ ]+ ,Delete "cnt"+ ]+ ,Clear (Memory "Hs" 0)+ ,Inline "#heap1Hs" []+ ]+ +-- | Mark nodes from S, using Hp as /frontier/ stack. Argument is cons arity.+gcMark :: [Int] -> SProc+gcMark ns=SProc "#gcMark" []+ [Comment "init frontiers"+ ,While (Memory "S0" 0)+ [Clear (Memory "Hp" 0)+ ,Copy (Memory "S0" 0) [Memory "Hp" 0]+ ,Locate 1+ ]+ ,Clear (Memory "Hp" 0)+ ,Locate (-1)+ ,Inline "#stack1S0" []+ ,Comment "top to bottom"+ ,Inline "#stackTopHp" []+ ,While (Memory "Hp" 0)+ [Alloc "addr"+ ,Move (Memory "Hp" 0) [Register "addr"]+ ,Inline "#stack1Hp" []+ ,Inline "#heapRefHs" ["addr"]+ ,Delete "addr"+ ,Comment "already visited?"+ ,Alloc "gf"+ ,Move (Memory "Hs" 1) [Register "gf"]+ ,Val (Memory "Hs" 1) 1+ ,Dispatch "gf"+ [(0,+ [Alloc "ntag"+ ,Copy (Memory "Hs" 2) [Register "ntag"]+ ,Dispatch "ntag" $+ [(appTag,+ [Alloc "t1"+ ,Copy (Memory "Hs" 3) [Register "t1"]+ ,Alloc "t2"+ ,Copy (Memory "Hs" 4) [Register "t2"]+ ,Inline "#heap1Hs" []+ ,Inline "#stackNewHp" []+ ,Move (Register "t1") [Memory "Hp" 0]+ ,Delete "t1"+ ,Move (Register "t2") [Memory "Hp" 1]+ ,Delete "t2"+ ,Clear (Memory "Hp" 2)+ ,Locate 1+ ])+ ,(scTag,+ [Inline "#heap1Hs" []+ ,Inline "#stackTopHp" []+ ])+ ,(constTag,+ [Inline "#heap1Hs" []+ ,Inline "#stackTopHp" []+ ])+ ]+++ if null ns then [] else+ [(structTag,+ [Alloc "sz"+ ,Copy (Memory "Hs" 0) [Register "sz"]+ ,Dispatch "sz" $ map f ns+ ,Delete "sz"+ ])+ ]+ ,Delete "ntag"+ ])+ ,(1,+ [Inline "#heap1Hs" []+ ,Inline "#stackTopHp" []+ ]+ )]+ ,Delete "gf"+ ]+ ]+ where+ f n=(n+6,+ concatMap (\x->[Alloc $ tempN x,Copy (Memory "Hs" $ x+3) [Register $ tempN x]]) [1..n]+++ [Inline "#heap1Hs" []+ ,Inline "#stackNewHp" []+ ]+++ concatMap (\x->[Move (Register $ tempN x) [Memory "Hp" $ x-1],Delete $ tempN x]) [1..n]+++ [Clear (Memory "Hp" n),Locate $ n-1]+ )++++-- | Copy marked frames from Hs to Hp.+gcCopy :: [Int] -> SProc+gcCopy ns=SProc "#gcCopy" []+ [While (Memory "Hs" 0)+ [Alloc "flag"+ ,Move (Memory "Hs" 1) [Register "flag"]+ ,Dispatch "flag"+ [(0,+ [Alloc "cnt"+ ,Copy (Memory "Hs" 0) [Register "cnt"]+ ,While (Register "cnt")+ [Val (Register "cnt") (-1)+ ,Locate 1+ ]+ ,Delete "cnt"+ ])+ ,(1,+ [Alloc "size"+ ,Copy (Memory "Hs" 0) [Register "size"]+ ,Dispatch "size" $ map f ss+ ,Delete "size"+ ])+ ]+ ,Delete "flag"+ ]+ ,Inline "#heap1Hs" []+ ]+ where+ f s=(s,+ concatMap (\x->[Alloc $ tempN x,Move (Memory "Hs" $ 1+x) [Register $ tempN x]]) [1..s-3]+++ [Alloc $ tempN $ s-2+ ,Copy (Memory "Hs" $ s-1) [Register $ tempN $ s-2]+ ,Inline "#heap1Hs" []+ ,Inline "#heapNew_Hp" []+ ,Move (Register $ tempN $ s-2) [Memory "Hp" 0,Memory "Hp" $ s-1]+ ,Delete $ tempN $ s-2+ ]+++ concatMap (\x->[Move (Register $ tempN x) [Memory "Hp" $ 1+x],Delete $ tempN x]) [1..s-3]+++ [Clear (Memory "Hp" 1)+ ,Clear (Memory "Hp" s)+ ,Inline "#heap1Hp" []+ ]+ )+ ss=nub $ map (6+) ns++[6,7]+++++-- | Construct OldAddr->NewAddr table in Hs.+--+-- O(n^2)+gcIndex :: SProc+gcIndex=SProc "#gcIndex" []+ [Alloc "naddr"+ ,While (Memory "Hp" 0)+ [Alloc "cnt"+ ,Copy (Memory "Hp" 0) [Register "cnt"]+ ,While (Register "cnt")+ [Val (Register "cnt") (-1)+ ,Locate 1+ ]+ ,Delete "cnt"+ ,Val (Register "naddr") 1+ ]+ ,While (Register "naddr")+ [Alloc "ta"+ ,Copy (Register "naddr") [Register "ta"]+ ,Val (Register "ta") 1+ ,Inline "#heapRefHp" ["ta"]+ ,Delete "ta"+ ,Alloc "oaddr"+ ,Copy (Memory "Hp" (-2)) [Register "oaddr"]+ ,Inline "#heap1Hp" []+ ,Comment "Write index"+ ,Alloc "cnt"+ ,Val (Register "oaddr") (-1)+ ,Copy (Register "oaddr") [Register "cnt"]+ ,While (Register "cnt")+ [Val (Register "cnt") (-1)+ ,Locate 1+ ]+ ,Delete "cnt"+ ,Clear (Memory "Hs" 0) -- Clear (Memory "Hs" 1) is UNNECESSARY! (lookup doesnt depend on stack top)+ ,Copy (Register "naddr") [Memory "Hs" 0]+ ,While (Register "oaddr")+ [Val (Register "oaddr") (-1)+ ,Locate (-1)+ ]+ ,Delete "oaddr"+ ,Val (Register "naddr") (-1)+ ]+ ,Delete "naddr"+ ,Comment "Rewrite id field"+ ,Alloc "naddr"+ ,While (Memory "Hp" 0)+ [Alloc "cnt"+ ,Copy (Memory "Hp" 0) [Register "cnt"]+ ,While (Register "cnt")+ [Val (Register "cnt") (-1)+ ,Locate 1+ ]+ ,Delete "cnt"+ ,Val (Register "naddr") 1+ ,Clear (Memory "Hp" (-2))+ ,Copy (Register "naddr") [Memory "Hp" (-2)]+ ]+ ,Delete "naddr"+ ,Inline "#heap1Hp" []+ ]++-- | Rewrite stack and Hp addressed based on the table in Hs.+gcRewrite :: [Int] -> SProc+gcRewrite ns=SProc "#gcRewrite" []+ [Comment "Rewrite heap"+ ,While (Memory "Hp" 0)+ [Alloc "ntag"+ ,Copy (Memory "Hp" 2) [Register "ntag"]+ ,Dispatch "ntag"+ [(appTag,+ [Alloc "t1"+ ,Move (Memory "Hp" 3) [Register "t1"]+ ,Alloc "t2"+ ,Move (Memory "Hp" 4) [Register "t2"]+ ,Alloc "ad"+ ,Copy (Memory "Hp" 5) [Register "ad"]+ ,Inline "#heap1Hp" []+ ,Inline "#resolve" ["t1"]+ ,Inline "#resolve" ["t2"]+ ,Inline "#heapRefHp" ["ad"]+ ,Delete "ad"+ ,Move (Register "t1") [Memory "Hp" 3]+ ,Delete "t1"+ ,Move (Register "t2") [Memory "Hp" 4]+ ,Delete "t2"+ ,Locate 7+ ])+ ,(scTag,[Locate 6])+ ,(constTag,[Locate 6])+ ,(structTag,+ [Alloc "nsize"+ ,Copy (Memory "Hp" 0) [Register "nsize"]+ ,Dispatch "nsize" $ map f ns+ ,Delete "nsize"+ ])+ ]+ ,Delete "ntag"+ ]+ ,Inline "#heap1Hp" []+ ,Comment "Rewrite stack"+ ,Alloc "size"+ ,While (Memory "S0" 0)+ [Val (Register "size") 1+ ,Locate 1+ ]+ ,While (Register "size")+ [Locate (-1)+ ,Val (Register "size") (-1)+ ,Alloc "val"+ ,Move (Memory "S0" 0) [Register "val"]+ ,Inline "#stack1S0" []+ ,Inline "#resolve" ["val"]+ ,Alloc "cnt"+ ,Copy (Register "size") [Register "cnt"]+ ,While (Register "cnt")+ [Val (Register "cnt") (-1)+ ,Locate 1+ ]+ ,Delete "cnt"+ ,Move (Register "val") [Memory "S0" 0]+ ,Delete "val"+ ]+ ,Delete "size"+ ]+ where+ f n=(n+6,+ concatMap (\x->[Alloc $ "t"++show x,Move (Memory "Hp" $ 3+x) [Register $ "t"++show x]]) [1..n]+++ [Alloc "ad"+ ,Copy (Memory "Hp" $ 4+n) [Register "ad"]+ ,Inline "#heap1Hp" []+ ]+++ map (\x->Inline "#resolve" ["t"++show x]) [1..n]+++ [Inline "#heapRefHp" ["ad"]+ ,Delete "ad"+ ]+++ concatMap (\x->[Move (Register $ "t"++show x) [Memory "Hp" $ 3+x],Delete $ "t"++show x]) [1..n]+++ [Locate $ n+6]+ )+ ++resolve :: SProc+resolve=SProc "#resolve" ["t"]+ [Val (Register "t") (-1)+ ,Alloc "cnt"+ ,Copy (Register "t") [Register "cnt"]+ ,While (Register "cnt")+ [Val (Register "cnt") (-1)+ ,Locate 1+ ]+ ,Move (Register "t") [Register "cnt"]+ ,Copy (Memory "Hs" 0) [Register "t"]+ ,While (Register "cnt")+ [Val (Register "cnt") (-1)+ ,Locate (-1)+ ]+ ,Delete "cnt"+ ]++isEqual :: SProc+isEqual=SProc "#isEqual" ["x","y","f"]+ [While (Register "x")+ [Val (Register "x") (-1)+ ,Val (Register "y") (-1)+ ]+ ,Val (Register "f") 1+ ,While (Register "y")+ [Clear (Register "y")+ ,Val (Register "f") (-1)+ ]+ ]++rewrite :: String -> SProc+rewrite r=SProc ("#rewrite"++r) ["from","to"]+ [SAM.Alloc "test0"+ ,Copy (Memory r 0) [Register "test0"]+ ,SAM.Alloc "test1"+ ,Copy (Register "from") [Register "test1"]+ ,SAM.Alloc "flag"+ ,Inline "#isEqual" ["test0","test1","flag"]+ ,Delete "test0"+ ,Delete "test1"+ ,While (Register "flag")+ [Val (Register "flag") (-1)+ ,Clear (Memory r 0)+ ,Copy (Register "to") [Memory r 0]+ ]+ ,Delete "flag"+ ]++tempN x="t"++show x+
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main=defaultMain+
+ Util.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE FlexibleInstances #-}+-- | Modular error reporting and common functions+--+-- note for future me: Arrow vs. Monad+-- Suppose each process can return either error or result.+-- Parallel execution of such processes can be written as:+-- (a -> m b) -> [a] -> m [b] : Monadic form+-- w a b -> w [a] [b] : Arrow form+-- +-- How to decide on one?+-- If you can write [m b] -> m [b] , then use Monad.+-- Otherwise use Arrow.+module Util(module Util,throwError) where+import Control.Arrow+import Control.Monad.Error+import Control.Monad.State+import Control.Monad.Identity+import Data.List+import Data.Word+import qualified Data.IntMap as IM+++-- | Process that may fail with ['CompileError']+-- ErrorT Identity is used for future use. (cf. ErrorT Writer)+type Process a=ErrorT [CompileError] Identity a++runProcess :: Process a -> Either [CompileError] a+runProcess=runIdentity . runErrorT++runProcessWithIO :: (a->IO ()) -> Process a -> IO ()+runProcessWithIO f=either (putStr . unlines . map show) f . runProcess+++++-- | A detailed compile error+-- +-- * 'CompileError' is used in early stages where filename and line number is known+--+-- * 'CompileErrorN' is used in later stages where only non-numerical position is available+data CompileError+ =CompileError String String String -- ^ e.g. CompileError "Haskell->Core" "Main.hs:12" "parse error"+ |CompileErrorN String String [String] -- ^ e.g. CompileErrorN "SAM->SAM" "unknown register x" ["while","proc foo"]++instance Show CompileError where+ show (CompileError m p d)=m++":"++p++":\n"++d+ show (CompileErrorN m d ps)=m++":\n"++d++"\n"++concatMap (\x->"in "++x++"\n") ps++instance Error [CompileError] where+ noMsg=[]+++-- | Nested structure multiple reporter monad+type NMR p e a=State ([p],[([p],e)]) a++report :: e -> NMR p e ()+report e=do+ (pos,es)<-get+ put (pos,(pos,e):es)++within :: p -> NMR p e a -> NMR p e a+within x f=do+ modify (first (x:))+ r<-f+ modify (first tail)+ return r++runNMR :: NMR p e a -> (a,[([p],e)])+runNMR=second snd . flip runState ([],[])++++++data SBlock+ =EmptyLine+ |Line IBlock+ |Group [SBlock]+ |Indent SBlock++-- | Inline string+data IBlock+ =Prim String+ |Pack [IBlock]+ |Span [IBlock]++-- | Render 'SBlock'+compileSB :: SBlock -> String+compileSB=unlines . saux 0++saux :: Int -> SBlock -> [String]+saux _ EmptyLine=[""]+saux n (Line i)=[replicate (n*4) ' '++compileIB i]+saux n (Group xs)=concatMap (saux n) xs+saux n (Indent x)=saux (n+1) x++-- | Render 'IBlock'+compileIB :: IBlock -> String+compileIB (Prim x)=x+compileIB (Pack xs)=concatMap compileIB xs+compileIB (Span xs)=concatMap compileIB $ intersperse (Prim " ") xs+++-- | Moderately fast memory suitable for use in interpreters.+data FlatMemory=FlatMemory (IM.IntMap Word8)++minit :: FlatMemory+minit=FlatMemory $ IM.empty++mread :: FlatMemory -> Int -> Word8+mread (FlatMemory m) i=maybe 0 id $ IM.lookup i m++mwrite :: FlatMemory -> Int -> Word8 -> FlatMemory+mwrite (FlatMemory m) i v=FlatMemory $ IM.insert i v m++mmodify :: FlatMemory -> Int -> (Word8 -> Word8) -> FlatMemory+mmodify fm i f=mwrite fm i (f $ mread fm i)++msize :: FlatMemory -> Int+msize (FlatMemory m)=case IM.maxViewWithKey m of+ Nothing -> 0+ Just ((k,v),m') -> if v/=0 then k+1 else msize $ FlatMemory m'+++-- | a b c ... z aa ab ac ... az ba ...+-- avoid CAF.+stringSeq :: String -> [String]+stringSeq prefix=tail $ map ((prefix++) . reverse) $ iterate stringInc []++stringInc :: String -> String+stringInc []="a"+stringInc ('z':xs)='a':stringInc xs+stringInc (x:xs)=succ x:xs++-- | usage+--+-- > change1 "XYZ" "abc"+--+-- evaluates to+--+-- > ["Xbc","aYc","abZ"]+change1 :: [a] -> [a] -> [[a]]+change1 (x:xs) (y:ys)=(x:ys):map (y:) (change1 xs ys)+change1 _ _=[]++mapAt :: Int -> (a->a) -> [a] -> [a]+mapAt ix0 f=zipWith g [0..]+ where g ix x=if ix==ix0 then f x else x++fst3 (x,_,_)=x+snd3 (_,y,_)=y+thr3 (_,_,z)=z+++equaling :: Eq b => (a -> b) -> (a -> a -> Bool)+equaling f x y=f x==f y+
+ hs2bf.cabal view
@@ -0,0 +1,25 @@+name: hs2bf+cabal-version: >=1.2+version: 0.6+author: Daiki Handa+maintainer: xanxys@gmail.com+synopsis: Haskell to Brainfu*k compiler+license: BSD3+license-File: LICENSE+category: Compiler+description:+ Proof of concept implementation of Haskell to Brainfu*k compiler.+ You can find examples of compilable codes at http://www.xanxys.net/public/hs2bf-demo/+build-type: Simple+data-files: Prelude.hs+data-dir: test+tested-with: GHC==6.10.4,GHC==6.12.1+extra-source-files:+ Front.hs Core.hs GMachine.hs SAM.hs SCGR.hs Brainfuck.hs+ Util.hs SRuntime.hs+executable hs2bf+ main-is: Main.hs+ build-depends:+ containers>=0.1, base>=4 && <5, mtl>=1, array>=0.2,+ filepath>=1, directory>=1, haskell-src>=1+
+ test/Prelude.hs view
@@ -0,0 +1,174 @@++-- internal+seq=undefined+undefined=undefined+addByteRaw=undefined+subByteRaw=undefined+cmpByteRaw=undefined+++-- generic combinanors+infixr 9 .+(.) f g x=f (g x)++infixr 0 $+f $ x=f x++infixr 0 $!+f $! x=x `seq` (f x)+++id x=x+flip f x y=f y x+++-- boolean+data Bool+ =False+ |True++infixr 2 ||+x || y=+ case x of+ True -> True+ False -> y++infixr 3 &&+x && y=+ case x of+ False -> False+ True -> y++otherwise=True+++-- maybe+data Maybe a+ =Nothing+ |Just a+++-- either+data Either a b+ =Left a+ |Right b+++-- ordering+data Ordering+ =EQ -- 0+ |LT -- 1+ |GT -- 2+++-- tuple+data XT1 a=XT1 a+data XT2 a b=XT2 a b+data XT3 a b c=XT3 a b c++++-- list+data XList a+ =XCons a (XList a)+ |XNil+++head (x:xs)=x+tail (x:xs)=xs++reverse []=[]+reverse (x:xs)=reverse xs++[x]++map f []=[]+map f (x:xs)=f x:map f xs++filter f []=[]+filter f (x:xs)+ |f x = x:filter f xs+ |otherwise = filter f xs++(x:xs) !! n+ |n `eqByte` 0 = x+ |otherwise = xs !! (n `subByte` 1)++xs ++ ys=+ case xs of+ [] -> ys+ x:xs -> x:(xs++ys)+++{- I don't know why, but this code doesn't work!+[]++ys=ys+(x:xs)++ys=x:(xs++ys)+-}++++length []=0+length (x:xs)=1 `addByte` (length xs)++foldr f z []=z+foldr f z (x:xs)=f x (foldr f z xs)++foldl f z []=z+foldl f z (x:xs)=foldl f (f x z) xs+++-- I/O+data E+ =Input (Char -> E)+ |Output !Char E+ |Halt+++++++addByte x y=x `seq` (y `seq` (addByteRaw x y))+subByte x y=x `seq` (y `seq` (subByteRaw x y))+cmpByte x y=x `seq` (y `seq` (cmpByteRaw x y))++eqByte x y=case cmpByte x y of+ EQ -> True+ s -> False++ltByte x y=case cmpByte x y of+ LT -> True+ s -> False++gtByte x y=case cmpByte x y of+ GT -> True+ s -> False++leByte x y=case cmpByte x y of+ GT -> False+ s -> True++geByte x y=case cmpByte x y of+ LT -> False+ s -> True++{-+data Int+ =PInt Byte+ |NInt Byte+++negateInt (PInt x)=NInt x+negateInt (NInt x)=PInt x++addInt (PInt x) (PInt y)=PInt $ x `addByte` y+addInt (NInt x) (NInt y)=NInt $ x `addByte` y+addInt (PInt x) (NInt y)+ |x `gtByte` y = PInt $ x `subByte` y+ |otherwise = NInt $ y `subByte` x+addInt (NInt x) (PInt y)+ |x `gtByte` y = NInt $ x `subByte` y+ |otherwise = PInt $ y `subByte` x++-}+++