From 30799e391ddfa9ca56289b3f300c373a727171d9 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sat, 23 Mar 2019 22:00:58 -0400 Subject: compContinue field. --- monkeypatch.hs | 122 ++++++++++++++++++++++++--------------------------------- 1 file changed, 52 insertions(+), 70 deletions(-) diff --git a/monkeypatch.hs b/monkeypatch.hs index f825868..d7c4282 100644 --- a/monkeypatch.hs +++ b/monkeypatch.hs @@ -150,12 +150,18 @@ transField (CDecl [CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _) transField _ = [] data Computation st = Computation - { compFree :: Map String () - , compIntro :: Map String () - , comp :: st + { compFree :: Map String () + , compIntro :: Map String () + , compContinue :: Maybe String + -- ^ The identifier name currently used to indicate the "continue;" + -- statement. + , comp :: st } deriving (Eq,Ord,Functor) +mkcomp :: x -> Computation x +mkcomp x = Computation Map.empty Map.empty Nothing x + hsvar :: String -> HS.Exp () hsvar v = Var () (UnQual () (HS.Ident () v)) @@ -190,11 +196,12 @@ applyComputation a@Computation{ comp = FormalLambda govar exp } b = in case listify matchgo exp of (_:_:_) -> error "TODO: Multiple go-refs; make let binding." _ -> Computation - { compFree = Map.union (compFree a) (compFree b) Map.\\ compIntro a - , compIntro = compIntro a `Map.union` compIntro b - , comp = let subst x | matchgo x = comp b - | otherwise = x - in everywhere (mkT subst) exp + { compFree = Map.union (compFree a) (compFree b) Map.\\ compIntro a + , compIntro = compIntro a `Map.union` compIntro b + , compContinue = Nothing + , comp = let subst x | matchgo x = comp b + | otherwise = x + in everywhere (mkT subst) exp } varmap :: [String] -> Map String () @@ -288,33 +295,24 @@ grokExpression fe (CVar cv _) = if isGlobalRef fe v then let k = uniqIdentifier "go" (varmap [v,hv]) s = Computation - { compFree = Map.singleton v () - , compIntro = Map.singleton hv () - , comp = FormalLambda k - $ infixOp (App () (hsvar "peek") (hsvar v)) ">>=" - $ Lambda () [hspvar hv] (hsvar k) + { compFree = Map.singleton v () + , compIntro = Map.singleton hv () + , compContinue = Nothing + , comp = FormalLambda k + $ infixOp (App () (hsvar "peek") (hsvar v)) ">>=" + $ Lambda () [hspvar hv] (hsvar k) } hv = "v" ++ v - in (,) [s] Computation + in (,) [s] (mkcomp $ hsvar hv) { compFree = Map.singleton hv () - , compIntro = Map.empty - , comp = hsvar hv } - else (,) [] $ Computation + else (,) [] $ (mkcomp $ hsvar v) { compFree = Map.singleton (identToString cv) () - , compIntro = Map.empty - , comp = hsvar v } -grokExpression fe (CConst (CIntConst n _)) = Just $ (,) [] $ Computation - { compFree = Map.empty - , compIntro = Map.empty - , comp = Lit () (Int () (getCInteger n) (show n)) - } -grokExpression fe (CConst (CStrConst s _)) = Just $ (,) [] $ Computation - { compFree = Map.empty - , compIntro = Map.empty - , comp = Lit () (HS.String () (getCString s) (getCString s)) - } +grokExpression fe (CConst (CIntConst n _)) = + Just $ (,) [] $ mkcomp $ Lit () (Int () (getCInteger n) (show n)) +grokExpression fe (CConst (CStrConst s _)) = + Just $ (,) [] $ mkcomp $ Lit () (HS.String () (getCString s) (getCString s)) grokExpression fe (CBinary op a b _) = do (as,ca) <- grokExpression fe a (bs0,cb0) <- grokExpression fe b @@ -325,10 +323,8 @@ grokExpression fe (CBinary op a b _) = do | 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 + return $ (,) ss $ (mkcomp $ infx (comp ca) hop (comp cb)) { compFree = compFree ca `Map.union` compFree cb - , compIntro = Map.empty - , comp = infx (comp ca) hop (comp cb) } grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do let cv = identToString cv0 @@ -337,15 +333,14 @@ grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do ss = pure Computation { compFree = Map.singleton cv () , compIntro = Map.singleton hv () + , compContinue = Nothing , comp = FormalLambda k $ infixFn (hsvar cv) "withPointer" (Lambda () [hspvar hv] (hsvar k)) } - return $ (,) ss Computation + return $ (,) ss (mkcomp $ hsvar hv) { compFree = Map.singleton hv () - , compIntro = Map.empty - , comp = hsvar hv } grokExpression fe (CCond cond (Just thn) els _) = do (cs,c) <- grokExpression fe cond @@ -364,10 +359,8 @@ grokExpression fe (CCast (CDecl [ CTypeSpec (CVoidType _) ] [ ( Just (CDeclr Nothing [ CPtrDeclr [] _ ] Nothing [] _) , Nothing , Nothing) ] _) (CConst (CIntConst zero _)) _) | 0 <- getCInteger zero = do - return $ (,) [] Computation + return $ (,) [] (mkcomp $ hsvar "nullPtr") { compFree = Map.singleton "nullPtr" () - , compIntro = Map.empty - , comp = hsvar "nullPtr" } grokExpression fe (CComma exps _) = do gs <- mapM (grokExpression fe) exps @@ -381,7 +374,7 @@ grokExpression fe (CComma exps _) = do k = uniqIdentifier "go" (compFree s) 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'],Computation (Map.singleton hv ()) Map.empty (hsvar hv)) + 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 @@ -392,14 +385,13 @@ grokExpression fe (C.CCall (CVar fn _) exps _) = do s = Computation { compFree = frees , compIntro = Map.singleton hv () + , compContinue = Nothing , comp = FormalLambda k $ infixOp cll ">>=" $ Lambda () [hspvar hv] (hsvar k) } - return $ (,) (ss++[s]) Computation + return $ (,) (ss++[s]) (mkcomp $ hsvar hv) { compFree = Map.singleton hv () - , compIntro = Map.empty - , comp = hsvar hv } grokExpression fe (CStatExpr (CCompound idents xs _) _) = do let (y,ys) = splitAt 1 (reverse xs) @@ -407,21 +399,20 @@ grokExpression fe (CStatExpr (CCompound idents xs _) _) = do [CBlockStmt (CExpr mexp ni)] -> Just $ CBlockStmt (CReturn mexp ni) _ -> Just (head y) -- Nothing FIXME gs <- mapM (grokStatement fe) (reverse $ y' : ys) - let s0 = foldr applyComputation (Computation Map.empty Map.empty retUnit) gs + let s0 = foldr applyComputation (mkcomp retUnit) gs s1 = fmap (\xp -> Paren () xp) s0 hv = uniqIdentifier "ret" (compFree s1) k = uniqIdentifier "go" (compFree s1) s = Computation { compFree = compFree s1 , compIntro = Map.singleton hv () + , compContinue = Nothing , comp = FormalLambda k $ infixOp (comp s1) ">>=" $ Lambda () [hspvar hv] (hsvar k) } - return $ (,) [s] Computation + return $ (,) [s] (mkcomp $ hsvar hv) { compFree = Map.singleton hv () - , compIntro = Map.empty - , comp = hsvar hv } grokExpression fe (CAssign CAssignOp cvar expr _) = do v <- cvarName cvar @@ -433,11 +424,7 @@ grokExpression fe (CAssign CAssignOp cvar expr _) = do $ infixOp (App () (hsvar "return") (comp x)) ">>=" $ Lambda () [hspvar v] (hsvar k) } - return $ (,) (ss ++ [s]) Computation - { compFree = Map.empty - , compIntro = Map.empty - , comp = hsvar v - } + return $ (,) (ss ++ [s]) $ mkcomp (hsvar v) grokExpression fe _ = Nothing @@ -470,7 +457,7 @@ grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = d let assigns = do (ms,(ss,x)) <- gs let k2 = uniqIdentifier "gopoo" (compFree ret) - ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k2)) (ss ++ cs) + ret = foldr applyComputation (mkcomp $ hsvar k2) (ss ++ cs) cs = do CMemberDesig m _ <- ms let k1 = uniqIdentifier "go" (compFree x) @@ -488,12 +475,13 @@ grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = d let newstruct = Computation { compFree = Map.empty -- todo , compIntro = Map.singleton v () + , compContinue = Nothing , comp = FormalLambda k $ infixOp (App () (hsvar "newStruct") (TypeApp () (TyCon () (UnQual () hident)))) ">>=" $ Lambda () [hspvar v] (hsvar k) } k = uniqIdentifier "go" Map.empty -- (compFree ret) TODO - ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) $ newstruct : assigns + ret = foldr applyComputation (mkcomp $ hsvar k) $ newstruct : assigns return $ fmap (FormalLambda k) ret _ -> Nothing grokInitialization _ _ _ = Nothing @@ -515,7 +503,7 @@ grokStatement fe (CBlockStmt (CReturn (Just exp) _)) = do x' = fmap (\y -> App () (hsvar "return") $ promote (fnArgs fe) y) x return $ fmap (\y -> FormalLambda k y) $ foldr applyComputation x' xs grokStatement fe (CBlockStmt (CReturn Nothing _)) = - Just $ Computation Map.empty Map.empty $ FormalLambda "go" retUnit + Just $ mkcomp $ FormalLambda "go" retUnit grokStatement fe (CBlockStmt (CIf exp thn els _)) = do (xs,x) <- grokExpression fe exp let mkif0 = If () (comp x) @@ -534,17 +522,18 @@ grokStatement fe (CBlockStmt (CIf exp thn els _)) = do _ -> trace ("Unhandled if: "++show (fmap (const LT) thn)) $ Nothing -- TODO ss <- sequence $ map (grokStatement fe) stmts - let s = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) ss + let s = foldr applyComputation (mkcomp $ hsvar k) ss k = uniqIdentifier "go" (Map.union (compFree x) (compFree s)) return $ fmap (FormalLambda k) $ flip (foldr applyComputation) xs Computation { compFree = compFree x `Map.union` compFree s , compIntro = compIntro s + , compContinue = Nothing , comp = mkif (comp s) (hsvar k) } 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)) + in Just $ mkcomp $ Lit () (HS.String () s s) _ -> Nothing let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x) x' = fmap (\y -> App () (hsvar "error") y) x @@ -573,11 +562,7 @@ grokStatement fe (CBlockStmt (CExpr (Just cll = foldl (App ()) (hsvar fn) $ map (comp . snd) gs frees = foldr Map.union (Map.singleton fn ()) (map (compFree . snd) gs) x = foldr applyComputation s $ concatMap fst gs - s = Computation - { compFree = frees - , compIntro = Map.empty - , comp = infixOp cll ">>" (hsvar k) - } + s = (mkcomp $ infixOp cll ">>" (hsvar k)) { compFree = frees } return $ fmap (FormalLambda k) x grokStatement fe (CBlockStmt (CExpr (Just (CAssign CAssignOp cvarnew @@ -588,6 +573,7 @@ grokStatement fe (CBlockStmt (CExpr (Just return Computation { compFree = Map.singleton fn () , compIntro = Map.singleton v () + , compContinue = Nothing , comp = FormalLambda k $ infixOp (hsvar fn) ">>=" $ Lambda () [hspvar v] (hsvar k) @@ -599,6 +585,7 @@ grokStatement fe (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 return Computation { compFree = varmap [v] , compIntro = Map.empty + , compContinue = Nothing , comp = FormalLambda k1 $ infixOp (App () (App () (App () (hsvar "modify") @@ -616,7 +603,7 @@ grokStatement fe (CBlockStmt (CExpr (Just expr) _)) = do return $ fmap (FormalLambda k) $ foldr applyComputation g ss -} grokStatement fe (CBlockStmt (CExpr mexpr _)) = do - (ss,pre) <- maybe (Just $ (,) [] $ Computation Map.empty Map.empty id) + (ss,pre) <- maybe (Just $ (,) [] $ mkcomp id) (fmap (second (fmap (\e -> infixFn e "seq"))) . grokExpression fe) mexpr let k = uniqIdentifier "go" (compFree s) s = foldr applyComputation (fmap ($ hsvar k) pre) ss @@ -625,16 +612,11 @@ 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 - [] -> - return Computation - { compFree = Map.empty - , compIntro = Map.empty - , comp = FormalLambda "go" $ hsvar "go" - } + [] -> return $ mkcomp $ FormalLambda "go" $ hsvar "go" initials -> do gs <- mapM (grokInitialization fe $ t:ts) initials return $ fmap (FormalLambda "go") - $ foldr applyComputation (Computation Map.empty Map.empty (hsvar "go")) gs + $ foldr applyComputation (mkcomp $ hsvar "go") gs grokStatement fe _ = Nothing isFunctionDecl :: CExternalDeclaration a -> Bool @@ -767,7 +749,7 @@ transpile o fname incs (CTranslUnit edecls _) = do else do let mhask = do xs <- mapM (grokStatement fe) bdy - return $ foldr applyComputation (Computation Map.empty Map.empty retUnit) xs + return $ foldr applyComputation (mkcomp retUnit) xs case mhask of Just hask -> do printHeader mapM_ (putStrLn . (" "++)) $ lines $ HS.prettyPrint $ applyDoSyntax' o $ comp hask -- cgit v1.2.3