diff --git a/alpha.cabal b/alpha.cabal --- a/alpha.cabal +++ b/alpha.cabal @@ -1,5 +1,5 @@ name: alpha -version: 1.0.14 +version: 1.0.15 synopsis: A compiler for the Alpha language description: Alpha is a programming language that aims at being very simple and low-level, so as to be efficient, while at the same time @@ -22,7 +22,7 @@ executable alpha build-depends: base<=4.6.0.0, unix, containers, array, mtl, bytestring, bimap, ghc-prim, directory, filepath, cereal, parsec, transformers, bindings-posix, AvlTree, COrdering, cpphs main-is: Alpha.hs - other-modules: Alpha Compile Compile.State Compile.Utils Context Context.Language Context.Types Format ID My.Control.Monad My.Control.Monad.RWTL My.Control.Monad.State My.Data.Either My.Data.Graph My.Data.List My.Data.Relation My.Data.SetBy My.Data.Tree My.Prelude Options PCode PCode.Builtin PCode.Instruction PCode.Value Serialize Specialize Specialize.Architecture Specialize.Frame Specialize.Types Specialize.X86_64 Specialize.X86_64.Binary Syntax Syntax.Parse Translate + other-modules: Alpha Compile Compile.Monad Context Context.Language Context.Types Format ID My.Control.Monad My.Control.Monad.RWTL My.Control.Monad.State My.Data.Either My.Data.List My.Data.Relation My.Data.SetBy My.Data.Tree My.Prelude Options PCode PCode.Builtin PCode.Instruction PCode.Value Serialize Specialize Specialize.Architecture Specialize.Frame Specialize.Types Specialize.X86_64 Specialize.X86_64.Binary Syntax Syntax.Parse Translate ghc-options: -pgmP cpphs -optP --hashes -optP --cpp hs-source-dirs: src c-sources: src/formats.c diff --git a/src/Alpha.hs b/src/Alpha.hs --- a/src/Alpha.hs +++ b/src/Alpha.hs @@ -170,7 +170,8 @@ ("alpha/lang" , Right $ exportAlpha callStub0 alpha_printLang), ("alpha/print-OK" , Right $ exportAlpha callStub0 alpha_printOK), ("alpha/print-num" , Right $ exportAlpha callStub1 alpha_printNum), - ("alpha/print-expr" , Right $ exportAlpha callStub1 alpha_printExpr) + ("alpha/print-expr" , Right $ exportAlpha callStub1 alpha_printExpr), + ("alpha/print-val" , Right $ exportAlpha callStub1 alpha_printVal) ] #define str(x) #x @@ -191,6 +192,8 @@ ALPHA_EXPORT(allocate,Int -> IO (Ptr())) = mallocBytes ALPHA_EXPORT(free,Ptr() -> IO ()) = free +ALPHA_EXPORT(printVal,ID -> IO ()) sym = gets (language >>> lookupSymVal sym) >>= print + ALPHA_EXPORT(printHelp,IO()) = printHelp ALPHA_EXPORT(printOK,IO()) = putStrLn "OK" ALPHA_EXPORT(printNum,Int -> IO()) n = print (intPtrToPtr $ fromIntegral n) @@ -220,7 +223,7 @@ get = readIORef contextRef put = writeIORef contextRef -withInitialContext = withState initialContext +withInitialContext = swapping id_ initialContext initialContext = C ?settings lang jitA M.empty (fromIntegral entry) Nothing where (lang,jitA) = execState (mapM_ st initialBindings) (mempty,M.empty) where st (s,v) = do diff --git a/src/Compile.hs b/src/Compile.hs --- a/src/Compile.hs +++ b/src/Compile.hs @@ -1,50 +1,76 @@ -{-# LANGUAGE TupleSections, ParallelListComp, NoMonomorphismRestriction #-} +{-# LANGUAGE TupleSections, ParallelListComp, NoMonomorphismRestriction, RecursiveDo, ViewPatterns #-} module Compile(compile) where -import Compile.State as CS -import Compile.Utils +import Compile.Monad import Context +import Control.Monad.Writer import Data.Either +import Data.Function import Data.Maybe import ID import My.Control.Monad import My.Control.Monad.State -import My.Data.Graph as G hiding (deleteEdge,deleteNode) import My.Data.List import My.Prelude import PCode +import qualified Data.Map as M import Syntax +import Data.Array +import My.Data.Tree -compile args ret expr = evalStateT st defaultState - where st = do - (_,(start,_)) <- compile' (fmap bindSym ret) expr - c <- simplify start >>= linearize >>= lift . uniquify args ret - return $ Code args c ret +lookupName s = lift $ gets (lookupSymName s) +getSymVal s = lift $ gets (lookupSymVal s) +newVar = lift (state createSym) +intercept m = censor (const mempty) $ listen m +m !- s = fromMaybe s $ M.lookup s m +addLocals ls = modifying locals_ $ \m -> foldr (uncurry M.insert) m ls +globVal t s locs = case M.lookup s locs of + Just s' -> SymVal t s' + Nothing -> SymVal GValue s +branch (IntVal (fromInteger -> n)) alts | n>=0 && n> return NullVal +goto n = branch NullVal [n] +a ?>>= b = listen a >>= \(a,l) -> if null l || not (isBranch $ last l) then b a else return a +a ?>> b = a ?>>= const b +flattenable code = map (f . instr) code' + where f (Branch v alts) = Branch v (map (a!) alts) + f i = i + (bounds,instr,nexts,_) = navigate code + t = spanningTree 0 nexts ; code' = flatten t + a = array bounds (zip code' [0..]) +compile args ret expr = runCompileT (compile' (fmap bindSym ret) expr) + (M.fromList [(s,s) | bv <- maybe id (:) ret args, s <- bindSyms bv]) + >§ \(_,c) -> Code args (flattenable $ c++[Branch NullVal []]) ret + compile' dest (Symbol sym) = do - name <- getSymName sym - let def = SymVal Value sym + name <- lookupName sym + locs <- gets locals + let def = globVal Value sym locs val = fromMaybe def (IntVal $< (readConstant =<< name)) - fromMaybe (nullCodeVal val) $ do - v <- dest - guard (not $ v `varEqVal` val) - return $ do n <- createNode (Instr $ set v val) - return (def,singleCode n) + case dest of + Just v | v/=sym -> tell [set v val] >> return def + _ -> return val compile' dest (Group (Symbol id:args)) = do gl <- getSymVal id let compile = case gl of - Just (Axiom a) -> compileAxiom a - Just (Builtin b) -> compileBuiltin b + Axiom a -> compileAxiom a + Builtin b -> compileBuiltin b _ -> \d a -> compileCall d (Symbol id:a) compile dest args compile' dest (Group args) = compileCall dest args +schedule dests args = do + (vals,code) <- unzip $< sequence [intercept $ compile' dest arg | dest <- dests | arg <- args] + mapM_ tell (reverse $ sortBy (compare`on`length) code) + return vals + compileBy op dest args = do - (vars,code) <- unzip $< mapM (compile' Nothing) args + vals <- schedule (repeat Nothing) args dest <- maybe newVar return dest - n <- createNode (Instr $ op dest vars) - sequence_ [createEdge TimeDep n' n | (_,l) <- code, n' <- l] - return (SymVal Value dest,(n:concatMap fst code,[n])) + tell [op dest vals] + return (SymVal Value dest) compileBuiltin _ dest [] = compileValue dest (IntVal 0) compileBuiltin b dest args = compileBy (Op b) dest args @@ -52,55 +78,62 @@ compileAxiom XAlter _ forms = do let (vars,exprs) = partitionEithers $ zipWith ($) (cycle [Left,Right]) forms - codes <- sequence [compile' (Just v) e | Symbol v <- vars | e <- exprs] - let (starts,ends) = unzip $ map snd codes - return (NullVal,(concat starts,concat ends)) + locs <- gets locals + let assocs = [(v,locs!-v) | Symbol v <- vars] + schedule (map (Just . snd) assocs) exprs + addLocals assocs + return NullVal compileAxiom XBind _ args = case args of [bVars] -> doBind bVars Nothing [bVars,expr] -> do v <- newVar - compile' (Just v) expr *>> doBind bVars (Just v) + compile' (Just v) expr + doBind bVars (Just v) where doBind bVars val = do bnd <- bindFromSyntax bVars - n <- createNode (Instr $ PCode.Bind bnd val) - return (NullVal,singleCode n) + bnd' <- localizeBV bnd + tell [PCode.Bind bnd' val] + return NullVal + localizeBV (BindVar s sz pad subs) = do + s' <- newVar + addLocals [(s,s')] + subs' <- mapM (\(bv,n) -> liftM (,n) (localizeBV bv)) subs + return (BindVar s' sz pad subs') -compileAxiom XDo dest [] = nullCode +compileAxiom XDo dest [] = return NullVal compileAxiom XDo dest forms = do let cs = reverse $ zipWith compile' (dest:repeat Nothing) (reverse forms) - foldr1 (*>>) cs + last $< sequence cs compileAxiom XChoose dest (cond:forms) = do - start <- mkNoop ; end <- mkNoop - alts <- replicateM (length forms) mkNoop v <- maybe newVar return dest - let dest = Just v - - withTopInfo (start,alts,end,dest) $ do - return (NullVal,singleCode start) - *>> compile' Nothing cond - *>>= \cv -> do - let code = zipWith compile' (repeat dest) forms - fun alt code = return (NullVal,singleCode alt) *>> code *>> makeBranch NullVal [end] - sequence_ $ zipWith fun alts code - makeBranch cv alts - - return (SymVal Value v,([start],[end])) + + rec + pushInfo (start,alts,end,dest) + start <- getPos + condVal <- compile' Nothing cond + branch condVal alts + let compileAlt alt = saving locals_ $ getPos ->> (compile' (Just v) alt ?>> goto end) + alts <- mapM compileAlt forms + end <- getPos + popInfo + + return (SymVal Value v) -compileAxiom XReturn dest [arg] = withInfo $ \(_,_,end,dest) -> compile' dest arg *>> makeBranch NullVal [end] +compileAxiom XReturn _ [arg] = withInfo $ \(_,_,end,dest) -> compile' dest arg ?>> goto end -compileAxiom XRestart _ [] = withInfo $ \(start,_,_,_) -> makeBackBranch NullVal [start] +compileAxiom XRestart _ [] = withInfo $ \(start,_,_,_) -> goto start compileAxiom XRestart _ [arg] = withInfo $ \(_,alts,_,_) -> - compile' Nothing arg *>>= \v -> makeBackBranch v alts + compile' Nothing arg ?>>= \v -> branch v alts -compileAxiom XAddr dest [Symbol s] = compileValue dest (SymVal Address s) +compileAxiom XAddr dest [Symbol s] = gets locals >>= compileValue dest . globVal Address s compileAxiom XSize dest [Symbol s] = compileValue dest (SymVal Size s) compileAxiom XID dest [Symbol s] = compileValue dest (SymVal SymID s) compileAxiom XVerb dest [Group (name:args),expr] = do bv@BindVar { bindSym = sym } <- bindFromSyntax name ret <- case bindSubs bv of - [] -> newVar >>= \ret -> return bv { bindSym = ret } + [] -> newVar >§ \ret -> bv { bindSym = ret } (h,_):_ -> return h code <- compileExpr args (Just ret) expr lift $ modify $ exportSymVal sym (Verb code) @@ -124,15 +157,13 @@ args <- mapM bindFromSyntax args code <- lift $ compile args ret expr return code -compileValue dest val = do - c <- singleCode $< case dest of - Just v -> createNode (Instr $ set v val) - Nothing -> mkNoop - return (val,c) +compileValue dest val = (>>return val) $ case dest of + Just v -> tell [set v val] + Nothing -> return () bindFromSyntax (Symbol v) = return $ symBind v bindFromSyntax (Group (Symbol v:t)) = do - let fun (ns,l) (Symbol v) = getSymName v >>= \s -> + let fun (ns,l) (Symbol v) = lookupName v >>= \s -> maybe (fun' ns l (Symbol v)) (\n -> return (n:ns,l)) (readConstant =<< s) fun (ns,l) e = fun' ns l e fun' ns l e = do @@ -145,4 +176,3 @@ (a,b) <+> (a',b') = (a+a',b+b') return $ BindVar v size pad subs bindFromSyntax s = error $ "Invalid shape for bindVar : "++show s - diff --git a/src/Compile/Monad.hs b/src/Compile/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Compile/Monad.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, NoMonomorphismRestriction #-} +module Compile.Monad where + +import My.Control.Monad.State +import My.Control.Monad.WriterAcc +import ID +import PCode.Instruction +import Data.Map + +data CompileState = CS { + infoStack :: [(Int,[Int],Int,Maybe ID)], + locals :: Map ID ID + } +infoStack_ = View (infoStack,\s cs -> cs { infoStack = s }) +locals_ = View (locals,\s cs -> cs { locals = s }) + +newtype CompileT m a = CM { runCM :: StateT CompileState (WriterAccT [Instruction] (Sum Int) m) a } + deriving (Monad,MonadFix,MonadState CompileState,MonadWriter [Instruction]) +instance MonadTrans CompileT where + lift = CM . lift . lift + +getPos = CM (liftM getSum (lift getAcc)) +runCompileT (CM m) locals = runWriterAccT (evalStateT m (CS [] locals)) + +pushInfo = modifying infoStack_ . (:) +popInfo = viewState infoStack_ (\l -> case l of + (h:t) -> (h,t) + [] -> error "Invalid use of Axioms <- or -> outside of a choose expression") +topInfo = getting (infoStack_ >>> f_ head) +withInfo f = popInfo >>= \i -> f i >>= \ret -> pushInfo i >> return ret + diff --git a/src/Compile/State.hs b/src/Compile/State.hs deleted file mode 100644 --- a/src/Compile/State.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE StandaloneDeriving, NoMonomorphismRestriction, ViewPatterns #-} -module Compile.State( - module My.Data.Graph, - CompileState(..),BranchType(..),EdgeData(..),NodeData(..),CaseInfo(..), - depGraph_,infoStack_, - newVar, - pushInfo,popInfo,topInfo,withInfo,withTopInfo, - defaultState, - getSymName,getSymVal, - singleCode, - isBackEdge, - getNodeList,getContext, - createEdge,deleteEdge, - createNode,deleteNode, - nullCode,nullCodeVal, - makeTimeDep,makeBranch,makeBackBranch,mkNoop, - (*>>=),(*>>) - ) - where - -import Control.Category ((>>>)) - -import PCode -import My.Control.Monad.State -import My.Control.Monad -import ID -import My.Data.Graph hiding (deleteEdge,deleteNode,getContext,empty) -import Context as C -import qualified My.Data.Graph as G -import qualified Data.Map as M - -deriving instance Eq Instruction -deriving instance Eq PCode.Value -deriving instance Eq BindVar - -data BranchType = Forward | Backward - deriving (Show,Eq) -data EdgeData = BranchAlt BranchType Int - | TimeDep - deriving (Show,Eq) -data NodeData = Instr Instruction - | BrPart PCode.Value - deriving Eq -type CaseInfo = (Node,[Node],Node,Maybe ID) - -data CompileState = CS { - infoStack :: [CaseInfo], - depGraph :: Graph EdgeData NodeData - } - deriving Show - -depGraph_ = View (depGraph,(\g cs -> cs { depGraph = g })) -infoStack_ = View (infoStack,(\l cs -> cs { infoStack = l })) - -defaultState = CS [] G.empty -singleCode n = ([n],[n]) -isBackEdge (_,BranchAlt Backward _) = True -isBackEdge _ = False - -getSymName = lift . gets . C.lookupSymName -getSymVal s = lift $ getting (vals_ >>> f_ (M.lookup s)) -newVar = lift $ state createSym - -pushInfo = modifying infoStack_ . (:) -popInfo = viewState infoStack_ (\l -> case l of - (h:t) -> (h,t) - [] -> error "Invalid use of Axioms <- or -> outside of a choose expression") -topInfo = getting (infoStack_ >>> f_ head) -withTopInfo i x = pushInfo i >> x >>= \v -> popInfo >> return v -withInfo f = popInfo >>= \i -> f i >>= \ret -> pushInfo i >> return ret - -mkNoop = createNode (Instr Noop) -nullCode = nullCodeVal NullVal -nullCodeVal v = mkNoop >>= \n -> return (v,singleCode n) - -getNodeList = getting (depGraph_ >>> f_ nodeList) -getContext n = getting (depGraph_ >>> f_ (G.getContext n)) - -createNode x = viewState depGraph_ (G.insertNode x) -deleteNode n = modifying depGraph_ (G.deleteNode n) -modifyNode n f = modifying depGraph_ (G.modifyNode n f) -createEdge x n1 n2 = modifying depGraph_ (G.insertEdge x n1 n2) -deleteEdge n1 n2 = modifying depGraph_ (G.deleteEdge n1 n2) - -makeTimeDep a b = do - (v,(_in,_out)) <- a - case _out of - [] -> return (NullVal,(_in,_out)) - _ -> do - (v,(_in',_out')) <- b v - sequence_ [createEdge TimeDep n n' | n <- _out,n' <- _in'] - return (v,(_in,_out')) -(*>>=) = makeTimeDep -a *>> b = a *>>= const b - -infixr 1 *>>= -infixr 1 *>> - -makeBranch = makeBranch' Forward -makeBackBranch = makeBranch' Backward -makeBranch' typ val alts = do - br <- createNode (BrPart val) - let makeAlt n = createEdge (BranchAlt typ n) br - case val of - IntVal (fromIntegral -> i) -> makeAlt 0 (if i+1 sequence_ $ zipWith makeAlt [0..] alts - return (NullVal,([br],[])) - -instance Show NodeData where - show (Instr i) = show i - show (BrPart v) = "case "++show v diff --git a/src/Compile/Utils.hs b/src/Compile/Utils.hs deleted file mode 100644 --- a/src/Compile/Utils.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE TupleSections, ViewPatterns, NoMonomorphismRestriction #-} -module Compile.Utils where - -import Control.Category ((>>>)) -import Compile.State as CS -import Context.Language -import Data.Array -import Data.Function -import Data.Maybe -import qualified Data.Map as M -import qualified Data.Set as S -import My.Control.Monad -import My.Control.Monad.State -import qualified My.Data.Graph as G -import My.Data.List -import My.Data.Tree -import My.Prelude -import PCode -import Syntax -import Translate - -flattenable code = map (f . instr) code' - where f (Branch v alts) = Branch v (map (a!) alts) - f i = i - (bounds,instr,nexts,_) = navigate code - t = spanningTree 0 nexts ; code' = flatten t - a = array bounds (zip code' [0..]) - -uniquify a r [] = uniquify a r [Branch NullVal []] -uniquify args ret code = do - ret <- descendM uniq (M.fromList $ zip syms syms) $ spanningTree 0 nexts - return (flatten ret) - where syms = concatMap bindSyms $ maybe id (:) ret args - (_,instr,nexts,_) = navigate $ flattenable code - uniq (instr -> Bind bv v) m = do - news <- mapM (const $ state createSym) (bindSyms bv) - let m' = foldr (uncurry M.insert) m (zip (bindSyms bv) news) - return (Bind (translate (translateBy m') bv) (fmap (translateBy m) v),m') - uniq i m = return (translate (translateBy m) `on_` fst_ $ withLocals m $ instr i) - localVal m (SymVal t s) | (t==Value || t==Address) && not (M.member s m) = SymVal GValue s - localVal m v = v - translateBy m s = fromMaybe s $ M.lookup s m - withLocals m (Op b v vs) = (Op b v (map (localVal m) vs),M.insertWith (flip const) v v m) - withLocals m (Branch v a) = (Branch (localVal m v) a,m) - withLocals m i = (i,m) - -simplify :: Monad m => [Node] -> StateT CompileState m [Node] -simplify start = do - oldDep <- getting depGraph_ ; purgeAll ; newDep <- getting depGraph_ - return $ concatMap (newStart oldDep newDep) start - where - purgeAll = do - mapM_ (purgeNode isNoop) =<< getNodeList - mapM_ (purgeNode isEmptyBranch) =<< getNodeList - purgeNode p n = do - c <- getContext n - if p c then remove (n,c) else return () - isNoop c = tag c==Instr Noop - isEmptyBranch c = case tag c of - BrPart _ -> not (null o) && all p i && all p' o - _ -> False - where (i,o) = edges c - p (_,BranchAlt _ _) = True ; p _ = False - p' (_,BranchAlt _ 0) = True ; p' _ = False - remove (n',c) = do - let - (lies,loes) = edges c - least Forward Forward = Forward - least _ _ = Backward - mergeEdge (BranchAlt t x) (BranchAlt t' _) = BranchAlt (least t t') x - mergeEdge TimeDep b = b - mergeEdge e t = mergeEdge t e - sequence_ [deleteEdge n n' | (n ,_) <- lies ] - sequence_ [deleteEdge n' n'' | (n'',_) <- loes ] - sequence_ [createEdge (mergeEdge t t') n n'' | (n ,t) <- lies, (n'',t') <- loes ] - deleteNode n' - newStart old new = newStart - where - newStart n = fromJust $ (lookupContext n new >> return [n]) - `mplus` (lookupContext n old >§ \c -> concat [newStart n | (n,_) <- outEdges c]) - `mplus` return [] - -data ANode = ANode { - weight :: Int, - erNum :: Int, - instr :: NodeData - } - deriving Show -linearize start = getting (depGraph_ >>> f_ (linearize' start)) -linearize' start depG = instrs - where - aG = annotate depG - getContext n = G.getContext n aG - withContext n = (n,getContext n) - (<#) = ((<) `on` (weight . tag)) - - isBrPart (instr . tag . getContext -> BrPart _) = True - isBrPart _ = False - instrMap = M.fromList $ zip instrs (sums (map (length . getInstr) instrs)) - where instrs = concat blocks - instrs = concatMap (concatMap getInstr) blocks - - getInstr (getContext -> c) = case tag c of - ANode { instr = BrPart v } -> [Branch v $ map branch (classesBy (===) oes)] - where branch ns = minimum $ catMaybes [M.lookup n instrMap | (n,_) <- ns] - (===) = (==)`on`snd - ANode { instr = Instr i } -> i : if null oes then [Branch NullVal []] else [] - where oes = outEdges c - - selectHeads l = [n | (n,c) <- l, weight (tag c)==1] - startHeads = selectHeads $ map withContext $ nub start - heads = startHeads : deleteBy headsEq startHeads heads - where eq n1 n2 = if n1`elem`start then n2`elem`start else c' - where c' = n2 `elem` [n | (n,e') <- outEdges $ getContext prev, e==e'] - (prev,e) = fromMaybe (error $ "Couldn't find edge of "++show n1++" in graph "++show aG) - $ find isBackEdge $ inEdges $ getContext n1 - headsEq a b = sort a==sort b - heads = classesBy eq $ selectHeads $ nodeListFull aG - tails = map (S.toList . S.unions) $ classesBy share $ map (S.fromList . concatMap saturate) heads - where share s s' = not $ S.null (s `S.intersection` s') - saturate n = if null nexts then [n] else concatMap saturate nexts - where nexts = [n' | let c = getContext n - , (n',c') <- map withContext $ nextNodes c - , c <# c'] - - - blocks = map blockFromTails tails - blockFromTails tails = evalState (concat $< mapM makeBlock tails) S.empty - where - visited n = gets (S.member n) ; visit n = modify (S.insert n) - - makeBlock n = ifM (visited n) (return []) $ do - prevs <- mapM makeBlock (getPrevs n) - visit n - return $ concat prevs ++ [n] - getPrevs n = map fst $ sortBy cmp $ filter p $ map withContext $ prevNodes ctx - where cmp = compare `on` (erNum . tag . snd) - p (_,c) = c <# ctx - ctx = getContext n - -annotate depG = newdepG - where - newdepG = mapNodes depCalc depG - depCalc (depCalc' -> (a,b)) i = ANode a b i - depCalc' (flip G.getContext depG -> c) - | any isBackEdge <||> null $ inEdges c = (1,1) - | otherwise = (1+maximum a, maximum $ zipWith (+) [0..] (reverse $ sort b)) - where (a,b) = unzip [(weight t,erNum t) - | n' <- prevNodes c - , let t = tag $ G.getContext n' newdepG] - - maximum = foldl max 0 - diff --git a/src/ID.hs b/src/ID.hs --- a/src/ID.hs +++ b/src/ID.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module ID where newtype ID = ID Int - deriving (Ord,Eq) + deriving (Ord,Eq,Enum,Num) newtype Range a = Range (a,a) singleRange i = Range (i,i) @@ -14,17 +15,6 @@ | b'<=a = GT | otherwise = EQ -instance Enum ID where - toEnum = ID - fromEnum (ID i) = i instance Show ID where show (ID i) = "x"++show i -instance Num ID where - ID a + ID b = ID (a+b) - ID a - ID b = ID (a-b) - ID a * ID b = ID (a*b) - negate = undefined - abs = undefined - signum = undefined - fromInteger n = ID $ fromInteger n diff --git a/src/My/Control/Monad.hs b/src/My/Control/Monad.hs --- a/src/My/Control/Monad.hs +++ b/src/My/Control/Monad.hs @@ -2,6 +2,7 @@ module My.Control.Monad (module Control.Monad ,($<),(>$),(>$<) ,(§),(§<),(>§),(>§<) + ,(->>) ,(<&&>),(<||>) ,ifM,findM,prog1 ,doNothing) where @@ -32,6 +33,7 @@ infixr 3 <||> prog1 a b = a >>= \x -> b >> return x +(->>) = prog1 findM p l = foldr fun (return Nothing) l where fun x ret = ifM (p x) (return $ Just x) ret diff --git a/src/My/Control/Monad/State.hs b/src/My/Control/Monad/State.hs --- a/src/My/Control/Monad/State.hs +++ b/src/My/Control/Monad/State.hs @@ -1,10 +1,14 @@ {-# LANGUAGE TupleSections, NoMonomorphismRestriction #-} module My.Control.Monad.State(module Control.Monad.State ,View(..) - ,viewState,viewing,modifying,getting,putting + ,viewState + ,viewing,modifying,getting,putting + ,swappingWith,swapping + ,saving ,fst_,snd_,id_,f_,on_ - ,withState) where + ,(>>>),(<<<)) where +import My.Control.Monad import Prelude hiding ((.),id) import Control.Monad.State hiding (withState) import Control.Category @@ -27,5 +31,9 @@ f `on_` View (v,v') = \x -> v' (f (v x)) x -withState s mx = get >>= \v -> put s >> mx >>= \x -> put v >> return x +saving v m = getting v >>= \x -> m ->> putting v x + +swappingWith v f m = saving v (modifying v f >> m) +swapping v s = swappingWith v (const s) + diff --git a/src/My/Data/Graph.hs b/src/My/Data/Graph.hs deleted file mode 100644 --- a/src/My/Data/Graph.hs +++ /dev/null @@ -1,73 +0,0 @@ -module My.Data.Graph( - Graph,Node(..), - - empty, - lookupContext,getContext, - insertNode,deleteNode,modifyNode, - insertEdge,deleteEdge, - - modifyInEdges,modifyOutEdges, - tag,inEdges,outEdges,edges, - nextNodes,prevNodes, - - nodeList,nodeListFull, - - mapNodes - ) - where - -import qualified Data.Map as M -import Data.List -import Data.Maybe - -type Node = Int -data Context e n = Context { - nodeTag :: n, - nodeInEdges :: M.Map Node e, - nodeOutEdges :: M.Map Node e - } deriving Show -data Graph e n = Graph { - nbNodes :: Int, - graphNodes :: M.Map Node (Context e n) - } - -empty = Graph 0 M.empty - -lookupContext n (Graph _ nds) = M.lookup n nds -getContext n g = fromMaybe (error $ "No node "++show n++" in graph "++show g) $ lookupContext n g - -insertNode x (Graph n nds) = (n,Graph (n+1) (M.insert n (Context x M.empty M.empty) nds)) -deleteNode nd (Graph n nds) = Graph n (M.delete nd nds) -modifyNode nd f (Graph n nds) = Graph n (M.adjust (\(Context t i o) -> Context (f t) i o) nd nds) - -insertEdge x n1 n2 (Graph n nds) = Graph n (M.adjust (modifyInEdges (M.insert n1 x)) n2 $ - M.adjust (modifyOutEdges (M.insert n2 x)) n1 nds) -deleteEdge n1 n2 (Graph n nds) = Graph n (M.adjust (modifyInEdges (M.delete n1)) n2 $ - M.adjust (modifyOutEdges (M.delete n2)) n1 nds) - -modifyInEdges f c = c { nodeInEdges = f $ nodeInEdges c } -modifyOutEdges f c = c { nodeOutEdges = f $ nodeOutEdges c } - -tag = nodeTag -inEdges = M.toList . nodeInEdges -outEdges = M.toList . nodeOutEdges -edges c = (inEdges c,outEdges c) - -nextNodes = map fst . outEdges -prevNodes = map fst . inEdges - -nodeList = map fst . nodeListFull -nodeListFull = M.toList . graphNodes - -mapNodes f (Graph n nds) = Graph n (M.mapWithKey (\n (Context t ie oe) -> Context (f n t) ie oe) nds) - -instance (Show n,Show e) => Show (Graph e n) where - show (Graph _ nds) = intercalate "\n" showNodes - where showNodes = map showNode $ M.toList nds - showNode (n,Context nd ie oe) = - show n++": "++show nd++"\n "++ - intercalate "\n " (map showNEdge (M.toList oe) - ++ map showREdge (M.toList ie)) - where showNEdge (n',e) = "--"++show e++"--> "++show n' - showREdge (n',e) = "<--"++show e++"-- "++show n' - diff --git a/src/Specialize/X86_64.hs b/src/Specialize/X86_64.hs --- a/src/Specialize/X86_64.hs +++ b/src/Specialize/X86_64.hs @@ -52,8 +52,9 @@ varSize s = fromMaybe defSize (M.lookup s $ sizes ?info) argSize = maybe defSize varSize . valSym verbAddress = let (me,addrs) = envInfo ?info in addrs me -instrAddress i = let (_,addrs) = branchPos ?info ; (e,s,_) = addrs i in (e,s) -instrPast i = let (_,addrs) = branchPos ?info ; (_,_,p) = addrs i in p +instrInfo = snd (branchPos ?info) +instrAddress i = let (e,s,_) = instrInfo i in (e,s) +instrPast i = let (_,_,p) = instrInfo i in p thisInstr = fst $ branchPos ?info frameAddr s = viewState frame_ (withAddr defSize s) @@ -196,8 +197,9 @@ compile i = ask >>= \info -> do let ?info = info (_,BC (e',s',_)) <- listen (storeFlags (branchSym i)) - let ?info = info { branchPos = (thisInstr, - \i -> let (e,s,p) = snd (branchPos ?info) i in (e+e',s+s',p)) } + let getPast i | i==thisInstr = let (e,s,p) = instrInfo i in (e+e',s+s',p) + | otherwise = instrInfo i + let ?info = info { branchPos = (thisInstr,getPast) } compile' i modifying locations_ (R.filterDom isActive) where branchSym (Branch (SymVal Value s) _) = Just s