From 99dfcb5d8d426c81488da9ae2c29da8a0e92733f Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Fri, 22 Mar 2019 02:57:08 -0400 Subject: Propagate function environment throughout transpiling. --- monkeypatch.hs | 103 ++++++++++++++++++++++++++++----------------------------- 1 file changed, 51 insertions(+), 52 deletions(-) diff --git a/monkeypatch.hs b/monkeypatch.hs index 8ed6ada..f12552e 100644 --- a/monkeypatch.hs +++ b/monkeypatch.hs @@ -198,35 +198,34 @@ varmap vs = Map.fromList $ map (,()) vs -- Returns a list of statements bringing variables into scope and an -- expression. --- --- TODO: FunctionEnvironment argument. -grokExpression :: CExpression a +grokExpression :: FunctionEnvironment + -> CExpression a -> Maybe ([Computation (HS.Exp ())], Computation (HS.Exp ())) -grokExpression (CVar cv _) = Just $ (,) [] $ Computation +grokExpression fe (CVar cv _) = Just $ (,) [] $ Computation { compFree = Map.singleton (identToString cv) () , compIntro = Map.empty , comp = hsvar (identToString cv) } -grokExpression (CConst (CIntConst n _)) = Just $ (,) [] $ Computation +grokExpression fe (CConst (CIntConst n _)) = Just $ (,) [] $ Computation { compFree = Map.empty , compIntro = Map.empty , comp = Lit () (Int () (getCInteger n) (show n)) } -grokExpression (CConst (CStrConst s _)) = Just $ (,) [] $ Computation +grokExpression fe (CConst (CStrConst s _)) = Just $ (,) [] $ Computation { compFree = Map.empty , compIntro = Map.empty , comp = Lit () (HS.String () (getCString s) (getCString s)) } -grokExpression (CBinary CNeqOp a b _) = do - (as,ca) <- grokExpression a - (bs,cb) <- grokExpression b +grokExpression fe (CBinary CNeqOp a b _) = do + (as,ca) <- grokExpression fe a + (bs,cb) <- grokExpression fe b let ss = as ++ bs -- TODO: resolve variable name conflicts return $ (,) ss $ Computation { compFree = compFree ca `Map.union` compFree cb , compIntro = Map.empty , comp = infixOp (comp ca) "/=" (comp cb) } -grokExpression (CUnary CAdrOp (CVar cv0 _) _) = do +grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do let cv = identToString cv0 hv = "p" ++ cv k = uniqIdentifier "go" (Map.empty {-todo-}) @@ -243,20 +242,20 @@ grokExpression (CUnary CAdrOp (CVar cv0 _) _) = do , compIntro = Map.empty , comp = hsvar hv } -grokExpression (CCond cond (Just thn) els _) = do - (cs,c) <- grokExpression cond - (ts,t) <- grokExpression thn - (es,e) <- grokExpression els +grokExpression fe (CCond cond (Just thn) els _) = do + (cs,c) <- grokExpression fe cond + (ts,t) <- grokExpression fe thn + (es,e) <- grokExpression fe els let tt = foldr applyComputation t ts ee = foldr applyComputation e es return $ (,) cs $ fmap (\cnd -> If () cnd (comp tt) (comp ee)) c { compFree = compFree ee `Map.union` compFree tt `Map.union` compFree c } -grokExpression (CSizeofExpr expr _) = do - (xs,x) <- grokExpression expr +grokExpression fe (CSizeofExpr expr _) = do + (xs,x) <- grokExpression fe expr return $ (,) xs $ fmap (App () (hsvar "sizeOf")) x -grokExpression (CCast (CDecl [CTypeSpec (CVoidType _)] [] _) expr _) = grokExpression expr -grokExpression (CCast (CDecl [ CTypeSpec (CVoidType _) ] +grokExpression fe (CCast (CDecl [CTypeSpec (CVoidType _)] [] _) expr _) = (grokExpression fe) expr +grokExpression fe (CCast (CDecl [ CTypeSpec (CVoidType _) ] [ ( Just (CDeclr Nothing [ CPtrDeclr [] _ ] Nothing [] _) , Nothing , Nothing) ] _) (CConst (CIntConst zero _)) _) | 0 <- getCInteger zero = do @@ -265,8 +264,8 @@ grokExpression (CCast (CDecl [ CTypeSpec (CVoidType _) ] , compIntro = Map.empty , comp = hsvar "nullPtr" } -grokExpression (CComma exps _) = do - gs <- mapM grokExpression exps +grokExpression fe (CComma exps _) = do + gs <- mapM (grokExpression fe) exps let ss = concatMap fst gs -- TODO: resolve variable name conflicts cll = foldr1 (\x y -> infixFn x "seq" y) $ map (comp . snd) gs frees = foldr1 Map.union (map (compFree . snd) gs) @@ -276,8 +275,8 @@ grokExpression (CComma exps _) = do , compIntro = Map.empty , comp = cll } -grokExpression (C.CCall (CVar fn _) exps _) = do - gs <- mapM grokExpression exps +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 @@ -295,12 +294,12 @@ grokExpression (C.CCall (CVar fn _) exps _) = do , compIntro = Map.empty , comp = hsvar hv } -grokExpression (CStatExpr (CCompound idents xs _) _) = do +grokExpression fe (CStatExpr (CCompound idents xs _) _) = do let (y,ys) = splitAt 1 (reverse xs) y' <- case y of [CBlockStmt (CExpr mexp ni)] -> Just $ CBlockStmt (CReturn mexp ni) _ -> Just (head y) -- Nothing FIXME - gs <- mapM grokStatement (reverse $ y' : ys) + gs <- mapM (grokStatement fe) (reverse $ y' : ys) let s0 = foldr applyComputation (Computation Map.empty Map.empty (App () (hsvar "return") hsopUnit)) gs s1 = fmap (\xp -> Paren () xp) s0 hv = uniqIdentifier "ret" (compFree s1) @@ -317,23 +316,24 @@ grokExpression (CStatExpr (CCompound idents xs _) _) = do , compIntro = Map.empty , comp = hsvar hv } -grokExpression _ = Nothing +grokExpression fe _ = Nothing grokInitialization :: Foldable t1 => - t1 (CDeclarationSpecifier t2) + FunctionEnvironment + -> t1 (CDeclarationSpecifier t2) -> (Maybe (CDeclarator a1), CInitializer a2) -> Maybe (Computation (HS.Exp ())) -grokInitialization _ (Just (CDeclr (Just cv0) _ _ _ _),CInitExpr exp _) = do +grokInitialization fe _ (Just (CDeclr (Just cv0) _ _ _ _),CInitExpr exp _) = do let v = identToString cv0 - (xs,x) <- grokExpression exp + (xs,x) <- grokExpression fe exp let hsexp = fmap (App () (hsvar "return")) x -- Paren () ( ret = flip (foldr applyComputation) xs $ fmap (\exp -> infixOp exp ">>=" $ Lambda () [hspvar v] (hsvar k)) hsexp k = uniqIdentifier "go" (compFree ret) return $ fmap (\exp -> Lambda () [hspvar k] exp) ret -grokInitialization ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do +grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do let v = identToString cv0 -- let k = uniqIdentifier "go" (varmap [v]) case lefts $ concatMap hsTypeSpec ts of @@ -343,7 +343,7 @@ grokInitialization ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do gs <- do forM exps $ \(ms,initexpr) -> do case initexpr of - CInitExpr ie _ -> grokExpression ie >>= \g -> return (ms,g) + CInitExpr ie _ -> (grokExpression fe) ie >>= \g -> return (ms,g) _ -> Nothing let assigns = do (ms,(ss,x)) <- gs @@ -374,17 +374,16 @@ grokInitialization ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) $ newstruct : assigns return $ fmap (\exp -> Lambda () [hspvar k] exp) ret _ -> Nothing -grokInitialization _ _ = Nothing +grokInitialization _ _ _ = Nothing --- TODO: FunctionEnvironment argument. -grokStatement :: CCompoundBlockItem a -> Maybe (Computation (HS.Exp ())) -grokStatement (CBlockStmt (CReturn (Just exp) _)) = do - (xs,x) <- grokExpression exp +grokStatement :: FunctionEnvironment -> CCompoundBlockItem a -> Maybe (Computation (HS.Exp ())) +grokStatement fe (CBlockStmt (CReturn (Just exp) _)) = do + (xs,x) <- grokExpression fe exp let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x) x' = fmap (\y -> App () (hsvar "return") y) x return $ fmap (\y -> Lambda () [hspvar k] y) $ foldr applyComputation x' xs -grokStatement (CBlockStmt (CExpr (Just (C.CCall (CVar (C.Ident "__assert_fail" _ _) _) xs _)) _)) = do +grokStatement fe (CBlockStmt (CExpr (Just (C.CCall (CVar (C.Ident "__assert_fail" _ _) _) xs _)) _)) = do x <- case xs of (CConst (CStrConst msg _):_) -> let s = getCString msg in Just $ Computation Map.empty Map.empty (Lit () (HS.String () s s)) @@ -392,10 +391,10 @@ grokStatement (CBlockStmt (CExpr (Just (C.CCall (CVar (C.Ident "__assert_fail" _ let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x) x' = fmap (\y -> App () (hsvar "error") y) x return $ fmap (\y -> Lambda () [hspvar k] y) x' -grokStatement (CBlockStmt (CExpr (Just +grokStatement fe (CBlockStmt (CExpr (Just (CAssign CAssignOp (CMember cvar fld isptr _) expr _)) _)) = do - (xs,x) <- grokExpression expr + (xs,x) <- grokExpression fe expr v <- cvarName cvar let fieldlbl = identToString fld k1 = uniqIdentifier "go" (compFree x) @@ -408,10 +407,10 @@ grokStatement (CBlockStmt (CExpr (Just fieldinit) ">>" (hsvar k1) } return $ fmap (\y -> Lambda () [hspvar k1] y) $ foldr applyComputation x' xs -grokStatement (CBlockStmt (CExpr (Just +grokStatement fe (CBlockStmt (CExpr (Just (C.CCall cvarfun exps _)) _)) = do fn <- cvarName cvarfun - gs <- mapM grokExpression exps + gs <- mapM (grokExpression fe) exps let k = uniqIdentifier "go" frees cll = foldl (App ()) (hsvar fn) $ map (comp . snd) gs frees = foldr Map.union (Map.singleton fn ()) (map (compFree . snd) gs) @@ -422,7 +421,7 @@ grokStatement (CBlockStmt (CExpr (Just , comp = infixOp cll ">>" (hsvar k) } return $ fmap (Lambda () [hspvar k]) x -grokStatement (CBlockStmt (CExpr (Just +grokStatement fe (CBlockStmt (CExpr (Just (CAssign CAssignOp cvarnew (C.CCall cvarfun [] _) _)) _)) = do v <- cvarName cvarnew @@ -435,8 +434,8 @@ grokStatement (CBlockStmt (CExpr (Just $ infixOp (hsvar fn) ">>=" $ Lambda () [hspvar v] (hsvar k) } -grokStatement (CBlockStmt (CIf exp thn els _)) = do - (xs,x) <- grokExpression exp +grokStatement fe (CBlockStmt (CIf exp thn els _)) = do + (xs,x) <- grokExpression fe exp let mkif0 = If () (comp x) (mkif,stmts) <- case (thn,els) of @@ -451,7 +450,7 @@ grokStatement (CBlockStmt (CIf exp thn els _)) = do _ -> Nothing -- TODO - ss <- sequence $ map grokStatement stmts + ss <- sequence $ map (grokStatement fe) stmts let s = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) ss k = uniqIdentifier "go" (Map.union (compFree x) (compFree s)) return $ flip (foldr applyComputation) xs Computation @@ -459,7 +458,7 @@ grokStatement (CBlockStmt (CIf exp thn els _)) = do , compIntro = compIntro s , comp = Lambda () [hspvar k] $ mkif (comp s) (hsvar k) } -grokStatement (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 _) fld True _) _)) _)) = do +grokStatement fe (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 _) fld True _) _)) _)) = do let k1 = uniqIdentifier "go" (varmap [fieldlbl,v]) fieldlbl = identToString fld v = identToString cv0 @@ -473,13 +472,13 @@ grokStatement (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 _) (hsvar v)) (hsvar "succ")) ">>" (hsvar k1) } -grokStatement (CBlockStmt (CExpr mexpr _)) = do +grokStatement fe (CBlockStmt (CExpr mexpr _)) = do (ss,pre) <- maybe (Just $ (,) [] $ Computation Map.empty Map.empty id) - (fmap (second (fmap (\e -> infixFn e "seq"))) . grokExpression) mexpr + (fmap (second (fmap (\e -> infixFn e "seq"))) . grokExpression fe) mexpr let k = uniqIdentifier "go" (compFree s) s = foldr applyComputation (fmap ($ hsvar k) pre) ss return $ fmap (Lambda () [hspvar k]) s -grokStatement (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do +grokStatement fe (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CDeclr i _ initial _ _) -> initial) (v:vs) of -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CInitList xs _) -> Just xs) (v:vs) of case mapMaybe (\(i,inits,_) -> fmap ((,) i) inits) (v:vs) of @@ -490,10 +489,10 @@ grokStatement (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do , comp = Lambda () [hspvar "go"] $ hsvar "go" } initials -> do - gs <- mapM (grokInitialization $ t:ts) initials + gs <- mapM (grokInitialization fe $ t:ts) initials return $ fmap (\exp -> Lambda () [hspvar "go"] exp) $ foldr applyComputation (Computation Map.empty Map.empty (hsvar "go")) gs -grokStatement _ = Nothing +grokStatement fe _ = Nothing isFunctionDecl :: CExternalDeclaration a -> Bool isFunctionDecl (CDeclExt (CDecl _ [(Just (CDeclr _ [CFunDeclr _ _ _] _ _ _),_,_)] _)) = True @@ -614,7 +613,7 @@ transpile o fname incs (CTranslUnit edecls _) = do forM_ bdy $ \d -> putStrLn $ ppShow $ cleanTree d else do let mhask = do - xs <- mapM grokStatement bdy + xs <- mapM (grokStatement fe) bdy return $ foldr applyComputation (Computation Map.empty Map.empty hsopUnit) xs case mhask of Just hask -> do printHeader @@ -623,7 +622,7 @@ transpile o fname incs (CTranslUnit edecls _) = do printHeader forM_ bdy $ \d -> do putStrLn $ " C: " ++ show (pretty d) - case grokStatement d of + case grokStatement fe d of Just hd -> do putStrLn $ "fr: " ++ intercalate " " (Map.keys (compFree hd)) putStrLn $ "HS: " ++ HS.prettyPrint (comp hd) -- cgit v1.2.3