[WIP] proof-of-concept disuse statement

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) =

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

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

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

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 =

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{} _ _ _ _ =

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