From 56b8d9316dcb37aedf5a7727f05b6cd81f9f0f19 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sat, 23 Mar 2019 01:11:05 -0400 Subject: Binary ops and global pointer refs. --- monkeypatch.hs | 132 ++++++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 117 insertions(+), 15 deletions(-) diff --git a/monkeypatch.hs b/monkeypatch.hs index bc55425..352a0f5 100644 --- a/monkeypatch.hs +++ b/monkeypatch.hs @@ -7,9 +7,12 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where +import Debug.Trace import Control.Arrow (left,first,second) +import Data.Bool import Data.Either import Data.Generics.Aliases import Data.Generics.Schemes @@ -52,8 +55,10 @@ import Text.Show.Pretty import Sweeten import GrepNested +{- trace :: p -> a -> a trace _ = id +-} -- | Pretty print the given tranlation unit, but replace declarations from header files with @#include@ directives. -- @@ -197,16 +202,105 @@ varmap vs = Map.fromList $ map (,()) vs -} + +renameIntros :: forall v st. (Typeable st, Data st) => + [Computation (HS.Exp st)] + -> Computation (HS.Exp st) + -> Map String v + -> ([Computation (HS.Exp st)], Computation (HS.Exp st)) +renameIntros bs cb vs = (bs',cb') + where + (rs,bs') = unzip $ map go bs + + cb' = foldr rename2 cb $ concat rs + + rename2 (x,v) c = + let subst p@(Var la (UnQual lc (HS.Ident lb s))) + | s==x = Var (la::st) (UnQual lc (HS.Ident lb v)) + subst p = p + in c { comp = everywhere (mkT subst) (comp c) } + + go c = + let xs = Map.keys (compIntro c) + in foldr rename1 ([],c) xs + + rename1 x (rs,c) = + let v = uniqIdentifier x vs + subst p@(PVar la (HS.Ident lb s)) + | s==x = PVar (la::st) (HS.Ident lb v) + subst p = p + in if x/=v then (,) ((x,v):rs) c { compIntro = Map.insert v () $ Map.delete x (compIntro c) + , comp = everywhere (mkT subst) (comp c) + } + else (rs,c) + +transpileBinOp :: CBinaryOp -> [Char] +transpileBinOp = \case + CMulOp -> "*" + CDivOp -> "/" + CRmdOp -> "rem" + CAddOp -> "+" + CSubOp -> "-" + CShlOp -> "shiftL" + CShrOp -> "shiftR" + CLeOp -> "<" + CGrOp -> ">" + CLeqOp -> "<=" + CGeqOp -> ">=" + CEqOp -> "==" + CNeqOp -> "/=" + CAndOp -> ".&." + CXorOp -> "xor" + COrOp -> ".|." + CLndOp -> "and" + CLorOp -> "or" + +-- This function decides whether to treat an identifier as a constant or as a +-- pointer that must be peeked. +isGlobalRef :: FunctionEnvironment -> String -> Bool +isGlobalRef fe sym = fromMaybe False $ do + SymbolInformation{symbolSource = xs} <- Map.lookup sym (fnExternals fe) + forM_ xs $ \x -> do + -- Pattern fail for functions and pointers. + forM_ (sigf (\_ ds -> ds) x) $ \d -> do + CDeclr _ xs _ _ _ <- Just d + let func = filter (\case + CFunDeclr _ _ _ -> True + _ -> False) xs + guard $ null func -- Functions are not pointerized. + -- trace (sym ++ ": " ++ show xs) $ return () + -- ring: [CPtrDeclr [] (NodeInfo ("fetchers/about.c": line 64) (("fetchers/about.c": line 64),4) (Name {nameId = 14030}))] + return () + return True + -- Returns a list of statements bringing variables into scope and an -- expression. grokExpression :: FunctionEnvironment -> CExpression a -> Maybe ([Computation (HS.Exp ())], Computation (HS.Exp ())) -grokExpression fe (CVar cv _) = Just $ (,) [] $ Computation - { compFree = Map.singleton (identToString cv) () - , compIntro = Map.empty - , comp = hsvar (identToString cv) - } +grokExpression fe (CVar cv _) = + let v = identToString cv + in Just $ + if isGlobalRef fe v + then let k = uniqIdentifier "go" (varmap [v,hv]) + s = Computation + { compFree = Map.singleton v () + , compIntro = Map.singleton hv () + , comp = Lambda () [hspvar k] + $ infixOp (App () (hsvar "peek") (hsvar v)) ">>=" + $ Lambda () [hspvar hv] (hsvar k) + } + hv = "v" ++ v + in (,) [s] Computation + { compFree = Map.singleton hv () + , compIntro = Map.empty + , comp = hsvar hv + } + else (,) [] $ Computation + { compFree = Map.singleton (identToString cv) () + , compIntro = Map.empty + , comp = hsvar v + } grokExpression fe (CConst (CIntConst n _)) = Just $ (,) [] $ Computation { compFree = Map.empty , compIntro = Map.empty @@ -217,14 +311,20 @@ grokExpression fe (CConst (CStrConst s _)) = Just $ (,) [] $ Computation , compIntro = Map.empty , comp = Lit () (HS.String () (getCString s) (getCString s)) } -grokExpression fe (CBinary CNeqOp a b _) = do +grokExpression fe (CBinary op a b _) = do (as,ca) <- grokExpression fe a - (bs,cb) <- grokExpression fe b - let ss = as ++ bs -- TODO: resolve variable name conflicts + (bs0,cb0) <- grokExpression fe b + let (bs,cb) = renameIntros bs0 cb0 (foldr Map.union Map.empty $ map compIntro as) + ss = as ++ bs + hop = transpileBinOp op + infx | isLower (head hop) = infixFn + | otherwise = infixOp + -- trace ("intros("++hop++"): "++show (foldr Map.union Map.empty $ map compIntro as)) $ return () + -- TODO: Short-circuit boolean evaluation side-effects. return $ (,) ss $ Computation { compFree = compFree ca `Map.union` compFree cb , compIntro = Map.empty - , comp = infixOp (comp ca) "/=" (comp cb) + , comp = infx (comp ca) hop (comp cb) } grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do let cv = identToString cv0 @@ -573,6 +673,8 @@ insertComment c stmts = everywhere (mkT go) stmts mixComments :: [StyledComment] -> [CCompoundBlockItem NodeInfo] -> [CCompoundBlockItem NodeInfo] mixComments cs stmts = foldr insertComment stmts cs +applyDoSyntax' :: Data l => + C2HaskellOptions -> HS.Exp l -> HS.Exp l applyDoSyntax' C2HaskellOptions{oSuppressDo=True} x = x applyDoSyntax' _ x = applyDoSyntax x @@ -763,7 +865,7 @@ hsTypeSpec (CTypeSpec (CIntType _)) = [ R hsTypeSpec (CTypeSpec (CCharType _)) = [ Right "Char"] hsTypeSpec (CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)) = maybeToList $ fmap Left mctyp -hsTypeSpec (CTypeSpec unhandled) = trace ("hsTypeSpec unhandled: "++ show (const () <$> unhandled)) $ [] +hsTypeSpec (CTypeSpec unhandled) = [] -- trace ("hsTypeSpec unhandled: "++ show (const () <$> unhandled)) $ [] hsTypeSpec _ = [] @@ -786,15 +888,15 @@ hsTransField ctyps vars (mcname,typname) <- second hsMkName . either ((\s -> (Just s,capitalize s)) . identToString) (Nothing,) <$> (hsTypeSpec =<< ctyps) - trace ("typname="++show typname) $ return () + -- trace ("typname="++show typname) $ return () -- (var,Nothing,Nothing) <- vars var <- vars - trace ("var="++show var) $ return () + -- trace ("var="++show var) $ return () -- CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var let CDeclr mfident ptrdeclr Nothing ignored_attrs _ = var -- TODO: Look into: Irrefutable pattern failed (ctox/toxcore/DHT.c) -- let CDeclr mfident ptrdeclr _ _ _ = var - trace ("fident="++show mfident) $ return () - trace ("ptrdeclr="++show ptrdeclr) $ return () + -- trace ("fident="++show mfident) $ return () + -- trace ("ptrdeclr="++show ptrdeclr) $ return () let btyp = HS.TyCon () typname grok :: Show a => [CDerivedDeclarator a] -> HS.Type () -> HS.Type () grok bs b = case bs of @@ -1306,7 +1408,7 @@ getArgList_ (CFDefExt (CFunDef xs ys zs c d)) = getArgList1 ys getArgList_ (CDeclExt (CDecl xs ys pos)) = getArgList2 ys getArgList :: CExternalDeclaration a -> [CDerivedDeclarator a] -getArgList x = let v=getArgList_ x in trace ("getArgList ("++show (u x)++") = "++show (fmap u v)) v +getArgList x = let v=getArgList_ x in {- trace ("getArgList ("++show (u x)++") = "++show (fmap u v)) -} v where u :: Functor f => f a -> f () u = fmap (const ()) -- cgit v1.2.3