carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-11-04 01:25:04 +03:00
Code Issues Projects Releases Wiki Activity

refactor: Clean up memory management functions (#1240)

Browse Source 
* 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:
Erik Svedäng 2021-06-16 21:41:58 +02:00 committed by GitHub
parent 5e5cf8d4c2
commit 3b429541a3
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
14 changed files with 1077 additions and 1022 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
CarpHask.cabal
View File

@ -37,6 +37,7 @@ library
Interfaces, Interfaces,
Managed, Managed,
Map, Map,
Memory,
Meta, Meta,
Obj, Obj,
Parsing, Parsing,

4
app/Main.hs
View File

@ -125,9 +125,9 @@ main = do
[] []
coreModulesToLoad = if core then coreModules (projectCarpDir project) else [] coreModulesToLoad = if core then coreModules (projectCarpDir project) else []
execStr :: String -> String -> Context -> IO Context 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 :: 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 preloads = optPreload fullOpts
postloads = optPostload fullOpts postloads = optPostload fullOpts
load = flip loadFiles load = flip loadFiles

1
src/ArrayTemplates.hs
View File

@ -4,6 +4,7 @@ module ArrayTemplates where
import Concretize import Concretize
import Obj import Obj
import Polymorphism
import StructUtils import StructUtils
import Template import Template
import ToTemplate import ToTemplate

856
src/Concretize.hs
View File

@ -5,19 +5,18 @@ module Concretize where
import AssignTypes import AssignTypes
import Constraints import Constraints
import Control.Monad.State import Control.Monad.State
import Data.Either (fromRight)
import Data.List (foldl') import Data.List (foldl')
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Debug.Trace import Debug.Trace
import Env (envIsExternal, findPoly, getTypeBinder, getValue, insert, insertX, lookupEverywhere, searchValue) import Env (envIsExternal, getTypeBinder, insert, insertX, searchValue)
import Info import Info
import InitialTypes import InitialTypes
import Managed import Managed
import qualified Map import qualified Map
import Memory (manageMemory)
import Obj import Obj
import Polymorphism import Polymorphism
import Reify import Reify
import Set ((\\))
import qualified Set import qualified Set
import SumtypeCase import SumtypeCase
import ToTemplate import ToTemplate
@ -700,7 +699,8 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit
then pure (withNewPath, []) then pure (withNewPath, [])
else do else do
(concrete, deps) <- concretizeXObj allowAmbiguity typeEnv globalEnv (newPath : visitedDefinitions) typed (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) pure (managed, deps ++ memDeps)
Left e -> Left e Left e -> Left e
XObj (Lst (XObj (Defn _) _ _ : _)) _ _ -> XObj (Lst (XObj (Defn _) _ _ : _)) _ _ ->
@ -712,7 +712,8 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit
then pure (withNewPath, []) then pure (withNewPath, [])
else do else do
(concrete, deps) <- concretizeXObj allowAmbiguity typeEnv globalEnv (newPath : visitedDefinitions) typed (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) pure (managed, deps ++ memDeps)
Left e -> Left e Left e -> Left e
XObj (Lst (XObj (Deftemplate (TemplateCreator templateCreator)) _ _ : _)) _ _ -> XObj (Lst (XObj (Deftemplate (TemplateCreator templateCreator)) _ _ : _)) _ _ ->
@ -738,31 +739,6 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit
_ -> _ ->
Left $ CannotConcretize definition 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. -- | 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 -> [SymPath] -> String -> Ty -> [XObj]
depsOfPolymorphicFunction typeEnv env visitedDefinitions functionName functionType = depsOfPolymorphicFunction typeEnv env visitedDefinitions functionName functionType =
@ -788,6 +764,10 @@ depsForDeleteFunc typeEnv env t =
then depsOfPolymorphicFunction typeEnv env [] "delete" (FuncTy [t] UnitTy StaticLifetimeTy) then depsOfPolymorphicFunction typeEnv env [] "delete" (FuncTy [t] UnitTy StaticLifetimeTy)
else [] 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. -- | Helper for finding the 'copy' function for a type.
depsForCopyFunc :: TypeEnv -> Env -> Ty -> [XObj] depsForCopyFunc :: TypeEnv -> Env -> Ty -> [XObj]
depsForCopyFunc typeEnv env t = depsForCopyFunc typeEnv env t =
@ -809,788 +789,6 @@ typesStrFunctionType typeEnv env memberType =
then FuncTy [RefTy memberType (VarTy "q")] StringTy StaticLifetimeTy then FuncTy [RefTy memberType (VarTy "q")] StringTy StaticLifetimeTy
else FuncTy [memberType] 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. -- | The template for the 'delete' function of a concrete deftype.
concreteDelete :: TypeEnv -> Env -> [(String, Ty)] -> Template concreteDelete :: TypeEnv -> Env -> [(String, Ty)] -> Template
concreteDelete typeEnv env members = concreteDelete typeEnv env members =
@ -1661,6 +859,18 @@ concreteCopy typeEnv env memberPairs =
(filter (isManaged typeEnv env) (map snd 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 -> [(String, Ty)] -> [Token]
tokensForCopy typeEnv env memberPairs = tokensForCopy typeEnv env memberPairs =
toTemplate $ toTemplate $
@ -1682,18 +892,6 @@ memberCopy typeEnv env (memberName, memberType) =
FunctionNotFound msg -> error msg FunctionNotFound msg -> error msg
FunctionIgnored -> " /* Ignore non-managed member '" ++ memberName ++ "' : " ++ show memberType ++ " */" 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 -> [(String, Ty)] -> [Token]
tokensForCopyPtr typeEnv env memberPairs = tokensForCopyPtr typeEnv env memberPairs =
toTemplate $ toTemplate $
@ -1713,3 +911,13 @@ memberCopyPtr typeEnv env (memberName, memberType) =
" copy->" ++ memberName ++ " = " ++ functionFullName ++ "(&(pRef->" ++ memberName ++ "));" " copy->" ++ memberName ++ " = " ++ functionFullName ++ "(&(pRef->" ++ memberName ++ "));"
FunctionNotFound msg -> error msg FunctionNotFound msg -> error msg
FunctionIgnored -> " /* Ignore non-managed member '" ++ memberName ++ "' : " ++ show memberType ++ " */" 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
View File

@ -17,6 +17,7 @@ import Emit
import qualified Env as E import qualified Env as E
import EvalError import EvalError
import Expand import Expand
import Forms
import Infer import Infer
import Info import Info
import qualified Map import qualified Map
@ -35,7 +36,6 @@ import TypeError
import Types import Types
import Util import Util
import Prelude hiding (exp, mod) import Prelude hiding (exp, mod)
import Forms
-- TODO: Formalize "lookup order preference" a bit better and move into -- TODO: Formalize "lookup order preference" a bit better and move into
-- the Context module. -- 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)) Left e -> pure (evalError ctx (format e) (xobjInfo xobj))
Right form' -> Right form' ->
case form' of case form' of
(IfPat _ _ _) -> evaluateIf form' (IfPat _ _ _ _) -> evaluateIf form'
(DefnPat _ _ _) -> specialCommandDefine ctx xobj (DefnPat _ _ _ _) -> specialCommandDefine ctx xobj
(DefPat _ _) -> specialCommandDefine ctx xobj (DefPat _ _ _) -> specialCommandDefine ctx xobj
(ThePat _ _ _) -> evaluateThe form' (ThePat _ _ _) -> evaluateThe form'
(LetPat _ _) -> evaluateLet form' (LetPat _ _ _) -> evaluateLet form'
(FnPat _ _ _) -> evaluateFn form' (FnPat _ _ _) -> evaluateFn form'
(AppPat (ClosurePat _ _ _) _) -> evaluateClosure form' (AppPat (ClosurePat _ _ _) _) -> evaluateClosure form'
(AppPat (DynamicFnPat _ _ _) _) -> evaluateDynamicFn form' (AppPat (DynamicFnPat _ _ _) _) -> evaluateDynamicFn form'
(AppPat (MacroPat _ _ _) _) -> evaluateMacro form' (AppPat (MacroPat _ _ _) _) -> evaluateMacro form'
(AppPat (CommandPat _ _ _) _) -> evaluateCommand form' (AppPat (CommandPat _ _ _) _) -> evaluateCommand form'
(AppPat (PrimitivePat _ _ _) _) -> evaluatePrimitive form' (AppPat (PrimitivePat _ _ _) _) -> evaluatePrimitive form'
(WithPat (SymPat sym path) forms) -> specialCommandWith ctx sym path forms (WithPat _ sym@(SymPat path) forms) -> specialCommandWith ctx sym path forms
(DoPat forms) -> evaluateSideEffects forms (DoPat _ forms) -> evaluateSideEffects forms
(WhilePat cond body) -> specialCommandWhile ctx cond body (WhilePat _ cond body) -> specialCommandWhile ctx cond body
(SetPat iden value) -> specialCommandSet ctx (iden:[value]) (SetPat _ iden value) -> specialCommandSet ctx (iden : [value])
-- This next match is a bit redundant looking at first glance, but -- 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) -- it is necessary to prevent hangs on input such as: `((def foo 2)
-- 4)`. Ideally, we could perform only *one* static check (the one -- 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*. -- 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 -- That is, passing a *symbol* that, e.g. resolves to a defn list, won't
-- break our normal loop. -- break our normal loop.
(AppPat (ListPat self ((SymPat x _):_)) args) -> (AppPat self@(ListPat (x@(SymPat _) : _)) args) ->
do (_, evald) <- eval ctx x preference ResolveGlobal do
case evald of (_, evald) <- eval ctx x preference ResolveGlobal
Left err -> pure (evalError ctx (show err) (xobjInfo xobj)) case evald of
Right x' -> case checkStatic' x' of Left err -> pure (evalError ctx (show err) (xobjInfo xobj))
Right _ -> evaluateApp (self:args) Right x' -> case checkStatic' x' of
Left er -> pure (evalError ctx (show er) (xobjInfo xobj)) Right _ -> evaluateApp (self : args)
(AppPat (ListPat _ _) _) -> evaluateApp form' Left er -> pure (evalError ctx (show er) (xobjInfo xobj))
(AppPat (SymPat _ _) _) -> evaluateApp form' (AppPat (ListPat _) _) -> evaluateApp form'
(AppPat (SymPat _) _) -> evaluateApp form'
[] -> pure (ctx, dynamicNil) [] -> pure (ctx, dynamicNil)
_ -> pure (throwErr (UnknownForm xobj) ctx (xobjInfo xobj)) _ -> pure (throwErr (UnknownForm xobj) ctx (xobjInfo xobj))
checkStatic' (XObj Def _ _) = Left (HasStaticCall xobj info) 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) Left err -> (newCtx, Left err)
evaluateIf :: Evaluator evaluateIf :: Evaluator
evaluateIf (IfPat cond true false) = do evaluateIf (IfPat _ cond true false) = do
(newCtx, evd) <- eval ctx cond preference ResolveLocal (newCtx, evd) <- eval ctx cond preference ResolveLocal
case evd of case evd of
Right cond' -> Right cond' ->
@ -263,15 +264,15 @@ eval ctx xobj@(XObj o info ty) preference resolver =
evaluateThe (ThePat the t value) = do evaluateThe (ThePat the t value) = do
(newCtx, evaledValue) <- expandAll (evalDynamic ResolveLocal) ctx value -- TODO: Why expand all here? (newCtx, evaledValue) <- expandAll (evalDynamic ResolveLocal) ctx value -- TODO: Why expand all here?
pure pure
( newCtx, ( newCtx,
do do
okValue <- evaledValue okValue <- evaledValue
Right (XObj (Lst [the, t, okValue]) info ty) Right (XObj (Lst [the, t, okValue]) info ty)
) )
evaluateThe _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) evaluateThe _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
evaluateLet :: Evaluator evaluateLet :: Evaluator
evaluateLet (LetPat (ArrPat _ bindings) body) = do evaluateLet (LetPat _ (ArrPat bindings) body) = do
let binds = unwrapVar (pairwise bindings) [] let binds = unwrapVar (pairwise bindings) []
ni = Env Map.empty (contextInternalEnv ctx) Nothing Set.empty InternalEnv 0 ni = Env Map.empty (contextInternalEnv ctx) Nothing Set.empty InternalEnv 0
eitherCtx <- foldrM successiveEval' (Right (replaceInternalEnv ctx ni)) binds eitherCtx <- foldrM successiveEval' (Right (replaceInternalEnv ctx ni)) binds
@ -398,16 +399,18 @@ eval ctx xobj@(XObj o info ty) preference resolver =
evaluateApp :: Evaluator evaluateApp :: Evaluator
evaluateApp (AppPat f' args) = evaluateApp (AppPat f' args) =
case f' of case f' of
(ListPat l _) -> go l ResolveLocal l@(ListPat _) -> go l ResolveLocal
(SymPat sym _) -> go sym resolver sym@(SymPat _) -> go sym resolver
_ -> pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) _ -> pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
where go x resolve = where
do (newCtx, f) <- eval ctx x preference resolve go x resolve =
case f of do
Right fun -> do (newCtx, f) <- eval ctx x preference resolve
(newCtx', res) <- eval (pushFrame newCtx xobj) (XObj (Lst (fun : args)) (xobjInfo x) (xobjTy x)) preference ResolveLocal case f of
pure (popFrame newCtx', res) Right fun -> do
x' -> pure (newCtx, x') (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)) evaluateApp _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
evaluateSideEffects :: Evaluator evaluateSideEffects :: Evaluator

