From a7f8fe53e5d8980084d51a3ee146243f46e5d79f Mon Sep 17 00:00:00 2001 From: James Barnes Date: Fri, 25 Nov 2022 12:32:09 +1100 Subject: [PATCH] [WIP] proof-of-concept `disuse` statement --- src/AST.hs | 7 +++++++ src/Flatten.hs | 6 ++++++ src/Parser.hs | 5 +++++ src/Resources.hs | 3 +++ src/Types.hs | 29 ++++++++++++++++++++++++----- src/Unbranch.hs | 2 ++ src/Unique.hs | 2 ++ 7 files changed, 49 insertions(+), 5 deletions(-) diff --git a/src/AST.hs b/src/AST.hs index 9b6d859b..89b2d8e3 100644 --- a/src/AST.hs +++ b/src/AST.hs @@ -2424,6 +2424,7 @@ foldStmt' _ _ val Nop pos = val foldStmt' _ _ val Fail pos = val foldStmt' sfn efn val (Loop body _ _) pos = foldStmts sfn efn val body foldStmt' sfn efn val (UseResources _ _ body) pos = foldStmts sfn efn val body +foldStmt' sfn efn val (DisuseResources _ body) pos = foldStmts sfn efn val body foldStmt' sfn efn val (For generators body) pos = val3 where val1 = foldExps sfn efn pos val $ loopVar . content <$> generators val2 = foldExps sfn efn pos val1 $ genExp . content <$> generators @@ -2865,6 +2866,7 @@ data Stmt -- listed resources can be used, and in which those resources do not -- change value. This statement is eliminated during resource processing. | UseResources [ResourceSpec] (Maybe VarDict) [Placed Stmt] + | DisuseResources [ResourceSpec] [Placed Stmt] -- |A case statement, which selects the statement sequence corresponding to -- the first expression that matches the value of the first argument. This -- is transformed to nested Cond statements. @@ -2922,6 +2924,7 @@ stmtImpurity (ProcCall (Higher fn) _ _ _) = stmtImpurity (ForeignCall _ _ flags _) = return $ flagsImpurity flags stmtImpurity (Cond cond thn els _ _ _) = stmtsImpurity $ cond:thn ++ els stmtImpurity (UseResources _ _ stmts) = stmtsImpurity stmts +stmtImpurity (DisuseResources _ stmts) = stmtsImpurity stmts stmtImpurity (Case _ cases _) = stmtsImpurity . concat $ snd <$> cases stmtImpurity (And stmts) = stmtsImpurity stmts @@ -3950,6 +3953,10 @@ showStmt indent (UseResources resources vars stmts) = ++ " in" ++ showBody (indent + 4) stmts ++ startLine indent ++ "}" ++ maybe "" (("\n preserving -> "++) . showVarMap) vars +showStmt indent (DisuseResources resources stmts) = + "disuse " ++ intercalate ", " (List.map show resources) + ++ " in" ++ showBody (indent + 4) stmts + ++ startLine indent ++ "}" showStmt _ Fail = "fail" showStmt _ Nop = "pass" showStmt indent (For generators body) = diff --git a/src/Flatten.hs b/src/Flatten.hs index 8194180e..9cf79703 100644 --- a/src/Flatten.hs +++ b/src/Flatten.hs @@ -404,6 +404,12 @@ flattenStmt' (UseResources res vars body) pos detism = do body' <- flattenInner True detism (flattenStmts body detism) modify $ \s -> s { defdVars = oldVars} emit pos $ UseResources res vars body' +flattenStmt' (DisuseResources res body) pos detism = do + oldVars <- gets defdVars + mapM_ (noteVarIntro . resourceName) res + body' <- flattenInner True detism (flattenStmts body detism) + modify $ \s -> s { defdVars = oldVars} + emit pos $ DisuseResources res body' flattenStmt' Nop pos _ = emit pos Nop flattenStmt' Fail pos _ = emit pos Fail flattenStmt' Break pos _ = emit pos Break diff --git a/src/Parser.hs b/src/Parser.hs index f22e329f..20a33ee0 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -1018,6 +1018,11 @@ termToStmt (Call pos [] "use" ParamIn ress' <- termToResourceList ress body' <- termToBody body return $ Placed (UseResources ress' Nothing body') pos +termToStmt (Call pos [] "disuse" ParamIn + [Call _ [] "in" ParamIn [ress,body]]) = do + ress' <- termToResourceList ress + body' <- termToBody body + return $ Placed (DisuseResources ress' body') pos termToStmt (Call pos [] "while" ParamIn [test]) = do t <- termToStmt test return $ Placed (Cond t [Unplaced Nop] [Unplaced Break] Nothing Nothing Nothing) pos diff --git a/src/Resources.hs b/src/Resources.hs index 70f3fe92..49c2c15e 100644 --- a/src/Resources.hs +++ b/src/Resources.hs @@ -396,6 +396,9 @@ transformStmt (UseResources res vars stmts) pos = do ++ stmts' -- store the old values of the resources ++ stores) +transformStmt (DisuseResources _ stmts) _ = + -- disused resources should already by out of scope + transformStmts stmts transformStmt Nop pos = return ([Nop `maybePlace` pos], False) transformStmt Fail pos = return ([Fail `maybePlace` pos], False) transformStmt Break pos = do diff --git a/src/Types.hs b/src/Types.hs index 1bbd02ee..35a25009 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -281,7 +281,7 @@ data TypeError = ReasonMessage Message -- ^Input resource not available in proc call | ReasonResourceOutOfScope ProcName ResourceSpec OptPos -- ^Resource not in scope in proc call - | ReasonUseType ResourceSpec OptPos + | ReasonUseType Bool ResourceSpec OptPos -- ^Type of resource in use stmt inconsistent with other use | ReasonWrongFamily Ident Int TypeFamily OptPos -- ^LLVM instruction expected different argument family @@ -436,9 +436,10 @@ typeErrorMessage (ReasonResourceUnavail proc res pos) = typeErrorMessage (ReasonResourceOutOfScope proc res pos) = Message Error pos $ "Resource " ++ show res ++ " not in scope at call to proc " ++ proc -typeErrorMessage (ReasonUseType res pos) = +typeErrorMessage (ReasonUseType use res pos) = Message Error pos $ - "Inconsistent type of resource " ++ show res ++ " in use statement" + "Inconsistent type of resource " ++ show res ++ " in " + ++ (if use then "" else "dis") ++ "use statement" typeErrorMessage (ReasonWrongFamily instr argNum fam pos) = Message Error pos $ "LLVM instruction '" ++ instr ++ "' argument " ++ show argNum @@ -511,7 +512,7 @@ typeErrorPos (ReasonResourceDef _ _ pos) = pos typeErrorPos (ReasonResourceUndef _ _ pos) = pos typeErrorPos (ReasonResourceUnavail _ _ pos) = pos typeErrorPos (ReasonResourceOutOfScope _ _ pos) = pos -typeErrorPos (ReasonUseType _ pos) = pos +typeErrorPos (ReasonUseType _ _ pos) = pos typeErrorPos (ReasonWrongFamily _ _ _ pos) = pos typeErrorPos (ReasonIncompatible _ _ _ pos) = pos typeErrorPos (ReasonWrongOutput _ _ _ pos) = pos @@ -1333,7 +1334,10 @@ bodyCalls'' nested (Cond cond thn els _ _ _) _ = do return $ cond' ++ thn' ++ els' bodyCalls'' nested (Loop stmts _ _) _ = bodyCallsConstraints nested stmts bodyCalls'' nested (UseResources res _ stmts) pos = do - mapM_ (flip (addResourceType ReasonUseType) pos) res + mapM_ (flip (addResourceType (ReasonUseType True)) pos) res + bodyCallsConstraints nested stmts +bodyCalls'' nested (DisuseResources res stmts) pos = do + mapM_ (flip (addResourceType (ReasonUseType False)) pos) res bodyCallsConstraints nested stmts bodyCalls'' _ For{} _ = shouldnt "bodyCalls: flattening left For stmt" bodyCalls'' _ Case{} _ = shouldnt "bodyCalls: flattening left Case stmt" @@ -2213,6 +2217,19 @@ modecheckStmt m name defPos assigned detism final let filter nm ty = nm `USet.member` resVars || isResourcefulHigherOrder ty return $ Map.filterWithKey filter varTys + +modecheckStmt m name defPos assigned detism final + stmt@(DisuseResources resources stmts) pos = do + logTyped $ "Mode checking disuse ... in stmt " ++ show stmt + canonRes <- lift (mapM (canonicaliseResourceSpec pos "use block") resources) + let resources' = fst <$> canonRes + let assigned' = assigned { bindingResources = + List.foldr Set.delete (bindingResources assigned) resources' } + (stmts', assigned'') + <- modecheckStmts m name defPos assigned' detism final stmts + return + ([DisuseResources resources stmts' `maybePlace` pos] + ,assigned'') -- XXX Need to implement these correctly: modecheckStmt m name defPos assigned detism final stmt@(And stmts) pos = do @@ -2708,6 +2725,8 @@ checkStmtTyped name pos stmt@(Loop stmts _ _) _ppos = do mapM_ (placedApply (checkStmtTyped name pos)) stmts checkStmtTyped name pos (UseResources _ _ stmts) _ppos = mapM_ (placedApply (checkStmtTyped name pos)) stmts +checkStmtTyped name pos (DisuseResources _ stmts) _ppos = + mapM_ (placedApply (checkStmtTyped name pos)) stmts checkStmtTyped name pos For{} ppos = shouldnt "For statement left by flattening" checkStmtTyped name pos Case{} ppos = diff --git a/src/Unbranch.hs b/src/Unbranch.hs index faefc925..d9e63b91 100644 --- a/src/Unbranch.hs +++ b/src/Unbranch.hs @@ -510,6 +510,8 @@ unbranchStmt detism (Loop body exitVars res) pos stmts alt sense = do return [next] unbranchStmt _ UseResources{} _ _ _ _ = shouldnt "resource handling should have removed use ... in statements" +unbranchStmt _ DisuseResources{} _ _ _ _ = + shouldnt "resource handling should have removed disuse ... in statements" unbranchStmt _ For{} _ _ _ _ = shouldnt "flattening should have removed For statements" unbranchStmt _ Case{} _ _ _ _ = diff --git a/src/Unique.hs b/src/Unique.hs index 819ea83b..8a90fe78 100644 --- a/src/Unique.hs +++ b/src/Unique.hs @@ -307,6 +307,8 @@ uniquenessCheckStmt (UseResources res _ body) pos = do uniquenessCheckStmts body -- resource is implicitly restored before block mapM_ (uniquenessCheckResourceArg pos . (`ResourceFlowSpec` ParamOut)) res +uniquenessCheckStmt (DisuseResources _ body) pos = do + uniquenessCheckStmts body uniquenessCheckStmt (For generators body) pos = do mapM_ ((\gen -> do placedApply uniquenessCheckExp $ genExp gen