From 5d98b03204e98259d8219c615199c796c286bb55 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Wed, 27 Mar 2019 16:00:47 -0400 Subject: Switch to using Unique symbols to simplify namespace hygiene. --- Unique.hs | 5 ++ monkeypatch.hs | 159 +++++++++++++++++++++++++++++---------------------------- 2 files changed, 85 insertions(+), 79 deletions(-) diff --git a/Unique.hs b/Unique.hs index d0d3eb1..1594b4a 100644 --- a/Unique.hs +++ b/Unique.hs @@ -1,8 +1,10 @@ module Unique ( UniqueFactory , freshUniques + , genUnique , Unique , uniqueSymbol + , uniquePattern , substituteUnique , multipleOccurances ) where @@ -25,6 +27,9 @@ genUnique (UniqueFactory c) = (Unique c, UniqueFactory (succ c)) uniqueSymbol :: Unique -> Exp () uniqueSymbol (Unique i) = Var () (UnQual () (Ident () (showSym i))) +uniquePattern :: Unique -> Pat () +uniquePattern (Unique i) = PVar () (Ident () (showSym i)) + showSym :: Integer -> String showSym i = " u" ++ show i diff --git a/monkeypatch.hs b/monkeypatch.hs index ceeaf25..5ef58da 100644 --- a/monkeypatch.hs +++ b/monkeypatch.hs @@ -201,7 +201,7 @@ infixOp x op y = InfixApp () x (QVarOp () (UnQual () (Symbol () op))) y infixFn :: HS.Exp () -> String -> HS.Exp () -> HS.Exp () infixFn x fn y = InfixApp () x (QVarOp () (UnQual () (HS.Ident () fn))) y -data FormalLambda = FormalLambda { formGo :: String +data FormalLambda = FormalLambda { formGo :: Unique , formExp :: HS.Exp () } @@ -215,18 +215,17 @@ 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 +informalize (FormalLambda k x) = Lambda () [uniquePattern k] x factorOutFunction :: String -- ^ New function name to factor out. -> [String] -- ^ Arguments to function. -> HS.Exp () -- ^ Body of function. - -> String -- ^ Variable name place holder for call sites in template. + -> HS.Exp () -- ^ Variable name place holder for call sites in template. -> HS.Exp () -- ^ Template containing place-holder call sites. -> HS.Exp () factorOutFunction k vs bdy govar expr = - let matchgo (Var () (UnQual () (HS.Ident () v))) = v==govar - matchgo _ = False + let matchgo v = v==govar subst x | matchgo x = callsite | otherwise = x callsite = foldl (App ()) (hsvar k) $ map hsvar vs @@ -245,14 +244,13 @@ multiwayContinuation a@Computation{ comp = FormalLambda govar exp } b = { compFree = Map.union (compFree a) (compFree b) Map.\\ compIntro a , compIntro = compIntro a `Map.union` compIntro b , compContinue = Nothing - , comp = factorOutFunction k vs (comp b) govar exp + , comp = factorOutFunction k vs (comp b) (uniqueSymbol govar) exp } applyComputation :: Computation FormalLambda -> Computation (HS.Exp ()) -> Computation (HS.Exp ()) applyComputation a@Computation{ comp = FormalLambda govar exp } b = - let matchgo (Var () (UnQual () (HS.Ident () v))) = v==govar - matchgo _ = False + let matchgo v = v==uniqueSymbol govar in case listify matchgo exp of (_:_:_) -> multiwayContinuation a b _ -> Computation @@ -349,24 +347,24 @@ isGlobalRef fe sym = fromMaybe False $ do grokExpression :: FunctionEnvironment -> CExpression a -> StateT UniqueFactory Maybe ([Computation FormalLambda], Computation (HS.Exp ())) -grokExpression fe (CVar cv _) = +grokExpression fe (CVar cv _) = do let v = identToString cv - in return $ - if isGlobalRef fe v - then let k = uniqIdentifier "go" (varmap [v,hv]) - s = Computation + if isGlobalRef fe v + then do + k <- StateT $ return . genUnique + let s = Computation { compFree = Map.singleton v () , compIntro = Map.singleton hv () , compContinue = Nothing , comp = FormalLambda k $ infixOp (App () (hsvar "peek") (hsvar v)) ">>=" - $ Lambda () [hspvar hv] (hsvar k) + $ Lambda () [hspvar hv] (uniqueSymbol k) } - hv = "v" ++ v - in (,) [s] (mkcomp $ hsvar hv) + hv = "v" ++ v + return $ (,) [s] (mkcomp $ hsvar hv) { compFree = Map.singleton hv () } - else (,) [] $ (mkcomp $ hsvar v) + else return $ (,) [] $ (mkcomp $ hsvar v) { compFree = Map.singleton (identToString cv) () } grokExpression fe (CConst (CIntConst n _)) = @@ -385,9 +383,9 @@ grokExpression fe (CBinary op a b _) = do -- TODO: Short-circuit boolean evaluation side-effects. return $ (,) ss $ infx <$> ca <*> pure hop <*> cb grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do + k <- StateT $ return . genUnique let cv = identToString cv0 hv = "p" ++ cv - k = uniqIdentifier "go" (Map.empty {-todo-}) ss = pure Computation { compFree = Map.singleton cv () , compIntro = Map.singleton hv () @@ -395,7 +393,7 @@ grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do , comp = FormalLambda k $ infixFn (hsvar cv) "withPointer" - (Lambda () [hspvar hv] (hsvar k)) + (Lambda () [hspvar hv] (uniqueSymbol k)) } return $ (,) ss (mkcomp $ hsvar hv) { compFree = Map.singleton hv () @@ -422,13 +420,13 @@ grokExpression fe (CComma exps _) = do gs <- mapM (grokExpression fe) exps let gs2 = map (\(ss,x) -> foldr applyComputation (App () (hsvar "return") <$> x) ss) gs parn e = Paren () e - ps = map (\x -> let k = uniqIdentifier "go" (compFree x) - in fmap (\xx -> FormalLambda k (infixOp (parn xx) ">>" (hsvar k))) x) + ps <- mapM (\x -> do k <- StateT $ return . genUnique + return $ fmap (\xx -> FormalLambda k (infixOp (parn xx) ">>" (uniqueSymbol k))) x) (init gs2) - s = foldr applyComputation (last gs2) ps + let s = foldr applyComputation (last gs2) ps hv = "u" - k = uniqIdentifier "go" (compFree s) - s' = fmap (\x -> FormalLambda k (infixOp (parn x) ">>=" (Lambda () [hspvar hv] (hsvar k)))) s + k <- StateT $ return . genUnique + let s' = fmap (\x -> FormalLambda k (infixOp (parn x) ">>=" (Lambda () [hspvar hv] (uniqueSymbol 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 fn exps u) = grokCall fe True (C.CCall fn exps u) @@ -441,14 +439,14 @@ grokExpression fe (CStatExpr (CCompound idents xs _) _) = do 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 + k <- StateT $ return . genUnique + let s = Computation { compFree = compFree s1 , compIntro = Map.singleton hv () , compContinue = Nothing , comp = FormalLambda k $ infixOp (comp s1) ">>=" - $ Lambda () [hspvar hv] (hsvar k) + $ Lambda () [hspvar hv] (uniqueSymbol k) } return $ (,) [s] (mkcomp $ hsvar hv) { compFree = Map.singleton hv () @@ -456,12 +454,12 @@ grokExpression fe (CStatExpr (CCompound idents xs _) _) = do grokExpression fe (CAssign CAssignOp cvar expr _) = do v <- mb $ cvarName cvar (ss,x) <- grokExpression fe expr - let k = uniqIdentifier "go" (Map.insert v () $ foldr (\s m -> compFree s `Map.union` compIntro s `Map.union` m) Map.empty ss) - s = x + k <- StateT $ return . genUnique + let s = x { compIntro = Map.singleton v () , comp = FormalLambda k $ infixOp (App () (hsvar "return") (comp x)) ">>=" - $ Lambda () [hspvar v] (hsvar k) + $ Lambda () [hspvar v] (uniqueSymbol k) } return $ (,) (ss ++ [s]) $ mkcomp (hsvar v) grokExpression fe (CMember cvar fld isptr _) = do @@ -472,8 +470,8 @@ grokExpression fe (CMember cvar fld isptr _) = do (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) (hsvar v) e' = (mkcomp e){ compFree = Map.singleton v () } - k = uniqIdentifier "go" (varmap [hv,v,fieldlbl]) - s = (FormalLambda k <$> fmap (($ Lambda () [hspvar hv] (hsvar k)) . (`infixOp` ">>=")) e') + k <- StateT $ return . genUnique + let s = (FormalLambda k <$> fmap (($ Lambda () [hspvar hv] (uniqueSymbol k)) . (`infixOp` ">>=")) e') { compIntro = Map.singleton hv () } return $ (,) [s] (mkcomp $ hsvar hv){ compFree = Map.singleton hv () } grokExpression fe _ = mzero @@ -490,11 +488,11 @@ grokCall fe wantsRet (C.CCall (CVar fn _) exps _) = do -- 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) + k <- StateT $ return . genUnique + let s | wantsRet = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (uniqueSymbol k)) cll) { compIntro = Map.singleton hv () } - | otherwise = fmap (\c -> FormalLambda k $ infixOp c ">>" (hsvar k)) cll + | otherwise = fmap (\c -> FormalLambda k $ infixOp c ">>" (uniqueSymbol k)) cll return $ (,) (ss++[s]) (mkcomp $ hsvar hv) { compFree = Map.singleton hv () } @@ -514,11 +512,11 @@ grokCall fe wantsRet (C.CCall fnx@(CMember cvar fld isptr _) exps _) = do -- 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) + k <- StateT $ return . genUnique + let s | wantsRet = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (uniqueSymbol k)) cll) { compIntro = Map.singleton hv () } - | otherwise = fmap (\c -> FormalLambda k $ infixOp c ">>" (hsvar k)) cll + | otherwise = fmap (\c -> FormalLambda k $ infixOp c ">>" (uniqueSymbol k)) cll return $ (,) (ss++[s]) (mkcomp $ hsvar hv) { compFree = Map.singleton hv () } @@ -534,10 +532,10 @@ grokInitialization fe _ (Just (CDeclr (Just cv0) _ _ _ _),CInitExpr exp _) = do let v = identToString cv0 (xs,x) <- grokExpression fe exp let hsexp = fmap (App () (hsvar "return")) x -- Paren () ( - ret = flip (foldr applyComputation) xs $ + k <- StateT $ return . genUnique + let ret = flip (foldr applyComputation) xs $ fmap (\exp -> infixOp exp ">>=" - $ Lambda () [hspvar v] (hsvar k)) hsexp - k = uniqIdentifier "go" (compFree ret) + $ Lambda () [hspvar v] (uniqueSymbol k)) hsexp return $ fmap (FormalLambda k) ret grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do let v = identToString cv0 @@ -551,14 +549,11 @@ grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = d case initexpr of CInitExpr ie _ -> (grokExpression fe) ie >>= \g -> return (ms,g) _ -> mzero - let assigns = do - (ms,(ss,x)) <- gs - let k2 = uniqIdentifier "gopoo" (compFree ret) - ret = foldr applyComputation (mkcomp $ hsvar k2) (ss ++ cs) - cs = do - CMemberDesig m _ <- ms - let k1 = uniqIdentifier "go" (compFree x) - fieldinit = comp x + assigns <- forM gs $ \(ms,(ss,x)) -> do + k2 <- StateT $ return . genUnique + cs <- forM (mapMaybe (\case { CMemberDesig m _ -> Just m ; _ -> Nothing}) ms) $ \m -> do + k1 <- StateT $ return . genUnique + let fieldinit = comp x fieldlbl = identToString m return x { comp = FormalLambda k1 @@ -566,19 +561,20 @@ grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = d (App () (App () (App () (hsvar "set") (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) (hsvar v)) - fieldinit) ">>" (hsvar k1) + fieldinit) ">>" (uniqueSymbol k1) } + let ret = foldr applyComputation (mkcomp $ uniqueSymbol k2) (ss ++ cs) return $ fmap (FormalLambda k2) ret + k <- StateT $ return . genUnique 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) + $ Lambda () [hspvar v] (uniqueSymbol k) } - k = uniqIdentifier "go" Map.empty -- (compFree ret) TODO - ret = foldr applyComputation (mkcomp $ hsvar k) $ newstruct : assigns + ret = foldr applyComputation (mkcomp $ uniqueSymbol k) $ newstruct : assigns return $ fmap (FormalLambda k) ret _ -> mzero grokInitialization _ _ _ = mzero @@ -597,13 +593,15 @@ promote _ y = y grokStatement :: FunctionEnvironment -> CCompoundBlockItem a -> StateT UniqueFactory Maybe (Computation FormalLambda) 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") $ promote (fnArgs fe) y) x + k <- StateT $ return . genUnique + let 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 _)) = - return $ mkcomp $ FormalLambda "go" retUnit -grokStatement fe (CBlockStmt (CCont _)) = - return (mkcomp $ FormalLambda "go" $ hsvar " continue") +grokStatement fe (CBlockStmt (CReturn Nothing _)) = do + k <- StateT $ return . genUnique + return $ mkcomp $ FormalLambda k retUnit +grokStatement fe (CBlockStmt (CCont _)) = do + k <- StateT $ return . genUnique + return (mkcomp $ FormalLambda k $ hsvar " continue") { compContinue = Just " continue" } grokStatement fe (CBlockStmt (CIf exp thn els _)) = do (xs,x) <- grokExpression fe exp @@ -623,62 +621,62 @@ grokStatement fe (CBlockStmt (CIf exp thn els _)) = do _ -> trace ("Unhandled if: "++show (fmap (const LT) thn)) $ mzero -- TODO ss <- sequence $ map (grokStatement fe) stmts - let s = foldr applyComputation (mkcomp $ hsvar k) ss - k = uniqIdentifier "go" (Map.union (compFree x) (compFree s)) + k <- StateT $ return . genUnique + let s = foldr applyComputation (mkcomp $ uniqueSymbol k) ss 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) + , comp = mkif (comp s) (uniqueSymbol 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 return $ mkcomp $ Lit () (HS.String () s s) _ -> mzero - let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x) - x' = fmap (\y -> App () (hsvar "error") y) x + k <- StateT $ return . genUnique + let x' = fmap (\y -> App () (hsvar "error") y) x return $ fmap (FormalLambda k) x' grokStatement fe (CBlockStmt (CExpr (Just (CAssign CAssignOp (CMember cvar fld isptr _) expr _)) _)) = do (xs,x) <- grokExpression fe expr v <- mb $ cvarName cvar + k1 <- StateT $ return . genUnique let fieldlbl = identToString fld - k1 = uniqIdentifier "go" (compFree x) fieldinit = comp x x' = x { comp = infixOp (App () (App () (App () (hsvar "set") (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) (hsvar v)) - fieldinit) ">>" (hsvar k1) + fieldinit) ">>" (uniqueSymbol k1) } return $ fmap (FormalLambda k1) $ foldr applyComputation x' xs 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. (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 + k <- StateT $ return . genUnique + let r = FormalLambda k <$> foldr applyComputation (mkcomp $ uniqueSymbol k) ss return r grokStatement fe (CBlockStmt (CExpr (Just (CAssign CAssignOp cvarnew (C.CCall cvarfun [] _) _)) _)) = do v <- mb $ cvarName cvarnew fn <- mb $ cvarName cvarfun - let k = uniqIdentifier "go" (varmap [v,fn]) + k <- StateT $ return . genUnique return Computation { compFree = Map.singleton fn () , compIntro = Map.singleton v () , compContinue = Nothing , comp = FormalLambda k $ infixOp (hsvar fn) ">>=" - $ Lambda () [hspvar v] (hsvar k) + $ Lambda () [hspvar v] (uniqueSymbol k) } grokStatement fe (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 _) fld True _) _)) _)) = do - let k1 = uniqIdentifier "go" (varmap [fieldlbl,v]) - fieldlbl = identToString fld + k1 <- StateT $ return . genUnique + let fieldlbl = identToString fld v = identToString cv0 return Computation { compFree = varmap [v] @@ -689,7 +687,7 @@ grokStatement fe (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 (App () (App () (App () (hsvar "modify") (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) (hsvar v)) - (hsvar "succ")) ">>" (hsvar k1) + (hsvar "succ")) ">>" (uniqueSymbol k1) } grokStatement fe (CBlockStmt (CExpr mexpr _)) = do -- trace ("CExpr statement: " ++ take 50 (show $ fmap (fmap $ const ()) mexpr)) $ return () @@ -700,18 +698,20 @@ grokStatement fe (CBlockStmt (CExpr mexpr _)) = do -- keep = fmap (\e -> infixFn e "seq") in (fmap (second discard) . grokExpression fe)) mexpr - let k = uniqIdentifier "go" (compFree s) - s = foldr applyComputation (fmap ($ hsvar k) pre) ss + k <- StateT $ return . genUnique + let s = foldr applyComputation (fmap ($ uniqueSymbol k) pre) ss return $ fmap (FormalLambda k) s 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 + k <- StateT $ return . genUnique case mapMaybe (\(i,inits,_) -> fmap ((,) i) inits) (v:vs) of - [] -> return $ mkcomp $ FormalLambda "go" $ hsvar "go" + [] -> return $ mkcomp $ FormalLambda k (uniqueSymbol k) initials -> do gs <- mapM (grokInitialization fe $ t:ts) initials - return $ fmap (FormalLambda "go") - $ foldr applyComputation (mkcomp $ hsvar "go") gs + k <- StateT $ return . genUnique + return $ fmap (FormalLambda k) + $ foldr applyComputation (mkcomp $ uniqueSymbol k) gs grokStatement fe (CBlockStmt (CWhile cond (CCompound [] bdy _) isDoWhile _)) = do gs <- mapM (grokStatement fe) bdy (ss,c) <- grokExpression fe cond @@ -723,7 +723,8 @@ grokStatement fe (CBlockStmt (CWhile cond (CCompound [] bdy _) isDoWhile _)) = d c' = fmap (\cnd -> If () cnd (Paren () loopcall) (hsvar "fin")) c x = foldr applyComputation c' ss -- continue function vs = [] -- Map.keys $ compIntro g - return $ fmap (FormalLambda "fin") $ fmap (factorOutFunction "continue" vs (comp x) " continue") g + fin <- StateT $ return . genUnique + return $ fmap (FormalLambda fin) $ fmap (factorOutFunction "continue" vs (comp x) (hsvar " continue")) g grokStatement fe _ = mzero isFunctionDecl :: CExternalDeclaration a -> Bool -- cgit v1.2.3