mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-17 16:38:14 +03:00
refactor: Clean up memory management functions (#1240)
* refactor: Mid-refactor save point. * feat: Code compiles * refactor: Remove unused imports * refactor: Move functions out of massive `manageMemory` block * refactor: Move out even more functions from `manageMemory` * refactor: Made most patterns match on "head form" of each s-expression e.g. (if a b c) matches on 'if', 'a', 'b' and 'c' * refactor: Use the pattern synonyms in Memory * refactor: Remove a little cruft * refactor: whenOK function * refactor: Use 'whenRight' functions to avoid directly matching on Either * docs: Comment the 'getConcretizedPath' function * refactor: Move functionFinding-functions into Polymorphism module
This commit is contained in:
parent
5e5cf8d4c2
commit
3b429541a3
@ -37,6 +37,7 @@ library
|
||||
Interfaces,
|
||||
Managed,
|
||||
Map,
|
||||
Memory,
|
||||
Meta,
|
||||
Obj,
|
||||
Parsing,
|
||||
|
@ -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
|
||||
|
@ -4,6 +4,7 @@ module ArrayTemplates where
|
||||
|
||||
import Concretize
|
||||
import Obj
|
||||
import Polymorphism
|
||||
import StructUtils
|
||||
import Template
|
||||
import ToTemplate
|
||||
|
@ -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
|
||||
|
71
src/Eval.hs
71
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
|
||||
|
337
src/Forms.hs
337
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)
|
||||
|
@ -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)
|
||||
|
||||
|
11
src/Info.hs
11
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
|
||||
|
694
src/Memory.hs
Normal file
694
src/Memory.hs
Normal file
@ -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
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
||||
|
@ -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`).
|
||||
|
@ -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)
|
||||
|
Loading…
Reference in New Issue
Block a user