zeolite-lang-0.16.1.0: src/CompilerCxx/Procedure.hs
{- -----------------------------------------------------------------------------
Copyright 2019-2021 Kevin P. Barry
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
----------------------------------------------------------------------------- -}
-- Author: Kevin P. Barry [ta0kira@gmail.com]
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Safe #-}
module CompilerCxx.Procedure (
CxxFunctionType(..),
categoriesFromTypes,
categoriesFromDefine,
categoriesFromRefine,
compileExecutableProcedure,
compileMainProcedure,
compileLazyInit,
compileRegularInit,
compileTestProcedure,
procedureDeclaration,
selectTestFromArgv1,
) where
import Control.Applicative ((<|>))
import Control.Monad (when)
import Control.Monad.Trans.State (execStateT,get,put,runStateT)
import Control.Monad.Trans (lift)
import Data.List (intercalate,nub)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Base.CompilerError
import Base.GeneralType
import Base.MergeTree
import Base.Positional
import Compilation.CompilerState
import Compilation.ProcedureContext (ExprMap)
import Compilation.ScopeContext
import CompilerCxx.CategoryContext
import CompilerCxx.Code
import CompilerCxx.Naming
import Types.Builtin
import Types.DefinedCategory
import Types.Function
import Types.Procedure
import Types.TypeCategory
import Types.TypeInstance
import Types.Variance
procedureDeclaration :: Monad m => Bool -> ScopedFunction c -> m (CompiledData [String])
procedureDeclaration abstract f = return $ onlyCode func where
func
| abstract = "virtual " ++ proto ++ " = 0;"
| otherwise = proto ++ ";"
name = callName (sfName f)
proto
| sfScope f == CategoryScope =
"ReturnTuple " ++ name ++ "(const ParamTuple& params, const ValueTuple& args)"
| sfScope f == TypeScope =
"ReturnTuple " ++ name ++
"(const S<TypeInstance>& Param_self, const ParamTuple& params, const ValueTuple& args)"
| sfScope f == ValueScope =
"ReturnTuple " ++ name ++
"(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args)"
| otherwise = undefined
data CxxFunctionType =
InlineFunction |
OutOfLineFunction String |
FinalInlineFunction
deriving Show
compileExecutableProcedure :: (Ord c, Show c, CollectErrorsM m) =>
CxxFunctionType -> ScopeContext c -> ScopedFunction c ->
ExecutableProcedure c -> m (CompiledData [String])
compileExecutableProcedure cxxType ctx
ff@(ScopedFunction _ _ _ s as1 rs1 ps1 _ _)
pp@(ExecutableProcedure c pragmas c2 n as2 rs2 p) = do
ctx' <- getProcedureContext ctx ff pp
output <- runDataCompiler compileWithReturn ctx'
procedureTrace <- setProcedureTrace
creationTrace <- setCreationTrace
return $ wrapProcedure output procedureTrace creationTrace
where
compileWithReturn = do
ctx0 <- getCleanContext >>= lift . flip ccSetNoTrace (any isNoTrace pragmas)
compileProcedure ctx0 p >>= put
unreachable <- csIsUnreachable
when (not unreachable) $
doImplicitReturn c2 <??
"In implicit return from " ++ show n ++ formatFullContextBrace c
funcMergeDeps f = mconcat $ (CompiledData (Set.fromList [sfType f]) []):(map funcMergeDeps $ sfMerges f)
wrapProcedure output pt ct =
mconcat [
funcMergeDeps ff,
onlyCode proto,
indentCompiled $ onlyCodes pt,
indentCompiled $ onlyCodes ct,
indentCompiled $ onlyCodes defineReturns,
indentCompiled $ onlyCodes nameParams,
indentCompiled $ onlyCodes nameArgs,
indentCompiled $ onlyCodes nameReturns,
indentCompiled output,
onlyCode close
]
close = "}"
name = callName n
prefix = case cxxType of
OutOfLineFunction cn -> cn ++ "::"
_ -> ""
final = case cxxType of
FinalInlineFunction -> " final"
_ -> ""
proto
| s == CategoryScope =
returnType ++ " " ++ prefix ++ name ++ "(const ParamTuple& params, const ValueTuple& args)" ++ final ++ " {"
| s == TypeScope =
returnType ++ " " ++ prefix ++ name ++
"(const S<TypeInstance>& Param_self, const ParamTuple& params, const ValueTuple& args)" ++ final ++ " {"
| s == ValueScope =
returnType ++ " " ++ prefix ++ name ++
"(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args)" ++ final ++ " {"
| otherwise = undefined
returnType = "ReturnTuple"
setProcedureTrace
| any isNoTrace pragmas = return []
| otherwise = return [startFunctionTracing (scName ctx) ff]
setCreationTrace
| not $ any isTraceCreation pragmas = return []
| s /= ValueScope =
(compilerWarningM $ "Creation tracing ignored for " ++ show s ++
" functions" ++ formatFullContextBrace c) >> return []
| otherwise = return [showCreationTrace]
defineReturns
| isUnnamedReturns rs2 = []
| otherwise = [returnType ++ " returns(" ++ show (length $ pValues rs1) ++ ");"]
nameParams = flip map (zip ([0..] :: [Int]) $ pValues ps1) $
(\(i,p2) -> paramType ++ " " ++ paramName (vpParam p2) ++ " = params.At(" ++ show i ++ ");")
nameArgs = flip map (zip ([0..] :: [Int]) $ filter (not . isDiscardedInput . snd) $ zip (pValues as1) (pValues $ avNames as2)) $
(\(i,(t2,n2)) -> "const " ++ variableProxyType (pvType t2) ++ " " ++ variableName (ivName n2) ++
" = " ++ writeStoredVariable (pvType t2) (UnwrappedSingle $ "args.At(" ++ show i ++ ")") ++ ";")
nameReturns
| isUnnamedReturns rs2 = []
| otherwise = map (\(i,(t2,n2)) -> nameReturn i (pvType t2) n2) (zip ([0..] :: [Int]) $ zip (pValues rs1) (pValues $ nrNames rs2))
nameReturn i t2 n2
| isPrimitiveType t2 = variableProxyType t2 ++ " " ++ variableName (ovName n2) ++ ";"
| otherwise =
variableProxyType t2 ++ " " ++ variableName (ovName n2) ++
" = " ++ writeStoredVariable t2 (UnwrappedSingle $ "returns.At(" ++ show i ++ ")") ++ ";"
compileCondition :: (Ord c, Show c, CollectErrorsM m,
CompilerContext c m [String] a) =>
a -> [c] -> Expression c -> CompilerState a m (String,a)
compileCondition ctx c e = do
(e',ctx') <- resetBackgroundM $ lift $ runStateT compile ctx
noTrace <- csGetNoTrace
if noTrace
then return (e',ctx')
else return (predTraceContext c ++ e',ctx')
where
compile = "In condition at " ++ formatFullContext c ??> do
(ts,e') <- compileExpression e
checkCondition ts
return $ useAsUnboxed PrimBool e'
where
checkCondition (Positional [t]) | t == boolRequiredValue = return ()
checkCondition (Positional ts) =
compilerErrorM $ "Expected exactly one Bool value but got " ++
intercalate ", " (map show ts)
-- Returns the state so that returns can be properly checked for if/elif/else.
compileProcedure :: (Ord c, Show c, CollectErrorsM m,
CompilerContext c m [String] a) =>
a -> Procedure c -> CompilerState a m a
compileProcedure ctx (Procedure _ ss) = do
ctx' <- lift $ execStateT (sequence $ map compile ss) ctx
return ctx' where
compile s = do
unreachable <- csIsUnreachable
if unreachable && not (isRawCodeLine s)
then compilerWarningM $ "Statement at " ++
formatFullContext (getStatementContext s) ++
" is unreachable (skipping compilation)"
else do
s' <- resetBackgroundM $ compileStatement s
return s'
maybeSetTrace :: (Ord c, Show c, CollectErrorsM m,
CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
maybeSetTrace c = do
noTrace <- csGetNoTrace
when (not noTrace) $ csWrite $ setTraceContext c
compileStatement :: (Ord c, Show c, CollectErrorsM m,
CompilerContext c m [String] a) =>
Statement c -> CompilerState a m ()
compileStatement (EmptyReturn c) = do
maybeSetTrace c
doImplicitReturn c
compileStatement (ExplicitReturn c es) = do
es' <- sequence $ map compileExpression $ pValues es
getReturn $ zip (map getExpressionContext $ pValues es) es'
where
-- Single expression, but possibly multi-return.
getReturn [(_,(Positional ts,e))] = do
csRegisterReturn c $ Just (Positional ts)
maybeSetTrace c
autoPositionalCleanup c e
-- Multi-expression => must all be singles.
getReturn rs = do
lift (mapCompilerM_ checkArity $ zip ([0..] :: [Int]) $ map (fst . snd) rs) <??
("In return at " ++ formatFullContext c)
csRegisterReturn c $ Just $ Positional $ map (head . pValues . fst . snd) rs
let e = OpaqueMulti $ "ReturnTuple(" ++ intercalate "," (map (useAsUnwrapped . snd . snd) rs) ++ ")"
maybeSetTrace c
autoPositionalCleanup c e
checkArity (_,Positional [_]) = return ()
checkArity (i,Positional ts) =
compilerErrorM $ "Return position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1"
compileStatement (LoopBreak c) = do
loop <- csGetLoop
case loop of
NotInLoop ->
compilerErrorM $ "Using break outside of while is no allowed" ++ formatFullContextBrace c
_ -> return ()
csSetJumpType c JumpBreak
get >>= autoInsertCleanup c JumpBreak
csWrite ["break;"]
compileStatement (LoopContinue c) = do
loop <- csGetLoop
case loop of
NotInLoop ->
compilerErrorM $ "Using continue outside of while is no allowed" ++ formatFullContextBrace c
_ -> return ()
csSetJumpType c JumpContinue
get >>= autoInsertCleanup c JumpContinue
csWrite $ ["{"] ++ lsUpdate loop ++ ["}","continue;"]
compileStatement (FailCall c e) = do
csAddRequired (Set.fromList [BuiltinFormatted,BuiltinString])
e' <- compileExpression e
when (length (pValues $ fst e') /= 1) $
compilerErrorM $ "Expected single return in argument" ++ formatFullContextBrace c
let (Positional [t0],e0) = e'
r <- csResolver
fa <- csAllFilters
lift $ (checkValueAssignment r fa t0 formattedRequiredValue) <??
"In fail call at " ++ formatFullContext c
csSetJumpType c JumpFailCall
maybeSetTrace c
csWrite ["BUILTIN_FAIL(" ++ useAsUnwrapped e0 ++ ")"]
compileStatement (RawFailCall s) = do
csSetJumpType [] JumpFailCall
csWrite ["RAW_FAIL(" ++ show s ++ ")"]
compileStatement (IgnoreValues c e) = do
(_,e') <- compileExpression e
maybeSetTrace c
csWrite ["(void) (" ++ useAsWhatever e' ++ ");"]
compileStatement (Assignment c as e) = message ??> do
(ts,e') <- compileExpression e
r <- csResolver
fa <- csAllFilters
-- Check for a count match first, to avoid the default error message.
_ <- processPairsT alwaysPair (fmap assignableName as) ts
_ <- processPairsT (createVariable r fa) as ts
maybeSetTrace c
variableTypes <- sequence $ map (uncurry getVariableType) $ zip (pValues as) (pValues ts)
assignAll (zip3 ([0..] :: [Int]) variableTypes (pValues as)) e'
where
message = "In assignment at " ++ formatFullContext c
assignAll [v] e2 = assignSingle v e2
assignAll vs e2 = do
csWrite ["{","const auto r = " ++ useAsReturns e2 ++ ";"]
sequence_ $ map assignMulti vs
csWrite ["}"]
getVariableType (CreateVariable _ t _) _ = return t
getVariableType (ExistingVariable (InputValue c2 n)) _ = do
(VariableValue _ _ t _) <- csGetVariable (UsedVariable c2 n)
return t
getVariableType (ExistingVariable (DiscardInput _)) t = return t
createVariable r fa (CreateVariable c2 t1 n) t2 =
"In creation of " ++ show n ++ " at " ++ formatFullContext c2 ??> do
self <- autoSelfType
t1' <- lift $ replaceSelfValueType self t1
-- TODO: Call csAddRequired for t1'. (Maybe needs a helper function.)
lift $ collectAllM_ [validateGeneralInstance r (Map.keysSet fa) (vtType t1'),
checkValueAssignment r fa t2 t1']
csAddVariable (UsedVariable c2 n) (VariableValue c2 LocalScope t1' VariableDefault)
csWrite [variableStoredType t1' ++ " " ++ variableName n ++ ";"]
createVariable r fa (ExistingVariable (InputValue c2 n)) t2 =
"In assignment to " ++ show n ++ " at " ++ formatFullContext c2 ??> do
(VariableValue _ _ t1 _) <- getWritableVariable c2 n
-- TODO: Also show original context.
lift $ (checkValueAssignment r fa t2 t1)
csUpdateAssigned n
createVariable _ _ _ _ = return ()
assignSingle (_,t,CreateVariable _ _ n) e2 =
csWrite [variableName n ++ " = " ++ writeStoredVariable t e2 ++ ";"]
assignSingle (_,t,ExistingVariable (InputValue c2 n)) e2 = do
(VariableValue _ s _ _) <- csGetVariable (UsedVariable c2 n)
scoped <- autoScope s
csWrite [scoped ++ variableName n ++ " = " ++ writeStoredVariable t e2 ++ ";"]
assignSingle _ _ = return ()
assignMulti (i,t,CreateVariable _ _ n) =
csWrite [variableName n ++ " = " ++
writeStoredVariable t (UnwrappedSingle $ "r.At(" ++ show i ++ ")") ++ ";"]
assignMulti (i,t,ExistingVariable (InputValue _ n)) = do
(VariableValue _ s _ _) <- csGetVariable (UsedVariable c n)
scoped <- autoScope s
csWrite [scoped ++ variableName n ++ " = " ++
writeStoredVariable t (UnwrappedSingle $ "r.At(" ++ show i ++ ")") ++ ";"]
assignMulti _ = return ()
compileStatement (NoValueExpression _ v) = compileVoidExpression v
compileStatement (MarkReadOnly c vs) = mapM_ (\v -> csSetReadOnly (UsedVariable c v)) vs
compileStatement (MarkHidden c vs) = mapM_ (\v -> csSetHidden (UsedVariable c v)) vs
compileStatement (RawCodeLine s) = csWrite [s]
compileRegularInit :: (Ord c, Show c, CollectErrorsM m,
CompilerContext c m [String] a) =>
DefinedMember c -> CompilerState a m ()
compileRegularInit (DefinedMember _ _ _ _ Nothing) = return ()
compileRegularInit (DefinedMember c2 s t n2 (Just e)) = resetBackgroundM $ do
csAddVariable (UsedVariable c2 n2) (VariableValue c2 s t VariableDefault)
let assign = Assignment c2 (Positional [ExistingVariable (InputValue c2 n2)]) e
compileStatement assign
getWritableVariable :: (Show c, CollectErrorsM m, CompilerContext c m [String] a) =>
[c] -> VariableName -> CompilerState a m (VariableValue c)
getWritableVariable c n = do
v@(VariableValue _ _ _ ro) <- csGetVariable (UsedVariable c n)
case ro of
VariableReadOnly [] -> compilerErrorM $ "Variable " ++ show n ++
formatFullContextBrace c ++ " is read-only"
VariableReadOnly c2 -> compilerErrorM $ "Variable " ++ show n ++
formatFullContextBrace c ++ " is marked read-only at " ++ formatFullContext c2
_ -> return v
compileLazyInit :: (Ord c, Show c, CollectErrorsM m,
CompilerContext c m [String] a) =>
DefinedMember c -> CompilerState a m ()
compileLazyInit (DefinedMember _ _ _ _ Nothing) = return ()
compileLazyInit (DefinedMember c _ t1 n (Just e)) = resetBackgroundM $ do
(ts,e') <- compileExpression e
when (length (pValues ts) /= 1) $
compilerErrorM $ "Expected single return in initializer" ++ formatFullContextBrace (getExpressionContext e)
r <- csResolver
fa <- csAllFilters
let Positional [t2] = ts
lift $ (checkValueAssignment r fa t2 t1) <??
"In initialization of " ++ show n ++ " at " ++ formatFullContext c
csWrite [variableName n ++ "([this]() { return " ++ writeStoredVariable t1 e' ++ "; })"]
compileVoidExpression :: (Ord c, Show c, CollectErrorsM m,
CompilerContext c m [String] a) =>
VoidExpression c -> CompilerState a m ()
compileVoidExpression (Conditional ie) = compileIfElifElse ie
compileVoidExpression (Loop l) = compileIteratedLoop l
compileVoidExpression (WithScope s) = compileScopedBlock s
compileVoidExpression (LineComment s) = csWrite $ map ("// " ++) $ lines s
compileVoidExpression (Unconditional p) = do
ctx0 <- getCleanContext
ctx <- compileProcedure ctx0 p
csWrite ["{"]
autoInlineOutput ctx
csWrite ["}"]
compileIfElifElse :: (Ord c, Show c, CollectErrorsM m,
CompilerContext c m [String] a) =>
IfElifElse c -> CompilerState a m ()
compileIfElifElse (IfStatement c e p es) = do
ctx0 <- getCleanContext
cs <- commonIf ctx0 "if" c e p es
csInheritReturns cs
where
unwind ctx0 (IfStatement c2 e2 p2 es2) = commonIf ctx0 "else if" c2 e2 p2 es2
unwind ctx0 (ElseStatement _ p2) = do
ctx <- compileProcedure ctx0 p2
inheritRequired ctx
csWrite ["else {"]
getAndIndentOutput ctx >>= csWrite
csWrite ["}"]
return [ctx]
unwind ctx0 TerminateConditional = return [ctx0]
commonIf ctx0 s c2 e2 p2 es2 = do
(e2',ctx1) <- compileCondition ctx0 c2 e2
ctx <- compileProcedure ctx1 p2
inheritRequired ctx
csWrite [s ++ " (" ++ e2' ++ ") {"]
getAndIndentOutput ctx >>= csWrite
csWrite ["}"]
cs <- unwind ctx1 es2
return $ ctx:cs
compileIfElifElse _ = undefined
compileIteratedLoop :: (Ord c, Show c, CollectErrorsM m, CompilerContext c m [String] a) =>
IteratedLoop c -> CompilerState a m ()
compileIteratedLoop (WhileLoop c e p u) = do
ctx0 <- getCleanContext
(e',ctx1) <- compileCondition ctx0 c e
csInheritReturns [ctx1]
ctx0' <- case u of
Just p2 -> do
ctx2 <- lift $ ccStartLoop ctx1 (LoopSetup [])
ctx3 <- compileProcedure ctx2 p2
inheritRequired ctx3
p2' <- getAndIndentOutput ctx3
lift $ ccStartLoop ctx1 (LoopSetup p2')
_ -> lift $ ccStartLoop ctx1 (LoopSetup [])
(LoopSetup u') <- lift $ ccGetLoop ctx0'
ctx <- compileProcedure ctx0' p
inheritRequired ctx
csWrite ["while (" ++ e' ++ ") {"]
getAndIndentOutput ctx >>= csWrite
csWrite $ ["{"] ++ u' ++ ["}"]
csWrite ["}"]
compileIteratedLoop (TraverseLoop c1 e c2 a (Procedure c3 ss)) = "In compilation of traverse at " ++ formatFullContext c1 ??> do
(Positional ts,e') <- compileExpression e
checkContainer ts
r <- csResolver
fa <- csAllFilters
let [t] = ts
let autoParam = ParamName "#auto"
let autoType = singleType $ JustParamName False autoParam
(Positional [t2]) <- lift $ guessParams r fa (Positional [orderOptionalValue autoType])
(Positional [autoParam])
(Positional [InferredInstance c1])
(Positional [t])
let currVar = hiddenVariableName $ VariableName "traverse"
let currType = orderOptionalValue $ fixTypeParams t2
let currExpr = BuiltinCall [] $ FunctionCall [] BuiltinRequire (Positional []) (Positional [RawExpression (Positional [currType]) (UnwrappedSingle currVar)])
let currPresent = BuiltinCall [] $ FunctionCall [] BuiltinPresent (Positional []) (Positional [RawExpression (Positional [currType]) (UnwrappedSingle currVar)])
let callNext = Expression c1 currExpr [ValueCall c1 $ FunctionCall c1 (FunctionName "next") (Positional []) (Positional [])]
let callGet = Expression c2 currExpr [ValueCall c2 $ FunctionCall c2 (FunctionName "get") (Positional []) (Positional [])]
(Positional [typeGet],exprNext) <- compileExpression callNext
when (typeGet /= currType) $ compilerErrorM $ "Unexpected return type from next(): " ++ show typeGet ++ " (expected) " ++ show currType ++ " (actual)"
let assnGet = Assignment c2 (Positional [a]) callGet
csAddRequired $ categoriesFromTypes $ vtType currType
compileStatement $ NoValueExpression [] $ WithScope $ ScopedBlock []
(Procedure [] [RawCodeLine $ variableStoredType currType ++ " " ++ currVar ++ " = " ++ writeStoredVariable currType e' ++ ";"]) Nothing []
(NoValueExpression [] $ Loop $ WhileLoop [] (Expression [] currPresent [])
(Procedure c3 (assnGet:ss))
(Just $ Procedure [] [RawCodeLine $ currVar ++ " = " ++ writeStoredVariable currType exprNext ++ ";"]))
where
checkContainer [_] = return ()
checkContainer ts =
compilerErrorM $ "Expected exactly one Order<?> value but got " ++
intercalate ", " (map show ts)
compileScopedBlock :: (Ord c, Show c, CollectErrorsM m,
CompilerContext c m [String] a) =>
ScopedBlock c -> CompilerState a m ()
compileScopedBlock s@(ScopedBlock _ _ _ c2 _) = do
let (vs,p,cl,st) = rewriteScoped s
self <- autoSelfType
vs' <- lift $ mapCompilerM (replaceSelfVariable self) vs
-- Capture context so we can discard scoped variable names.
ctx0 <- getCleanContext
r <- csResolver
fa <- csAllFilters
sequence_ $ map (createVariable r fa) vs'
ctxP0 <- compileProcedure ctx0 p
-- Make variables to be created visible *after* p has been compiled so that p
-- can't refer to them.
ctxP <- lift $ execStateT (sequence $ map showVariable vs') ctxP0
ctxCl0 <- lift $ ccClearOutput ctxP >>= flip ccStartCleanup c2
ctxP' <-
case cl of
-- Insert cleanup into the context for the in block.
Just (Procedure c ss) -> do
noTrace <- csGetNoTrace
let trace = if noTrace then [] else [RawCodeLine startCleanupTracing]
let p2' = Procedure c $ [RawCodeLine "{"] ++ trace ++ ss ++ [RawCodeLine "}"]
ctxCl <- compileProcedure ctxCl0 p2' <?? "In cleanup starting at " ++ formatFullContext c
ctxP' <- lift $ ccPushCleanup ctxP ctxCl
return ctxP'
-- Insert an empty cleanup so that it can be used below.
Nothing -> lift $ ccPushCleanup ctxP ctxCl0
ctxS <- compileProcedure ctxP' (Procedure [] [st])
csWrite ["{"]
autoInlineOutput ctxS
-- NOTE: Keep this after inlining the in block in case the in block contains a
-- jump. (If it does, the cleanup will already be inlined.)
unreachable <- csIsUnreachable
when (not unreachable) $ autoInsertCleanup c2 NextStatement ctxP'
csWrite ["}"]
sequence_ $ map showVariable vs'
where
replaceSelfVariable self (c,t,n) = do
t' <- replaceSelfValueType self t
return (c,t',n)
createVariable r fa (c,t,n) = do
lift $ validateGeneralInstance r (Map.keysSet fa) (vtType t) <??
"In creation of " ++ show n ++ " at " ++ formatFullContext c
csWrite [variableStoredType t ++ " " ++ variableName n ++ ";"]
showVariable (c,t,n) = do
-- TODO: Call csAddRequired for t. (Maybe needs a helper function.)
csAddVariable (UsedVariable c n) (VariableValue c LocalScope t VariableDefault)
-- Don't merge if the second scope has cleanup, so that the latter can't
-- refer to variables defined in the first scope.
rewriteScoped (ScopedBlock _ p cl@(Just _) _
s2@(NoValueExpression _ (WithScope
(ScopedBlock _ _ (Just _) _ _)))) =
([],p,cl,s2)
-- Merge chained scoped sections into a single section.
rewriteScoped (ScopedBlock c (Procedure c3 ss1) cl1 c4
(NoValueExpression _ (WithScope
(ScopedBlock _ (Procedure _ ss2) cl2 _ s2)))) =
rewriteScoped $ ScopedBlock c (Procedure c3 $ ss1 ++ ss2) (cl1 <|> cl2) c4 s2
-- Gather to-be-created variables.
rewriteScoped (ScopedBlock _ p cl _ (Assignment c3 vs e)) =
(created,p,cl,Assignment c3 (Positional existing) e) where
(created,existing) = foldr update ([],[]) (pValues vs)
update (CreateVariable c t n) (cs,es) = ((c,t,n):cs,(ExistingVariable $ InputValue c n):es)
update e2 (cs,es) = (cs,e2:es)
-- Merge the statement into the scoped block.
rewriteScoped (ScopedBlock _ p cl _ s2) =
([],p,cl,s2)
compileExpression :: (Ord c, Show c, CollectErrorsM m,
CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType,ExpressionValue)
compileExpression = compile where
compile (Literal (StringLiteral _ l)) = do
csAddRequired (Set.fromList [BuiltinString])
return (Positional [stringRequiredValue],UnboxedPrimitive PrimString $ "PrimString_FromLiteral(" ++ escapeChars l ++ ")")
compile (Literal (CharLiteral _ l)) = do
csAddRequired (Set.fromList [BuiltinChar])
return (Positional [charRequiredValue],UnboxedPrimitive PrimChar $ "PrimChar('" ++ escapeChar l ++ "')")
compile (Literal (IntegerLiteral c True l)) = do
csAddRequired (Set.fromList [BuiltinInt])
when (l > 2^(64 :: Integer) - 1) $ compilerErrorM $
"Literal " ++ show l ++ formatFullContextBrace c ++ " is greater than the max value for 64-bit unsigned"
let l' = if l > 2^(63 :: Integer) - 1 then l - 2^(64 :: Integer) else l
return (Positional [intRequiredValue],UnboxedPrimitive PrimInt $ "PrimInt(" ++ show l' ++ ")")
compile (Literal (IntegerLiteral c False l)) = do
csAddRequired (Set.fromList [BuiltinInt])
when (l > 2^(63 :: Integer) - 1) $ compilerErrorM $
"Literal " ++ show l ++ formatFullContextBrace c ++ " is greater than the max value for 64-bit signed"
when ((-l) > (2^(63 :: Integer) - 2)) $ compilerErrorM $
"Literal " ++ show l ++ formatFullContextBrace c ++ " is less than the min value for 64-bit signed"
return (Positional [intRequiredValue],UnboxedPrimitive PrimInt $ "PrimInt(" ++ show l ++ ")")
compile (Literal (DecimalLiteral _ l e)) = do
csAddRequired (Set.fromList [BuiltinFloat])
-- TODO: Check bounds.
return (Positional [floatRequiredValue],UnboxedPrimitive PrimFloat $ "PrimFloat(" ++ show l ++ "E" ++ show e ++ ")")
compile (Literal (BoolLiteral _ True)) = do
csAddRequired (Set.fromList [BuiltinBool])
return (Positional [boolRequiredValue],UnboxedPrimitive PrimBool "true")
compile (Literal (BoolLiteral _ False)) = do
csAddRequired (Set.fromList [BuiltinBool])
return (Positional [boolRequiredValue],UnboxedPrimitive PrimBool "false")
compile (Literal (EmptyLiteral _)) = do
return (Positional [emptyType],UnwrappedSingle "Var_empty")
compile (Expression _ s os) = do
foldl transform (compileExpressionStart s) os
compile (UnaryExpression c (FunctionOperator _ (FunctionSpec _ (CategoryFunction c2 cn) fn ps)) e) =
compile (Expression c (CategoryCall c2 cn (FunctionCall c fn ps (Positional [e]))) [])
compile (UnaryExpression c (FunctionOperator _ (FunctionSpec _ (TypeFunction c2 tn) fn ps)) e) =
compile (Expression c (TypeCall c2 tn (FunctionCall c fn ps (Positional [e]))) [])
compile (UnaryExpression c (FunctionOperator _ (FunctionSpec _ (ValueFunction c2 e0) fn ps)) e) =
compile (Expression c (ParensExpression c2 e0) [ValueCall c (FunctionCall c fn ps (Positional [e]))])
compile (UnaryExpression c (FunctionOperator _ (FunctionSpec c2 UnqualifiedFunction fn ps)) e) =
compile (Expression c (UnqualifiedCall c2 (FunctionCall c fn ps (Positional [e]))) [])
compile (UnaryExpression _ (NamedOperator c "-") (Literal (IntegerLiteral _ _ l))) =
compile (Literal (IntegerLiteral c False (-l)))
compile (UnaryExpression _ (NamedOperator c "-") (Literal (DecimalLiteral _ l e))) =
compile (Literal (DecimalLiteral c (-l) e))
compile (UnaryExpression _ (NamedOperator c o) e) = do
(Positional ts,e') <- compileExpression e
t' <- requireSingle c ts
doUnary t' e'
where
doUnary t e2
| o == "!" = doNot t e2
| o == "-" = doNeg t e2
| o == "~" = doComp t e2
| otherwise = compilerErrorM $ "Unknown unary operator \"" ++ o ++ "\" " ++
formatFullContextBrace c
doNot t e2 = do
when (t /= boolRequiredValue) $
compilerErrorM $ "Cannot use " ++ show t ++ " with unary ! operator" ++
formatFullContextBrace c
return $ (Positional [boolRequiredValue],UnboxedPrimitive PrimBool $ "!" ++ useAsUnboxed PrimBool e2)
doNeg t e2
| t == intRequiredValue = return $ (Positional [intRequiredValue],
UnboxedPrimitive PrimInt $ "-" ++ useAsUnboxed PrimInt e2)
| t == floatRequiredValue = return $ (Positional [floatRequiredValue],
UnboxedPrimitive PrimFloat $ "-" ++ useAsUnboxed PrimFloat e2)
| otherwise = compilerErrorM $ "Cannot use " ++ show t ++ " with unary - operator" ++
formatFullContextBrace c
doComp t e2
| t == intRequiredValue = return $ (Positional [intRequiredValue],
UnboxedPrimitive PrimInt $ "~" ++ useAsUnboxed PrimInt e2)
| otherwise = compilerErrorM $ "Cannot use " ++ show t ++ " with unary ~ operator" ++
formatFullContextBrace c
compile (InitializeValue c t es) = do
scope <- csCurrentScope
t' <- case scope of
CategoryScope -> case t of
Nothing -> compilerErrorM $ "Param " ++ show ParamSelf ++ " not found"
Just t0 -> return t0
_ -> do
self <- csSelfType
case t of
Just t0 -> lift $ replaceSelfSingle (singleType $ JustTypeInstance self) t0
Nothing -> return self
es' <- sequence $ map compileExpression $ pValues es
(ts,es'') <- lift $ getValues es'
csCheckValueInit c t' (Positional ts)
params <- expandParams $ tiParams t'
sameType <- csSameType t'
s <- csCurrentScope
let typeInstance = getType t' sameType s params
-- TODO: This is unsafe if used in a type or category constructor.
return (Positional [ValueType RequiredValue $ singleType $ JustTypeInstance t'],
UnwrappedSingle $ valueCreator (tiName t') ++ "(" ++ typeInstance ++ ", " ++ es'' ++ ")")
where
getType _ True ValueScope _ = "parent"
getType _ True TypeScope _ = "shared_from_this()"
getType t2 _ _ params = typeCreator (tiName t2) ++ "(" ++ params ++ ")"
-- Single expression, but possibly multi-return.
getValues [(Positional ts,e)] = return (ts,useAsArgs e)
-- Multi-expression => must all be singles.
getValues rs = do
(mapCompilerM_ checkArity $ zip ([0..] :: [Int]) $ map fst rs) <??
"In return at " ++ formatFullContext c
return (map (head . pValues . fst) rs,
"ArgTuple(" ++ intercalate ", " (map (useAsUnwrapped . snd) rs) ++ ")")
checkArity (_,Positional [_]) = return ()
checkArity (i,Positional ts) =
compilerErrorM $ "Initializer position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1"
compile (InfixExpression c e1 (FunctionOperator _ (FunctionSpec _ (CategoryFunction c2 cn) fn ps)) e2) =
compile (Expression c (CategoryCall c2 cn (FunctionCall c fn ps (Positional [e1,e2]))) [])
compile (InfixExpression c e1 (FunctionOperator _ (FunctionSpec _ (TypeFunction c2 tn) fn ps)) e2) =
compile (Expression c (TypeCall c2 tn (FunctionCall c fn ps (Positional [e1,e2]))) [])
compile (InfixExpression c e1 (FunctionOperator _ (FunctionSpec _ (ValueFunction c2 e0) fn ps)) e2) =
compile (Expression c (ParensExpression c2 e0) [ValueCall c (FunctionCall c fn ps (Positional [e1,e2]))])
compile (InfixExpression c e1 (FunctionOperator _ (FunctionSpec c2 UnqualifiedFunction fn ps)) e2) =
compile (Expression c (UnqualifiedCall c2 (FunctionCall c fn ps (Positional [e1,e2]))) [])
compile (InfixExpression _ e1 (NamedOperator c o) e2) = do
e1' <- compileExpression e1
e2' <- if o `Set.member` logical
then isolateExpression e2 -- Ignore named-return assignments.
else compileExpression e2
bindInfix c e1' o e2'
compile (RawExpression ts e) = return (ts,e)
isolateExpression e = do
ctx <- getCleanContext
(e',ctx') <- lift $ runStateT (compileExpression e) ctx
inheritRequired ctx'
csInheritUsed ctx'
return e'
arithmetic1 = Set.fromList ["*","/"]
arithmetic2 = Set.fromList ["%"]
arithmetic3 = Set.fromList ["+","-"]
equals = Set.fromList ["==","!="]
comparison = Set.fromList ["==","!=","<","<=",">",">="]
logical = Set.fromList ["&&","||"]
bitwise = Set.fromList ["&","|","^",">>","<<"]
bindInfix c (Positional ts1,e1) o (Positional ts2,e2) = do
-- TODO: Needs better error messages.
t1' <- requireSingle c ts1
t2' <- requireSingle c ts2
bind t1' t2'
where
bind t1 t2
| t1 /= t2 =
compilerErrorM $ "Cannot " ++ show o ++ " " ++ show t1 ++ " and " ++
show t2 ++ formatFullContextBrace c
| o `Set.member` comparison && t1 == intRequiredValue = do
return (Positional [boolRequiredValue],glueInfix PrimInt PrimBool e1 o e2)
| o `Set.member` comparison && t1 == floatRequiredValue = do
return (Positional [boolRequiredValue],glueInfix PrimFloat PrimBool e1 o e2)
| o `Set.member` comparison && t1 == stringRequiredValue = do
return (Positional [boolRequiredValue],glueInfix PrimString PrimBool e1 o e2)
| o `Set.member` comparison && t1 == charRequiredValue = do
return (Positional [boolRequiredValue],glueInfix PrimChar PrimBool e1 o e2)
| o `Set.member` arithmetic1 && t1 == intRequiredValue = do
return (Positional [intRequiredValue],glueInfix PrimInt PrimInt e1 o e2)
| o `Set.member` bitwise && t1 == intRequiredValue = do
return (Positional [intRequiredValue],glueInfix PrimInt PrimInt e1 o e2)
| o `Set.member` arithmetic2 && t1 == intRequiredValue = do
return (Positional [intRequiredValue],glueInfix PrimInt PrimInt e1 o e2)
| o `Set.member` arithmetic3 && t1 == intRequiredValue = do
return (Positional [intRequiredValue],glueInfix PrimInt PrimInt e1 o e2)
| o `Set.member` arithmetic1 && t1 == floatRequiredValue = do
return (Positional [floatRequiredValue],glueInfix PrimFloat PrimFloat e1 o e2)
| o `Set.member` arithmetic3 && t1 == floatRequiredValue = do
return (Positional [floatRequiredValue],glueInfix PrimFloat PrimFloat e1 o e2)
| o == "+" && t1 == stringRequiredValue = do
return (Positional [stringRequiredValue],glueInfix PrimString PrimString e1 o e2)
| o `Set.member` logical && t1 == boolRequiredValue = do
return (Positional [boolRequiredValue],glueInfix PrimBool PrimBool e1 o e2)
| o == "^" && t1 == boolRequiredValue = do
return (Positional [boolRequiredValue],glueInfix PrimBool PrimBool e1 o e2)
| o == "-" && t1 == charRequiredValue = do
return (Positional [intRequiredValue],glueInfix PrimChar PrimInt e1 o e2)
| o `Set.member` equals && t1 == boolRequiredValue = do
return (Positional [boolRequiredValue],glueInfix PrimBool PrimBool e1 o e2)
| otherwise =
compilerErrorM $ "Cannot " ++ show o ++ " " ++ show t1 ++ " and " ++
show t2 ++ formatFullContextBrace c
glueInfix t1 t2 e3 o2 e4 =
UnboxedPrimitive t2 $ useAsUnboxed t1 e3 ++ o2 ++ useAsUnboxed t1 e4
transform e (ConvertedCall c t f) = do
(Positional ts,e') <- e
t' <- requireSingle c ts
r <- csResolver
fa <- csAllFilters
let vt = ValueType RequiredValue $ singleType $ JustTypeInstance t
(lift $ checkValueAssignment r fa t' vt) <??
"In converted call at " ++ formatFullContext c
f' <- lookupValueFunction vt f
compileFunctionCall (Just $ useAsUnwrapped e') f' f
transform e (ValueCall c f) = do
(Positional ts,e') <- e
t' <- requireSingle c ts
f' <- lookupValueFunction t' f
compileFunctionCall (Just $ useAsUnwrapped e') f' f
requireSingle _ [t] = return t
requireSingle c2 ts =
compilerErrorM $ "Function call requires 1 return but found but found {" ++
intercalate "," (map show ts) ++ "}" ++ formatFullContextBrace c2
lookupValueFunction :: (Ord c, Show c, CollectErrorsM m,
CompilerContext c m [String] a) =>
ValueType -> FunctionCall c -> CompilerState a m (ScopedFunction c)
lookupValueFunction (ValueType WeakValue t) (FunctionCall c _ _ _) =
compilerErrorM $ "Use strong to convert " ++ show t ++
" to optional first" ++ formatFullContextBrace c
lookupValueFunction (ValueType OptionalValue t) (FunctionCall c _ _ _) =
compilerErrorM $ "Use require to convert " ++ show t ++
" to required first" ++ formatFullContextBrace c
lookupValueFunction (ValueType RequiredValue t) (FunctionCall c n _ _) =
csGetTypeFunction c (Just t) n
compileExpressionStart :: (Ord c, Show c, CollectErrorsM m,
CompilerContext c m [String] a) =>
ExpressionStart c -> CompilerState a m (ExpressionType,ExpressionValue)
compileExpressionStart (NamedVariable (OutputValue c n)) = do
let var = UsedVariable c n
(VariableValue _ s t _) <- csGetVariable var
csCheckVariableInit [var]
csAddUsed var
scoped <- autoScope s
let lazy = s == CategoryScope
return (Positional [t],readStoredVariable lazy t (scoped ++ variableName n))
compileExpressionStart (NamedMacro c n) = do
e <- csExprLookup c n
csReserveExprMacro c n
e' <- compileExpression e <?? "In expansion of " ++ show n ++ " at " ++ formatFullContext c
-- NOTE: This will be skipped if expression compilation fails.
csReleaseExprMacro c n
return e'
compileExpressionStart (CategoryCall c t f@(FunctionCall _ n _ _)) = do
f' <- csGetCategoryFunction c (Just t) n
csAddRequired $ Set.fromList [t,sfType f']
t' <- expandCategory t
compileFunctionCall (Just t') f' f
compileExpressionStart (TypeCall c t f@(FunctionCall _ n _ _)) = do
self <- autoSelfType
t' <- lift $ replaceSelfInstance self (singleType t)
r <- csResolver
fa <- csAllFilters
lift $ validateGeneralInstanceForCall r fa t' <?? "In function call at " ++ formatFullContext c
f' <- csGetTypeFunction c (Just t') n
when (sfScope f' /= TypeScope) $ compilerErrorM $ "Function " ++ show n ++
" cannot be used as a type function" ++
formatFullContextBrace c
csAddRequired $ Set.unions $ map categoriesFromTypes [t']
csAddRequired $ Set.fromList [sfType f']
t2 <- expandGeneralInstance t'
compileFunctionCall (Just t2) f' f
compileExpressionStart (UnqualifiedCall c f@(FunctionCall _ n _ _)) = do
ctx <- get
f' <- lift $ collectFirstM [tryCategory ctx,tryNonCategory ctx]
csAddRequired $ Set.fromList [sfType f']
compileFunctionCall Nothing f' f
where
tryCategory ctx = ccGetCategoryFunction ctx c Nothing n
tryNonCategory ctx = do
f' <- ccGetTypeFunction ctx c Nothing n
s <- ccCurrentScope ctx
when (sfScope f' > s) $ compilerErrorM $
"Function " ++ show n ++ " is not in scope here" ++ formatFullContextBrace c
return f'
-- TODO: Compile BuiltinCall like regular functions, for consistent validation.
compileExpressionStart (BuiltinCall c (FunctionCall _ BuiltinPresent ps es)) = do
csAddRequired (Set.fromList [BuiltinBool])
when (length (pValues ps) /= 0) $
compilerErrorM $ "Expected 0 type parameters" ++ formatFullContextBrace c
when (length (pValues es) /= 1) $
compilerErrorM $ "Expected 1 argument" ++ formatFullContextBrace c
es' <- sequence $ map compileExpression $ pValues es
when (length (pValues $ fst $ head es') /= 1) $
compilerErrorM $ "Expected single return in argument" ++ formatFullContextBrace c
let (Positional [t0],e) = head es'
when (isWeakValue t0) $
compilerErrorM $ "Weak values not allowed here" ++ formatFullContextBrace c
return $ (Positional [boolRequiredValue],
UnboxedPrimitive PrimBool $ valueBase ++ "::Present(" ++ useAsUnwrapped e ++ ")")
compileExpressionStart (BuiltinCall c (FunctionCall _ BuiltinReduce ps es)) = do
when (length (pValues ps) /= 2) $
compilerErrorM $ "Expected 2 type parameters" ++ formatFullContextBrace c
when (length (pValues es) /= 1) $
compilerErrorM $ "Expected 1 argument" ++ formatFullContextBrace c
es' <- sequence $ map compileExpression $ pValues es
when (length (pValues $ fst $ head es') /= 1) $
compilerErrorM $ "Expected single return in argument" ++ formatFullContextBrace c
let (Positional [t0],e) = head es'
self <- autoSelfType
ps' <- lift $ disallowInferred ps
[t1,t2] <- lift $ mapCompilerM (replaceSelfInstance self) ps'
r <- csResolver
fa <- csAllFilters
lift $ validateGeneralInstance r (Map.keysSet fa) t1
lift $ validateGeneralInstance r (Map.keysSet fa) t2
lift $ (checkValueAssignment r fa t0 (ValueType OptionalValue t1)) <??
"In argument to reduce call at " ++ formatFullContext c
-- TODO: If t1 -> t2 then just return e without a Reduce call.
t1' <- expandGeneralInstance t1
t2' <- expandGeneralInstance t2
csAddRequired $ categoriesFromTypes t1
csAddRequired $ categoriesFromTypes t2
return $ (Positional [ValueType OptionalValue t2],
UnwrappedSingle $ typeBase ++ "::Reduce(" ++ t1' ++ ", " ++ t2' ++ ", " ++ useAsUnwrapped e ++ ")")
compileExpressionStart (BuiltinCall c (FunctionCall _ BuiltinRequire ps es)) = do
when (length (pValues ps) /= 0) $
compilerErrorM $ "Expected 0 type parameters" ++ formatFullContextBrace c
when (length (pValues es) /= 1) $
compilerErrorM $ "Expected 1 argument" ++ formatFullContextBrace c
es' <- sequence $ map compileExpression $ pValues es
when (length (pValues $ fst $ head es') /= 1) $
compilerErrorM $ "Expected single return in argument" ++ formatFullContextBrace c
let (Positional [t0],e) = head es'
when (isWeakValue t0) $
compilerErrorM $ "Weak values not allowed here" ++ formatFullContextBrace c
return $ (Positional [ValueType RequiredValue (vtType t0)],
UnwrappedSingle $ valueBase ++ "::Require(" ++ useAsUnwrapped e ++ ")")
compileExpressionStart (BuiltinCall c (FunctionCall _ BuiltinStrong ps es)) = do
when (length (pValues ps) /= 0) $
compilerErrorM $ "Expected 0 type parameters" ++ formatFullContextBrace c
when (length (pValues es) /= 1) $
compilerErrorM $ "Expected 1 argument" ++ formatFullContextBrace c
es' <- sequence $ map compileExpression $ pValues es
when (length (pValues $ fst $ head es') /= 1) $
compilerErrorM $ "Expected single return in argument" ++ formatFullContextBrace c
let (Positional [t0],e) = head es'
let t1 = Positional [ValueType OptionalValue (vtType t0)]
if isWeakValue t0
-- Weak values are already unboxed.
then return (t1,UnwrappedSingle $ valueBase ++ "::Strong(" ++ useAsUnwrapped e ++ ")")
else return (t1,e)
compileExpressionStart (BuiltinCall c (FunctionCall _ BuiltinTypename ps es)) = do
when (length (pValues ps) /= 1) $
compilerErrorM $ "Expected 1 type parameter" ++ formatFullContextBrace c
when (length (pValues es) /= 0) $
compilerErrorM $ "Expected 0 arguments" ++ formatFullContextBrace c
self <- autoSelfType
ps' <- lift $ disallowInferred ps
[t] <- lift $ mapCompilerM (replaceSelfInstance self) ps'
r <- csResolver
fa <- csAllFilters
lift $ validateGeneralInstance r (Map.keysSet fa) t
t' <- expandGeneralInstance t
csAddRequired $ Set.unions $ map categoriesFromTypes [t]
return $ (Positional [formattedRequiredValue],
valueAsWrapped $ UnboxedPrimitive PrimString $ typeBase ++ "::TypeName(" ++ t' ++ ")")
compileExpressionStart (BuiltinCall _ _) = undefined
compileExpressionStart (ParensExpression _ e) = compileExpression e
compileExpressionStart (InlineAssignment c n e) = do
(VariableValue _ s t0 _) <- getWritableVariable c n
(Positional [t],e') <- compileExpression e -- TODO: Get rid of the Positional matching here.
r <- csResolver
fa <- csAllFilters
lift $ (checkValueAssignment r fa t t0) <??
"In assignment at " ++ formatFullContext c
csUpdateAssigned n
scoped <- autoScope s
let lazy = s == CategoryScope
return (Positional [t0],readStoredVariable lazy t0 $ "(" ++ scoped ++ variableName n ++
" = " ++ writeStoredVariable t0 e' ++ ")")
disallowInferred :: (Ord c, Show c, CollectErrorsM m) => Positional (InstanceOrInferred c) -> m [GeneralInstance]
disallowInferred = mapCompilerM disallow . pValues where
disallow (AssignedInstance _ t) = return t
disallow (InferredInstance c) =
compilerErrorM $ "Type inference is not allowed in reduce calls" ++ formatFullContextBrace c
compileFunctionCall :: (Ord c, Show c, CollectErrorsM m,
CompilerContext c m [String] a) =>
Maybe String -> ScopedFunction c -> FunctionCall c ->
CompilerState a m (ExpressionType,ExpressionValue)
compileFunctionCall e f (FunctionCall c _ ps es) = message ??> do
r <- csResolver
fa <- csAllFilters
es' <- sequence $ map compileExpression $ pValues es
(ts,es'') <- lift $ getValues es'
self <- autoSelfType
ps' <- lift $ fmap Positional $ mapCompilerM (replaceSelfParam self) $ pValues ps
ps2 <- lift $ guessParamsFromArgs r fa f ps' (Positional ts)
lift $ mapCompilerM_ backgroundMessage $ zip3 (map vpParam $ pValues $ sfParams f) (pValues ps') (pValues ps2)
f' <- lift $ parsedToFunctionType f
f'' <- lift $ assignFunctionParams r fa Map.empty ps2 f'
-- Called an extra time so arg count mismatches have reasonable errors.
lift $ processPairs_ (\_ _ -> return ()) (ftArgs f'') (Positional ts)
lift $ processPairs_ (checkArg r fa) (ftArgs f'') (Positional $ zip ([0..] :: [Int]) ts)
csAddRequired $ Set.unions $ map categoriesFromTypes $ pValues ps2
csAddRequired (Set.fromList [sfType f])
params <- expandParams2 ps2
scope <- csCurrentScope
scoped <- autoScope (sfScope f)
call <- assemble e scoped scope (sfScope f) params es''
return $ (ftReturns f'',OpaqueMulti call)
where
replaceSelfParam self (AssignedInstance c2 t) = do
t' <- replaceSelfInstance self t
return $ AssignedInstance c2 t'
replaceSelfParam _ t = return t
message = "In call to " ++ show (sfName f) ++ " at " ++ formatFullContext c
backgroundMessage (n,(InferredInstance c2),t) =
compilerBackgroundM $ "Parameter " ++ show n ++ " (from " ++ show (sfType f) ++ "." ++
show (sfName f) ++ ") inferred as " ++ show t ++ " at " ++ formatFullContext c2
backgroundMessage _ = return ()
assemble Nothing _ ValueScope ValueScope ps2 es2 =
return $ callName (sfName f) ++ "(Var_self, " ++ ps2 ++ ", " ++ es2 ++ ")"
assemble Nothing _ TypeScope TypeScope ps2 es2 =
return $ callName (sfName f) ++ "(Param_self, " ++ ps2 ++ ", " ++ es2 ++ ")"
assemble Nothing scoped ValueScope TypeScope ps2 es2 =
return $ scoped ++ callName (sfName f) ++ "(parent, "++ ps2 ++ ", " ++ es2 ++ ")"
assemble Nothing scoped _ _ ps2 es2 =
return $ scoped ++ callName (sfName f) ++ "(" ++ ps2 ++ ", " ++ es2 ++ ")"
assemble (Just e2) _ _ ValueScope ps2 es2 =
return $ valueBase ++ "::Call(" ++ e2 ++ ", " ++ functionName f ++ ", " ++ ps2 ++ ", " ++ es2 ++ ")"
assemble (Just e2) _ _ TypeScope ps2 es2 =
return $ typeBase ++ "::Call(" ++ e2 ++ ", " ++ functionName f ++ ", " ++ ps2 ++ ", " ++ es2 ++ ")"
assemble (Just e2) _ _ _ ps2 es2 =
return $ e2 ++ ".Call(" ++ functionName f ++ ", " ++ ps2 ++ ", " ++ es2 ++ ")"
-- TODO: Lots of duplication with assignments and initialization.
-- Single expression, but possibly multi-return.
getValues [(Positional ts,e2)] = return (ts,useAsArgs e2)
-- Multi-expression => must all be singles.
getValues rs = do
(mapCompilerM_ checkArity $ zip ([0..] :: [Int]) $ map fst rs) <??
"In return at " ++ formatFullContext c
return (map (head . pValues . fst) rs, "ArgTuple(" ++ intercalate ", " (map (useAsUnwrapped . snd) rs) ++ ")")
checkArity (_,Positional [_]) = return ()
checkArity (i,Positional ts) =
compilerErrorM $ "Return position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1"
checkArg r fa t0 (i,t1) = do
checkValueAssignment r fa t1 t0 <?? "In argument " ++ show i ++ " to " ++ show (sfName f)
guessParamsFromArgs :: (Ord c, Show c, CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ScopedFunction c -> Positional (InstanceOrInferred c) ->
Positional ValueType -> m (Positional GeneralInstance)
guessParamsFromArgs r fa f ps ts = do
fm <- getFunctionFilterMap f
args <- processPairs (\t1 t2 -> return $ PatternMatch Covariant t1 t2) ts (fmap pvType $ sfArgs f)
pa <- fmap Map.fromList $ processPairs toInstance (fmap vpParam $ sfParams f) ps
gs <- inferParamTypes r fa pa args
gs' <- mergeInferredTypes r fa fm pa gs
let pa3 = guessesAsParams gs' `Map.union` pa
fmap Positional $ mapCompilerM (subPosition pa3) (pValues $ sfParams f) where
subPosition pa2 p =
case (vpParam p) `Map.lookup` pa2 of
Just t -> return t
Nothing -> compilerErrorM $ "Something went wrong inferring " ++
show (vpParam p) ++ formatFullContextBrace (vpContext p)
toInstance p1 (AssignedInstance _ t) = return (p1,t)
toInstance p1 (InferredInstance _) = return (p1,singleType $ JustInferredType p1)
guessParams :: (Ord c, Show c, CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> Positional ValueType -> Positional ParamName ->
Positional (InstanceOrInferred c) -> Positional ValueType -> m (Positional GeneralInstance)
guessParams r fa args params ps ts = do
args' <- processPairs (\t1 t2 -> return $ PatternMatch Covariant t1 t2) ts args
pa <- fmap Map.fromList $ processPairs toInstance params ps
gs <- inferParamTypes r fa pa args'
gs' <- mergeInferredTypes r fa (Map.fromList $ zip (pValues params) (repeat [])) pa gs
let pa3 = guessesAsParams gs' `Map.union` pa
fmap Positional $ mapCompilerM (subPosition pa3) (pValues params) where
subPosition pa2 p =
case p `Map.lookup` pa2 of
Just t -> return t
Nothing -> compilerErrorM $ "Something went wrong inferring " ++ show p
toInstance p1 (AssignedInstance _ t) = return (p1,t)
toInstance p1 (InferredInstance _) = return (p1,singleType $ JustInferredType p1)
compileMainProcedure :: (Ord c, Show c, CollectErrorsM m) =>
CategoryMap c -> ExprMap c -> Expression c -> m (CompiledData [String])
compileMainProcedure tm em e = do
ctx <- getMainContext tm em
runDataCompiler compiler ctx where
procedure = Procedure [] [IgnoreValues [] e]
compiler = do
ctx0 <- getCleanContext
compileProcedure ctx0 procedure >>= put
compileTestProcedure :: (Ord c, Show c, CollectErrorsM m) =>
CategoryMap c -> ExprMap c -> TestProcedure c -> m (CompiledData [String])
compileTestProcedure tm em (TestProcedure c n p) = do
ctx <- getMainContext tm em
p' <- runDataCompiler compiler ctx <??
"In unittest " ++ show n ++ formatFullContextBrace c
return $ mconcat [
onlyCode $ "ReturnTuple " ++ testFunctionName n ++ "() {",
indentCompiled $ onlyCode $ startTestTracing n,
indentCompiled p',
indentCompiled $ onlyCode $ "return ReturnTuple();",
onlyCode "}"
] where
compiler = do
ctx0 <- getCleanContext
compileProcedure ctx0 p >>= put
selectTestFromArgv1 :: CollectErrorsM m => [FunctionName] -> m ([String],CompiledData [String])
selectTestFromArgv1 fs = return (includes,allCode) where
allCode = mconcat [
initMap,
selectFromMap
]
initMap = onlyCodes $ [
"const std::unordered_map<std::string, ReturnTuple(*)()> tests{"
] ++ map ((" " ++) . testEntry) fs ++ [
"};"
]
selectFromMap = onlyCodes [
"if (argc < 2) FAIL() << argv[0] << \" [unittest name]\";",
"const auto name = argv[1];",
"const auto test = tests.find(name);",
"if (test != tests.end()) {",
" (void) (*test->second)();",
" } else {",
" FAIL() << argv[0] << \": unittest \" << name << \" does not exist\";",
"}"
]
testEntry f = "{ \"" ++ show f ++ "\", &" ++ testFunctionName f ++ " },"
includes = [
"#include <string>",
"#include <unordered_map>"
]
autoScope :: CompilerContext c m s a =>
SymbolScope -> CompilerState a m String
autoScope s = do
s1 <- csCurrentScope
return $ scoped s1 s
where
scoped ValueScope TypeScope = "parent->"
scoped ValueScope CategoryScope = "parent->parent."
scoped TypeScope CategoryScope = "parent."
-- NOTE: Don't use this->; otherwise, self won't work properly.
scoped _ _ = ""
categoriesFromTypes :: GeneralInstance -> Set.Set CategoryName
categoriesFromTypes = reduceMergeTree Set.unions Set.unions getAll where
getAll (JustTypeInstance (TypeInstance t ps)) =
t `Set.insert` (Set.unions $ map categoriesFromTypes $ pValues ps)
getAll _ = Set.empty
categoriesFromRefine :: TypeInstance -> Set.Set CategoryName
categoriesFromRefine (TypeInstance t ps) = t `Set.insert` (Set.unions $ map categoriesFromTypes $ pValues ps)
categoriesFromDefine :: DefinesInstance -> Set.Set CategoryName
categoriesFromDefine (DefinesInstance t ps) = t `Set.insert` (Set.unions $ map categoriesFromTypes $ pValues ps)
expandParams :: (CollectErrorsM m, CompilerContext c m s a) =>
Positional GeneralInstance -> CompilerState a m String
expandParams ps = do
ps' <- sequence $ map expandGeneralInstance $ pValues ps
return $ "T_get(" ++ intercalate ", " ps' ++ ")"
expandParams2 :: (CollectErrorsM m, CompilerContext c m s a) =>
Positional GeneralInstance -> CompilerState a m String
expandParams2 ps = do
ps' <- sequence $ map expandGeneralInstance $ pValues ps
return $ "ParamTuple(" ++ intercalate "," ps' ++ ")"
expandCategory :: CompilerContext c m s a =>
CategoryName -> CompilerState a m String
expandCategory t = return $ categoryGetter t ++ "()"
expandGeneralInstance :: (CollectErrorsM m, CompilerContext c m s a) =>
GeneralInstance -> CompilerState a m String
expandGeneralInstance t
| t == minBound = return $ allGetter ++ "()"
| t == maxBound = return $ anyGetter ++ "()"
expandGeneralInstance t = reduceMergeTree getAny getAll getSingle t where
getAny ts = combine ts >>= return . (unionGetter ++)
getAll ts = combine ts >>= return . (intersectGetter ++)
getSingle (JustTypeInstance (TypeInstance t2 ps)) = do
ps' <- sequence $ map expandGeneralInstance $ pValues ps
return $ typeGetter t2 ++ "(T_get(" ++ intercalate "," ps' ++ "))"
getSingle (JustParamName _ p) = do
s <- csGetParamScope p
scoped <- autoScope s
return $ scoped ++ paramName p
getSingle (JustInferredType p) = getSingle (JustParamName False p)
combine ps = do
ps' <- sequence ps
return $ "(L_get<S<const " ++ typeBase ++ ">>(" ++ intercalate "," ps' ++ "))"
doImplicitReturn :: (CollectErrorsM m, Ord c, Show c, CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
doImplicitReturn c = do
named <- csIsNamedReturns
csRegisterReturn c Nothing
(CleanupBlock ss _ _ req) <- csGetCleanup JumpReturn
csAddRequired req
csSetJumpType c JumpReturn
csWrite ss
if not named
then csWrite ["return ReturnTuple(0);"]
else do
getPrimNamedReturns
csWrite ["return returns;"]
where
autoPositionalCleanup :: (CollectErrorsM m, CompilerContext c m [String] a) =>
[c] -> ExpressionValue -> CompilerState a m ()
autoPositionalCleanup c e = do
named <- csIsNamedReturns
(CleanupBlock ss _ _ req) <- csGetCleanup JumpReturn
csAddRequired req
csSetJumpType c JumpReturn
if null ss
then csWrite ["return " ++ useAsReturns e ++ ";"]
else do
if named
then do
csWrite ["returns = " ++ useAsReturns e ++ ";"]
setPrimNamedReturns
csWrite ss
csWrite ["return returns;"]
else do
csWrite ["{","ReturnTuple returns = " ++ useAsReturns e ++ ";"]
csWrite ss
csWrite ["return returns;","}"]
setPrimNamedReturns :: (CollectErrorsM m, CompilerContext c m [String] a) =>
CompilerState a m ()
setPrimNamedReturns = do
vars <- csPrimNamedReturns
sequence_ $ map (csWrite . (:[]) . assign) vars where
assign (ReturnVariable i n t) =
variableName n ++ " = " ++ writeStoredVariable t (position i) ++ ";"
position i = WrappedSingle $ "returns.At(" ++ show i ++ ")"
getPrimNamedReturns :: (CollectErrorsM m, CompilerContext c m [String] a) =>
CompilerState a m ()
getPrimNamedReturns = do
vars <- csPrimNamedReturns
sequence_ $ map (csWrite . (:[]) . assign) vars where
assign (ReturnVariable i n t) =
"returns.At(" ++ show i ++ ") = " ++ useAsUnwrapped (readStoredVariable False t $ variableName n) ++ ";"
autoInsertCleanup :: (Ord c, Show c, CollectErrorsM m, CompilerContext c m [String] a) =>
[c] -> JumpType -> a -> CompilerState a m ()
autoInsertCleanup c j ctx = do
(CleanupBlock ss vs jump req) <- lift $ ccGetCleanup ctx j
lift (ccCheckVariableInit ctx $ nub vs) <??
"In inlining of cleanup block after statement at " ++ formatFullContext c
let vs2 = map (\(UsedVariable c0 v) -> UsedVariable (c ++ c0) v) vs
-- This is needed in case a cleanup is inlined within another cleanup, e.g.,
-- e.g., if the latter has a break statement.
sequence_ $ map csAddUsed $ vs2
csWrite ss
csAddRequired req
csSetJumpType c jump
inheritRequired :: (CollectErrorsM m, CompilerContext c m [String] a) =>
a -> CompilerState a m ()
inheritRequired ctx = lift (ccGetRequired ctx) >>= csAddRequired
autoInlineOutput :: (Ord c, Show c, CollectErrorsM m, CompilerContext c m [String] a) =>
a -> CompilerState a m ()
autoInlineOutput ctx = do
inheritRequired ctx
getAndIndentOutput ctx >>= csWrite
csInheritReturns [ctx]
getAndIndentOutput :: (Ord c, Show c, CollectErrorsM m, CompilerContext c m [String] a) =>
a -> CompilerState a m [String]
getAndIndentOutput ctx = fmap indentCode (lift $ ccGetOutput ctx)
indentCode :: [String] -> [String]
indentCode = map (" " ++)