From 0d0feb172bebd181a9b1f993e5ce3e168abde966 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sun, 24 Mar 2019 04:03:47 -0400 Subject: Use dynCall when calling FunPtr types. --- monkeypatch.hs | 87 +++++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 62 insertions(+), 25 deletions(-) diff --git a/monkeypatch.hs b/monkeypatch.hs index 8e2dcf8..14359fe 100644 --- a/monkeypatch.hs +++ b/monkeypatch.hs @@ -199,6 +199,15 @@ data FormalLambda = FormalLambda { formGo :: String , formExp :: HS.Exp () } +modifyFormal :: (HS.Exp () -> HS.Exp ()) + -> FormalLambda -> FormalLambda +modifyFormal f (FormalLambda s x) = FormalLambda s (f x) + +-- modifyLambda f (Lambda l p x) = Lambda l p (f x) + +modifyOperand1 :: (HS.Exp l -> HS.Exp l) -> HS.Exp l -> HS.Exp l +modifyOperand1 f (InfixApp l x op y) = InfixApp l (f x) op y + informalize :: FormalLambda -> HS.Exp () informalize (FormalLambda k x) = Lambda () [hspvar k] x @@ -384,21 +393,7 @@ grokExpression fe (CComma exps _) = do s' = fmap (\x -> FormalLambda k (infixOp (parn x) ">>=" (Lambda () [hspvar hv] (hsvar k)))) s -- TODO: It would be cleaner if I could return only a statement and not an expression. return $ (,) [s'] (mkcomp $ hsvar hv) { compFree = Map.singleton hv () } -grokExpression fe (C.CCall (CVar fn _) exps _) = do - gs <- mapM (grokExpression fe) exps - let ss = concatMap fst gs -- TODO: resolve variable name conflicts - hv = "r" ++ identToString fn - -- cll = foldl (App ()) (hsvar (identToString fn)) $ map (comp . snd) gs - -- frees = foldr Map.union (Map.singleton (identToString fn) ()) (map (compFree . snd) gs) - fn' = identToString fn - cll = foldl (\f x -> App () <$> f <*> x) (mkcomp $ hsvar fn'){compFree = Map.singleton fn' ()} (map snd gs) - k = uniqIdentifier "go" (compFree s) - s = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (hsvar k)) cll) - { compIntro = Map.singleton hv () - } - return $ (,) (ss++[s]) (mkcomp $ hsvar hv) - { compFree = Map.singleton hv () - } +grokExpression fe (C.CCall fn exps u) = grokCall fe True (C.CCall fn exps u) grokExpression fe (CStatExpr (CCompound idents xs _) _) = do let (y,ys) = splitAt 1 (reverse xs) y' <- case y of @@ -445,6 +440,51 @@ grokExpression fe (CMember cvar fld isptr _) = do return $ (,) [s] (mkcomp $ hsvar hv){ compFree = Map.singleton hv () } grokExpression fe _ = Nothing +grokCall :: FunctionEnvironment + -> Bool + -> CExpression a + -> Maybe ([Computation FormalLambda], Computation (HS.Exp ())) +grokCall fe wantsRet (C.CCall (CVar fn _) exps _) = do + gs <- mapM (grokExpression fe) exps + let ss = concatMap fst gs -- TODO: resolve variable name conflicts + hv = "r" ++ identToString fn + -- cll = foldl (App ()) (hsvar (identToString fn)) $ map (comp . snd) gs + -- frees = foldr Map.union (Map.singleton (identToString fn) ()) (map (compFree . snd) gs) + fn' = identToString fn + cll = foldl (\f x -> App () <$> f <*> x) (mkcomp $ hsvar fn'){compFree = Map.singleton fn' ()} (map snd gs) + k = uniqIdentifier "go" (compFree s) + s | wantsRet = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (hsvar k)) cll) + { compIntro = Map.singleton hv () + } + | otherwise = fmap (\c -> FormalLambda k $ infixOp c ">>" (hsvar k)) cll + return $ (,) (ss++[s]) (mkcomp $ hsvar hv) + { compFree = Map.singleton hv () + } +grokCall fe wantsRet (C.CCall fnx@(CMember cvar fld isptr _) exps _) = do + -- We're calling a FunPtr so a "dynamic" import will need to be declared. + -- We'll assume that a dynCall type class method points to it. + -- fun <- dynCall <$> get @fld cvar + -- fun arg1 arg2 ... + (fss,fn) <- grokExpression fe fnx + let getfn = case reverse fss of + fnst:fs -> reverse $ (modifyFormal (modifyOperand1 $ infixOp (hsvar "callDyn") "<$>") <$> fnst) : fs + [] -> [] + gs <- mapM (grokExpression fe) exps + let ss = getfn ++ concatMap fst gs -- TODO: resolve variable name conflicts + hv = "r" ++ fn' + -- cll = foldl (App ()) (hsvar (identToString fn)) $ map (comp . snd) gs + -- frees = foldr Map.union (Map.singleton (identToString fn) ()) (map (compFree . snd) gs) + fn' = concat (Map.keys $ compFree fn) + cll = foldl (\f x -> App () <$> f <*> x) fn (map snd gs) + k = uniqIdentifier "go" (compFree s) + s | wantsRet = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (hsvar k)) cll) + { compIntro = Map.singleton hv () + } + | otherwise = fmap (\c -> FormalLambda k $ infixOp c ">>" (hsvar k)) cll + return $ (,) (ss++[s]) (mkcomp $ hsvar hv) + { compFree = Map.singleton hv () + } +grokCall _ _ _ = Nothing grokInitialization :: Foldable t1 => @@ -515,6 +555,7 @@ promote fe y@(Lit () (Int () n _)) | (n==0 || n==1) && hasBool (fe Map.! "") = 1 -> "True" promote _ y = y + grokStatement :: FunctionEnvironment -> CCompoundBlockItem a -> Maybe (Computation FormalLambda) grokStatement fe (CBlockStmt (CReturn (Just exp) _)) = do (xs,x) <- grokExpression fe exp @@ -573,18 +614,13 @@ grokStatement fe (CBlockStmt (CExpr (Just fieldinit) ">>" (hsvar k1) } return $ fmap (FormalLambda k1) $ foldr applyComputation x' xs -grokStatement fe (CBlockStmt (CExpr (Just - (C.CCall cvarfun exps _)) _)) = do +grokStatement fe (CBlockStmt (CExpr (Just (C.CCall cvarfun exps a)) _)) = do -- This case is technically not needed, but it makes slightly cleaner output -- by avoiding a bind operation. - fn <- cvarName cvarfun - gs <- mapM (grokExpression fe) exps - let k = uniqIdentifier "go" (compFree s1) - cll = foldl (\f x -> App () <$> f <*> x) (mkcomp $ hsvar fn){compFree = Map.singleton fn ()} $ map snd gs - s1 = fmap (`infixOp` ">>") cll - s = s1 <*> mkcomp (hsvar k) - x = foldr applyComputation s $ concatMap fst gs - return $ fmap (FormalLambda k) x + (ss,_) <- grokCall fe False (C.CCall cvarfun exps a) + let k = uniqIdentifier "go" (compFree r `Map.union` compIntro r) + r = FormalLambda k <$> foldr applyComputation (mkcomp $ hsvar k) ss + return r grokStatement fe (CBlockStmt (CExpr (Just (CAssign CAssignOp cvarnew (C.CCall cvarfun [] _) _)) _)) = do @@ -615,6 +651,7 @@ grokStatement fe (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 (hsvar "succ")) ">>" (hsvar k1) } grokStatement fe (CBlockStmt (CExpr mexpr _)) = do + -- trace ("CExpr statement: " ++ take 50 (show $ fmap (fmap $ const ()) mexpr)) $ return () (ss,pre) <- maybe (Just $ (,) [] $ mkcomp id) (let -- Discard pure value since we are interested only in side-effects. discard = const $ mkcomp id -- cgit v1.2.3