diff --git a/CarpHask.cabal b/CarpHask.cabal index 809eb145..5883451f 100644 --- a/CarpHask.cabal +++ b/CarpHask.cabal @@ -37,6 +37,7 @@ library Interfaces, Managed, Map, + Memory, Meta, Obj, Parsing, diff --git a/app/Main.hs b/app/Main.hs index 522f7698..ab6360fd 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -125,9 +125,9 @@ main = do [] coreModulesToLoad = if core then coreModules (projectCarpDir project) else [] execStr :: String -> String -> Context -> IO Context - execStr info str ctx = executeString True False ctx str info + execStr i s ctx = executeString True False ctx s i execStrs :: String -> [String] -> Context -> IO Context - execStrs info strs ctx = foldM (\ctx str -> execStr info str ctx) ctx strs + execStrs i strs ctx = foldM (\ctx' str' -> execStr i str' ctx') ctx strs preloads = optPreload fullOpts postloads = optPostload fullOpts load = flip loadFiles diff --git a/src/ArrayTemplates.hs b/src/ArrayTemplates.hs index dcf6166d..ce91e30e 100644 --- a/src/ArrayTemplates.hs +++ b/src/ArrayTemplates.hs @@ -4,6 +4,7 @@ module ArrayTemplates where import Concretize import Obj +import Polymorphism import StructUtils import Template import ToTemplate diff --git a/src/Concretize.hs b/src/Concretize.hs index a18fc3a5..14620929 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -5,19 +5,18 @@ module Concretize where import AssignTypes import Constraints import Control.Monad.State -import Data.Either (fromRight) import Data.List (foldl') import Data.Maybe (fromMaybe) import Debug.Trace -import Env (envIsExternal, findPoly, getTypeBinder, getValue, insert, insertX, lookupEverywhere, searchValue) +import Env (envIsExternal, getTypeBinder, insert, insertX, searchValue) import Info import InitialTypes import Managed import qualified Map +import Memory (manageMemory) import Obj import Polymorphism import Reify -import Set ((\\)) import qualified Set import SumtypeCase import ToTemplate @@ -700,7 +699,8 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit then pure (withNewPath, []) else do (concrete, deps) <- concretizeXObj allowAmbiguity typeEnv globalEnv (newPath : visitedDefinitions) typed - (managed, memDeps) <- manageMemory typeEnv globalEnv concrete + (managed, memDepsTys) <- manageMemory typeEnv globalEnv concrete + let memDeps = depsForDeleteFuncs typeEnv globalEnv memDepsTys pure (managed, deps ++ memDeps) Left e -> Left e XObj (Lst (XObj (Defn _) _ _ : _)) _ _ -> @@ -712,7 +712,8 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit then pure (withNewPath, []) else do (concrete, deps) <- concretizeXObj allowAmbiguity typeEnv globalEnv (newPath : visitedDefinitions) typed - (managed, memDeps) <- manageMemory typeEnv globalEnv concrete + (managed, memDepsTys) <- manageMemory typeEnv globalEnv concrete + let memDeps = depsForDeleteFuncs typeEnv globalEnv memDepsTys pure (managed, deps ++ memDeps) Left e -> Left e XObj (Lst (XObj (Deftemplate (TemplateCreator templateCreator)) _ _ : _)) _ _ -> @@ -738,31 +739,6 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit _ -> Left $ CannotConcretize definition --- | Find ALL functions with a certain name, matching a type signature. --- When the functionName argument denotes an interface, the name will match iff either: --- 1. The name of the binding matches functionName exactly OR --- 2. The name of the binding matches one of the names in the interface's implementation paths --- For all other functions, the name must match exactly, and in all cases, the signature must match. -allImplementations :: TypeEnv -> Env -> String -> Ty -> [(Env, Binder)] -allImplementations typeEnv env functionName functionType = - (filter (predicate . xobjTy . binderXObj . snd) foundBindings) - where - predicate (Just t) = - --trace ("areUnifiable? " ++ show functionType ++ " == " ++ show t ++ " " ++ show (areUnifiable functionType t)) $ - areUnifiable functionType t - predicate Nothing = error "allfunctionswithnameandsignature" - foundBindings = case getTypeBinder typeEnv functionName of - -- this function is an interface; lookup implementations - Right (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) -> - case sequence $ map (\p -> searchValue env p) (paths ++ [(SymPath [] functionName)]) of - Right found -> found - Left _ -> - case findPoly env functionName functionType of - Right r -> [r] - Left _ -> (lookupEverywhere env functionName) - -- just a regular function; look for it - _ -> fromRight [] ((fmap (: []) (Env.getValue env functionName)) <> pure (lookupEverywhere env functionName)) - -- | Find all the dependencies of a polymorphic function with a name and a desired concrete type. depsOfPolymorphicFunction :: TypeEnv -> Env -> [SymPath] -> String -> Ty -> [XObj] depsOfPolymorphicFunction typeEnv env visitedDefinitions functionName functionType = @@ -788,6 +764,10 @@ depsForDeleteFunc typeEnv env t = then depsOfPolymorphicFunction typeEnv env [] "delete" (FuncTy [t] UnitTy StaticLifetimeTy) else [] +-- | Helper for finding the 'delete' functions for several types. +depsForDeleteFuncs :: TypeEnv -> Env -> Set.Set Ty -> [XObj] +depsForDeleteFuncs typeEnv env tys = concatMap (depsForDeleteFunc typeEnv env) (Set.toList tys) + -- | Helper for finding the 'copy' function for a type. depsForCopyFunc :: TypeEnv -> Env -> Ty -> [XObj] depsForCopyFunc typeEnv env t = @@ -809,788 +789,6 @@ typesStrFunctionType typeEnv env memberType = then FuncTy [RefTy memberType (VarTy "q")] StringTy StaticLifetimeTy else FuncTy [memberType] StringTy StaticLifetimeTy --- | The various results when trying to find a function using 'findFunctionForMember'. -data FunctionFinderResult - = FunctionFound String - | FunctionNotFound String - | FunctionIgnored - deriving (Show) - --- | TODO: COMMENT THIS -getConcretizedPath :: XObj -> Ty -> SymPath -getConcretizedPath single functionType = - let Just t' = xobjTy single - (SymPath pathStrings name) = getPath single - suffix = polymorphicSuffix t' functionType - in SymPath pathStrings (name ++ suffix) - --- | Used for finding functions like 'delete' or 'copy' for members of a Deftype (or Array). -findFunctionForMember :: TypeEnv -> Env -> String -> Ty -> (String, Ty) -> FunctionFinderResult -findFunctionForMember typeEnv env functionName functionType (memberName, memberType) - | isManaged typeEnv env memberType = - case allImplementations typeEnv env functionName functionType of - [] -> - FunctionNotFound - ( "Can't find any '" ++ functionName ++ "' function for member '" - ++ memberName - ++ "' of type " - ++ show functionType - ) - [(_, Binder _ single)] -> - let concretizedPath = getConcretizedPath single functionType - in FunctionFound (pathToC concretizedPath) - _ -> - FunctionNotFound - ( "Can't find a single '" ++ functionName ++ "' function for member '" - ++ memberName - ++ "' of type " - ++ show functionType - ) - | otherwise = FunctionIgnored - --- | TODO: should this be the default and 'findFunctionForMember' be the specific one -findFunctionForMemberIncludePrimitives :: TypeEnv -> Env -> String -> Ty -> (String, Ty) -> FunctionFinderResult -findFunctionForMemberIncludePrimitives typeEnv env functionName functionType (memberName, _) = - case allImplementations typeEnv env functionName functionType of - [] -> - FunctionNotFound - ( "Can't find any '" ++ functionName ++ "' function for member '" - ++ memberName - ++ "' of type " - ++ show functionType - ) - [(_, Binder _ single)] -> - let concretizedPath = getConcretizedPath single functionType - in FunctionFound (pathToC concretizedPath) - _ -> - FunctionNotFound - ( "Can't find a single '" ++ functionName ++ "' function for member '" - ++ memberName - ++ "' of type " - ++ show functionType - ) - --- | Manage memory needs access to the concretizer --- | (and the concretizer needs to manage memory) --- | so they are put into the same module. - --- | Assign a set of Deleters to the 'infoDelete' field on Info. -setDeletersOnInfo :: Maybe Info -> Set.Set Deleter -> Maybe Info -setDeletersOnInfo i deleters = fmap (\i' -> i' {infoDelete = deleters}) i - -addDeletersToInfo :: Maybe Info -> Set.Set Deleter -> Maybe Info -addDeletersToInfo i deleters = - fmap (\i' -> i' {infoDelete = Set.union (infoDelete i') deleters}) i - --- | Helper function for setting the deleters for an XObj. -del :: XObj -> Set.Set Deleter -> XObj -del xobj deleters = xobj {xobjInfo = setDeletersOnInfo (xobjInfo xobj) deleters} - --- | Differentiate between lifetimes depending on variables in a lexical scope and depending on something outside the function -data LifetimeMode - = LifetimeInsideFunction String - | LifetimeOutsideFunction - deriving (Show) - --- | To keep track of the deleters when recursively walking the form. -data MemState = MemState - { memStateDeleters :: Set.Set Deleter, - memStateDeps :: [XObj], - memStateLifetimes :: Map.Map String LifetimeMode - } - deriving (Show) - -prettyLifetimeMappings :: Map.Map String LifetimeMode -> String -prettyLifetimeMappings mappings = - joinLines (map prettyMapping (Map.toList mappings)) - where - prettyMapping (key, value) = " " ++ key ++ " => " ++ show value - --- | Find out what deleters are needed and where in an XObj. --- | Deleters will be added to the info field on XObj so that --- | the code emitter can access them and insert calls to destructors. -manageMemory :: TypeEnv -> Env -> XObj -> Either TypeError (XObj, [XObj]) -manageMemory typeEnv globalEnv root = - let (finalObj, finalState) = runState (visit root) (MemState (Set.fromList []) [] Map.empty) - deleteThese = memStateDeleters finalState - deps = memStateDeps finalState - in -- (trace ("Delete these: " ++ joinWithComma (map show (Set.toList deleteThese)))) $ - case finalObj of - Left err -> Left err - Right ok -> - let newInfo = fmap (\i -> i {infoDelete = deleteThese}) (xobjInfo ok) - in -- This final check of lifetimes works on the lifetimes mappings after analyzing the function form, and - -- after all the local variables in it have been deleted. This is needed for values that are created - -- directly in body position, e.g. (defn f [] &[1 2 3]) - case evalState (checkThatRefTargetIsAlive ok) (MemState (Set.fromList []) [] (memStateLifetimes finalState)) of - Left err -> Left err - Right _ -> Right (ok {xobjInfo = newInfo}, deps) - where - visit :: XObj -> State MemState (Either TypeError XObj) - visit xobj = - do - r <- case xobjObj xobj of - Lst _ -> visitList xobj - Arr _ -> visitArray xobj - StaticArr _ -> visitStaticArray xobj - Str _ -> do - manage xobj - addToLifetimesMappingsIfRef False xobj -- TODO: Should "internal = True" here? TODO: Possible to remove this one? - pure (Right xobj) - Pattern _ -> do - manage xobj - addToLifetimesMappingsIfRef False xobj -- TODO: Also possible to remove, *should* be superseeded by (***) below? - pure (Right xobj) - _ -> - pure (Right xobj) - case r of - Right ok -> do - MemState {} <- get - r' <- checkThatRefTargetIsAlive ok -- trace ("CHECKING " ++ pretty ok ++ " : " ++ showMaybeTy (ty xobj) ++ ", mappings: " ++ prettyLifetimeMappings m) $ - addToLifetimesMappingsIfRef True ok -- (***) - pure r' - Left err -> pure (Left err) - visitArray :: XObj -> State MemState (Either TypeError XObj) - visitArray xobj@(XObj (Arr arr) _ _) = - do - mapM_ visit arr - results <- mapM unmanage arr - case sequence results of - Left e -> pure (Left e) - Right _ -> - do - _ <- manage xobj -- TODO: result is discarded here, is that OK? - pure (Right xobj) - visitArray _ = error "Must visit array." - visitStaticArray :: XObj -> State MemState (Either TypeError XObj) - visitStaticArray xobj@(XObj (StaticArr arr) _ _) = - do - mapM_ visit arr - results <- mapM unmanage arr - case sequence results of - Left e -> pure (Left e) - Right _ -> - -- We know that we want to add a deleter for the static array here - do - let var = varOfXObj xobj - Just (RefTy t@(StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [_]) _) = xobjTy xobj - deleter = case nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [t] UnitTy StaticLifetimeTy) "delete" of - Just pathOfDeleteFunc -> - ProperDeleter pathOfDeleteFunc (getDropFunc (xobjInfo xobj) t) var - Nothing -> - error ("No deleter found for Static Array : " ++ show t) --Just (FakeDeleter var) - MemState deleters deps lifetimes <- get - let newDeleters = Set.insert deleter deleters - newDeps = deps ++ depsForDeleteFunc typeEnv globalEnv t - newState = MemState newDeleters newDeps lifetimes - put newState --(trace (show newState) newState) - pure (Right xobj) - visitStaticArray _ = error "Must visit static array." - visitList :: XObj -> State MemState (Either TypeError XObj) - visitList xobj@(XObj (Lst lst) i t) = - case lst of - [defn@(XObj (Defn maybeCaptures) _ _), nameSymbol@(XObj (Sym _ _) _ _), args@(XObj (Arr argList) _ _), body] -> - let captures = maybe [] Set.toList maybeCaptures - in --case defnReturnType of - -- RefTy _ _ -> - -- pure (Left (FunctionsCantReturnRefTy xobj funcTy)) - -- _ -> - do - mapM_ manage argList - -- Add the captured variables (if any, only happens in lifted lambdas) as fake deleters - -- TODO: Use another kind of Deleter for this case since it's pretty special? - mapM_ - ( ( \cap -> - modify - ( \memState -> - memState {memStateDeleters = Set.insert (FakeDeleter cap) (memStateDeleters memState)} - ) - ) - . getName - ) - captures - mapM_ (addToLifetimesMappingsIfRef False) argList - mapM_ (addToLifetimesMappingsIfRef False) captures -- For captured variables inside of lifted lambdas - visitedBody <- visit body - result <- unmanage body - pure $ - case result of - Left e -> Left e - Right _ -> - do - okBody <- visitedBody - pure (XObj (Lst [defn, nameSymbol, args, okBody]) i t) - -- Fn / λ (Lambda) - [fn@(XObj (Fn _ captures) _ _), args@(XObj (Arr _) _ _), body] -> - do - manage xobj -- manage inner lambdas but leave their bodies unvisited, they will be visited in the lifted version... - mapM_ unmanage captures - pure (Right (XObj (Lst [fn, args, body]) i t)) - -- Def - [def@(XObj Def _ _), nameSymbol@(XObj (Sym _ _) _ _), expr] -> - do - visitedExpr <- visit expr - result <- unmanage expr - pure $ - case result of - Left e -> Left e - Right () -> - do - okExpr <- visitedExpr - pure (XObj (Lst [def, nameSymbol, okExpr]) i t) - -- Let - [letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body] -> - do - MemState preDeleters _ _ <- get - visitedBindings <- mapM visitLetBinding (pairwise bindings) - visitedBody <- visit body - result <- unmanage body - case result of - Left e -> pure (Left e) - Right _ -> - do - MemState postDeleters deps postLifetimes <- get - let diff = postDeleters Set.\\ preDeleters - newInfo = setDeletersOnInfo i diff - survivors = postDeleters Set.\\ diff -- Same as just pre deleters, right?! - put (MemState survivors deps postLifetimes) - --trace ("LET Pre: " ++ show preDeleters ++ "\nPost: " ++ show postDeleters ++ "\nDiff: " ++ show diff ++ "\nSurvivors: " ++ show survivors) - manage xobj - pure $ do - okBody <- visitedBody - let finalBody = searchForInnerBreak diff okBody - okBindings <- fmap (concatMap (\(n, x) -> [n, x])) (sequence visitedBindings) - pure (XObj (Lst [letExpr, XObj (Arr okBindings) bindi bindt, finalBody]) newInfo t) - -- Set! - [setbangExpr@(XObj SetBang _ _), variable, value] -> - let varInfo = xobjInfo variable - correctVariableAndMode = - case variable of - -- DISABLE FOR NOW: (XObj (Lst (XObj (Sym (SymPath _ "copy") _) _ _ : symObj@(XObj (Sym _ _) _ _) : _)) _ _) -> Right symObj - symObj@(XObj (Sym _ mode) _ _) -> Right (symObj, mode) - anythingElse -> Left (CannotSet anythingElse) - in case correctVariableAndMode of - Left err -> - pure (Left err) - Right (okCorrectVariable, okMode) -> - do - MemState preDeleters _ _ <- get - let ownsTheVarBefore = case createDeleter okCorrectVariable of - Nothing -> Right () - Just d -> - if Set.member d preDeleters || isLookupGlobal okMode - then Right () - else Left (UsingUnownedValue variable) - visitedValue <- visit value - _ <- unmanage value -- The assigned value can't be used anymore - MemState managed _ _ <- get - -- Delete the value previously stored in the variable, if it's still alive - let deleters = case createDeleter okCorrectVariable of - Just d -> Set.fromList [d] - Nothing -> Set.empty - newVariable = - case okMode of - Symbol -> error "How to handle this?" - LookupLocal _ -> - if Set.size (Set.intersection managed deleters) == 1 -- The variable is still alive - then variable {xobjInfo = setDeletersOnInfo varInfo deleters} - else variable -- don't add the new info = no deleter - LookupGlobal _ _ -> - variable {xobjInfo = setDeletersOnInfo varInfo deleters} - _ -> error "managememory set! 1" - -- traceDeps = trace ("SET!-deleters for " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ ":\n" ++ - -- "unmanaged " ++ pretty value ++ "\n" ++ - -- "managed: " ++ show managed ++ "\n" ++ - -- "deleters: " ++ show deleters ++ "\n") - - case okMode of - Symbol -> error "Should only be be a global/local lookup symbol." - LookupLocal _ -> manage okCorrectVariable - LookupGlobal _ _ -> pure () - _ -> error "managememory set! 2" - pure $ case okMode of - LookupLocal (Capture _) -> - Left (CannotSetVariableFromLambda variable setbangExpr) - _ -> - do - okValue <- visitedValue - _ <- ownsTheVarBefore -- Force Either to fail - pure (XObj (Lst [setbangExpr, newVariable, okValue]) i t) - [theExpr@(XObj The _ _), typeXObj, value] -> - do - visitedValue <- visit value - result <- transferOwnership value xobj - pure $ case result of - Left e -> Left e - Right _ -> do - okValue <- visitedValue - pure (XObj (Lst [theExpr, typeXObj, okValue]) i t) - [refExpr@(XObj Ref _ _), value] -> - do - visited <- visit value - case visited of - Left e -> pure (Left e) - Right visitedValue -> - do - checkResult <- refCheck visitedValue - case checkResult of - Left e -> pure (Left e) - Right () -> do - let reffed = XObj (Lst [refExpr, visitedValue]) i t - pure $ Right reffed - (XObj Deref _ _ : _) -> - error "Shouldn't end up here, deref only works when calling a function, i.e. ((deref f) 1 2 3)." - doExpr@(XObj Do _ _) : expressions -> - do - visitedExpressions <- mapM visit expressions - result <- transferOwnership (last expressions) xobj - pure $ case result of - Left e -> Left e - Right _ -> do - okExpressions <- sequence visitedExpressions - pure (XObj (Lst (doExpr : okExpressions)) i t) - [whileExpr@(XObj While _ _), expr, body] -> - do - MemState preDeleters _ _ <- get - visitedExpr <- visit expr - MemState afterExprDeleters _ _ <- get - visitedBody <- visit body - manage body - MemState postDeleters deps postLifetimes <- get - -- Visit an extra time to simulate repeated use - visitedExpr2 <- visit expr - visitedBody2 <- visit body - let diff = postDeleters \\ preDeleters - put (MemState (postDeleters \\ diff) deps postLifetimes) -- Same as just pre deleters, right?! - pure $ do - okExpr <- visitedExpr - okBody <- visitedBody - _ <- visitedExpr2 -- This evaluates the second visit so that it actually produces the error - _ <- visitedBody2 -- And this one too. Laziness FTW. - let newInfo = setDeletersOnInfo i diff - -- Also need to set deleters ON the expression (for first run through the loop) - XObj objExpr objInfo objTy = okExpr - newExprInfo = setDeletersOnInfo objInfo (afterExprDeleters \\ preDeleters) - newExpr = XObj objExpr newExprInfo objTy - finalBody = searchForInnerBreak diff okBody - pure (XObj (Lst [whileExpr, newExpr, finalBody]) newInfo t) - [ifExpr@(XObj If _ _), expr, ifTrue, ifFalse] -> - do - visitedExpr <- visit expr - MemState preDeleters deps lifetimes <- get - let (visitedTrue, stillAliveTrue) = - runState - ( do - v <- visit ifTrue - result <- transferOwnership ifTrue xobj - pure $ case result of - Left e -> error (show e) - Right () -> v - ) - (MemState preDeleters deps lifetimes) - (visitedFalse, stillAliveFalse) = - runState - ( do - v <- visit ifFalse - result <- transferOwnership ifFalse xobj - pure $ case result of - Left e -> error (show e) - Right () -> v - ) - (MemState preDeleters deps lifetimes) - let deletedInTrue = preDeleters \\ memStateDeleters stillAliveTrue - deletedInFalse = preDeleters \\ memStateDeleters stillAliveFalse - deletedInBoth = Set.intersection deletedInTrue deletedInFalse - createdInTrue = memStateDeleters stillAliveTrue \\ preDeleters - createdInFalse = memStateDeleters stillAliveFalse \\ preDeleters - selfDeleter = case createDeleter xobj of - Just ok -> Set.fromList [ok] - Nothing -> Set.empty - createdAndDeletedInTrue = createdInTrue \\ selfDeleter - createdAndDeletedInFalse = createdInFalse \\ selfDeleter - delsTrue = Set.union (deletedInFalse \\ deletedInBoth) createdAndDeletedInTrue - delsFalse = Set.union (deletedInTrue \\ deletedInBoth) createdAndDeletedInFalse - stillAliveAfter = preDeleters \\ Set.union deletedInTrue deletedInFalse - depsAfter = memStateDeps stillAliveTrue ++ memStateDeps stillAliveFalse ++ deps -- Note: This merges all previous deps and the new ones, could be optimized..?! - - -- traceDeps = trace ("IF-deleters for " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " " ++ identifierStr xobj ++ ":\n" ++ - -- "preDeleters: " ++ show preDeleters ++ "\n" ++ - -- "stillAliveTrue: " ++ show (memStateDeleters stillAliveTrue) ++ "\n" ++ - -- "stillAliveFalse: " ++ show (memStateDeleters stillAliveFalse) ++ "\n" ++ - -- "createdInTrue: " ++ show createdInTrue ++ "\n" ++ - -- "createdInFalse: " ++ show createdInFalse ++ "\n" ++ - -- "createdAndDeletedInTrue: " ++ show createdAndDeletedInTrue ++ "\n" ++ - -- "createdAndDeletedInFalse: " ++ show createdAndDeletedInFalse ++ "\n" ++ - -- "deletedInTrue: " ++ show deletedInTrue ++ "\n" ++ - -- "deletedInFalse: " ++ show deletedInFalse ++ "\n" ++ - -- "deletedInBoth: " ++ show deletedInBoth ++ "\n" ++ - -- "delsTrue: " ++ show delsTrue ++ "\n" ++ - -- "delsFalse: " ++ show delsFalse ++ "\n" ++ - -- "stillAlive: " ++ show stillAliveAfter ++ "\n" ++ - -- "depsAfter: " ++ show depsAfter ++ "\n" - -- ) - - put (MemState stillAliveAfter depsAfter lifetimes) - manage xobj - pure $ do - okExpr <- visitedExpr - okTrue <- visitedTrue - okFalse <- visitedFalse - pure (XObj (Lst [ifExpr, okExpr, del okTrue delsTrue, del okFalse delsFalse]) i t) - matchExpr@(XObj (Match _) _ _) : expr : cases -> - -- General idea of how to figure out what to delete in a 'match' statement: - -- 1. Visit each case and investigate which variables are deleted in each one of the cases - -- 2. Variables deleted in at least one case has to be deleted in all, so make a union U of all such vars - -- but remove the ones that were not present before the 'match' - -- 3. In each case - take the intersection of U and the vars deleted in that case and add this result to its deleters - do - visitedExpr <- visit expr - case visitedExpr of - Left e -> pure (Left e) - Right okVisitedExpr -> - do - _ <- unmanage okVisitedExpr - MemState preDeleters deps lifetimes <- get - vistedCasesAndDeps <- mapM visitMatchCase (pairwise cases) - case sequence vistedCasesAndDeps of - Left e -> pure (Left e) - Right okCasesAndDeps -> - let visitedCases = map fst okCasesAndDeps - depsFromCases = concatMap snd okCasesAndDeps - (finalXObj, postDeleters) = figureOutStuff okVisitedExpr visitedCases preDeleters - in do - put (MemState postDeleters (deps ++ depsFromCases) lifetimes) - manage xobj - pure (Right finalXObj) - where - figureOutStuff :: - XObj -> - [(Set.Set Deleter, (XObj, XObj))] -> - Set.Set Deleter -> - (XObj, Set.Set Deleter) - figureOutStuff okVisitedExpr visitedCasesWithDeleters preDeleters = - let postDeleters = map fst visitedCasesWithDeleters - -- postDeletersUnion = unionOfSetsInList postDeleters - postDeletersIntersection = intersectionOfSetsInList postDeleters - deletersAfterTheMatch = Set.intersection preDeleters postDeletersIntersection - -- The "postDeletersUnionPreExisting" are the vars that existed before the match but needs to - -- be deleted after it has executed (because some branches delete them) - -- postDeletersUnionPreExisting = Set.intersection postDeletersUnion preDeleters - deletersForEachCase = map (\\ deletersAfterTheMatch) postDeleters - -- These are the surviving vars after the 'match' expression: - - okVisitedCases = map snd visitedCasesWithDeleters - okVisitedCasesWithAllDeleters = - zipWith - ( \(lhs, rhs) finalSetOfDeleters -> - -- Putting the deleter info on the lhs, - -- because the right one can collide with - -- the other expressions, e.g. a 'let' - let newLhsInfo = setDeletersOnInfo (xobjInfo lhs) finalSetOfDeleters - in [lhs {xobjInfo = newLhsInfo}, rhs] - ) - okVisitedCases - deletersForEachCase - in -- trace ("post deleters: " ++ show postDeleters) - -- trace ("\npost deleters union: " ++ show postDeletersUnion) - -- trace ("\npost deleters intersection: " ++ show postDeletersIntersection) - -- trace ("Post deleters union pre-existing: " ++ show postDeletersUnionPreExisting) - -- trace ("Post deleters for each case: " ++ show postDeleters) - ( XObj (Lst ([matchExpr, okVisitedExpr] ++ concat okVisitedCasesWithAllDeleters)) i t, - deletersAfterTheMatch - ) - XObj (Lst [deref@(XObj Deref _ _), f]) xi xt : uargs -> - do - -- Do not visit f in this case, we don't want to manage it's memory since it is a ref! - visitedArgs <- sequence <$> mapM visitArg uargs - case visitedArgs of - Left err -> pure (Left err) - Right args -> - do - unmanagedArgs <- sequence <$> mapM unmanageArg args - manage xobj - pure $ do - okArgs <- unmanagedArgs - Right (XObj (Lst (XObj (Lst [deref, f]) xi xt : okArgs)) i t) - f : uargs -> - do - visitedF <- visit f - visitedArgs <- sequence <$> mapM visitArg uargs - case visitedArgs of - Left err -> pure (Left err) - Right args -> do - unmanagedArgs <- sequence <$> mapM unmanageArg args - manage xobj - pure $ do - okF <- visitedF - okArgs <- unmanagedArgs - Right (XObj (Lst (okF : okArgs)) i t) - [] -> pure (Right xobj) - visitList _ = error "Must visit list." - searchForInnerBreak :: Set.Set Deleter -> XObj -> XObj - searchForInnerBreak diff (XObj (Lst [(XObj Break i' t')]) xi xt) = - let ni = addDeletersToInfo i' diff - in XObj (Lst [(XObj Break ni t')]) xi xt - searchForInnerBreak _ x@(XObj (Lst ((XObj While _ _) : _)) _ _) = x - searchForInnerBreak diff (XObj (Lst elems) i' t') = - let newElems = map (searchForInnerBreak diff) elems - in XObj (Lst newElems) i' t' - searchForInnerBreak _ e = e - visitMatchCase :: (XObj, XObj) -> State MemState (Either TypeError ((Set.Set Deleter, (XObj, XObj)), [XObj])) - visitMatchCase (lhs@XObj {}, rhs@XObj {}) = - do - MemState preDeleters _ _ <- get - _ <- visitCaseLhs lhs - visitedRhs <- visit rhs - _ <- unmanage rhs - MemState postDeleters postDeps postLifetimes <- get - -- let diff = postDeleters \\ preDeleters - put (MemState preDeleters postDeps postLifetimes) -- Restore managed variables, TODO: Use a "local" state monad instead? - pure $ do - okVisitedRhs <- visitedRhs - -- trace ("\npre: " ++ show preDeleters ++ - -- "\npost: " ++ show postDeleters ++ - -- "\ndiff: " ++ show diff) - -- $ - pure ((postDeleters, (lhs, okVisitedRhs)), postDeps) - visitCaseLhs :: XObj -> State MemState (Either TypeError [()]) - visitCaseLhs (XObj (Lst vars) _ _) = - do - result <- mapM visitCaseLhs vars - let result' = sequence result - pure (fmap concat result') - visitCaseLhs xobj@(XObj (Sym (SymPath _ name) _) _ _) - | isVarName name = do - manage xobj - pure (Right []) - | otherwise = pure (Right []) - visitCaseLhs (XObj Ref _ _) = - pure (Right []) - visitCaseLhs x = - error ("Unhandled: " ++ show x) - addToLifetimesMappingsIfRef :: Bool -> XObj -> State MemState () - addToLifetimesMappingsIfRef internal xobj = - case xobjTy xobj of - Just (RefTy _ (VarTy lt)) -> - do - m@(MemState _ _ lifetimes) <- get - case Map.lookup lt lifetimes of - Just _ -> - --trace ("\nThere is already a mapping for '" ++ pretty xobj ++ "' from the lifetime '" ++ lt ++ "' to " ++ show existing ++ ", won't add " ++ show (makeLifetimeMode xobj)) $ - pure () - Nothing -> - do - let lifetimes' = Map.insert lt makeLifetimeMode lifetimes - put $ --(trace $ "\nExtended lifetimes mappings for '" ++ pretty xobj ++ "' with " ++ show lt ++ " => " ++ show (makeLifetimeMode xobj) ++ " at " ++ prettyInfoFromXObj xobj ++ ":\n" ++ prettyLifetimeMappings lifetimes') $ - m {memStateLifetimes = lifetimes'} - pure () - Just _ -> - --trace ("Won't add to mappings! " ++ pretty xobj ++ " : " ++ show notThisType ++ " at " ++ prettyInfoFromXObj xobj) $ - pure () - _ -> - --trace ("No type on " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj) $ - pure () - where - makeLifetimeMode = - if internal - then LifetimeInsideFunction $ - case xobj of - XObj (Lst [XObj Ref _ _, target]) _ _ -> varOfXObj target - _ -> varOfXObj xobj - else LifetimeOutsideFunction - checkThatRefTargetIsAlive :: XObj -> State MemState (Either TypeError XObj) - checkThatRefTargetIsAlive xobj = - -- TODO: Replace this whole thing with a function that collects all lifetime variables in a type. - case xobjTy xobj of - Just (RefTy _ (VarTy lt)) -> - performCheck lt - Just (FuncTy _ _ (VarTy lt)) -> - performCheck lt - -- HACK (not exhaustive): - Just (FuncTy _ (RefTy _ (VarTy lt)) _) -> - performCheck lt - _ -> - pure -- trace ("Won't check " ++ pretty xobj ++ " : " ++ show (ty xobj)) - (Right xobj) - where - performCheck :: String -> State MemState (Either TypeError XObj) - performCheck lt = - do - MemState deleters _ lifetimeMappings <- get - case Map.lookup lt lifetimeMappings of - Just (LifetimeInsideFunction deleterName) -> - let matchingDeleters = - Set.toList $ - Set.filter - ( \case - ProperDeleter {deleterVariable = dv} -> dv == deleterName - FakeDeleter {deleterVariable = dv} -> dv == deleterName - PrimDeleter {aliveVariable = dv} -> dv == deleterName - RefDeleter {refVariable = dv} -> dv == deleterName - ) - deleters - in case matchingDeleters of - [] -> - --trace ("Can't use reference " ++ pretty xobj ++ " (with lifetime '" ++ lt ++ "', depending on " ++ show deleterName ++ ") at " ++ prettyInfoFromXObj xobj ++ ", it's not alive here:\n" ++ show xobj ++ "\nMappings: " ++ prettyLifetimeMappings lifetimeMappings ++ "\nAlive: " ++ show deleters ++ "\n") $ - --pure (Right xobj) - pure (Left (UsingDeadReference xobj deleterName)) - _ -> - --trace ("CAN use reference " ++ pretty xobj ++ " (with lifetime '" ++ lt ++ "', depending on " ++ show deleterName ++ ") at " ++ prettyInfoFromXObj xobj ++ ", it's not alive here:\n" ++ show xobj ++ "\nMappings: " ++ prettyLifetimeMappings lifetimeMappings ++ "\nAlive: " ++ show deleters ++ "\n") $ - pure (Right xobj) - Just LifetimeOutsideFunction -> - --trace ("Lifetime OUTSIDE function: " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj) $ - pure (Right xobj) - Nothing -> - pure (Right xobj) - -- case xobj of - -- XObj (Sym _ (LookupLocal Capture)) _ _ -> - -- -- Ignore these for the moment! TODO: FIX!!! - -- pure (Right xobj) - -- _ -> - -- trace ("Failed to find lifetime key (when checking) '" ++ lt ++ "' for " ++ pretty xobj ++ " in mappings at " ++ prettyInfoFromXObj xobj) $ - -- pure (Right xobj) - - visitLetBinding :: (XObj, XObj) -> State MemState (Either TypeError (XObj, XObj)) - visitLetBinding (name, expr) = - do - visitedExpr <- visit expr - addToLifetimesMappingsIfRef True expr - result <- transferOwnership expr name - pure $ case result of - Left e -> Left e - Right _ -> do - okExpr <- visitedExpr - pure (name, okExpr) - visitArg :: XObj -> State MemState (Either TypeError XObj) - visitArg xobj@(XObj _ _ (Just _)) = - do - afterVisit <- visit xobj - case afterVisit of - Right okAfterVisit -> do - addToLifetimesMappingsIfRef True okAfterVisit - pure (Right okAfterVisit) - Left err -> pure (Left err) - visitArg xobj@XObj {} = - visit xobj - unmanageArg :: XObj -> State MemState (Either TypeError XObj) - unmanageArg xobj@(XObj _ _ (Just t)) = - if isManaged typeEnv globalEnv t - then do - r <- unmanage xobj - pure $ case r of - Left err -> Left err - Right () -> Right xobj - else pure (Right xobj) - unmanageArg xobj@XObj {} = - pure (Right xobj) - getDropFunc i t = nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [RefTy t (VarTy (makeTypeVariableNameFromInfo i))] UnitTy StaticLifetimeTy) "drop" - createDeleter xobj = - case xobjTy xobj of - Just (RefTy _ _) -> Just (RefDeleter (varOfXObj xobj)) - Just t -> - let var = varOfXObj xobj - in if isManaged typeEnv globalEnv t - then case nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [t] UnitTy StaticLifetimeTy) "delete" of - Just pathOfDeleteFunc -> - Just (ProperDeleter pathOfDeleteFunc (getDropFunc (xobjInfo xobj) t) var) - Nothing -> - --trace ("Found no delete function for " ++ var ++ " : " ++ (showMaybeTy (ty xobj))) - Just (FakeDeleter var) - else Just (PrimDeleter var) - Nothing -> error ("No type, can't manage " ++ show xobj) - manage :: XObj -> State MemState () - manage xobj = - if isSymbolThatCaptures xobj -- When visiting lifted lambdas, don't manage symbols that capture (they are owned by the environment). - then pure () - else case createDeleter xobj of - Just deleter -> do - MemState deleters deps lifetimes <- get - let newDeleters = Set.insert deleter deleters - Just t = xobjTy xobj - newDeps = deps ++ depsForDeleteFunc typeEnv globalEnv t - put (MemState newDeleters newDeps lifetimes) - Nothing -> pure () - deletersMatchingXObj :: XObj -> Set.Set Deleter -> [Deleter] - deletersMatchingXObj xobj deleters = - let var = varOfXObj xobj - in Set.toList $ - Set.filter - ( \case - ProperDeleter {deleterVariable = dv} -> dv == var - FakeDeleter {deleterVariable = dv} -> dv == var - PrimDeleter {aliveVariable = dv} -> dv == var - RefDeleter {refVariable = dv} -> dv == var - ) - deleters - isSymbolThatCaptures :: XObj -> Bool - isSymbolThatCaptures xobj = - case xobj of - XObj (Sym _ (LookupLocal (Capture _))) _ _ -> True - _ -> False - unmanage :: XObj -> State MemState (Either TypeError ()) - unmanage xobj = - let Just t = xobjTy xobj - in if isManaged typeEnv globalEnv t && not (isGlobalFunc xobj) - then do - MemState deleters deps lifetimes <- get - case deletersMatchingXObj xobj deleters of - [] -> - pure $ - if isSymbolThatCaptures xobj - then Left (UsingCapturedValue xobj) - else Left (UsingUnownedValue xobj) - [one] -> - let newDeleters = Set.delete one deleters - in do - put (MemState newDeleters deps lifetimes) - pure (Right ()) - tooMany -> error ("Too many variables with the same name in set: " ++ show tooMany) - else pure (Right ()) - refCheck :: XObj -> State MemState (Either TypeError ()) - refCheck xobj = - let Just t = xobjTy xobj - isGlobalVariable = case xobj of - XObj (Sym _ (LookupGlobal _ _)) _ _ -> True - _ -> False - in if not isGlobalVariable && not (isGlobalFunc xobj) && isManaged typeEnv globalEnv t && not (isSymbolThatCaptures xobj) -- TODO: The 'isManaged typeEnv t' boolean check should be removed! - then do - MemState deleters _ _ <- get - pure $ case deletersMatchingXObj xobj deleters of - [] -> Left (GettingReferenceToUnownedValue xobj) - [_] -> pure () - _ -> error $ "Too many variables with the same name in set (was looking for " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ ")" - else pure (pure ()) - transferOwnership :: XObj -> XObj -> State MemState (Either TypeError ()) - transferOwnership from to = - do - result <- unmanage from - case result of - Left e -> pure (Left e) - Right _ -> do - manage to --(trace ("Transfered from " ++ getName from ++ " '" ++ varOfXObj from ++ "' to " ++ getName to ++ " '" ++ varOfXObj to ++ "'") to) - pure (Right ()) - -varOfXObj :: XObj -> String -varOfXObj xobj = - case xobj of - XObj (Sym path _) _ _ -> pathToC path - _ -> case xobjInfo xobj of - Just i -> freshVar i - Nothing -> error ("Missing info on " ++ show xobj) - -suffixTyVars :: String -> Ty -> Ty -suffixTyVars suffix t = - case t of - VarTy key -> VarTy (key ++ suffix) - FuncTy argTys retTy ltTy -> FuncTy (map (suffixTyVars suffix) argTys) (suffixTyVars suffix retTy) (suffixTyVars suffix ltTy) - StructTy name tyArgs -> StructTy name (fmap (suffixTyVars suffix) tyArgs) - PointerTy x -> PointerTy (suffixTyVars suffix x) - RefTy x lt -> RefTy (suffixTyVars suffix x) (suffixTyVars suffix lt) - _ -> t - --- | The following functions will generate deleters and copy:ing methods for structs, they are shared with the Deftype module -data AllocationMode = StackAlloc | HeapAlloc - -- | The template for the 'delete' function of a concrete deftype. concreteDelete :: TypeEnv -> Env -> [(String, Ty)] -> Template concreteDelete typeEnv env members = @@ -1661,6 +859,18 @@ concreteCopy typeEnv env memberPairs = (filter (isManaged typeEnv env) (map snd memberPairs)) ) +concreteCopyPtr :: TypeEnv -> Env -> [(String, Ty)] -> Template +concreteCopyPtr typeEnv env memberPairs = + Template + (FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy) + (const (toTemplate "$p* $NAME($p* pRef)")) + (const (tokensForCopyPtr typeEnv env memberPairs)) + ( \_ -> + concatMap + (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType) + (filter (isManaged typeEnv env) (map snd memberPairs)) + ) + tokensForCopy :: TypeEnv -> Env -> [(String, Ty)] -> [Token] tokensForCopy typeEnv env memberPairs = toTemplate $ @@ -1682,18 +892,6 @@ memberCopy typeEnv env (memberName, memberType) = FunctionNotFound msg -> error msg FunctionIgnored -> " /* Ignore non-managed member '" ++ memberName ++ "' : " ++ show memberType ++ " */" -concreteCopyPtr :: TypeEnv -> Env -> [(String, Ty)] -> Template -concreteCopyPtr typeEnv env memberPairs = - Template - (FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy) - (const (toTemplate "$p* $NAME($p* pRef)")) - (const (tokensForCopyPtr typeEnv env memberPairs)) - ( \_ -> - concatMap - (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType) - (filter (isManaged typeEnv env) (map snd memberPairs)) - ) - tokensForCopyPtr :: TypeEnv -> Env -> [(String, Ty)] -> [Token] tokensForCopyPtr typeEnv env memberPairs = toTemplate $ @@ -1713,3 +911,13 @@ memberCopyPtr typeEnv env (memberName, memberType) = " copy->" ++ memberName ++ " = " ++ functionFullName ++ "(&(pRef->" ++ memberName ++ "));" FunctionNotFound msg -> error msg FunctionIgnored -> " /* Ignore non-managed member '" ++ memberName ++ "' : " ++ show memberType ++ " */" + +suffixTyVars :: String -> Ty -> Ty +suffixTyVars suffix t = + case t of + VarTy key -> VarTy (key ++ suffix) + FuncTy argTys retTy ltTy -> FuncTy (map (suffixTyVars suffix) argTys) (suffixTyVars suffix retTy) (suffixTyVars suffix ltTy) + StructTy name tyArgs -> StructTy name (fmap (suffixTyVars suffix) tyArgs) + PointerTy x -> PointerTy (suffixTyVars suffix x) + RefTy x lt -> RefTy (suffixTyVars suffix x) (suffixTyVars suffix lt) + _ -> t diff --git a/src/Eval.hs b/src/Eval.hs index 3b93f64c..c2fbe77c 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -17,6 +17,7 @@ import Emit import qualified Env as E import EvalError import Expand +import Forms import Infer import Info import qualified Map @@ -35,7 +36,6 @@ import TypeError import Types import Util import Prelude hiding (exp, mod) -import Forms -- TODO: Formalize "lookup order preference" a bit better and move into -- the Context module. @@ -190,21 +190,21 @@ eval ctx xobj@(XObj o info ty) preference resolver = Left e -> pure (evalError ctx (format e) (xobjInfo xobj)) Right form' -> case form' of - (IfPat _ _ _) -> evaluateIf form' - (DefnPat _ _ _) -> specialCommandDefine ctx xobj - (DefPat _ _) -> specialCommandDefine ctx xobj + (IfPat _ _ _ _) -> evaluateIf form' + (DefnPat _ _ _ _) -> specialCommandDefine ctx xobj + (DefPat _ _ _) -> specialCommandDefine ctx xobj (ThePat _ _ _) -> evaluateThe form' - (LetPat _ _) -> evaluateLet form' + (LetPat _ _ _) -> evaluateLet form' (FnPat _ _ _) -> evaluateFn form' (AppPat (ClosurePat _ _ _) _) -> evaluateClosure form' (AppPat (DynamicFnPat _ _ _) _) -> evaluateDynamicFn form' (AppPat (MacroPat _ _ _) _) -> evaluateMacro form' (AppPat (CommandPat _ _ _) _) -> evaluateCommand form' (AppPat (PrimitivePat _ _ _) _) -> evaluatePrimitive form' - (WithPat (SymPat sym path) forms) -> specialCommandWith ctx sym path forms - (DoPat forms) -> evaluateSideEffects forms - (WhilePat cond body) -> specialCommandWhile ctx cond body - (SetPat iden value) -> specialCommandSet ctx (iden:[value]) + (WithPat _ sym@(SymPat path) forms) -> specialCommandWith ctx sym path forms + (DoPat _ forms) -> evaluateSideEffects forms + (WhilePat _ cond body) -> specialCommandWhile ctx cond body + (SetPat _ iden value) -> specialCommandSet ctx (iden : [value]) -- This next match is a bit redundant looking at first glance, but -- it is necessary to prevent hangs on input such as: `((def foo 2) -- 4)`. Ideally, we could perform only *one* static check (the one @@ -218,15 +218,16 @@ eval ctx xobj@(XObj o info ty) preference resolver = -- Importantly, the loop *is only broken on literal nested lists*. -- That is, passing a *symbol* that, e.g. resolves to a defn list, won't -- break our normal loop. - (AppPat (ListPat self ((SymPat x _):_)) args) -> - do (_, evald) <- eval ctx x preference ResolveGlobal - case evald of - Left err -> pure (evalError ctx (show err) (xobjInfo xobj)) - Right x' -> case checkStatic' x' of - Right _ -> evaluateApp (self:args) - Left er -> pure (evalError ctx (show er) (xobjInfo xobj)) - (AppPat (ListPat _ _) _) -> evaluateApp form' - (AppPat (SymPat _ _) _) -> evaluateApp form' + (AppPat self@(ListPat (x@(SymPat _) : _)) args) -> + do + (_, evald) <- eval ctx x preference ResolveGlobal + case evald of + Left err -> pure (evalError ctx (show err) (xobjInfo xobj)) + Right x' -> case checkStatic' x' of + Right _ -> evaluateApp (self : args) + Left er -> pure (evalError ctx (show er) (xobjInfo xobj)) + (AppPat (ListPat _) _) -> evaluateApp form' + (AppPat (SymPat _) _) -> evaluateApp form' [] -> pure (ctx, dynamicNil) _ -> pure (throwErr (UnknownForm xobj) ctx (xobjInfo xobj)) checkStatic' (XObj Def _ _) = Left (HasStaticCall xobj info) @@ -248,7 +249,7 @@ eval ctx xobj@(XObj o info ty) preference resolver = Left err -> (newCtx, Left err) evaluateIf :: Evaluator - evaluateIf (IfPat cond true false) = do + evaluateIf (IfPat _ cond true false) = do (newCtx, evd) <- eval ctx cond preference ResolveLocal case evd of Right cond' -> @@ -263,15 +264,15 @@ eval ctx xobj@(XObj o info ty) preference resolver = evaluateThe (ThePat the t value) = do (newCtx, evaledValue) <- expandAll (evalDynamic ResolveLocal) ctx value -- TODO: Why expand all here? pure - ( newCtx, - do - okValue <- evaledValue - Right (XObj (Lst [the, t, okValue]) info ty) - ) + ( newCtx, + do + okValue <- evaledValue + Right (XObj (Lst [the, t, okValue]) info ty) + ) evaluateThe _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) evaluateLet :: Evaluator - evaluateLet (LetPat (ArrPat _ bindings) body) = do + evaluateLet (LetPat _ (ArrPat bindings) body) = do let binds = unwrapVar (pairwise bindings) [] ni = Env Map.empty (contextInternalEnv ctx) Nothing Set.empty InternalEnv 0 eitherCtx <- foldrM successiveEval' (Right (replaceInternalEnv ctx ni)) binds @@ -398,16 +399,18 @@ eval ctx xobj@(XObj o info ty) preference resolver = evaluateApp :: Evaluator evaluateApp (AppPat f' args) = case f' of - (ListPat l _) -> go l ResolveLocal - (SymPat sym _) -> go sym resolver + l@(ListPat _) -> go l ResolveLocal + sym@(SymPat _) -> go sym resolver _ -> pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) - where go x resolve = - do (newCtx, f) <- eval ctx x preference resolve - case f of - Right fun -> do - (newCtx', res) <- eval (pushFrame newCtx xobj) (XObj (Lst (fun : args)) (xobjInfo x) (xobjTy x)) preference ResolveLocal - pure (popFrame newCtx', res) - x' -> pure (newCtx, x') + where + go x resolve = + do + (newCtx, f) <- eval ctx x preference resolve + case f of + Right fun -> do + (newCtx', res) <- eval (pushFrame newCtx xobj) (XObj (Lst (fun : args)) (xobjInfo x) (xobjTy x)) preference ResolveLocal + pure (popFrame newCtx', res) + x' -> pure (newCtx, x') evaluateApp _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) evaluateSideEffects :: Evaluator diff --git a/src/Forms.hs b/src/Forms.hs index a731d7b3..f03b0d7d 100644 --- a/src/Forms.hs +++ b/src/Forms.hs @@ -4,36 +4,39 @@ -- unchecked forms (xobjs). -- -- It defines a number of pattern synonyms for ease of pattern matching. -module Forms ( - validate, - format, - Malformed(GenericMalformed), - pattern ArrPat, - pattern ListPat, - pattern SymPat, - pattern UnqualifiedSymPat, - pattern DefPat, - pattern DefnPat, - pattern IfPat, - pattern ThePat, - pattern LetPat, - pattern FnPat, - pattern ClosurePat, - pattern DynamicFnPat, - pattern MacroPat, - pattern CommandPat, - pattern PrimitivePat, - pattern AppPat, - pattern WithPat, - pattern DoPat, - pattern WhilePat, - pattern SetPat, - ) where +module Forms + ( validate, + format, + Malformed (GenericMalformed), + pattern ArrPat, + pattern StaticArrPat, + pattern ListPat, + pattern SymPat, + pattern UnqualifiedSymPat, + pattern DefPat, + pattern DefnPat, + pattern IfPat, + pattern ThePat, + pattern RefPat, + pattern LetPat, + pattern FnPat, + pattern ClosurePat, + pattern DynamicFnPat, + pattern MacroPat, + pattern CommandPat, + pattern PrimitivePat, + pattern AppPat, + pattern WithPat, + pattern DoPat, + pattern WhilePat, + pattern SetPat, + ) +where +import Data.List (intercalate) import Obj import SymPath import Util -import Data.List (intercalate) -------------------------------------------------------------------------------- -- Data @@ -41,19 +44,20 @@ import Data.List (intercalate) -- Specialized constructors for each built-in language form. -- | Error type representing a generic malformed expression. -data Malformed = InvalidIdentifier XObj Modifier - | QualifiedIdentifier XObj Modifier - | GenericMalformed XObj - | InvalidArguments XObj Modifier - | InvalidBody XObj Modifier - | InvalidCondition XObj Modifier - | InvalidType XObj Modifier - | InvalidBindings XObj Modifier - | UnevenForms XObj Int Modifier - | InsufficientArguments XObj Int Int [XObj] - | TooManyArguments XObj Int Int [XObj] - | InvalidApplication XObj - | DoMissingForms +data Malformed + = InvalidIdentifier XObj Modifier + | QualifiedIdentifier XObj Modifier + | GenericMalformed XObj + | InvalidArguments XObj Modifier + | InvalidBody XObj Modifier + | InvalidCondition XObj Modifier + | InvalidType XObj Modifier + | InvalidBindings XObj Modifier + | UnevenForms XObj Int Modifier + | InsufficientArguments XObj Int Int [XObj] + | TooManyArguments XObj Int Int [XObj] + | InvalidApplication XObj + | DoMissingForms instance Show Malformed where show (QualifiedIdentifier x modifier) = @@ -79,15 +83,18 @@ instance Show Malformed where ++ formatModifier modifier show (UnevenForms forms len modifier) = "Expected an even number of forms, but got: " ++ pretty forms - ++ "of length " ++ show len ++ " " ++ formatModifier modifier + ++ "of length " + ++ show len + ++ " " + ++ formatModifier modifier show (InsufficientArguments form lenExpected lenRecieved params) = let name = case form of - (DynamicFnPat sym _ _) -> getName sym - (MacroPat sym _ _) -> getName sym - (CommandPat _ sym _) -> getName sym - (PrimitivePat _ sym _) -> getName sym - XObj Ref _ _ -> "ref" - _ -> pretty form + (DynamicFnPat sym _ _) -> getName sym + (MacroPat sym _ _) -> getName sym + (CommandPat _ sym _) -> getName sym + (PrimitivePat _ sym _) -> getName sym + XObj Ref _ _ -> "ref" + _ -> pretty form in name ++ " expected " ++ show lenExpected ++ " arguments but received only " @@ -97,12 +104,12 @@ instance Show Malformed where ++ " as well." show (TooManyArguments form lenExpected lenRecieved args) = let name = case form of - (DynamicFnPat sym _ _) -> getName sym - (MacroPat sym _ _) -> getName sym - (CommandPat _ sym _) -> getName sym - (PrimitivePat _ sym _) -> getName sym - XObj Ref _ _ -> "ref" - _ -> pretty form + (DynamicFnPat sym _ _) -> getName sym + (MacroPat sym _ _) -> getName sym + (CommandPat _ sym _) -> getName sym + (PrimitivePat _ sym _) -> getName sym + XObj Ref _ _ -> "ref" + _ -> pretty form in name ++ " expected " ++ show lenExpected ++ " arguments but received " @@ -118,40 +125,46 @@ instance Show Malformed where "The form: " ++ pretty x ++ " is malformed" -- | Specific errors for particular types of malformed expressions. -data Modifier = DefnQualifiedSyms XObj - | DefnNonArrayArgs XObj - | DefnNonSymArgs XObj - | IfInvalidCondition XObj - | WhileInvalidCondition XObj - | TheInvalidType XObj - | LetMalformedBinding XObj - | LetUnevenForms XObj - | LetNonArrayBindings XObj - | FnQualifiedSyms XObj - | FnNonArrayArgs XObj - | FnNonSymArgs XObj - | InvalidWith XObj - | None +data Modifier + = DefnQualifiedSyms XObj + | DefnNonArrayArgs XObj + | DefnNonSymArgs XObj + | IfInvalidCondition XObj + | WhileInvalidCondition XObj + | TheInvalidType XObj + | LetMalformedBinding XObj + | LetUnevenForms XObj + | LetNonArrayBindings XObj + | FnQualifiedSyms XObj + | FnNonArrayArgs XObj + | FnNonSymArgs XObj + | InvalidWith XObj + | None instance Show Modifier where show None = "" show (DefnQualifiedSyms arg) = "`defn` requires all of its arguments to be unqualified symbols, but the arugment: " - ++ pretty arg ++ " is qualified" + ++ pretty arg + ++ " is qualified" show (DefnNonArrayArgs args) = "`defn` requires an array of arugments, but it got: " ++ pretty args show (DefnNonSymArgs arg) = "`defn` requires an array of symbols as arguments, but the argument: " - ++ pretty arg ++ " is not a symbol" + ++ pretty arg + ++ " is not a symbol" show (IfInvalidCondition cond) = "`if` requires a condition that can be evaluated to a boolean, but it got: " - ++ pretty cond ++ " which cannot resolve to a boolean value." + ++ pretty cond + ++ " which cannot resolve to a boolean value." show (WhileInvalidCondition cond) = "`while` requires a condition that can be evaluated to a boolean, but it got: " - ++ pretty cond ++ " which cannot resolve to a boolean value." + ++ pretty cond + ++ " which cannot resolve to a boolean value." show (TheInvalidType t) = "`the` requires a valid type name, but it got: " - ++ pretty t ++ " which is not a valid type name" + ++ pretty t + ++ " which is not a valid type name" show (LetMalformedBinding bind) = "`let` requires name-value binding pairs, but it got: " ++ pretty bind ++ " as a binding name, which is invalid. Binding names must be symbols" @@ -161,12 +174,14 @@ instance Show Modifier where "`let` requires an array of bindings, but it got: " ++ pretty invalid show (FnQualifiedSyms arg) = "`fn` requires all of its arguments to be unqualified symbols, but the arugment: " - ++ pretty arg ++ " is qualified" + ++ pretty arg + ++ " is qualified" show (FnNonArrayArgs args) = "`fn` requires an array of arugments, but it got: " ++ pretty args show (FnNonSymArgs arg) = "`fn` requires an array of symbols as arguments, but the argument: " - ++ pretty arg ++ " is not a symbol" + ++ pretty arg + ++ " is not a symbol" show (InvalidWith x) = "`with` requires a symbol as an arugment, but got: " ++ pretty x @@ -185,15 +200,15 @@ format e = "[ERROR] " ++ show e validate :: [XObj] -> Either Malformed [XObj] validate xs = case xs of - DefPat _ _ -> validateDef xs - DefnPat _ _ _ -> validateDefn xs - IfPat _ _ _ -> validateIf xs + DefPat _ _ _ -> validateDef xs + DefnPat _ _ _ _ -> validateDefn xs + IfPat _ _ _ _ -> validateIf xs ThePat _ _ _ -> validateThe xs - LetPat _ _ -> validateLet xs + LetPat _ _ _ -> validateLet xs FnPat _ _ _ -> validateFn xs - WithPat _ _ -> validateWith xs - DoPat _ -> validateDo xs - WhilePat _ _ -> validateWhile xs + WithPat _ _ _ -> validateWith xs + DoPat _ _ -> validateDo xs + WhilePat _ _ _ -> validateWhile xs -- There are a number of application patterns (the "has static call patterns") -- that are formally caught at evaluation time. AppPat (ClosurePat _ _ _) _ -> validateApp xs @@ -208,9 +223,9 @@ validate xs = -- for truthiness But there is a class of list forms we can rule out purely -- symbolically, e.g. `def`, etc.. validateIf :: [XObj] -> Either Malformed [XObj] -validateIf x@(IfPat (ListPat _ _) _ _) = Right x -- needs further evaluation -validateIf (IfPat (ArrPat invalid _) _ _) = Left (InvalidCondition invalid (IfInvalidCondition invalid)) -validateIf x@(IfPat cond _ _) +validateIf x@(IfPat _ (ListPat _) _ _) = Right x -- needs further evaluation +validateIf (IfPat _ invalid@(ArrPat _) _ _) = Left (InvalidCondition invalid (IfInvalidCondition invalid)) +validateIf x@(IfPat _ cond _ _) | isSym cond = Right x -- needs further evaluation | isBool cond = Right x | otherwise = Left (InvalidCondition cond (IfInvalidCondition cond)) @@ -218,9 +233,9 @@ validateIf invalid = Left (GenericMalformed (XObj (Lst invalid) Nothing Nothing) -- | Validation of (while cond body) expressions. validateWhile :: [XObj] -> Either Malformed [XObj] -validateWhile x@(WhilePat (ListPat _ _) _) = Right x -- needs further evaluation -validateWhile (WhilePat (ArrPat invalid _) _) = Left (InvalidCondition invalid (WhileInvalidCondition invalid)) -validateWhile x@(WhilePat cond _) +validateWhile x@(WhilePat _ (ListPat _) _) = Right x -- needs further evaluation +validateWhile (WhilePat _ invalid@(ArrPat _) _) = Left (InvalidCondition invalid (WhileInvalidCondition invalid)) +validateWhile x@(WhilePat _ cond _) | isSym cond = Right x -- needs further evaluation | isBool cond = Right x | otherwise = Left (InvalidCondition cond (WhileInvalidCondition cond)) @@ -228,22 +243,22 @@ validateWhile invalid = Left (GenericMalformed (XObj (Lst invalid) Nothing Nothi -- | Validation of (def name value) expressions. validateDef :: [XObj] -> Either Malformed [XObj] -validateDef x@(DefPat (UnqualifiedSymPat _ _) _) = Right x -validateDef (DefPat (SymPat invalid _) _) = Left (QualifiedIdentifier invalid None) -validateDef (DefPat invalid _) = Left (InvalidIdentifier invalid None) +validateDef x@(DefPat _ (UnqualifiedSymPat _) _) = Right x +validateDef (DefPat _ invalid@(SymPat _) _) = Left (QualifiedIdentifier invalid None) +validateDef (DefPat _ invalid _) = Left (InvalidIdentifier invalid None) validateDef def = Left (GenericMalformed (XObj (Lst def) Nothing Nothing)) -- | Validation of (defn name [args] body) expressions. validateDefn :: [XObj] -> Either Malformed [XObj] -validateDefn x@(DefnPat (UnqualifiedSymPat _ _) (ArrPat arr args) _) +validateDefn x@(DefnPat _ (UnqualifiedSymPat _) arr@(ArrPat args) _) | not (all isSym args) = Left (InvalidArguments arr (DefnNonSymArgs (head (remove isSym args)))) | not (all isUnqualifiedSym args) = - Left (InvalidArguments arr (DefnQualifiedSyms (head (remove isUnqualifiedSym args)))) + Left (InvalidArguments arr (DefnQualifiedSyms (head (remove isUnqualifiedSym args)))) | otherwise = pure x -validateDefn (DefnPat (UnqualifiedSymPat _ _) invalid _) = +validateDefn (DefnPat _ (UnqualifiedSymPat _) invalid _) = Left (InvalidArguments invalid (DefnNonArrayArgs invalid)) -validateDefn (DefnPat (SymPat invalid _) _ _) = Left (QualifiedIdentifier invalid None) -validateDefn (DefnPat invalid _ _) = Left (InvalidIdentifier invalid None) +validateDefn (DefnPat _ invalid@(SymPat _) _ _) = Left (QualifiedIdentifier invalid None) +validateDefn (DefnPat _ invalid _ _) = Left (InvalidIdentifier invalid None) validateDefn defn = Left (GenericMalformed (XObj (Lst defn) Nothing Nothing)) -- | Validation of (the type body) expressions @@ -251,33 +266,33 @@ validateThe :: [XObj] -> Either Malformed [XObj] validateThe x@(ThePat _ t _) = case xobjToTy t of Nothing -> Left (InvalidType t (TheInvalidType t)) - Just _ -> Right x + Just _ -> Right x validateThe the = Left (GenericMalformed (XObj (Lst the) Nothing Nothing)) -- | Validation of (let [bindings] body) expressions. validateLet :: [XObj] -> Either Malformed [XObj] -validateLet x@(LetPat (ArrPat arr binds) _) +validateLet x@(LetPat _ arr@(ArrPat binds) _) | odd (length binds) = - Left (UnevenForms arr (length binds) (LetUnevenForms arr)) + Left (UnevenForms arr (length binds) (LetUnevenForms arr)) | not (all isSym (evenIndices binds)) = - Left (InvalidBindings arr (LetMalformedBinding (head (remove isSym (evenIndices binds))))) + Left (InvalidBindings arr (LetMalformedBinding (head (remove isSym (evenIndices binds))))) | otherwise = Right x -validateLet (LetPat invalid _) = Left (InvalidBindings invalid (LetNonArrayBindings invalid)) +validateLet (LetPat _ invalid _) = Left (InvalidBindings invalid (LetNonArrayBindings invalid)) validateLet lett = Left (GenericMalformed (XObj (Lst lett) Nothing Nothing)) -- | Validation of (fn [args] body) expressions. validateFn :: [XObj] -> Either Malformed [XObj] -validateFn x@(FnPat _ (ArrPat arr args) _) +validateFn x@(FnPat _ arr@(ArrPat args) _) | not (all isSym args) = Left (InvalidArguments arr (FnNonSymArgs (head (remove isSym args)))) | not (all isUnqualifiedSym args) = - Left (InvalidArguments arr (FnQualifiedSyms (head (remove isUnqualifiedSym args)))) + Left (InvalidArguments arr (FnQualifiedSyms (head (remove isUnqualifiedSym args)))) | otherwise = pure x validateFn (FnPat _ invalid _) = Left (InvalidArguments invalid (FnNonArrayArgs invalid)) validateFn fn = Left (GenericMalformed (XObj (Lst fn) Nothing Nothing)) -- | Validation of (do body) expressions. validateDo :: [XObj] -> Either Malformed [XObj] -validateDo x@(DoPat forms) = +validateDo x@(DoPat _ forms) = case forms of [] -> Left DoMissingForms _ -> Right x @@ -301,14 +316,15 @@ validateApp x@(AppPat f@(CommandPat arity _ _) args) = (BinaryCommandFunction _) -> checkAppArity f p args >> Right x (TernaryCommandFunction _) -> checkAppArity f p args >> Right x (VariadicCommandFunction _) -> Right x - where p = (\y -> XObj (Sym (SymPath [] y) Symbol) Nothing Nothing) <$> argnames - argnames = - case arity of - NullaryCommandFunction _ -> [] - UnaryCommandFunction _ -> ["x"] - BinaryCommandFunction _ -> ["x", "y"] - TernaryCommandFunction _ -> ["x", "y", "z"] - VariadicCommandFunction _ -> [] + where + p = (\y -> XObj (Sym (SymPath [] y) Symbol) Nothing Nothing) <$> argnames + argnames = + case arity of + NullaryCommandFunction _ -> [] + UnaryCommandFunction _ -> ["x"] + BinaryCommandFunction _ -> ["x", "y"] + TernaryCommandFunction _ -> ["x", "y", "z"] + VariadicCommandFunction _ -> [] validateApp x@(AppPat f@(PrimitivePat arity _ _) args) = case arity of (NullaryPrimitive _) -> checkAppArity f p args >> Right x @@ -317,22 +333,23 @@ validateApp x@(AppPat f@(PrimitivePat arity _ _) args) = (TernaryPrimitive _) -> checkAppArity f p args >> Right x (QuaternaryPrimitive _) -> checkAppArity f p args >> Right x (VariadicPrimitive _) -> Right x - where p = (\y -> XObj (Sym (SymPath [] y) Symbol) Nothing Nothing) <$> argnames - argnames = - case arity of - NullaryPrimitive _ -> [] - UnaryPrimitive _ -> ["x"] - BinaryPrimitive _ -> ["x", "y"] - TernaryPrimitive _ -> ["x", "y", "z"] - QuaternaryPrimitive _ -> ["x", "y", "z", "w"] - VariadicPrimitive _ -> [] + where + p = (\y -> XObj (Sym (SymPath [] y) Symbol) Nothing Nothing) <$> argnames + argnames = + case arity of + NullaryPrimitive _ -> [] + UnaryPrimitive _ -> ["x"] + BinaryPrimitive _ -> ["x", "y"] + TernaryPrimitive _ -> ["x", "y", "z"] + QuaternaryPrimitive _ -> ["x", "y", "z", "w"] + VariadicPrimitive _ -> [] validateApp (AppPat invalid _) = Left (InvalidApplication invalid) validateApp app = Left (GenericMalformed (XObj (Lst app) Nothing Nothing)) -- | Validation of (with module body) expressions validateWith :: [XObj] -> Either Malformed [XObj] -validateWith x@(WithPat (SymPat _ _) _) = Right x -validateWith (WithPat invalid _) = Left (InvalidIdentifier invalid (InvalidWith invalid)) +validateWith x@(WithPat _ (SymPat _) _) = Right x +validateWith (WithPat _ invalid _) = Left (InvalidIdentifier invalid (InvalidWith invalid)) validateWith with = Left (GenericMalformed (XObj (Lst with) Nothing Nothing)) -- | Checks that the number of arguments passed to a function are correct. @@ -351,62 +368,68 @@ checkAppArity xobj params args = -------------------------------------------------------------------------------- -- Pattern Synonyms -pattern ArrPat :: XObj -> [XObj] -> XObj -pattern ArrPat self members <- self@(XObj (Arr members) _ _) +pattern ArrPat :: [XObj] -> XObj +pattern ArrPat members <- XObj (Arr members) _ _ -pattern ListPat :: XObj -> [XObj] -> XObj -pattern ListPat self members <- self@(XObj (Lst members) _ _) +pattern StaticArrPat :: [XObj] -> XObj +pattern StaticArrPat members <- XObj (StaticArr members) _ _ -pattern SymPat :: XObj -> SymPath -> XObj -pattern SymPat self path <- self@(XObj (Sym path _) _ _) +pattern ListPat :: [XObj] -> XObj +pattern ListPat members <- XObj (Lst members) _ _ -pattern UnqualifiedSymPat :: XObj -> SymPath -> XObj -pattern UnqualifiedSymPat self path <- self@(XObj (Sym path@(SymPath [] _) _) _ _) +pattern SymPat :: SymPath -> XObj +pattern SymPat path <- XObj (Sym path _) _ _ -pattern DefPat :: XObj -> XObj -> [XObj] -pattern DefPat name value <- [XObj Def _ _, name, value] +pattern UnqualifiedSymPat :: SymPath -> XObj +pattern UnqualifiedSymPat path <- XObj (Sym path@(SymPath [] _) _) _ _ -pattern DefnPat :: XObj -> XObj -> XObj -> [XObj] -pattern DefnPat name args body <- [XObj (Defn _) _ _, name, args, body] +pattern DefPat :: XObj -> XObj -> XObj -> [XObj] +pattern DefPat def name value <- [def@(XObj Def _ _), name, value] -pattern IfPat :: XObj -> XObj -> XObj -> [XObj] -pattern IfPat cond true false <- [XObj If _ _, cond, true, false] +pattern DefnPat :: XObj -> XObj -> XObj -> XObj -> [XObj] +pattern DefnPat defn name args body <- [defn@(XObj (Defn _) _ _), name, args, body] + +pattern IfPat :: XObj -> XObj -> XObj -> XObj -> [XObj] +pattern IfPat ifHead cond true false <- [ifHead@(XObj If _ _), cond, true, false] pattern ThePat :: XObj -> XObj -> XObj -> [XObj] -pattern ThePat self t value <- [self@(XObj The _ _), t, value] +pattern ThePat theHead t value <- [theHead@(XObj The _ _), t, value] -pattern LetPat :: XObj -> XObj -> [XObj] -pattern LetPat bindings body <- [XObj Let _ _, bindings, body] +pattern RefPat :: XObj -> XObj -> [XObj] +pattern RefPat refHead value <- [refHead@(XObj Ref _ _), value] + +pattern LetPat :: XObj -> XObj -> XObj -> [XObj] +pattern LetPat letHead bindings body <- [letHead@(XObj Let _ _), bindings, body] pattern FnPat :: XObj -> XObj -> XObj -> [XObj] -pattern FnPat self args body <- [self@(XObj (Fn _ _) _ _), args, body] +pattern FnPat fnHead args body <- [fnHead@(XObj (Fn _ _) _ _), args, body] + +pattern WithPat :: XObj -> XObj -> [XObj] -> [XObj] +pattern WithPat withHead sym forms <- (withHead@(XObj With _ _) : sym : forms) + +pattern DoPat :: XObj -> [XObj] -> [XObj] +pattern DoPat doHead forms <- (doHead@(XObj Do _ _) : forms) + +pattern WhilePat :: XObj -> XObj -> XObj -> [XObj] +pattern WhilePat whileHead cond body <- [whileHead@(XObj While _ _), cond, body] + +pattern SetPat :: XObj -> XObj -> XObj -> [XObj] +pattern SetPat setBangHead iden value <- [setBangHead@(XObj SetBang _ _), iden, value] pattern ClosurePat :: [XObj] -> XObj -> Context -> XObj -pattern ClosurePat params body ctx <- XObj (Closure (XObj (Lst [_, (ArrPat _ params), body]) _ _) (CCtx ctx)) _ _ +pattern ClosurePat params body ctx <- XObj (Closure (XObj (Lst [_, (ArrPat params), body]) _ _) (CCtx ctx)) _ _ pattern DynamicFnPat :: XObj -> [XObj] -> XObj -> XObj -pattern DynamicFnPat sym params body <- XObj (Lst [XObj Dynamic _ _, sym, (ArrPat _ params), body]) _ _ +pattern DynamicFnPat sym params body <- XObj (Lst [XObj Dynamic _ _, sym, (ArrPat params), body]) _ _ pattern MacroPat :: XObj -> [XObj] -> XObj -> XObj -pattern MacroPat sym params body <- XObj (Lst [XObj Macro _ _, sym, (ArrPat _ params), body]) _ _ +pattern MacroPat sym params body <- XObj (Lst [XObj Macro _ _, sym, (ArrPat params), body]) _ _ pattern CommandPat :: CommandFunctionType -> XObj -> [XObj] -> XObj -pattern CommandPat arity sym params <- XObj (Lst [XObj (Command arity) _ _, sym, (ArrPat _ params)]) _ _ +pattern CommandPat arity sym params <- XObj (Lst [XObj (Command arity) _ _, sym, (ArrPat params)]) _ _ pattern PrimitivePat :: PrimitiveFunctionType -> XObj -> [XObj] -> XObj -pattern PrimitivePat arity sym params <- XObj (Lst [XObj (Primitive arity) _ _, sym, (ArrPat _ params)]) _ _ +pattern PrimitivePat arity sym params <- XObj (Lst [XObj (Primitive arity) _ _, sym, (ArrPat params)]) _ _ pattern AppPat :: XObj -> [XObj] -> [XObj] -pattern AppPat f args <- (f:args) - -pattern WithPat :: XObj -> [XObj] -> [XObj] -pattern WithPat sym forms <- (XObj With _ _: sym: forms) - -pattern DoPat :: [XObj] -> [XObj] -pattern DoPat forms <- (XObj Do _ _ : forms) - -pattern WhilePat :: XObj -> XObj -> [XObj] -pattern WhilePat cond body <- [XObj While _ _, cond, body] - -pattern SetPat :: XObj -> XObj -> [XObj] -pattern SetPat iden value <- [XObj SetBang _ _, iden, value] +pattern AppPat f args <- (f : args) diff --git a/src/Infer.hs b/src/Infer.hs index 752651e0..2355fa41 100644 --- a/src/Infer.hs +++ b/src/Infer.hs @@ -14,6 +14,7 @@ import Concretize import Constraints import GenerateConstraints import InitialTypes +import Memory import Obj import Qualify import TypeError @@ -28,7 +29,8 @@ annotate typeEnv globalEnv qualifiedXObj rootSig = do initiated <- initialTypes typeEnv globalEnv (unQualified qualifiedXObj) (annotated, dependencies) <- annotateUntilDone typeEnv globalEnv initiated rootSig [] 100 - (final, deleteDeps) <- manageMemory typeEnv globalEnv annotated + (final, deleteDepsTys) <- manageMemory typeEnv globalEnv annotated + let deleteDeps = depsForDeleteFuncs typeEnv globalEnv deleteDepsTys finalWithNiceTypes <- beautifyTypeVariables final pure (finalWithNiceTypes, dependencies ++ deleteDeps) diff --git a/src/Info.hs b/src/Info.hs index 53f44f1e..913bb4be 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -10,6 +10,8 @@ module Info freshVar, machineReadableInfo, makeTypeVariableNameFromInfo, + setDeletersOnInfo, + addDeletersToInfo, ) where @@ -105,3 +107,12 @@ makeTypeVariableNameFromInfo :: Maybe Info -> String makeTypeVariableNameFromInfo (Just i) = "tyvar-from-info-" ++ show (infoIdentifier i) ++ "_" ++ show (infoLine i) ++ "_" ++ show (infoColumn i) makeTypeVariableNameFromInfo Nothing = error "unnamed-typevariable" + +-- | Assign a set of Deleters to the 'infoDelete' field on Info. +setDeletersOnInfo :: Maybe Info -> Set.Set Deleter -> Maybe Info +setDeletersOnInfo i deleters = fmap (\i' -> i' {infoDelete = deleters}) i + +-- | Add to the set of Deleters in the 'infoDelete' field on Info. +addDeletersToInfo :: Maybe Info -> Set.Set Deleter -> Maybe Info +addDeletersToInfo i deleters = + fmap (\i' -> i' {infoDelete = Set.union (infoDelete i') deleters}) i diff --git a/src/Memory.hs b/src/Memory.hs new file mode 100644 index 00000000..bcf1515a --- /dev/null +++ b/src/Memory.hs @@ -0,0 +1,694 @@ +{-# LANGUAGE LambdaCase #-} + +module Memory (manageMemory) where + +import Control.Monad.State +import Forms +import Info +import Managed +import qualified Map +import Obj +import Polymorphism +import Set ((\\)) +import qualified Set +import TypeError +import Types +import Util +import Prelude hiding (lookup) + +-- | To keep track of the deleters when recursively walking the form. +-- | To avoid having to concretize the deleters here, they are just stored as their Ty in `memStateDeps`. +data MemState = MemState + { memStateDeleters :: Set.Set Deleter, + memStateDeps :: Set.Set Ty, + memStateLifetimes :: Map.Map String LifetimeMode + } + deriving (Show) + +-- | Differentiate between lifetimes depending on variables in a lexical scope and depending on something outside the function. +data LifetimeMode + = LifetimeInsideFunction String + | LifetimeOutsideFunction + deriving (Show) + +-- | Find out what deleters are needed and where in an XObj. +-- | Deleters will be added to the info field on XObj so that +-- | the code emitter can access them and insert calls to destructors. +manageMemory :: TypeEnv -> Env -> XObj -> Either TypeError (XObj, Set.Set Ty) +manageMemory typeEnv globalEnv root = + let (finalObj, finalState) = runState (visit root) (MemState Set.empty Set.empty Map.empty) + deleteThese = memStateDeleters finalState + deps = memStateDeps finalState + in -- (trace ("Delete these: " ++ joinWithComma (map show (Set.toList deleteThese)))) $ + case finalObj of + Left err -> Left err + Right ok -> + let newInfo = fmap (\i -> i {infoDelete = deleteThese}) (xobjInfo ok) + in -- This final check of lifetimes works on the lifetimes mappings after analyzing the function form, and + -- after all the local variables in it have been deleted. This is needed for values that are created + -- directly in body position, e.g. (defn f [] &[1 2 3]) + case evalState (refTargetIsAlive ok) (MemState Set.empty Set.empty (memStateLifetimes finalState)) of + Left err -> Left err + Right _ -> Right (ok {xobjInfo = newInfo}, deps) + where + visit :: XObj -> State MemState (Either TypeError XObj) + visit xobj = + do + r <- case xobjObj xobj of + Lst _ -> visitList xobj + Arr _ -> visitArray xobj + StaticArr _ -> visitStaticArray xobj + Str _ -> do + manage typeEnv globalEnv xobj + addToLifetimesMappingsIfRef False xobj -- TODO: Should "internal = True" here? TODO: Possible to remove this one? + pure (Right xobj) + Pattern _ -> do + manage typeEnv globalEnv xobj + addToLifetimesMappingsIfRef False xobj -- TODO: Also possible to remove, *should* be superseeded by (***) below? + pure (Right xobj) + _ -> + pure (Right xobj) + case r of + Right ok -> do + MemState {} <- get + r' <- refTargetIsAlive ok -- trace ("CHECKING " ++ pretty ok ++ " : " ++ showMaybeTy (ty xobj) ++ ", mappings: " ++ prettyLifetimeMappings m) $ + addToLifetimesMappingsIfRef True ok -- (***) + pure r' + Left err -> pure (Left err) + + visitArray :: XObj -> State MemState (Either TypeError XObj) + visitArray xobj@(ArrPat arr) = + do + mapM_ visit arr + results <- mapM (unmanage typeEnv globalEnv) arr + whenRight (sequence results) $ + do + _ <- manage typeEnv globalEnv xobj -- TODO: result is discarded here, is that OK? + pure (Right xobj) + visitArray _ = error "Must visit array." + + visitStaticArray :: XObj -> State MemState (Either TypeError XObj) + visitStaticArray xobj@(StaticArrPat arr) = + do + mapM_ visit arr + results <- mapM (unmanage typeEnv globalEnv) arr + whenRight (sequence results) $ do + -- We know that we want to add a deleter for the static array here + let var = varOfXObj xobj + Just (RefTy t@(StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [_]) _) = xobjTy xobj + deleter = case nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [t] UnitTy StaticLifetimeTy) "delete" of + Just pathOfDeleteFunc -> + ProperDeleter pathOfDeleteFunc (getDropFunc typeEnv globalEnv (xobjInfo xobj) t) var + Nothing -> + error ("No deleter found for Static Array : " ++ show t) --Just (FakeDeleter var) + MemState deleters deps lifetimes <- get + let newDeleters = Set.insert deleter deleters + newDeps = Set.insert t deps + newState = MemState newDeleters newDeps lifetimes + put newState --(trace (show newState) newState) + pure (Right xobj) + visitStaticArray _ = error "Must visit static array." + + visitList :: XObj -> State MemState (Either TypeError XObj) + visitList xobj@(XObj (Lst lst) i t) = + case lst of + [defn@(XObj (Defn maybeCaptures) _ _), nameSymbol@(XObj (Sym _ _) _ _), args@(XObj (Arr argList) _ _), body] -> + let captures = maybe [] Set.toList maybeCaptures + in do + mapM_ (manage typeEnv globalEnv) argList + -- Add the captured variables (if any, only happens in lifted lambdas) as fake deleters + -- TODO: Use another kind of Deleter for this case since it's pretty special? + mapM_ + ( ( \cap -> + modify + ( \memState -> + memState {memStateDeleters = Set.insert (FakeDeleter cap) (memStateDeleters memState)} + ) + ) + . getName + ) + captures + mapM_ (addToLifetimesMappingsIfRef False) argList + mapM_ (addToLifetimesMappingsIfRef False) captures -- For captured variables inside of lifted lambdas + visitedBody <- visit body + result <- unmanage typeEnv globalEnv body + whenRightReturn result $ + do + okBody <- visitedBody + Right (XObj (Lst [defn, nameSymbol, args, okBody]) i t) + + -- Fn / λ (Lambda) + [fn@(XObj (Fn _ captures) _ _), args@(XObj (Arr _) _ _), body] -> + do + manage typeEnv globalEnv xobj -- manage inner lambdas but leave their bodies unvisited, they will be visited in the lifted version... + mapM_ (unmanage typeEnv globalEnv) captures + pure (Right (XObj (Lst [fn, args, body]) i t)) + + -- Def + DefPat def nameSymbol expr -> + do + visitedExpr <- visit expr + result <- unmanage typeEnv globalEnv expr + whenRightReturn result $ + do + okExpr <- visitedExpr + Right (XObj (Lst [def, nameSymbol, okExpr]) i t) + -- Let + LetPat letExpr (XObj (Arr bindings) bindi bindt) body -> + do + MemState preDeleters _ _ <- get + visitedBindings <- mapM visitLetBinding (pairwise bindings) + visitedBody <- visit body + result <- unmanage typeEnv globalEnv body + whenRight result $ + do + MemState postDeleters deps postLifetimes <- get + let diff = postDeleters Set.\\ preDeleters + newInfo = setDeletersOnInfo i diff + survivors = postDeleters Set.\\ diff -- Same as just pre deleters, right?! + put (MemState survivors deps postLifetimes) + --trace ("LET Pre: " ++ show preDeleters ++ "\nPost: " ++ show postDeleters ++ "\nDiff: " ++ show diff ++ "\nSurvivors: " ++ show survivors) + manage typeEnv globalEnv xobj + pure $ do + okBody <- visitedBody + let finalBody = searchForInnerBreak diff okBody + okBindings <- fmap (concatMap (\(n, x) -> [n, x])) (sequence visitedBindings) + pure (XObj (Lst [letExpr, XObj (Arr okBindings) bindi bindt, finalBody]) newInfo t) + + -- Set! + SetPat setbangExpr variable value -> + let varInfo = xobjInfo variable + correctVariableAndMode = + case variable of + symObj@(XObj (Sym _ mode) _ _) -> Right (symObj, mode) + anythingElse -> Left (CannotSet anythingElse) + in case correctVariableAndMode of + Left err -> + pure (Left err) + Right (okCorrectVariable, okMode) -> + do + MemState preDeleters _ _ <- get + let ownsTheVarBefore = case createDeleter typeEnv globalEnv okCorrectVariable of + Nothing -> Right () + Just d -> + if Set.member d preDeleters || isLookupGlobal okMode + then Right () + else Left (UsingUnownedValue variable) + visitedValue <- visit value + _ <- unmanage typeEnv globalEnv value -- The assigned value can't be used anymore + MemState managed _ _ <- get + -- Delete the value previously stored in the variable, if it's still alive + let deleters = case createDeleter typeEnv globalEnv okCorrectVariable of + Just d -> Set.fromList [d] + Nothing -> Set.empty + newVariable = + case okMode of + Symbol -> error "How to handle this?" + LookupLocal _ -> + if Set.size (Set.intersection managed deleters) == 1 -- The variable is still alive + then variable {xobjInfo = setDeletersOnInfo varInfo deleters} + else variable -- don't add the new info = no deleter + LookupGlobal _ _ -> + variable {xobjInfo = setDeletersOnInfo varInfo deleters} + _ -> error "managememory set! 1" + case okMode of + Symbol -> error "Should only be be a global/local lookup symbol." + LookupLocal _ -> manage typeEnv globalEnv okCorrectVariable + LookupGlobal _ _ -> pure () + _ -> error "managememory set! 2" + pure $ case okMode of + LookupLocal (Capture _) -> + Left (CannotSetVariableFromLambda variable setbangExpr) + _ -> + do + okValue <- visitedValue + _ <- ownsTheVarBefore -- Force Either to fail + pure (XObj (Lst [setbangExpr, newVariable, okValue]) i t) + + -- The + ThePat theExpr typeXObj value -> + do + visitedValue <- visit value + result <- transferOwnership typeEnv globalEnv value xobj + whenRightReturn result $ + do + okValue <- visitedValue + Right (XObj (Lst [theExpr, typeXObj, okValue]) i t) + + -- Ref + RefPat refExpr value -> + do + visited <- visit value + case visited of + Left e -> pure (Left e) + Right visitedValue -> + do + result <- canBeReferenced typeEnv globalEnv visitedValue + whenRightReturn result $ do + Right (XObj (Lst [refExpr, visitedValue]) i t) + + -- Deref + (XObj Deref _ _ : _) -> + error "Shouldn't end up here, deref only works when calling a function, i.e. ((deref f) 1 2 3)." + -- Do + DoPat doExpr expressions -> + do + visitedExpressions <- mapM visit expressions + result <- transferOwnership typeEnv globalEnv (last expressions) xobj + whenRightReturn result $ do + okExpressions <- sequence visitedExpressions + Right (XObj (Lst (doExpr : okExpressions)) i t) + + -- While + WhilePat whileExpr expr body -> + do + MemState preDeleters _ _ <- get + visitedExpr <- visit expr + MemState afterExprDeleters _ _ <- get + visitedBody <- visit body + manage typeEnv globalEnv body + MemState postDeleters deps postLifetimes <- get + -- Visit an extra time to simulate repeated use + visitedExpr2 <- visit expr + visitedBody2 <- visit body + let diff = postDeleters \\ preDeleters + put (MemState (postDeleters \\ diff) deps postLifetimes) -- Same as just pre deleters, right?! + pure $ do + okExpr <- visitedExpr + okBody <- visitedBody + _ <- visitedExpr2 -- This evaluates the second visit so that it actually produces the error + _ <- visitedBody2 -- And this one too. Laziness FTW. + let newInfo = setDeletersOnInfo i diff + -- Also need to set deleters ON the expression (for first run through the loop) + XObj objExpr objInfo objTy = okExpr + newExprInfo = setDeletersOnInfo objInfo (afterExprDeleters \\ preDeleters) + newExpr = XObj objExpr newExprInfo objTy + finalBody = searchForInnerBreak diff okBody + pure (XObj (Lst [whileExpr, newExpr, finalBody]) newInfo t) + + -- If + IfPat ifExpr expr ifTrue ifFalse -> + do + visitedExpr <- visit expr + MemState preDeleters deps lifetimes <- get + let (visitedTrue, stillAliveTrue) = + runState + ( do + v <- visit ifTrue + result <- transferOwnership typeEnv globalEnv ifTrue xobj + pure $ case result of + Left e -> error (show e) + Right () -> v + ) + (MemState preDeleters deps lifetimes) + (visitedFalse, stillAliveFalse) = + runState + ( do + v <- visit ifFalse + result <- transferOwnership typeEnv globalEnv ifFalse xobj + pure $ case result of + Left e -> error (show e) + Right () -> v + ) + (MemState preDeleters deps lifetimes) + let deletedInTrue = preDeleters \\ memStateDeleters stillAliveTrue + deletedInFalse = preDeleters \\ memStateDeleters stillAliveFalse + deletedInBoth = Set.intersection deletedInTrue deletedInFalse + createdInTrue = memStateDeleters stillAliveTrue \\ preDeleters + createdInFalse = memStateDeleters stillAliveFalse \\ preDeleters + selfDeleter = case createDeleter typeEnv globalEnv xobj of + Just ok -> Set.fromList [ok] + Nothing -> Set.empty + createdAndDeletedInTrue = createdInTrue \\ selfDeleter + createdAndDeletedInFalse = createdInFalse \\ selfDeleter + delsTrue = Set.union (deletedInFalse \\ deletedInBoth) createdAndDeletedInTrue + delsFalse = Set.union (deletedInTrue \\ deletedInBoth) createdAndDeletedInFalse + stillAliveAfter = preDeleters \\ Set.union deletedInTrue deletedInFalse + -- Note: The following line merges all previous deps and the new ones, could be optimized? + depsAfter = Set.unions [memStateDeps stillAliveTrue, memStateDeps stillAliveFalse, deps] + put (MemState stillAliveAfter depsAfter lifetimes) + manage typeEnv globalEnv xobj + pure $ do + okExpr <- visitedExpr + okTrue <- visitedTrue + okFalse <- visitedFalse + pure (XObj (Lst [ifExpr, okExpr, setDeletersOnXObj okTrue delsTrue, setDeletersOnXObj okFalse delsFalse]) i t) + + -- Match + -- The general idea of how to figure out what to delete in a 'match' statement: + -- 1. Visit each case and investigate which variables are deleted in each one of the cases + -- 2. Variables deleted in at least one case has to be deleted in all, so make a union U of all such vars + -- but remove the ones that were not present before the 'match' + -- 3. In each case - take the intersection of U and the vars deleted in that case and add this result to its deleters + matchExpr@(XObj (Match _) _ _) : expr : cases -> + do + visitedExpr <- visit expr + case visitedExpr of + Left e -> pure (Left e) + Right okVisitedExpr -> + do + _ <- unmanage typeEnv globalEnv okVisitedExpr + MemState preDeleters deps lifetimes <- get + vistedCasesAndDeps <- mapM visitMatchCase (pairwise cases) + case sequence vistedCasesAndDeps of + Left e -> pure (Left e) + Right okCasesAndDeps -> + let visitedCases = map fst okCasesAndDeps + depsFromCases = Set.unions (map snd okCasesAndDeps) + (finalXObj, postDeleters) = analyzeFinal okVisitedExpr visitedCases preDeleters + in do + put (MemState postDeleters (Set.union deps depsFromCases) lifetimes) + manage typeEnv globalEnv xobj + pure (Right finalXObj) + where + analyzeFinal :: XObj -> [(Set.Set Deleter, (XObj, XObj))] -> Set.Set Deleter -> (XObj, Set.Set Deleter) + analyzeFinal okVisitedExpr visitedCasesWithDeleters preDeleters = + let postDeleters = map fst visitedCasesWithDeleters + -- postDeletersUnion = unionOfSetsInList postDeleters + postDeletersIntersection = intersectionOfSetsInList postDeleters + deletersAfterTheMatch = Set.intersection preDeleters postDeletersIntersection + -- The "postDeletersUnionPreExisting" are the vars that existed before the match but needs to + -- be deleted after it has executed (because some branches delete them) + -- postDeletersUnionPreExisting = Set.intersection postDeletersUnion preDeleters + deletersForEachCase = map (\\ deletersAfterTheMatch) postDeleters + -- These are the surviving vars after the 'match' expression: + okVisitedCases = map snd visitedCasesWithDeleters + okVisitedCasesWithAllDeleters = + zipWith + ( \(lhs, rhs) finalSetOfDeleters -> + -- Putting the deleter info on the lhs, + -- because the right one can collide with + -- the other expressions, e.g. a 'let' + let newLhsInfo = setDeletersOnInfo (xobjInfo lhs) finalSetOfDeleters + in [lhs {xobjInfo = newLhsInfo}, rhs] + ) + okVisitedCases + deletersForEachCase + in ( XObj (Lst ([matchExpr, okVisitedExpr] ++ concat okVisitedCasesWithAllDeleters)) i t, + deletersAfterTheMatch + ) + + -- Deref (only works in function application) + XObj (Lst [deref@(XObj Deref _ _), f]) xi xt : uargs -> + do + -- Do not visit f in this case, we don't want to manage it's memory since it is a ref! + visitedArgs <- sequence <$> mapM visitArg uargs + case visitedArgs of + Left err -> pure (Left err) + Right args -> + do + unmanagedArgs <- sequence <$> mapM unmanageArg args + manage typeEnv globalEnv xobj + pure $ do + okArgs <- unmanagedArgs + Right (XObj (Lst (XObj (Lst [deref, f]) xi xt : okArgs)) i t) + + -- Function application + f : uargs -> + do + visitedF <- visit f + visitedArgs <- sequence <$> mapM visitArg uargs + case visitedArgs of + Left err -> pure (Left err) + Right args -> do + unmanagedArgs <- sequence <$> mapM unmanageArg args + manage typeEnv globalEnv xobj + pure $ do + okF <- visitedF + okArgs <- unmanagedArgs + Right (XObj (Lst (okF : okArgs)) i t) + [] -> pure (Right xobj) + visitList _ = error "Must visit list." + + visitMatchCase :: (XObj, XObj) -> State MemState (Either TypeError ((Set.Set Deleter, (XObj, XObj)), Set.Set Ty)) + visitMatchCase (lhs@XObj {}, rhs@XObj {}) = + do + MemState preDeleters _ _ <- get + _ <- visitCaseLhs lhs + visitedRhs <- visit rhs + _ <- unmanage typeEnv globalEnv rhs + MemState postDeleters postDeps postLifetimes <- get + put (MemState preDeleters postDeps postLifetimes) -- Restore managed variables, TODO: Use a "local" state monad instead? + pure $ do + okVisitedRhs <- visitedRhs + pure ((postDeleters, (lhs, okVisitedRhs)), postDeps) + + visitCaseLhs :: XObj -> State MemState (Either TypeError [()]) + visitCaseLhs (XObj (Lst vars) _ _) = + do + result <- mapM visitCaseLhs vars + let result' = sequence result + pure (fmap concat result') + visitCaseLhs xobj@(XObj (Sym (SymPath _ name) _) _ _) + | isVarName name = do + manage typeEnv globalEnv xobj + pure (Right []) + | otherwise = pure (Right []) + visitCaseLhs (XObj Ref _ _) = + pure (Right []) + visitCaseLhs x = + error ("Unhandled: " ++ show x) + + visitLetBinding :: (XObj, XObj) -> State MemState (Either TypeError (XObj, XObj)) + visitLetBinding (name, expr) = + do + visitedExpr <- visit expr + addToLifetimesMappingsIfRef True expr + result <- transferOwnership typeEnv globalEnv expr name + whenRightReturn result $ do + okExpr <- visitedExpr + pure (name, okExpr) + + visitArg :: XObj -> State MemState (Either TypeError XObj) + visitArg xobj@(XObj _ _ (Just _)) = + do + afterVisit <- visit xobj + case afterVisit of + Right okAfterVisit -> do + addToLifetimesMappingsIfRef True okAfterVisit + pure (Right okAfterVisit) + Left err -> pure (Left err) + visitArg xobj@XObj {} = + visit xobj + + unmanageArg :: XObj -> State MemState (Either TypeError XObj) + unmanageArg xobj@(XObj _ _ (Just t)) = + if isManaged typeEnv globalEnv t + then do + r <- unmanage typeEnv globalEnv xobj + pure $ case r of + Left err -> Left err + Right () -> Right xobj + else pure (Right xobj) + unmanageArg xobj@XObj {} = + pure (Right xobj) + +-------------------------------------------------------------------------------- +-- The basic primitives of memory management + +-- | Add `xobj` to the set of alive variables, in need of deletion at end of scope. +manage :: TypeEnv -> Env -> XObj -> State MemState () +manage typeEnv globalEnv xobj = + if isSymbolThatCaptures xobj -- When visiting lifted lambdas, don't manage symbols that capture (they are owned by the environment). + then pure () + else case createDeleter typeEnv globalEnv xobj of + Just deleter -> do + MemState deleters deps lifetimes <- get + let newDeleters = Set.insert deleter deleters + Just t = xobjTy xobj + newDeps = Set.insert t deps + put (MemState newDeleters newDeps lifetimes) + Nothing -> pure () + +-- | Remove `xobj` from the set of alive variables, in need of deletion at end of scope. +unmanage :: TypeEnv -> Env -> XObj -> State MemState (Either TypeError ()) +unmanage typeEnv globalEnv xobj = + let Just t = xobjTy xobj + in if isManaged typeEnv globalEnv t && not (isGlobalFunc xobj) + then do + MemState deleters deps lifetimes <- get + case deletersMatchingXObj xobj deleters of + [] -> + pure $ + if isSymbolThatCaptures xobj + then Left (UsingCapturedValue xobj) + else Left (UsingUnownedValue xobj) + [one] -> + let newDeleters = Set.delete one deleters + in do + put (MemState newDeleters deps lifetimes) + pure (Right ()) + tooMany -> error ("Too many variables with the same name in set: " ++ show tooMany) + else pure (Right ()) + +-- | A combination of `manage` and `unmanage`. +transferOwnership :: TypeEnv -> Env -> XObj -> XObj -> State MemState (Either TypeError ()) +transferOwnership typeEnv globalEnv from to = + do + result <- unmanage typeEnv globalEnv from + whenRight result $ do + manage typeEnv globalEnv to --(trace ("Transfered from " ++ getName from ++ " '" ++ varOfXObj from ++ "' to " ++ getName to ++ " '" ++ varOfXObj to ++ "'") to) + pure (Right ()) + +-- | Control that an `xobj` is OK to reference +canBeReferenced :: TypeEnv -> Env -> XObj -> State MemState (Either TypeError ()) +canBeReferenced typeEnv globalEnv xobj = + let Just t = xobjTy xobj + isGlobalVariable = case xobj of + XObj (Sym _ (LookupGlobal _ _)) _ _ -> True + _ -> False + in -- TODO: The 'isManaged typeEnv t' boolean check should be removed + if not isGlobalVariable && not (isGlobalFunc xobj) && isManaged typeEnv globalEnv t && not (isSymbolThatCaptures xobj) + then do + MemState deleters _ _ <- get + pure $ case deletersMatchingXObj xobj deleters of + [] -> Left (GettingReferenceToUnownedValue xobj) + [_] -> pure () + _ -> error $ "Too many variables with the same name in set (was looking for " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ ")" + else pure (Right ()) + +-- | Makes sure that whatever a reference is refering too, is still alive (i.e. in the set of live Deleters) +refTargetIsAlive :: XObj -> State MemState (Either TypeError XObj) +refTargetIsAlive xobj = + -- TODO: Replace this whole thing with a function that collects all lifetime variables in a type. + case xobjTy xobj of + Just (RefTy _ (VarTy lt)) -> + performCheck lt + Just (FuncTy _ _ (VarTy lt)) -> + performCheck lt + -- HACK (not exhaustive): + Just (FuncTy _ (RefTy _ (VarTy lt)) _) -> + performCheck lt + _ -> + pure -- trace ("Won't check " ++ pretty xobj ++ " : " ++ show (ty xobj)) + (Right xobj) + where + performCheck :: String -> State MemState (Either TypeError XObj) + performCheck lt = + do + MemState deleters _ lifetimeMappings <- get + case Map.lookup lt lifetimeMappings of + Just (LifetimeInsideFunction deleterName) -> + let matchingDeleters = + Set.toList $ + Set.filter + ( \case + ProperDeleter {deleterVariable = dv} -> dv == deleterName + FakeDeleter {deleterVariable = dv} -> dv == deleterName + PrimDeleter {aliveVariable = dv} -> dv == deleterName + RefDeleter {refVariable = dv} -> dv == deleterName + ) + deleters + in case matchingDeleters of + [] -> + --trace ("Can't use reference " ++ pretty xobj ++ " (with lifetime '" ++ lt ++ "', depending on " ++ show deleterName ++ ") at " ++ prettyInfoFromXObj xobj ++ ", it's not alive here:\n" ++ show xobj ++ "\nMappings: " ++ prettyLifetimeMappings lifetimeMappings ++ "\nAlive: " ++ show deleters ++ "\n") $ + --pure (Right xobj) + pure (Left (UsingDeadReference xobj deleterName)) + _ -> + --trace ("CAN use reference " ++ pretty xobj ++ " (with lifetime '" ++ lt ++ "', depending on " ++ show deleterName ++ ") at " ++ prettyInfoFromXObj xobj ++ ", it's not alive here:\n" ++ show xobj ++ "\nMappings: " ++ prettyLifetimeMappings lifetimeMappings ++ "\nAlive: " ++ show deleters ++ "\n") $ + pure (Right xobj) + Just LifetimeOutsideFunction -> + --trace ("Lifetime OUTSIDE function: " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj) $ + pure (Right xobj) + Nothing -> + pure (Right xobj) + +-- | Map from lifetime variables (of refs) to a `LifetimeMode` +-- | (usually containing the name of the XObj that the lifetime is tied to). +addToLifetimesMappingsIfRef :: Bool -> XObj -> State MemState () +addToLifetimesMappingsIfRef internal xobj = + case xobjTy xobj of + Just (RefTy _ (VarTy lt)) -> + do + m@(MemState _ _ lifetimes) <- get + case Map.lookup lt lifetimes of + Just _ -> + --trace ("\nThere is already a mapping for '" ++ pretty xobj ++ "' from the lifetime '" ++ lt ++ "' to " ++ show existing ++ ", won't add " ++ show (makeLifetimeMode xobj)) $ + pure () + Nothing -> + do + let lifetimes' = Map.insert lt makeLifetimeMode lifetimes + put $ --(trace $ "\nExtended lifetimes mappings for '" ++ pretty xobj ++ "' with " ++ show lt ++ " => " ++ show (makeLifetimeMode xobj) ++ " at " ++ prettyInfoFromXObj xobj ++ ":\n" ++ prettyLifetimeMappings lifetimes') $ + m {memStateLifetimes = lifetimes'} + pure () + Just _ -> + --trace ("Won't add to mappings! " ++ pretty xobj ++ " : " ++ show notThisType ++ " at " ++ prettyInfoFromXObj xobj) $ + pure () + _ -> + --trace ("No type on " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj) $ + pure () + where + makeLifetimeMode = + if internal + then LifetimeInsideFunction $ + case xobj of + XObj (Lst [XObj Ref _ _, target]) _ _ -> varOfXObj target + _ -> varOfXObj xobj + else LifetimeOutsideFunction + +-------------------------------------------------------------------------------- +-- Deleters + +deletersMatchingXObj :: XObj -> Set.Set Deleter -> [Deleter] +deletersMatchingXObj xobj deleters = + let var = varOfXObj xobj + in Set.toList $ + Set.filter + ( \case + ProperDeleter {deleterVariable = dv} -> dv == var + FakeDeleter {deleterVariable = dv} -> dv == var + PrimDeleter {aliveVariable = dv} -> dv == var + RefDeleter {refVariable = dv} -> dv == var + ) + deleters + +-- | Helper function for setting the deleters for an XObj. +setDeletersOnXObj :: XObj -> Set.Set Deleter -> XObj +setDeletersOnXObj xobj deleters = xobj {xobjInfo = setDeletersOnInfo (xobjInfo xobj) deleters} + +createDeleter :: TypeEnv -> Env -> XObj -> Maybe Deleter +createDeleter typeEnv globalEnv xobj = + case xobjTy xobj of + Just (RefTy _ _) -> Just (RefDeleter (varOfXObj xobj)) + Just t -> + let var = varOfXObj xobj + in if isManaged typeEnv globalEnv t + then case nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [t] UnitTy StaticLifetimeTy) "delete" of + Just pathOfDeleteFunc -> + Just (ProperDeleter pathOfDeleteFunc (getDropFunc typeEnv globalEnv (xobjInfo xobj) t) var) + Nothing -> + --trace ("Found no delete function for " ++ var ++ " : " ++ (showMaybeTy (ty xobj))) + Just (FakeDeleter var) + else Just (PrimDeleter var) + Nothing -> error ("No type, can't manage " ++ show xobj) + +getDropFunc :: TypeEnv -> Env -> Maybe Info -> Ty -> Maybe SymPath +getDropFunc typeEnv globalEnv i t = + nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [RefTy t (VarTy (makeTypeVariableNameFromInfo i))] UnitTy StaticLifetimeTy) "drop" + +-- | To make the `while` form behave correctly with memory management rules +searchForInnerBreak :: Set.Set Deleter -> XObj -> XObj +searchForInnerBreak diff (XObj (Lst [(XObj Break i' t')]) xi xt) = + let ni = addDeletersToInfo i' diff + in XObj (Lst [(XObj Break ni t')]) xi xt +searchForInnerBreak _ x@(XObj (Lst ((XObj While _ _) : _)) _ _) = x +searchForInnerBreak diff (XObj (Lst elems) i' t') = + let newElems = map (searchForInnerBreak diff) elems + in XObj (Lst newElems) i' t' +searchForInnerBreak _ e = e + +-------------------------------------------------------------------------------- +-- Helpers + +isSymbolThatCaptures :: XObj -> Bool +isSymbolThatCaptures xobj = + case xobj of + XObj (Sym _ (LookupLocal (Capture _))) _ _ -> True + _ -> False + +-- | Show lifetime mappings in a more readable way. +-- prettyLifetimeMappings :: Map.Map String LifetimeMode -> String +-- prettyLifetimeMappings mappings = +-- joinLines (map prettyMapping (Map.toList mappings)) +-- where +-- prettyMapping (key, value) = " " ++ key ++ " => " ++ show value diff --git a/src/Obj.hs b/src/Obj.hs index 0edb9e44..75d83f49 100644 --- a/src/Obj.hs +++ b/src/Obj.hs @@ -1027,6 +1027,15 @@ unwrapSymPathXObj :: XObj -> Either String SymPath unwrapSymPathXObj (XObj (Sym p _) _ _) = Right p unwrapSymPathXObj x = Left ("The value '" ++ pretty x ++ "' at " ++ prettyInfoFromXObj x ++ " is not a Symbol.") +-- | Gives the name used to refer to a specific XObj (in emitted code) +varOfXObj :: XObj -> String +varOfXObj xobj = + case xobj of + XObj (Sym path _) _ _ -> pathToC path + _ -> case xobjInfo xobj of + Just i -> freshVar i + Nothing -> error ("Missing info on " ++ show xobj) + -- | Given a form, what definition mode will it generate? definitionMode :: XObj -> DefinitionMode definitionMode (XObj (Lst (XObj Def _ _ : _)) _ _) = AVariable diff --git a/src/Polymorphism.hs b/src/Polymorphism.hs index 1aa930e4..1973cde6 100644 --- a/src/Polymorphism.hs +++ b/src/Polymorphism.hs @@ -1,9 +1,15 @@ module Polymorphism ( nameOfPolymorphicFunction, + allImplementations, + FunctionFinderResult (..), + findFunctionForMember, + findFunctionForMemberIncludePrimitives, ) where -import Env as E +import Data.Either (fromRight) +import Env +import Managed import Obj import Types @@ -19,8 +25,8 @@ import Types nameOfPolymorphicFunction :: TypeEnv -> Env -> Ty -> String -> Maybe SymPath nameOfPolymorphicFunction _ env functionType functionName = let foundBinder = - (E.findPoly env functionName functionType) - <> (E.findPoly (progenitor env) functionName functionType) + (findPoly env functionName functionType) + <> (findPoly (progenitor env) functionName functionType) in case foundBinder of Right (_, (Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))) -> Just (SymPath [] name) @@ -31,3 +37,91 @@ nameOfPolymorphicFunction _ env functionType functionName = concretizedPath = SymPath pathStrings (name ++ suffix) in Just concretizedPath _ -> Nothing + +-- | Find ALL functions with a certain name, matching a type signature. +-- When the functionName argument denotes an interface, the name will match iff either: +-- 1. The name of the binding matches functionName exactly OR +-- 2. The name of the binding matches one of the names in the interface's implementation paths +-- For all other functions, the name must match exactly, and in all cases, the signature must match. +allImplementations :: TypeEnv -> Env -> String -> Ty -> [(Env, Binder)] +allImplementations typeEnv env functionName functionType = + (filter (predicate . xobjTy . binderXObj . snd) foundBindings) + where + predicate (Just t) = + --trace ("areUnifiable? " ++ show functionType ++ " == " ++ show t ++ " " ++ show (areUnifiable functionType t)) $ + areUnifiable functionType t + predicate Nothing = error "allfunctionswithnameandsignature" + foundBindings = case getTypeBinder typeEnv functionName of + -- this function is an interface; lookup implementations + Right (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) -> + case sequence $ map (\p -> searchValue env p) (paths ++ [(SymPath [] functionName)]) of + Right found -> found + Left _ -> + case findPoly env functionName functionType of + Right r -> [r] + Left _ -> (lookupEverywhere env functionName) + -- just a regular function; look for it + _ -> fromRight [] ((fmap (: []) (Env.getValue env functionName)) <> pure (lookupEverywhere env functionName)) + +-- | The various results when trying to find a function using 'findFunctionForMember'. +data FunctionFinderResult + = FunctionFound String + | FunctionNotFound String + | FunctionIgnored + deriving (Show) + +-- | Used for finding functions like 'delete' or 'copy' for members of a Deftype (or Array). +findFunctionForMember :: TypeEnv -> Env -> String -> Ty -> (String, Ty) -> FunctionFinderResult +findFunctionForMember typeEnv env functionName functionType (memberName, memberType) + | isManaged typeEnv env memberType = + case allImplementations typeEnv env functionName functionType of + [] -> + FunctionNotFound + ( "Can't find any '" ++ functionName ++ "' function for member '" + ++ memberName + ++ "' of type " + ++ show functionType + ) + [(_, Binder _ single)] -> + let concretizedPath = getConcretizedPath single functionType + in FunctionFound (pathToC concretizedPath) + _ -> + FunctionNotFound + ( "Can't find a single '" ++ functionName ++ "' function for member '" + ++ memberName + ++ "' of type " + ++ show functionType + ) + | otherwise = FunctionIgnored + +-- | TODO: should this be the default and 'findFunctionForMember' be the specific one +findFunctionForMemberIncludePrimitives :: TypeEnv -> Env -> String -> Ty -> (String, Ty) -> FunctionFinderResult +findFunctionForMemberIncludePrimitives typeEnv env functionName functionType (memberName, _) = + case allImplementations typeEnv env functionName functionType of + [] -> + FunctionNotFound + ( "Can't find any '" ++ functionName ++ "' function for member '" + ++ memberName + ++ "' of type " + ++ show functionType + ) + [(_, Binder _ single)] -> + let concretizedPath = getConcretizedPath single functionType + in FunctionFound (pathToC concretizedPath) + _ -> + FunctionNotFound + ( "Can't find a single '" ++ functionName ++ "' function for member '" + ++ memberName + ++ "' of type " + ++ show functionType + ) + +-- | Creates a new SymPath with a suffix added to the name, +-- for differentiating the concrete version of the function from +-- its generic ancestor. +getConcretizedPath :: XObj -> Ty -> SymPath +getConcretizedPath defn functionType = + let Just t' = xobjTy defn + SymPath pathStrings name = getPath defn + suffix = polymorphicSuffix t' functionType + in SymPath pathStrings (name ++ suffix) diff --git a/src/Set.hs b/src/Set.hs index f9fa6187..1e840ab0 100644 --- a/src/Set.hs +++ b/src/Set.hs @@ -28,6 +28,9 @@ intersection (Set a) (Set b) = Set (S.intersection a b) union :: Ord v => Set v -> Set v -> Set v union (Set a) (Set b) = Set (S.union a b) +unions :: (Functor f, Foldable f, Ord a) => f (Set a) -> Set a +unions sets = Set $ S.unions (fmap unSet sets) + member :: Ord v => v -> Set v -> Bool member k (Set s) = S.member k s diff --git a/src/StructUtils.hs b/src/StructUtils.hs index ddb96ccc..feb62fc2 100644 --- a/src/StructUtils.hs +++ b/src/StructUtils.hs @@ -5,6 +5,8 @@ import Obj import Polymorphism import Types +data AllocationMode = StackAlloc | HeapAlloc + -- | The 'str'/'prn' functions for primitive types don't take refs, while other types do -- so we need to adjust for that when finding and calling them in compound types. -- The returned tuple contains ("" || "&", `str function type`). diff --git a/src/Util.hs b/src/Util.hs index 0b341fe6..87a7d21b 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -130,6 +130,10 @@ toMaybe f e = either (const Nothing) (Just . f) e maybeId :: Either a b -> Maybe b maybeId = toMaybe id -whenRight :: Monad m => Either a b -> m (Either a c) -> m (Either a c) +whenRight :: Applicative f => Either a b -> f (Either a c) -> f (Either a c) whenRight (Right _) cont = cont whenRight (Left err) _ = pure (Left err) + +whenRightReturn :: Applicative f => Either a b -> Either a c -> f (Either a c) +whenRightReturn (Right _) cont = pure cont +whenRightReturn (Left err) _ = pure (Left err)