337
src/Forms.hs
View File

@ -4,36 +4,39 @@
-- unchecked forms (xobjs). -- unchecked forms (xobjs).
-- --
-- It defines a number of pattern synonyms for ease of pattern matching. -- It defines a number of pattern synonyms for ease of pattern matching.
module Forms ( module Forms
validate, ( validate,
format, format,
Malformed(GenericMalformed), Malformed (GenericMalformed),
pattern ArrPat, pattern ArrPat,
pattern ListPat, pattern StaticArrPat,
pattern SymPat, pattern ListPat,
pattern UnqualifiedSymPat, pattern SymPat,
pattern DefPat, pattern UnqualifiedSymPat,
pattern DefnPat, pattern DefPat,
pattern IfPat, pattern DefnPat,
pattern ThePat, pattern IfPat,
pattern LetPat, pattern ThePat,
pattern FnPat, pattern RefPat,
pattern ClosurePat, pattern LetPat,
pattern DynamicFnPat, pattern FnPat,
pattern MacroPat, pattern ClosurePat,
pattern CommandPat, pattern DynamicFnPat,
pattern PrimitivePat, pattern MacroPat,
pattern AppPat, pattern CommandPat,
pattern WithPat, pattern PrimitivePat,
pattern DoPat, pattern AppPat,
pattern WhilePat, pattern WithPat,
pattern SetPat, pattern DoPat,
) where pattern WhilePat,
pattern SetPat,
)
where
import Data.List (intercalate)
import Obj import Obj
import SymPath import SymPath
import Util import Util
import Data.List (intercalate)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Data -- Data
@ -41,19 +44,20 @@ import Data.List (intercalate)
-- Specialized constructors for each built-in language form. -- Specialized constructors for each built-in language form.
-- | Error type representing a generic malformed expression. -- | Error type representing a generic malformed expression.
data Malformed = InvalidIdentifier XObj Modifier data Malformed
| QualifiedIdentifier XObj Modifier = InvalidIdentifier XObj Modifier
| GenericMalformed XObj | QualifiedIdentifier XObj Modifier
| InvalidArguments XObj Modifier | GenericMalformed XObj
| InvalidBody XObj Modifier | InvalidArguments XObj Modifier
| InvalidCondition XObj Modifier | InvalidBody XObj Modifier
| InvalidType XObj Modifier | InvalidCondition XObj Modifier
| InvalidBindings XObj Modifier | InvalidType XObj Modifier
| UnevenForms XObj Int Modifier | InvalidBindings XObj Modifier
| InsufficientArguments XObj Int Int [XObj] | UnevenForms XObj Int Modifier
| TooManyArguments XObj Int Int [XObj] | InsufficientArguments XObj Int Int [XObj]
| InvalidApplication XObj | TooManyArguments XObj Int Int [XObj]
| DoMissingForms | InvalidApplication XObj
| DoMissingForms
instance Show Malformed where instance Show Malformed where
show (QualifiedIdentifier x modifier) = show (QualifiedIdentifier x modifier) =
@ -79,15 +83,18 @@ instance Show Malformed where
++ formatModifier modifier ++ formatModifier modifier
show (UnevenForms forms len modifier) = show (UnevenForms forms len modifier) =
"Expected an even number of forms, but got: " ++ pretty forms "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) = show (InsufficientArguments form lenExpected lenRecieved params) =
let name = case form of let name = case form of
(DynamicFnPat sym _ _) -> getName sym (DynamicFnPat sym _ _) -> getName sym
(MacroPat sym _ _) -> getName sym (MacroPat sym _ _) -> getName sym
(CommandPat _ sym _) -> getName sym (CommandPat _ sym _) -> getName sym
(PrimitivePat _ sym _) -> getName sym (PrimitivePat _ sym _) -> getName sym
XObj Ref _ _ -> "ref" XObj Ref _ _ -> "ref"
_ -> pretty form _ -> pretty form
in name ++ " expected " in name ++ " expected "
++ show lenExpected ++ show lenExpected
++ " arguments but received only " ++ " arguments but received only "
@ -97,12 +104,12 @@ instance Show Malformed where
++ " as well." ++ " as well."
show (TooManyArguments form lenExpected lenRecieved args) = show (TooManyArguments form lenExpected lenRecieved args) =
let name = case form of let name = case form of
(DynamicFnPat sym _ _) -> getName sym (DynamicFnPat sym _ _) -> getName sym
(MacroPat sym _ _) -> getName sym (MacroPat sym _ _) -> getName sym
(CommandPat _ sym _) -> getName sym (CommandPat _ sym _) -> getName sym
(PrimitivePat _ sym _) -> getName sym (PrimitivePat _ sym _) -> getName sym
XObj Ref _ _ -> "ref" XObj Ref _ _ -> "ref"
_ -> pretty form _ -> pretty form
in name ++ " expected " in name ++ " expected "
++ show lenExpected ++ show lenExpected
++ " arguments but received " ++ " arguments but received "
@ -118,40 +125,46 @@ instance Show Malformed where
"The form: " ++ pretty x ++ " is malformed" "The form: " ++ pretty x ++ " is malformed"
-- | Specific errors for particular types of malformed expressions. -- | Specific errors for particular types of malformed expressions.
data Modifier = DefnQualifiedSyms XObj data Modifier
| DefnNonArrayArgs XObj = DefnQualifiedSyms XObj
| DefnNonSymArgs XObj | DefnNonArrayArgs XObj
| IfInvalidCondition XObj | DefnNonSymArgs XObj
| WhileInvalidCondition XObj | IfInvalidCondition XObj
| TheInvalidType XObj | WhileInvalidCondition XObj
| LetMalformedBinding XObj | TheInvalidType XObj
| LetUnevenForms XObj | LetMalformedBinding XObj
| LetNonArrayBindings XObj | LetUnevenForms XObj
| FnQualifiedSyms XObj | LetNonArrayBindings XObj
| FnNonArrayArgs XObj | FnQualifiedSyms XObj
| FnNonSymArgs XObj | FnNonArrayArgs XObj
| InvalidWith XObj | FnNonSymArgs XObj
| None | InvalidWith XObj
| None
instance Show Modifier where instance Show Modifier where
show None = "" show None = ""
show (DefnQualifiedSyms arg) = show (DefnQualifiedSyms arg) =
"`defn` requires all of its arguments to be unqualified symbols, but the arugment: " "`defn` requires all of its arguments to be unqualified symbols, but the arugment: "
++ pretty arg ++ " is qualified" ++ pretty arg
++ " is qualified"
show (DefnNonArrayArgs args) = show (DefnNonArrayArgs args) =
"`defn` requires an array of arugments, but it got: " ++ pretty args "`defn` requires an array of arugments, but it got: " ++ pretty args
show (DefnNonSymArgs arg) = show (DefnNonSymArgs arg) =
"`defn` requires an array of symbols as arguments, but the argument: " "`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) = show (IfInvalidCondition cond) =
"`if` requires a condition that can be evaluated to a boolean, but it got: " "`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) = show (WhileInvalidCondition cond) =
"`while` requires a condition that can be evaluated to a boolean, but it got: " "`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) = show (TheInvalidType t) =
"`the` requires a valid type name, but it got: " "`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) = show (LetMalformedBinding bind) =
"`let` requires name-value binding pairs, but it got: " ++ pretty bind "`let` requires name-value binding pairs, but it got: " ++ pretty bind
++ " as a binding name, which is invalid. Binding names must be symbols" ++ " 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 "`let` requires an array of bindings, but it got: " ++ pretty invalid
show (FnQualifiedSyms arg) = show (FnQualifiedSyms arg) =
"`fn` requires all of its arguments to be unqualified symbols, but the arugment: " "`fn` requires all of its arguments to be unqualified symbols, but the arugment: "
++ pretty arg ++ " is qualified" ++ pretty arg
++ " is qualified"
show (FnNonArrayArgs args) = show (FnNonArrayArgs args) =
"`fn` requires an array of arugments, but it got: " ++ pretty args "`fn` requires an array of arugments, but it got: " ++ pretty args
show (FnNonSymArgs arg) = show (FnNonSymArgs arg) =
"`fn` requires an array of symbols as arguments, but the argument: " "`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) = show (InvalidWith x) =
"`with` requires a symbol as an arugment, but got: " ++ pretty 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 :: [XObj] -> Either Malformed [XObj]
validate xs = validate xs =
case xs of case xs of
DefPat _ _ -> validateDef xs DefPat _ _ _ -> validateDef xs
DefnPat _ _ _ -> validateDefn xs DefnPat _ _ _ _ -> validateDefn xs
IfPat _ _ _ -> validateIf xs IfPat _ _ _ _ -> validateIf xs
ThePat _ _ _ -> validateThe xs ThePat _ _ _ -> validateThe xs
LetPat _ _ -> validateLet xs LetPat _ _ _ -> validateLet xs
FnPat _ _ _ -> validateFn xs FnPat _ _ _ -> validateFn xs
WithPat _ _ -> validateWith xs WithPat _ _ _ -> validateWith xs
DoPat _ -> validateDo xs DoPat _ _ -> validateDo xs
WhilePat _ _ -> validateWhile xs WhilePat _ _ _ -> validateWhile xs
-- There are a number of application patterns (the "has static call patterns") -- There are a number of application patterns (the "has static call patterns")
-- that are formally caught at evaluation time. -- that are formally caught at evaluation time.
AppPat (ClosurePat _ _ _) _ -> validateApp xs 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 -- for truthiness But there is a class of list forms we can rule out purely
-- symbolically, e.g. `def`, etc.. -- symbolically, e.g. `def`, etc..
validateIf :: [XObj] -> Either Malformed [XObj] validateIf :: [XObj] -> Either Malformed [XObj]
validateIf x@(IfPat (ListPat _ _) _ _) = Right x -- needs further evaluation validateIf x@(IfPat _ (ListPat _) _ _) = Right x -- needs further evaluation
validateIf (IfPat (ArrPat invalid _) _ _) = Left (InvalidCondition invalid (IfInvalidCondition invalid)) validateIf (IfPat _ invalid@(ArrPat _) _ _) = Left (InvalidCondition invalid (IfInvalidCondition invalid))
validateIf x@(IfPat cond _ _) validateIf x@(IfPat _ cond _ _)
| isSym cond = Right x -- needs further evaluation | isSym cond = Right x -- needs further evaluation
| isBool cond = Right x | isBool cond = Right x
| otherwise = Left (InvalidCondition cond (IfInvalidCondition cond)) | 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. -- | Validation of (while cond body) expressions.
validateWhile :: [XObj] -> Either Malformed [XObj] validateWhile :: [XObj] -> Either Malformed [XObj]
validateWhile x@(WhilePat (ListPat _ _) _) = Right x -- needs further evaluation validateWhile x@(WhilePat _ (ListPat _) _) = Right x -- needs further evaluation
validateWhile (WhilePat (ArrPat invalid _) _) = Left (InvalidCondition invalid (WhileInvalidCondition invalid)) validateWhile (WhilePat _ invalid@(ArrPat _) _) = Left (InvalidCondition invalid (WhileInvalidCondition invalid))
validateWhile x@(WhilePat cond _) validateWhile x@(WhilePat _ cond _)
| isSym cond = Right x -- needs further evaluation | isSym cond = Right x -- needs further evaluation
| isBool cond = Right x | isBool cond = Right x
| otherwise = Left (InvalidCondition cond (WhileInvalidCondition cond)) | 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. -- | Validation of (def name value) expressions.
validateDef :: [XObj] -> Either Malformed [XObj] validateDef :: [XObj] -> Either Malformed [XObj]
validateDef x@(DefPat (UnqualifiedSymPat _ _) _) = Right x validateDef x@(DefPat _ (UnqualifiedSymPat _) _) = Right x
validateDef (DefPat (SymPat invalid _) _) = Left (QualifiedIdentifier invalid None) validateDef (DefPat _ invalid@(SymPat _) _) = Left (QualifiedIdentifier invalid None)
validateDef (DefPat invalid _) = Left (InvalidIdentifier invalid None) validateDef (DefPat _ invalid _) = Left (InvalidIdentifier invalid None)
validateDef def = Left (GenericMalformed (XObj (Lst def) Nothing Nothing)) validateDef def = Left (GenericMalformed (XObj (Lst def) Nothing Nothing))
-- | Validation of (defn name [args] body) expressions. -- | Validation of (defn name [args] body) expressions.
validateDefn :: [XObj] -> Either Malformed [XObj] 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 isSym args) = Left (InvalidArguments arr (DefnNonSymArgs (head (remove isSym args))))
| not (all isUnqualifiedSym args) = | not (all isUnqualifiedSym args) =
Left (InvalidArguments arr (DefnQualifiedSyms (head (remove isUnqualifiedSym args)))) Left (InvalidArguments arr (DefnQualifiedSyms (head (remove isUnqualifiedSym args))))
| otherwise = pure x | otherwise = pure x
validateDefn (DefnPat (UnqualifiedSymPat _ _) invalid _) = validateDefn (DefnPat _ (UnqualifiedSymPat _) invalid _) =
Left (InvalidArguments invalid (DefnNonArrayArgs invalid)) Left (InvalidArguments invalid (DefnNonArrayArgs invalid))
validateDefn (DefnPat (SymPat invalid _) _ _) = Left (QualifiedIdentifier invalid None) validateDefn (DefnPat _ invalid@(SymPat _) _ _) = Left (QualifiedIdentifier invalid None)
validateDefn (DefnPat invalid _ _) = Left (InvalidIdentifier invalid None) validateDefn (DefnPat _ invalid _ _) = Left (InvalidIdentifier invalid None)
validateDefn defn = Left (GenericMalformed (XObj (Lst defn) Nothing Nothing)) validateDefn defn = Left (GenericMalformed (XObj (Lst defn) Nothing Nothing))
-- | Validation of (the type body) expressions -- | Validation of (the type body) expressions
@ -251,33 +266,33 @@ validateThe :: [XObj] -> Either Malformed [XObj]
validateThe x@(ThePat _ t _) = validateThe x@(ThePat _ t _) =
case xobjToTy t of case xobjToTy t of
Nothing -> Left (InvalidType t (TheInvalidType t)) Nothing -> Left (InvalidType t (TheInvalidType t))
Just _ -> Right x Just _ -> Right x
validateThe the = Left (GenericMalformed (XObj (Lst the) Nothing Nothing)) validateThe the = Left (GenericMalformed (XObj (Lst the) Nothing Nothing))
-- | Validation of (let [bindings] body) expressions. -- | Validation of (let [bindings] body) expressions.
validateLet :: [XObj] -> Either Malformed [XObj] validateLet :: [XObj] -> Either Malformed [XObj]
validateLet x@(LetPat (ArrPat arr binds) _) validateLet x@(LetPat _ arr@(ArrPat binds) _)
| odd (length binds) = | odd (length binds) =
Left (UnevenForms arr (length binds) (LetUnevenForms arr)) Left (UnevenForms arr (length binds) (LetUnevenForms arr))
| not (all isSym (evenIndices binds)) = | 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 | 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)) validateLet lett = Left (GenericMalformed (XObj (Lst lett) Nothing Nothing))
-- | Validation of (fn [args] body) expressions. -- | Validation of (fn [args] body) expressions.
validateFn :: [XObj] -> Either Malformed [XObj] 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 isSym args) = Left (InvalidArguments arr (FnNonSymArgs (head (remove isSym args))))
| not (all isUnqualifiedSym args) = | not (all isUnqualifiedSym args) =
Left (InvalidArguments arr (FnQualifiedSyms (head (remove isUnqualifiedSym args)))) Left (InvalidArguments arr (FnQualifiedSyms (head (remove isUnqualifiedSym args))))
| otherwise = pure x | otherwise = pure x
validateFn (FnPat _ invalid _) = Left (InvalidArguments invalid (FnNonArrayArgs invalid)) validateFn (FnPat _ invalid _) = Left (InvalidArguments invalid (FnNonArrayArgs invalid))
validateFn fn = Left (GenericMalformed (XObj (Lst fn) Nothing Nothing)) validateFn fn = Left (GenericMalformed (XObj (Lst fn) Nothing Nothing))
-- | Validation of (do body) expressions. -- | Validation of (do body) expressions.
validateDo :: [XObj] -> Either Malformed [XObj] validateDo :: [XObj] -> Either Malformed [XObj]
validateDo x@(DoPat forms) = validateDo x@(DoPat _ forms) =
case forms of case forms of
[] -> Left DoMissingForms [] -> Left DoMissingForms
_ -> Right x _ -> Right x
@ -301,14 +316,15 @@ validateApp x@(AppPat f@(CommandPat arity _ _) args) =
(BinaryCommandFunction _) -> checkAppArity f p args >> Right x (BinaryCommandFunction _) -> checkAppArity f p args >> Right x
(TernaryCommandFunction _) -> checkAppArity f p args >> Right x (TernaryCommandFunction _) -> checkAppArity f p args >> Right x
(VariadicCommandFunction _) -> Right x (VariadicCommandFunction _) -> Right x
where p = (\y -> XObj (Sym (SymPath [] y) Symbol) Nothing Nothing) <$> argnames where
argnames = p = (\y -> XObj (Sym (SymPath [] y) Symbol) Nothing Nothing) <$> argnames
case arity of argnames =
NullaryCommandFunction _ -> [] case arity of
UnaryCommandFunction _ -> ["x"] NullaryCommandFunction _ -> []
BinaryCommandFunction _ -> ["x", "y"] UnaryCommandFunction _ -> ["x"]
TernaryCommandFunction _ -> ["x", "y", "z"] BinaryCommandFunction _ -> ["x", "y"]
VariadicCommandFunction _ -> [] TernaryCommandFunction _ -> ["x", "y", "z"]
VariadicCommandFunction _ -> []
validateApp x@(AppPat f@(PrimitivePat arity _ _) args) = validateApp x@(AppPat f@(PrimitivePat arity _ _) args) =
case arity of case arity of
(NullaryPrimitive _) -> checkAppArity f p args >> Right x (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 (TernaryPrimitive _) -> checkAppArity f p args >> Right x
(QuaternaryPrimitive _) -> checkAppArity f p args >> Right x (QuaternaryPrimitive _) -> checkAppArity f p args >> Right x
(VariadicPrimitive _) -> Right x (VariadicPrimitive _) -> Right x
where p = (\y -> XObj (Sym (SymPath [] y) Symbol) Nothing Nothing) <$> argnames where
argnames = p = (\y -> XObj (Sym (SymPath [] y) Symbol) Nothing Nothing) <$> argnames
case arity of argnames =
NullaryPrimitive _ -> [] case arity of
UnaryPrimitive _ -> ["x"] NullaryPrimitive _ -> []
BinaryPrimitive _ -> ["x", "y"] UnaryPrimitive _ -> ["x"]
TernaryPrimitive _ -> ["x", "y", "z"] BinaryPrimitive _ -> ["x", "y"]
QuaternaryPrimitive _ -> ["x", "y", "z", "w"] TernaryPrimitive _ -> ["x", "y", "z"]
VariadicPrimitive _ -> [] QuaternaryPrimitive _ -> ["x", "y", "z", "w"]
VariadicPrimitive _ -> []
validateApp (AppPat invalid _) = Left (InvalidApplication invalid) validateApp (AppPat invalid _) = Left (InvalidApplication invalid)
validateApp app = Left (GenericMalformed (XObj (Lst app) Nothing Nothing)) validateApp app = Left (GenericMalformed (XObj (Lst app) Nothing Nothing))
-- | Validation of (with module body) expressions -- | Validation of (with module body) expressions
validateWith :: [XObj] -> Either Malformed [XObj] validateWith :: [XObj] -> Either Malformed [XObj]
validateWith x@(WithPat (SymPat _ _) _) = Right x validateWith x@(WithPat _ (SymPat _) _) = Right x
validateWith (WithPat invalid _) = Left (InvalidIdentifier invalid (InvalidWith invalid)) validateWith (WithPat _ invalid _) = Left (InvalidIdentifier invalid (InvalidWith invalid))
validateWith with = Left (GenericMalformed (XObj (Lst with) Nothing Nothing)) validateWith with = Left (GenericMalformed (XObj (Lst with) Nothing Nothing))
-- | Checks that the number of arguments passed to a function are correct. -- | Checks that the number of arguments passed to a function are correct.
@ -351,62 +368,68 @@ checkAppArity xobj params args =
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Pattern Synonyms -- Pattern Synonyms
pattern ArrPat :: XObj -> [XObj] -> XObj pattern ArrPat :: [XObj] -> XObj
pattern ArrPat self members <- self@(XObj (Arr members) _ _) pattern ArrPat members <- XObj (Arr members) _ _
pattern ListPat :: XObj -> [XObj] -> XObj pattern StaticArrPat :: [XObj] -> XObj
pattern ListPat self members <- self@(XObj (Lst members) _ _) pattern StaticArrPat members <- XObj (StaticArr members) _ _
pattern SymPat :: XObj -> SymPath -> XObj pattern ListPat :: [XObj] -> XObj
pattern SymPat self path <- self@(XObj (Sym path _) _ _) pattern ListPat members <- XObj (Lst members) _ _
pattern UnqualifiedSymPat :: XObj -> SymPath -> XObj pattern SymPat :: SymPath -> XObj
pattern UnqualifiedSymPat self path <- self@(XObj (Sym path@(SymPath [] _) _) _ _) pattern SymPat path <- XObj (Sym path _) _ _
pattern DefPat :: XObj -> XObj -> [XObj] pattern UnqualifiedSymPat :: SymPath -> XObj
pattern DefPat name value <- [XObj Def _ _, name, value] pattern UnqualifiedSymPat path <- XObj (Sym path@(SymPath [] _) _) _ _
pattern DefnPat :: XObj -> XObj -> XObj -> [XObj] pattern DefPat :: XObj -> XObj -> XObj -> [XObj]
pattern DefnPat name args body <- [XObj (Defn _) _ _, name, args, body] pattern DefPat def name value <- [def@(XObj Def _ _), name, value]
pattern IfPat :: XObj -> XObj -> XObj -> [XObj] pattern DefnPat :: XObj -> XObj -> XObj -> XObj -> [XObj]
pattern IfPat cond true false <- [XObj If _ _, cond, true, false] 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 :: 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 RefPat :: XObj -> XObj -> [XObj]
pattern LetPat bindings body <- [XObj Let _ _, bindings, body] 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 :: 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 :: [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 :: 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 :: 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 :: 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 :: 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 :: XObj -> [XObj] -> [XObj]
pattern AppPat f args <- (f:args) 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]

4
src/Infer.hs
View File

@ -14,6 +14,7 @@ import Concretize
import Constraints import Constraints
import GenerateConstraints import GenerateConstraints
import InitialTypes import InitialTypes
import Memory
import Obj import Obj
import Qualify import Qualify
import TypeError import TypeError
@ -28,7 +29,8 @@ annotate typeEnv globalEnv qualifiedXObj rootSig =
do do
initiated <- initialTypes typeEnv globalEnv (unQualified qualifiedXObj) initiated <- initialTypes typeEnv globalEnv (unQualified qualifiedXObj)
(annotated, dependencies) <- annotateUntilDone typeEnv globalEnv initiated rootSig [] 100 (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 finalWithNiceTypes <- beautifyTypeVariables final
pure (finalWithNiceTypes, dependencies ++ deleteDeps) pure (finalWithNiceTypes, dependencies ++ deleteDeps)

11
src/Info.hs
View File

@ -10,6 +10,8 @@ module Info
freshVar, freshVar,
machineReadableInfo, machineReadableInfo,
makeTypeVariableNameFromInfo, makeTypeVariableNameFromInfo,
setDeletersOnInfo,
addDeletersToInfo,
) )
where where
@ -105,3 +107,12 @@ makeTypeVariableNameFromInfo :: Maybe Info -> String
makeTypeVariableNameFromInfo (Just i) = makeTypeVariableNameFromInfo (Just i) =
"tyvar-from-info-" ++ show (infoIdentifier i) ++ "_" ++ show (infoLine i) ++ "_" ++ show (infoColumn i) "tyvar-from-info-" ++ show (infoIdentifier i) ++ "_" ++ show (infoLine i) ++ "_" ++ show (infoColumn i)
makeTypeVariableNameFromInfo Nothing = error "unnamed-typevariable" 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
View 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

9
src/Obj.hs
View File

@ -1027,6 +1027,15 @@ unwrapSymPathXObj :: XObj -> Either String SymPath
unwrapSymPathXObj (XObj (Sym p _) _ _) = Right p unwrapSymPathXObj (XObj (Sym p _) _ _) = Right p
unwrapSymPathXObj x = Left ("The value '" ++ pretty x ++ "' at " ++ prettyInfoFromXObj x ++ " is not a Symbol.") 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? -- | Given a form, what definition mode will it generate?
definitionMode :: XObj -> DefinitionMode definitionMode :: XObj -> DefinitionMode
definitionMode (XObj (Lst (XObj Def _ _ : _)) _ _) = AVariable definitionMode (XObj (Lst (XObj Def _ _ : _)) _ _) = AVariable

100
src/Polymorphism.hs
View File

@ -1,9 +1,15 @@
module Polymorphism module Polymorphism
( nameOfPolymorphicFunction, ( nameOfPolymorphicFunction,
allImplementations,
FunctionFinderResult (..),
findFunctionForMember,
findFunctionForMemberIncludePrimitives,
) )
where where
import Env as E import Data.Either (fromRight)
import Env
import Managed
import Obj import Obj
import Types import Types
@ -19,8 +25,8 @@ import Types
nameOfPolymorphicFunction :: TypeEnv -> Env -> Ty -> String -> Maybe SymPath nameOfPolymorphicFunction :: TypeEnv -> Env -> Ty -> String -> Maybe SymPath
nameOfPolymorphicFunction _ env functionType functionName = nameOfPolymorphicFunction _ env functionType functionName =
let foundBinder = let foundBinder =
(E.findPoly env functionName functionType) (findPoly env functionName functionType)
<> (E.findPoly (progenitor env) functionName functionType) <> (findPoly (progenitor env) functionName functionType)
in case foundBinder of in case foundBinder of
Right (_, (Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))) -> Right (_, (Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))) ->
Just (SymPath [] name) Just (SymPath [] name)
@ -31,3 +37,91 @@ nameOfPolymorphicFunction _ env functionType functionName =
concretizedPath = SymPath pathStrings (name ++ suffix) concretizedPath = SymPath pathStrings (name ++ suffix)
in Just concretizedPath in Just concretizedPath
_ -> Nothing _ -> 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)

3
src/Set.hs
View File

@ -28,6 +28,9 @@ intersection (Set a) (Set b) = Set (S.intersection a b)
union :: Ord v => Set v -> Set v -> Set v union :: Ord v => Set v -> Set v -> Set v
union (Set a) (Set b) = Set (S.union a b) 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 :: Ord v => v -> Set v -> Bool
member k (Set s) = S.member k s member k (Set s) = S.member k s

2
src/StructUtils.hs
View File

@ -5,6 +5,8 @@ import Obj
import Polymorphism import Polymorphism
import Types import Types
data AllocationMode = StackAlloc | HeapAlloc
-- | The 'str'/'prn' functions for primitive types don't take refs, while other types do -- | 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. -- so we need to adjust for that when finding and calling them in compound types.
-- The returned tuple contains ("" || "&", `str function type`). -- The returned tuple contains ("" || "&", `str function type`).

6
src/Util.hs
View File

@ -130,6 +130,10 @@ toMaybe f e = either (const Nothing) (Just . f) e
maybeId :: Either a b -> Maybe b maybeId :: Either a b -> Maybe b
maybeId = toMaybe id 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 (Right _) cont = cont
whenRight (Left err) _ = pure (Left err) 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)