mirror of
https://github.com/carp-lang/Carp.git
synced 2024-10-26 13:51:50 +03:00
Delete and copy functions are set and called.
This commit is contained in:
Erik Svedäng
parent
72c2330bab
commit
2d38eeba2c
@ -21,8 +21,8 @@ typedef struct {
|
||||
typedef struct {
|
||||
void *callback;
|
||||
void *env;
|
||||
void (*delete)(void*);
|
||||
void *(*copy)(void*);
|
||||
void *delete;
|
||||
void *copy;
|
||||
} Lambda;
|
||||
|
||||
typedef void* LambdaEnv;
|
||||
|
||||
@ -25,19 +25,19 @@
|
||||
|
||||
|
||||
|
||||
(use Array)
|
||||
;; (use Array)
|
||||
|
||||
(defn pow-to [exponent to]
|
||||
(let [fff (fn [] ())
|
||||
ff2 @&fff
|
||||
to-copy @to
|
||||
upper (to-copy)]
|
||||
(endo-map (fn [x] (Int.pow x exponent)) (range 0 upper 1))))
|
||||
;; (defn pow-to [exponent to]
|
||||
;; (let [fff (fn [] ())
|
||||
;; ff2 @&fff
|
||||
;; to-copy @to
|
||||
;; upper (to-copy)]
|
||||
;; (endo-map (fn [x] (Int.pow x exponent)) (range 0 upper 1))))
|
||||
|
||||
(defn twenty [] 20)
|
||||
;; (defn twenty [] 20)
|
||||
|
||||
(defn main []
|
||||
(println* (ref (pow-to 3 &twenty))))
|
||||
;; (defn main []
|
||||
;; (println* (ref (pow-to 3 &twenty))))
|
||||
|
||||
|
||||
|
||||
@ -49,3 +49,17 @@
|
||||
;; (let [b (Blah.init hej)
|
||||
;; f @(Blah.function &b)]
|
||||
;; (f)))
|
||||
|
||||
|
||||
|
||||
(defn main []
|
||||
(let [x 100
|
||||
y 23
|
||||
f (fn [] (+ x y))
|
||||
ignore-me (fn [] ())]
|
||||
(f)))
|
||||
|
||||
|
||||
;; (defn main []
|
||||
;; (let [strings [@"a" @"bb" @"ccc"]]
|
||||
;; (println* &(Array.copy-map String.length &strings))))
|
||||
|
||||
@ -1,12 +1,16 @@
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
|
||||
module Concretize where
|
||||
|
||||
import Control.Monad.State
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Maybe (fromMaybe, fromJust)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Set ((\\))
|
||||
import Data.List (foldl')
|
||||
import Debug.Trace
|
||||
import qualified Text.Parsec as Parsec
|
||||
import Text.Parsec ((<|>))
|
||||
|
||||
import Obj
|
||||
import Constraints
|
||||
@ -17,6 +21,10 @@ import AssignTypes
|
||||
import Polymorphism
|
||||
import InitialTypes
|
||||
import Lookup
|
||||
import Parsing
|
||||
|
||||
--import Template
|
||||
--import ArrayTemplates
|
||||
|
||||
-- | This function performs two things:
|
||||
-- | 1. Finds out which polymorphic functions that needs to be added to the environment for the calls in the function to work.
|
||||
@ -116,13 +124,26 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
||||
XObj (Arr structMemberPairs) Nothing Nothing :
|
||||
[])) i (Just TypeTy)
|
||||
|
||||
deleteFnTy = typesDeleterFunctionType environmentStructTy
|
||||
deleteFnTemplate = concreteDelete typeEnv env (memberXObjsToPairs structMemberPairs)
|
||||
(deleteFn, deleterDeps) = instantiateTemplate (SymPath [] (environmentTypeName ++ "_delete")) deleteFnTy deleteFnTemplate
|
||||
|
||||
copyFnTy = typesCopyFunctionType environmentStructTy
|
||||
copyFnTemplate = concreteCopy typeEnv env (memberXObjsToPairs structMemberPairs)
|
||||
(copyFn, copyDeps) = instantiateTemplate (SymPath [] (environmentTypeName ++ "_copy")) copyFnTy copyFnTemplate
|
||||
|
||||
-- The type env has to contain the lambdas environment struct for 'concretizeDefinition' to work:
|
||||
extendedTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) environmentTypeName environmentStruct)
|
||||
|
||||
in case concretizeDefinition allowAmbig extendedTypeEnv env visitedDefinitions lambdaCallback funcTy of
|
||||
Left err -> return (Left err)
|
||||
Right (concreteLiftedLambda, deps) ->
|
||||
do modify (environmentStruct :)
|
||||
do when (not (null capturedVars)) $
|
||||
do modify (environmentStruct :)
|
||||
modify (deleteFn :)
|
||||
modify (deleterDeps ++)
|
||||
modify (copyFn :)
|
||||
modify (copyDeps ++)
|
||||
modify (concreteLiftedLambda :)
|
||||
modify (deps ++)
|
||||
return (Right [XObj (Fn (Just lambdaName) (Set.fromList capturedVars)) fni fnt, args, okBody])
|
||||
@ -906,3 +927,658 @@ isGlobalFunc xobj =
|
||||
XObj (Sym _ (LookupGlobal _)) _ (Just (FuncTy _ _)) -> True
|
||||
XObj (Sym _ (LookupGlobalOverride _)) _ (Just (FuncTy _ _)) -> True
|
||||
_ -> False
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
data AllocationMode = StackAlloc | HeapAlloc
|
||||
|
||||
{-# ANN module "HLint: ignore Reduce duplication" #-}
|
||||
-- | This function creates a "Type Module" with the same name as the type being defined.
|
||||
-- A type module provides a namespace for all the functions that area automatically
|
||||
-- generated by a deftype.
|
||||
moduleForDeftype :: TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe Env -> Either String (String, XObj, [XObj])
|
||||
moduleForDeftype typeEnv env pathStrings typeName typeVariables rest i existingEnv =
|
||||
let typeModuleName = typeName
|
||||
typeModuleEnv = case existingEnv of
|
||||
Just env -> env
|
||||
Nothing -> Env (Map.fromList []) (Just env) (Just typeModuleName) [] ExternalEnv 0
|
||||
-- The variable 'insidePath' is the path used for all member functions inside the 'typeModule'.
|
||||
-- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc.
|
||||
insidePath = pathStrings ++ [typeModuleName]
|
||||
in do validateMemberCases typeEnv typeVariables rest
|
||||
let structTy = StructTy typeName typeVariables
|
||||
(okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest
|
||||
okInit <- binderForInit insidePath structTy rest
|
||||
--okNew <- templateForNew insidePath structTy rest
|
||||
(okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str"
|
||||
(okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn"
|
||||
(okDelete, deleteDeps) <- binderForDelete typeEnv env insidePath structTy rest
|
||||
(okCopy, copyDeps) <- binderForCopy typeEnv env insidePath structTy rest
|
||||
let funcs = okInit : okStr : okPrn : okDelete : okCopy : okMembers
|
||||
moduleEnvWithBindings = addListOfBindings typeModuleEnv funcs
|
||||
typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
|
||||
deps = deleteDeps ++ membersDeps ++ copyDeps ++ strDeps
|
||||
return (typeModuleName, typeModuleXObj, deps)
|
||||
|
||||
-- | Will generate getters/setters/updaters when registering EXTERNAL types.
|
||||
-- | i.e. (register-type VRUnicornData [hp Int, magic Float])
|
||||
-- | TODO: Remove duplication shared by moduleForDeftype-function.
|
||||
bindingsForRegisteredType :: TypeEnv -> Env -> [String] -> String -> [XObj] -> Maybe Info -> Maybe Env -> Either String (String, XObj, [XObj])
|
||||
bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv =
|
||||
let typeModuleName = typeName
|
||||
typeModuleEnv = case existingEnv of
|
||||
Just env -> env
|
||||
Nothing -> Env (Map.fromList []) (Just env) (Just typeModuleName) [] ExternalEnv 0
|
||||
insidePath = pathStrings ++ [typeModuleName]
|
||||
in do validateMemberCases typeEnv [] rest
|
||||
let structTy = StructTy typeName []
|
||||
(binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest
|
||||
okInit <- binderForInit insidePath structTy rest
|
||||
--okNew <- templateForNew insidePath structTy rest
|
||||
(okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str"
|
||||
(okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn"
|
||||
let moduleEnvWithBindings = addListOfBindings typeModuleEnv (okInit : okStr : okPrn : binders)
|
||||
typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
|
||||
return (typeModuleName, typeModuleXObj, deps ++ strDeps)
|
||||
|
||||
|
||||
|
||||
-- | Generate all the templates for ALL the member variables in a deftype declaration.
|
||||
templatesForMembers :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either String ([(String, Binder)], [XObj])
|
||||
templatesForMembers typeEnv env insidePath structTy [XObj (Arr membersXobjs) _ _] =
|
||||
let bindersAndDeps = concatMap (templatesForSingleMember typeEnv env insidePath structTy) (pairwise membersXobjs)
|
||||
in Right (map fst bindersAndDeps, concatMap snd bindersAndDeps)
|
||||
templatesForMembers _ _ _ _ _ = Left "Can't create member functions for type with more than one case (yet)."
|
||||
|
||||
-- | Generate the templates for a single member in a deftype declaration.
|
||||
templatesForSingleMember :: TypeEnv -> Env -> [String] -> Ty -> (XObj, XObj) -> [((String, Binder), [XObj])]
|
||||
templatesForSingleMember typeEnv env insidePath p@(StructTy typeName _) (nameXObj, typeXObj) =
|
||||
let Just t = xobjToTy typeXObj
|
||||
memberName = getName nameXObj
|
||||
in [instanceBinderWithDeps (SymPath insidePath memberName) (FuncTy [RefTy p] (RefTy t)) (templateGetter (mangle memberName) t)
|
||||
, if isTypeGeneric t
|
||||
then (templateGenericSetter insidePath p t memberName, [])
|
||||
else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) (FuncTy [p, t] p) (templateSetter typeEnv env (mangle memberName) t)
|
||||
,instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) (FuncTy [RefTy (p), t] UnitTy) (templateMutatingSetter typeEnv env (mangle memberName) t)
|
||||
,instanceBinderWithDeps (SymPath insidePath ("update-" ++ memberName))
|
||||
(FuncTy [p, FuncTy [t] t] p)
|
||||
(templateUpdater (mangle memberName))]
|
||||
|
||||
-- | The template for getters of a deftype.
|
||||
templateGetter :: String -> Ty -> Template
|
||||
templateGetter member memberTy =
|
||||
Template
|
||||
(FuncTy [RefTy (VarTy "p")] (VarTy "t"))
|
||||
(const (toTemplate "$t $NAME($(Ref p) p)"))
|
||||
(const $
|
||||
let fixForVoidStarMembers =
|
||||
if isFunctionType memberTy && (not (isTypeGeneric memberTy))
|
||||
then "(" ++ tyToCLambdaFix (RefTy memberTy) ++ ")"
|
||||
else ""
|
||||
in (toTemplate ("$DECL { return " ++ fixForVoidStarMembers ++ "(&(p->" ++ member ++ ")); }\n")))
|
||||
(const [])
|
||||
|
||||
-- | The template for setters of a concrete deftype.
|
||||
templateSetter :: TypeEnv -> Env -> String -> Ty -> Template
|
||||
templateSetter typeEnv env memberName memberTy =
|
||||
let callToDelete = memberDeletion typeEnv env (memberName, memberTy)
|
||||
in
|
||||
Template
|
||||
(FuncTy [VarTy "p", VarTy "t"] (VarTy "p"))
|
||||
(const (toTemplate "$p $NAME($p p, $t newValue)"))
|
||||
(const (toTemplate (unlines ["$DECL {"
|
||||
,callToDelete
|
||||
," p." ++ memberName ++ " = newValue;"
|
||||
," return p;"
|
||||
,"}\n"])))
|
||||
(\_ -> if | isManaged typeEnv memberTy -> depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy)
|
||||
| isFunctionType memberTy -> [defineFunctionTypeAlias memberTy]
|
||||
| otherwise -> [])
|
||||
|
||||
-- | The template for setters of a generic deftype.
|
||||
templateGenericSetter :: [String] -> Ty -> Ty -> String -> (String, Binder)
|
||||
templateGenericSetter pathStrings originalStructTy memberTy memberName =
|
||||
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy, memberTy] originalStructTy)
|
||||
where path = SymPath pathStrings ("set-" ++ memberName)
|
||||
t = (FuncTy [VarTy "p", VarTy "t"] (VarTy "p"))
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
Template
|
||||
t
|
||||
(const (toTemplate "$p $NAME($p p, $t newValue)"))
|
||||
(\(FuncTy [_, memberTy] _) ->
|
||||
(let callToDelete = memberDeletion typeEnv env (memberName, memberTy)
|
||||
in (toTemplate (unlines ["$DECL {"
|
||||
,callToDelete
|
||||
," p." ++ memberName ++ " = newValue;"
|
||||
," return p;"
|
||||
,"}\n"]))))
|
||||
(\(FuncTy [_, memberTy] _) ->
|
||||
if isManaged typeEnv memberTy
|
||||
then depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy)
|
||||
else [])
|
||||
|
||||
-- | The template for mutating setters of a deftype.
|
||||
templateMutatingSetter :: TypeEnv -> Env -> String -> Ty -> Template
|
||||
templateMutatingSetter typeEnv env memberName memberTy =
|
||||
Template
|
||||
(FuncTy [RefTy (VarTy "p"), VarTy "t"] UnitTy)
|
||||
(const (toTemplate "void $NAME($p* pRef, $t newValue)"))
|
||||
(const (toTemplate (unlines ["$DECL {"
|
||||
," pRef->" ++ memberName ++ " = newValue;"
|
||||
,"}\n"])))
|
||||
(const [])
|
||||
|
||||
-- | The template for updater functions of a deftype.
|
||||
-- | (allows changing a variable by passing an transformation function).
|
||||
templateUpdater :: String -> Template
|
||||
templateUpdater member =
|
||||
Template
|
||||
(FuncTy [VarTy "p", FuncTy [VarTy "t"] (VarTy "t")] (VarTy "p"))
|
||||
(const (toTemplate "$p $NAME($p p, Lambda updater)")) -- "Lambda" used to be: $(Fn [t] t)
|
||||
(const (toTemplate (unlines ["$DECL {"
|
||||
," p." ++ member ++ " = " ++ (templateCodeForCallingLambda "updater" (FuncTy [VarTy "t"] (VarTy "t")) ["p." ++ member]) ++ ";"
|
||||
," return p;"
|
||||
,"}\n"])))
|
||||
(\(FuncTy [_, t@(FuncTy fArgTys fRetTy)] _) ->
|
||||
if isTypeGeneric fRetTy
|
||||
then []
|
||||
else [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy)])
|
||||
|
||||
-- | Helper function to create the binder for the 'init' template.
|
||||
binderForInit :: [String] -> Ty -> [XObj] -> Either String (String, Binder)
|
||||
binderForInit insidePath structTy@(StructTy typeName _) [XObj (Arr membersXObjs) _ _] =
|
||||
if isTypeGeneric structTy
|
||||
then Right (genericInit StackAlloc insidePath structTy membersXObjs)
|
||||
else Right $ instanceBinder (SymPath insidePath "init")
|
||||
(FuncTy (initArgListTypes membersXObjs) structTy)
|
||||
(concreteInit StackAlloc structTy membersXObjs)
|
||||
|
||||
-- | Generate a list of types from a deftype declaration.
|
||||
initArgListTypes :: [XObj] -> [Ty]
|
||||
initArgListTypes xobjs = map (\(_, x) -> fromJust (xobjToTy x)) (pairwise xobjs)
|
||||
|
||||
-- | The template for the 'init' and 'new' functions for a concrete deftype.
|
||||
concreteInit :: AllocationMode -> Ty -> [XObj] -> Template
|
||||
concreteInit allocationMode originalStructTy@(StructTy typeName typeVariables) membersXObjs =
|
||||
Template
|
||||
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p"))
|
||||
(\(FuncTy _ concreteStructTy) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
memberPairs = memberXObjsToPairs correctedMembers
|
||||
in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg memberPairs) ++ ")"))
|
||||
(const (tokensForInit allocationMode typeName membersXObjs))
|
||||
(\(FuncTy _ _) -> [])
|
||||
|
||||
-- | The template for the 'init' and 'new' functions for a generic deftype.
|
||||
genericInit :: AllocationMode -> [String] -> Ty -> [XObj] -> (String, Binder)
|
||||
genericInit allocationMode pathStrings originalStructTy@(StructTy typeName _) membersXObjs =
|
||||
defineTypeParameterizedTemplate templateCreator path t
|
||||
where path = SymPath pathStrings "init"
|
||||
t = (FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy)
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
Template
|
||||
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p"))
|
||||
(\(FuncTy _ concreteStructTy) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
memberPairs = memberXObjsToPairs correctedMembers
|
||||
in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg memberPairs) ++ ")"))
|
||||
(const (tokensForInit allocationMode typeName membersXObjs))
|
||||
(\(FuncTy _ concreteStructTy) ->
|
||||
case concretizeType typeEnv concreteStructTy of
|
||||
Left err -> error (err ++ ". This error should not crash the compiler - change return type to Either here.")
|
||||
Right ok -> ok
|
||||
)
|
||||
|
||||
tokensForInit :: AllocationMode -> String -> [XObj] -> [Token]
|
||||
tokensForInit allocationMode typeName membersXObjs =
|
||||
toTemplate $ unlines [ "$DECL {"
|
||||
, case allocationMode of
|
||||
StackAlloc -> " $p instance;"
|
||||
HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));"
|
||||
, joinWith "\n" (map (memberAssignment allocationMode) (memberXObjsToPairs membersXObjs))
|
||||
, " return instance;"
|
||||
, "}"]
|
||||
|
||||
-- | Creates the C code for an arg to the init function.
|
||||
-- | i.e. "(deftype A [x Int])" will generate "int x" which
|
||||
-- | will be used in the init function like this: "A_init(int x)"
|
||||
memberArg :: (String, Ty) -> String
|
||||
memberArg (memberName, memberTy) =
|
||||
tyToCLambdaFix (templitizeTy memberTy) ++ " " ++ memberName
|
||||
|
||||
-- | If the type is just a type variable; create a template type variable by appending $ in front of it's name
|
||||
templitizeTy :: Ty -> Ty
|
||||
templitizeTy (VarTy vt) = VarTy ("$" ++ vt)
|
||||
templitizeTy (FuncTy argTys retTy) = FuncTy (map templitizeTy argTys) (templitizeTy retTy)
|
||||
templitizeTy (StructTy name tys) = StructTy name (map templitizeTy tys)
|
||||
templitizeTy (RefTy t) = RefTy (templitizeTy t)
|
||||
templitizeTy (PointerTy t) = PointerTy (templitizeTy t)
|
||||
templitizeTy t = t
|
||||
|
||||
-- | Helper function to create the binder for the 'str' template.
|
||||
binderForStrOrPrn :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> String -> Either String ((String, Binder), [XObj])
|
||||
binderForStrOrPrn typeEnv env insidePath structTy@(StructTy typeName _) [XObj (Arr membersXObjs) _ _] strOrPrn =
|
||||
if isTypeGeneric structTy
|
||||
then Right (genericStr insidePath structTy membersXObjs strOrPrn, [])
|
||||
else Right (instanceBinderWithDeps (SymPath insidePath strOrPrn)
|
||||
(FuncTy [RefTy structTy] StringTy)
|
||||
(concreteStr typeEnv env structTy (memberXObjsToPairs membersXObjs) strOrPrn))
|
||||
|
||||
-- | The template for the 'str' function for a concrete deftype.
|
||||
concreteStr :: TypeEnv -> Env -> Ty -> [(String, Ty)] -> String -> Template
|
||||
concreteStr typeEnv env concreteStructTy@(StructTy typeName _) memberPairs strOrPrn =
|
||||
Template
|
||||
(FuncTy [RefTy concreteStructTy] StringTy)
|
||||
(\(FuncTy [RefTy structTy] StringTy) -> (toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)"))
|
||||
(\(FuncTy [RefTy structTy@(StructTy _ concreteMemberTys)] StringTy) ->
|
||||
(tokensForStr typeEnv env typeName memberPairs concreteStructTy))
|
||||
(\(ft@(FuncTy [RefTy structTy@(StructTy _ concreteMemberTys)] StringTy)) ->
|
||||
concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv)
|
||||
(filter (\t -> (not . isExternalType typeEnv) t && (not . isFullyGenericType) t)
|
||||
(map snd memberPairs)))
|
||||
|
||||
-- | The template for the 'str' function for a generic deftype.
|
||||
genericStr :: [String] -> Ty -> [XObj] -> String -> (String, Binder)
|
||||
genericStr pathStrings originalStructTy@(StructTy typeName varTys) membersXObjs strOrPrn =
|
||||
defineTypeParameterizedTemplate templateCreator path t
|
||||
where path = SymPath pathStrings strOrPrn
|
||||
t = FuncTy [(RefTy originalStructTy)] StringTy
|
||||
members = memberXObjsToPairs membersXObjs
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
Template
|
||||
t
|
||||
(\(FuncTy [RefTy concreteStructTy] StringTy) ->
|
||||
(toTemplate $ "String $NAME(" ++ tyToCLambdaFix concreteStructTy ++ " *p)"))
|
||||
(\(FuncTy [RefTy concreteStructTy@(StructTy _ concreteMemberTys)] StringTy) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
memberPairs = memberXObjsToPairs correctedMembers
|
||||
in (tokensForStr typeEnv env typeName memberPairs concreteStructTy))
|
||||
(\(ft@(FuncTy [RefTy concreteStructTy@(StructTy _ concreteMemberTys)] StringTy)) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
memberPairs = memberXObjsToPairs correctedMembers
|
||||
in concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv)
|
||||
(filter (\t -> (not . isExternalType typeEnv) t && (not . isFullyGenericType) t)
|
||||
(map snd memberPairs))
|
||||
++
|
||||
(if isTypeGeneric concreteStructTy then [] else [defineFunctionTypeAlias ft]))
|
||||
|
||||
tokensForStr :: TypeEnv -> Env -> String -> [(String, Ty)] -> Ty -> [Token]
|
||||
tokensForStr typeEnv env typeName memberPairs concreteStructTy =
|
||||
(toTemplate $ unlines [ "$DECL {"
|
||||
, " // convert members to String here:"
|
||||
, " String temp = NULL;"
|
||||
, " int tempsize = 0;"
|
||||
, " (void)tempsize; // that way we remove the occasional unused warning "
|
||||
, calculateStructStrSize typeEnv env memberPairs concreteStructTy
|
||||
, " String buffer = CARP_MALLOC(size);"
|
||||
, " String bufferPtr = buffer;"
|
||||
, ""
|
||||
, " snprintf(bufferPtr, size, \"(%s \", \"" ++ typeName ++ "\");"
|
||||
, " bufferPtr += strlen(\"" ++ typeName ++ "\") + 2;\n"
|
||||
, joinWith "\n" (map (memberPrn typeEnv env) memberPairs)
|
||||
, " bufferPtr--;"
|
||||
, " snprintf(bufferPtr, size, \")\");"
|
||||
, " return buffer;"
|
||||
, "}"])
|
||||
|
||||
-- | Figure out how big the string needed for the string representation of the struct has to be.
|
||||
calculateStructStrSize :: TypeEnv -> Env -> [(String, Ty)] -> Ty -> String
|
||||
calculateStructStrSize typeEnv env members structTy@(StructTy name _) =
|
||||
" int size = snprintf(NULL, 0, \"(%s )\", \"" ++ name ++ "\");\n" ++
|
||||
unlines (map memberPrnSize members)
|
||||
where memberPrnSize (memberName, memberTy) =
|
||||
let refOrNotRefType = if isManaged typeEnv memberTy then RefTy memberTy else memberTy
|
||||
maybeTakeAddress = if isManaged typeEnv memberTy then "&" else ""
|
||||
strFuncType = FuncTy [refOrNotRefType] StringTy
|
||||
in case nameOfPolymorphicFunction typeEnv env strFuncType "prn" of
|
||||
Just strFunctionPath ->
|
||||
unlines [" temp = " ++ pathToC strFunctionPath ++ "(" ++ maybeTakeAddress ++ "p->" ++ memberName ++ "); "
|
||||
, " size += snprintf(NULL, 0, \"%s \", temp);"
|
||||
, " if(temp) { CARP_FREE(temp); temp = NULL; }"
|
||||
]
|
||||
Nothing ->
|
||||
if isExternalType typeEnv memberTy
|
||||
then unlines [ " size += snprintf(NULL, 0, \"%p \", p->" ++ memberName ++ ");"
|
||||
, " if(temp) { CARP_FREE(temp); temp = NULL; }"
|
||||
]
|
||||
else " // Failed to find str function for " ++ memberName ++ " : " ++ show memberTy ++ "\n"
|
||||
|
||||
-- | Generate C code for converting a member variable to a string and appending it to a buffer.
|
||||
memberPrn :: TypeEnv -> Env -> (String, Ty) -> String
|
||||
memberPrn typeEnv env (memberName, memberTy) =
|
||||
let refOrNotRefType = if isManaged typeEnv memberTy then RefTy memberTy else memberTy
|
||||
maybeTakeAddress = if isManaged typeEnv memberTy then "&" else ""
|
||||
strFuncType = FuncTy [refOrNotRefType] StringTy
|
||||
in case nameOfPolymorphicFunction typeEnv env strFuncType "prn" of
|
||||
Just strFunctionPath ->
|
||||
unlines [" temp = " ++ pathToC strFunctionPath ++ "(" ++ maybeTakeAddress ++ "p->" ++ memberName ++ ");"
|
||||
, " snprintf(bufferPtr, size, \"%s \", temp);"
|
||||
, " bufferPtr += strlen(temp) + 1;"
|
||||
, " if(temp) { CARP_FREE(temp); temp = NULL; }"
|
||||
]
|
||||
Nothing ->
|
||||
if isExternalType typeEnv memberTy
|
||||
then unlines [ " tempsize = snprintf(NULL, 0, \"%p\", p->" ++ memberName ++ ");"
|
||||
, " temp = malloc(tempsize);"
|
||||
, " snprintf(temp, tempsize, \"%p\", p->" ++ memberName ++ ");"
|
||||
, " snprintf(bufferPtr, size, \"%s \", temp);"
|
||||
, " bufferPtr += strlen(temp) + 1;"
|
||||
, " if(temp) { CARP_FREE(temp); temp = NULL; }"
|
||||
]
|
||||
else " // Failed to find str function for " ++ memberName ++ " : " ++ show memberTy ++ "\n"
|
||||
|
||||
-- | Generate C code for assigning to a member variable.
|
||||
-- | Needs to know if the instance is a pointer or stack variable.
|
||||
memberAssignment :: AllocationMode -> (String, Ty) -> String
|
||||
memberAssignment allocationMode (memberName, _) = " instance" ++ sep ++ memberName ++ " = " ++ memberName ++ ";"
|
||||
where sep = case allocationMode of
|
||||
StackAlloc -> "."
|
||||
HeapAlloc -> "->"
|
||||
|
||||
|
||||
|
||||
-- | Helper function to create the binder for the 'delete' template.
|
||||
binderForDelete :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either String ((String, Binder), [XObj])
|
||||
binderForDelete typeEnv env insidePath structTy@(StructTy typeName _) [XObj (Arr membersXObjs) _ _] =
|
||||
if isTypeGeneric structTy
|
||||
then Right (genericDelete insidePath structTy membersXObjs, [])
|
||||
else Right (instanceBinderWithDeps (SymPath insidePath "delete")
|
||||
(FuncTy [structTy] UnitTy)
|
||||
(concreteDelete typeEnv env (memberXObjsToPairs membersXObjs)))
|
||||
|
||||
-- | The template for the 'delete' function of a concrete deftype.
|
||||
concreteDelete :: TypeEnv -> Env -> [(String, Ty)] -> Template
|
||||
concreteDelete typeEnv env members =
|
||||
Template
|
||||
(FuncTy [VarTy "p"] UnitTy)
|
||||
(const (toTemplate "void $NAME($p p)"))
|
||||
(const (toTemplate $ unlines [ "$DECL {"
|
||||
, joinWith "\n" (map (memberDeletion typeEnv env) members)
|
||||
, "}"]))
|
||||
(\_ -> concatMap (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType)
|
||||
(filter (isManaged typeEnv) (map snd members)))
|
||||
|
||||
-- | The template for the 'delete' function of a generic deftype.
|
||||
genericDelete :: [String] -> Ty -> [XObj] -> (String, Binder)
|
||||
genericDelete pathStrings originalStructTy membersXObjs =
|
||||
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy)
|
||||
where path = SymPath pathStrings "delete"
|
||||
t = (FuncTy [VarTy "p"] UnitTy)
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
Template
|
||||
t
|
||||
(const (toTemplate "void $NAME($p p)"))
|
||||
(\(FuncTy [concreteStructTy] UnitTy) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
memberPairs = memberXObjsToPairs correctedMembers
|
||||
in (toTemplate $ unlines [ "$DECL {"
|
||||
, joinWith "\n" (map (memberDeletion typeEnv env) memberPairs)
|
||||
, "}"]))
|
||||
(\(FuncTy [concreteStructTy] UnitTy) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
memberPairs = memberXObjsToPairs correctedMembers
|
||||
in if isTypeGeneric concreteStructTy
|
||||
then []
|
||||
else concatMap (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType)
|
||||
(filter (isManaged typeEnv) (map snd memberPairs)))
|
||||
|
||||
-- | Generate the C code for deleting a single member of the deftype.
|
||||
-- | TODO: Should return an Either since this can fail!
|
||||
memberDeletion :: TypeEnv -> Env -> (String, Ty) -> String
|
||||
memberDeletion typeEnv env (memberName, memberType) =
|
||||
case findFunctionForMember typeEnv env "delete" (typesDeleterFunctionType memberType) (memberName, memberType) of
|
||||
FunctionFound functionFullName -> " " ++ functionFullName ++ "(p." ++ memberName ++ ");"
|
||||
FunctionNotFound msg -> error msg
|
||||
FunctionIgnored -> " /* Ignore non-managed member '" ++ memberName ++ "' */"
|
||||
|
||||
|
||||
|
||||
-- | Helper function to create the binder for the 'copy' template.
|
||||
binderForCopy :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either String ((String, Binder), [XObj])
|
||||
binderForCopy typeEnv env insidePath structTy@(StructTy typeName _) [XObj (Arr membersXObjs) _ _] =
|
||||
if isTypeGeneric structTy
|
||||
then Right (genericCopy insidePath structTy membersXObjs, [])
|
||||
else Right (instanceBinderWithDeps (SymPath insidePath "copy")
|
||||
(FuncTy [RefTy structTy] structTy)
|
||||
(concreteCopy typeEnv env (memberXObjsToPairs membersXObjs)))
|
||||
|
||||
-- | The template for the 'copy' function of a concrete deftype.
|
||||
concreteCopy :: TypeEnv -> Env -> [(String, Ty)] -> Template
|
||||
concreteCopy typeEnv env memberPairs =
|
||||
Template
|
||||
(FuncTy [RefTy (VarTy "p")] (VarTy "p"))
|
||||
(const (toTemplate "$p $NAME($p* pRef)"))
|
||||
(const (tokensForCopy typeEnv env memberPairs))
|
||||
(\_ -> concatMap (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType)
|
||||
(filter (isManaged typeEnv) (map snd memberPairs)))
|
||||
|
||||
-- | The template for the 'copy' function of a generic deftype.
|
||||
genericCopy :: [String] -> Ty -> [XObj] -> (String, Binder)
|
||||
genericCopy pathStrings originalStructTy membersXObjs =
|
||||
defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy] originalStructTy)
|
||||
where path = SymPath pathStrings "copy"
|
||||
t = (FuncTy [RefTy (VarTy "p")] (VarTy "p"))
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
Template
|
||||
t
|
||||
(const (toTemplate "$p $NAME($p* pRef)"))
|
||||
(\(FuncTy [RefTy concreteStructTy] _) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
memberPairs = memberXObjsToPairs correctedMembers
|
||||
in (tokensForCopy typeEnv env memberPairs))
|
||||
(\(FuncTy [RefTy concreteStructTy] _) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
memberPairs = memberXObjsToPairs correctedMembers
|
||||
in if isTypeGeneric concreteStructTy
|
||||
then []
|
||||
else concatMap (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType)
|
||||
(filter (isManaged typeEnv) (map snd memberPairs)))
|
||||
|
||||
tokensForCopy :: TypeEnv -> Env -> [(String, Ty)] -> [Token]
|
||||
tokensForCopy typeEnv env memberPairs=
|
||||
(toTemplate $ unlines [ "$DECL {"
|
||||
, " $p copy = *pRef;"
|
||||
, joinWith "\n" (map (memberCopy typeEnv env) memberPairs)
|
||||
, " return copy;"
|
||||
, "}"])
|
||||
|
||||
-- | Generate the C code for copying the member of a deftype.
|
||||
-- | TODO: Should return an Either since this can fail!
|
||||
memberCopy :: TypeEnv -> Env -> (String, Ty) -> String
|
||||
memberCopy typeEnv env (memberName, memberType) =
|
||||
case findFunctionForMember typeEnv env "copy" (typesCopyFunctionType memberType) (memberName, memberType) of
|
||||
FunctionFound functionFullName ->
|
||||
" copy." ++ memberName ++ " = " ++ functionFullName ++ "(&(pRef->" ++ memberName ++ "));"
|
||||
FunctionNotFound msg -> error msg
|
||||
FunctionIgnored -> " /* Ignore non-managed member '" ++ memberName ++ "' */"
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
-- | Create a binding pair used for adding a template instantiation to an environment.
|
||||
instanceBinder :: SymPath -> Ty -> Template -> (String, Binder)
|
||||
instanceBinder path@(SymPath _ name) actualType template =
|
||||
let (x, _) = instantiateTemplate path actualType template
|
||||
in (name, Binder emptyMeta x)
|
||||
|
||||
-- | Create a binding pair and don't discard the dependencies
|
||||
instanceBinderWithDeps :: SymPath -> Ty -> Template -> ((String, Binder), [XObj])
|
||||
instanceBinderWithDeps path@(SymPath _ name) actualType template =
|
||||
let (x, deps) = instantiateTemplate path actualType template
|
||||
in ((name, Binder emptyMeta x), deps)
|
||||
|
||||
-- | Templates are instructions for the compiler to generate some C-code
|
||||
-- | based on some template and the names and types to fill into the template.
|
||||
-- | Templates are generic and need to be given an explicit type to generate the
|
||||
-- | correct code.
|
||||
|
||||
-- | Example:
|
||||
-- | template1 : ((Array T) -> Int) = "int length__T(<T> xs) { return xs->len; }"
|
||||
-- | Given the type ((Array Float) -> Int) the following code is produced:
|
||||
-- | "int length__Float(Array__Float xs) { return xs->len; }"
|
||||
|
||||
-- | Create a binding pair used for adding a template definition to an environment.
|
||||
defineTemplate :: SymPath -> Ty -> [Token] -> [Token] -> (Ty -> [XObj]) -> (String, Binder)
|
||||
defineTemplate path t declaration definition depsFunc =
|
||||
let (SymPath _ name) = path
|
||||
template = Template t (const declaration) (const definition) depsFunc
|
||||
i = Info 0 0 (show path ++ ".template") Set.empty 0
|
||||
defLst = [XObj (Deftemplate (TemplateCreator (\_ _ -> template))) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]
|
||||
in (name, Binder emptyMeta (XObj (Lst defLst) (Just i) (Just t)))
|
||||
|
||||
-- | The more advanced version of a template, where the code can vary depending on the type.
|
||||
defineTypeParameterizedTemplate :: TemplateCreator -> SymPath -> Ty -> (String, Binder)
|
||||
defineTypeParameterizedTemplate templateCreator path t =
|
||||
let (SymPath _ name) = path
|
||||
i = Info 0 0 (show path ++ ".parameterizedTemplate") Set.empty 0
|
||||
defLst = [XObj (Deftemplate templateCreator) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]
|
||||
in (name, Binder emptyMeta (XObj (Lst defLst) (Just i) (Just t)))
|
||||
|
||||
-- | Concretizes the types used in @token
|
||||
-- @cName is the name of the definition, i.e. the "foo" in "void foo() { ... }"
|
||||
concretizeTypesInToken :: TypeMappings -> String -> [Token] -> Token -> [Token]
|
||||
concretizeTypesInToken mappings cName decl token =
|
||||
case token of
|
||||
TokDecl -> concatMap (concretizeTypesInToken mappings cName (error "Nope.")) decl
|
||||
TokName -> [TokC cName]
|
||||
TokTy t mode -> [TokTy (replaceTyVars mappings t) mode]
|
||||
_ -> [token]
|
||||
|
||||
-- | High-level helper function for creating templates from strings of C code.
|
||||
toTemplate :: String -> [Token]
|
||||
toTemplate text = case Parsec.runParser templateSyntax 0 "(template)" text of
|
||||
Right ok -> ok
|
||||
Left err -> error (show err)
|
||||
where
|
||||
templateSyntax :: Parsec.Parsec String Int [Token]
|
||||
templateSyntax = Parsec.many parseTok
|
||||
|
||||
parseTok = Parsec.try parseTokDecl <|> --- $DECL
|
||||
Parsec.try parseTokName <|> --- $NAME
|
||||
Parsec.try parseTokTyGrouped <|> --- i.e. $(Fn [Int] t)
|
||||
Parsec.try parseTokTyRawGrouped <|>
|
||||
Parsec.try parseTokTy <|> --- i.e. $t
|
||||
parseTokC --- Anything else...
|
||||
|
||||
parseTokDecl :: Parsec.Parsec String Int Token
|
||||
parseTokDecl = do _ <- Parsec.string "$DECL"
|
||||
return TokDecl
|
||||
|
||||
parseTokName :: Parsec.Parsec String Int Token
|
||||
parseTokName = do _ <- Parsec.string "$NAME"
|
||||
return TokName
|
||||
|
||||
parseTokC :: Parsec.Parsec String Int Token
|
||||
parseTokC = do s <- Parsec.many1 validInSymbol
|
||||
return (TokC s)
|
||||
where validInSymbol = Parsec.choice [Parsec.letter, Parsec.digit, Parsec.oneOf validCharactersInTemplate]
|
||||
validCharactersInTemplate = " ><{}()[]|;:.,_-+*#/'^!?€%&=@\"\n\t"
|
||||
|
||||
parseTokTy :: Parsec.Parsec String Int Token
|
||||
parseTokTy = do _ <- Parsec.char '$'
|
||||
s <- Parsec.many1 Parsec.letter
|
||||
return (toTokTy Normal s)
|
||||
|
||||
parseTokTyGrouped :: Parsec.Parsec String Int Token
|
||||
parseTokTyGrouped = do _ <- Parsec.char '$'
|
||||
_ <- Parsec.char '('
|
||||
Parsec.putState 1 -- One paren to close.
|
||||
s <- fmap ('(' :) (Parsec.many parseCharBalanced)
|
||||
-- Note: The closing paren is read by parseCharBalanced.
|
||||
return (toTokTy Normal s)
|
||||
|
||||
parseTokTyRawGrouped :: Parsec.Parsec String Int Token
|
||||
parseTokTyRawGrouped = do _ <- Parsec.char '§'
|
||||
_ <- Parsec.char '('
|
||||
Parsec.putState 1 -- One paren to close.
|
||||
s <- fmap ('(' :) (Parsec.many parseCharBalanced)
|
||||
-- Note: The closing paren is read by parseCharBalanced.
|
||||
return (toTokTy Raw s)
|
||||
|
||||
parseCharBalanced :: Parsec.Parsec String Int Char
|
||||
parseCharBalanced = do balanceState <- Parsec.getState
|
||||
if balanceState > 0
|
||||
then Parsec.try openParen <|>
|
||||
Parsec.try closeParen <|>
|
||||
Parsec.anyChar
|
||||
else Parsec.char '\0' -- Should always fail which will end the string.
|
||||
|
||||
openParen :: Parsec.Parsec String Int Char
|
||||
openParen = do _ <- Parsec.char '('
|
||||
Parsec.modifyState (+1)
|
||||
return '('
|
||||
|
||||
closeParen :: Parsec.Parsec String Int Char
|
||||
closeParen = do _ <- Parsec.char ')'
|
||||
Parsec.modifyState (\x -> x - 1)
|
||||
return ')'
|
||||
|
||||
-- | Converts a string containing a type to a template token ('TokTy').
|
||||
-- | i.e. the string "(Array Int)" becomes (TokTy (StructTy "Array" IntTy)).
|
||||
toTokTy :: TokTyMode -> String -> Token
|
||||
toTokTy mode s =
|
||||
case parse s "" of
|
||||
Left err -> error (show err)
|
||||
Right [] -> error ("toTokTy got [] when parsing: '" ++ s ++ "'")
|
||||
Right [xobj] -> case xobjToTy xobj of
|
||||
Just ok -> TokTy ok mode
|
||||
Nothing -> error ("toTokTy failed to convert this s-expression to a type: " ++ pretty xobj)
|
||||
Right xobjs -> error ("toTokTy parsed too many s-expressions: " ++ joinWithSpace (map pretty xobjs))
|
||||
|
||||
-- | The code needed to correctly call a lambda from C.
|
||||
templateCodeForCallingLambda :: String -> Ty -> [String] -> String
|
||||
templateCodeForCallingLambda functionName t args =
|
||||
let FuncTy argTys retTy = t
|
||||
castToFnWithEnv = tyToCast (FuncTy (lambdaEnvTy : argTys) retTy)
|
||||
castToFn = tyToCast t
|
||||
in
|
||||
functionName ++ ".env ? " ++
|
||||
"((" ++ castToFnWithEnv ++ ")" ++ functionName ++ ".callback)(" ++ functionName ++ ".env" ++ (if null args then "" else ", ") ++ joinWithComma args ++ ")" ++
|
||||
" : " ++
|
||||
"((" ++ castToFn ++ ")" ++ functionName ++ ".callback)(" ++ joinWithComma args ++ ")"
|
||||
|
||||
-- | Must cast a lambda:s .callback member to the correct type to be able to call it.
|
||||
tyToCast :: Ty -> String
|
||||
tyToCast t =
|
||||
let FuncTy argTys retTy = t
|
||||
in "§(Fn [" ++ joinWithSpace (map show argTys) ++ "] " ++ show retTy ++ ")" -- Note! The '§' means that the emitted type will be "raw" and not converted to 'Lambda'.
|
||||
|
||||
----------------------------------------------------------------------------------------------------------
|
||||
-- ACTUAL TEMPLATES
|
||||
|
||||
-- | This function accepts a pointer and will do nothing with it.
|
||||
templateNoop :: (String, Binder)
|
||||
templateNoop = defineTemplate
|
||||
(SymPath [] "noop")
|
||||
(FuncTy [PointerTy (VarTy "a")] UnitTy)
|
||||
(toTemplate "void $NAME ($a* a)")
|
||||
(toTemplate "$DECL { }")
|
||||
(const [])
|
||||
|
||||
504
src/Deftype.hs
504
src/Deftype.hs
@ -1,492 +1,18 @@
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
-- {-# LANGUAGE MultiWayIf #-}
|
||||
|
||||
module Deftype (moduleForDeftype, bindingsForRegisteredType) where
|
||||
module Deftype where
|
||||
-- module Deftype (moduleForDeftype, bindingsForRegisteredType) where
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe
|
||||
import Debug.Trace
|
||||
-- import qualified Data.Map as Map
|
||||
-- import Data.Maybe
|
||||
-- import Debug.Trace
|
||||
|
||||
import Obj
|
||||
import Types
|
||||
import Util
|
||||
import Template
|
||||
import Infer
|
||||
import Concretize
|
||||
import Polymorphism
|
||||
import ArrayTemplates
|
||||
import Lookup
|
||||
|
||||
data AllocationMode = StackAlloc | HeapAlloc
|
||||
|
||||
{-# ANN module "HLint: ignore Reduce duplication" #-}
|
||||
-- | This function creates a "Type Module" with the same name as the type being defined.
|
||||
-- A type module provides a namespace for all the functions that area automatically
|
||||
-- generated by a deftype.
|
||||
moduleForDeftype :: TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe Env -> Either String (String, XObj, [XObj])
|
||||
moduleForDeftype typeEnv env pathStrings typeName typeVariables rest i existingEnv =
|
||||
let typeModuleName = typeName
|
||||
typeModuleEnv = case existingEnv of
|
||||
Just env -> env
|
||||
Nothing -> Env (Map.fromList []) (Just env) (Just typeModuleName) [] ExternalEnv 0
|
||||
-- The variable 'insidePath' is the path used for all member functions inside the 'typeModule'.
|
||||
-- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc.
|
||||
insidePath = pathStrings ++ [typeModuleName]
|
||||
in do validateMemberCases typeEnv typeVariables rest
|
||||
let structTy = StructTy typeName typeVariables
|
||||
(okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest
|
||||
okInit <- binderForInit insidePath structTy rest
|
||||
--okNew <- templateForNew insidePath structTy rest
|
||||
(okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str"
|
||||
(okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn"
|
||||
(okDelete, deleteDeps) <- binderForDelete typeEnv env insidePath structTy rest
|
||||
(okCopy, copyDeps) <- binderForCopy typeEnv env insidePath structTy rest
|
||||
let funcs = okInit : okStr : okPrn : okDelete : okCopy : okMembers
|
||||
moduleEnvWithBindings = addListOfBindings typeModuleEnv funcs
|
||||
typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
|
||||
deps = deleteDeps ++ membersDeps ++ copyDeps ++ strDeps
|
||||
return (typeModuleName, typeModuleXObj, deps)
|
||||
|
||||
-- | Will generate getters/setters/updaters when registering EXTERNAL types.
|
||||
-- | i.e. (register-type VRUnicornData [hp Int, magic Float])
|
||||
-- | TODO: Remove duplication shared by moduleForDeftype-function.
|
||||
bindingsForRegisteredType :: TypeEnv -> Env -> [String] -> String -> [XObj] -> Maybe Info -> Maybe Env -> Either String (String, XObj, [XObj])
|
||||
bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv =
|
||||
let typeModuleName = typeName
|
||||
typeModuleEnv = case existingEnv of
|
||||
Just env -> env
|
||||
Nothing -> Env (Map.fromList []) (Just env) (Just typeModuleName) [] ExternalEnv 0
|
||||
insidePath = pathStrings ++ [typeModuleName]
|
||||
in do validateMemberCases typeEnv [] rest
|
||||
let structTy = StructTy typeName []
|
||||
(binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest
|
||||
okInit <- binderForInit insidePath structTy rest
|
||||
--okNew <- templateForNew insidePath structTy rest
|
||||
(okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str"
|
||||
(okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn"
|
||||
let moduleEnvWithBindings = addListOfBindings typeModuleEnv (okInit : okStr : okPrn : binders)
|
||||
typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
|
||||
return (typeModuleName, typeModuleXObj, deps ++ strDeps)
|
||||
|
||||
|
||||
|
||||
-- | Generate all the templates for ALL the member variables in a deftype declaration.
|
||||
templatesForMembers :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either String ([(String, Binder)], [XObj])
|
||||
templatesForMembers typeEnv env insidePath structTy [XObj (Arr membersXobjs) _ _] =
|
||||
let bindersAndDeps = concatMap (templatesForSingleMember typeEnv env insidePath structTy) (pairwise membersXobjs)
|
||||
in Right (map fst bindersAndDeps, concatMap snd bindersAndDeps)
|
||||
templatesForMembers _ _ _ _ _ = Left "Can't create member functions for type with more than one case (yet)."
|
||||
|
||||
-- | Generate the templates for a single member in a deftype declaration.
|
||||
templatesForSingleMember :: TypeEnv -> Env -> [String] -> Ty -> (XObj, XObj) -> [((String, Binder), [XObj])]
|
||||
templatesForSingleMember typeEnv env insidePath p@(StructTy typeName _) (nameXObj, typeXObj) =
|
||||
let Just t = xobjToTy typeXObj
|
||||
memberName = getName nameXObj
|
||||
in [instanceBinderWithDeps (SymPath insidePath memberName) (FuncTy [RefTy p] (RefTy t)) (templateGetter (mangle memberName) t)
|
||||
, if isTypeGeneric t
|
||||
then (templateGenericSetter insidePath p t memberName, [])
|
||||
else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) (FuncTy [p, t] p) (templateSetter typeEnv env (mangle memberName) t)
|
||||
,instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) (FuncTy [RefTy (p), t] UnitTy) (templateMutatingSetter typeEnv env (mangle memberName) t)
|
||||
,instanceBinderWithDeps (SymPath insidePath ("update-" ++ memberName))
|
||||
(FuncTy [p, FuncTy [t] t] p)
|
||||
(templateUpdater (mangle memberName))]
|
||||
|
||||
-- | The template for getters of a deftype.
|
||||
templateGetter :: String -> Ty -> Template
|
||||
templateGetter member memberTy =
|
||||
Template
|
||||
(FuncTy [RefTy (VarTy "p")] (VarTy "t"))
|
||||
(const (toTemplate "$t $NAME($(Ref p) p)"))
|
||||
(const $
|
||||
let fixForVoidStarMembers =
|
||||
if isFunctionType memberTy && (not (isTypeGeneric memberTy))
|
||||
then "(" ++ tyToCLambdaFix (RefTy memberTy) ++ ")"
|
||||
else ""
|
||||
in (toTemplate ("$DECL { return " ++ fixForVoidStarMembers ++ "(&(p->" ++ member ++ ")); }\n")))
|
||||
(const [])
|
||||
|
||||
-- | The template for setters of a concrete deftype.
|
||||
templateSetter :: TypeEnv -> Env -> String -> Ty -> Template
|
||||
templateSetter typeEnv env memberName memberTy =
|
||||
let callToDelete = memberDeletion typeEnv env (memberName, memberTy)
|
||||
in
|
||||
Template
|
||||
(FuncTy [VarTy "p", VarTy "t"] (VarTy "p"))
|
||||
(const (toTemplate "$p $NAME($p p, $t newValue)"))
|
||||
(const (toTemplate (unlines ["$DECL {"
|
||||
,callToDelete
|
||||
," p." ++ memberName ++ " = newValue;"
|
||||
," return p;"
|
||||
,"}\n"])))
|
||||
(\_ -> if | isManaged typeEnv memberTy -> depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy)
|
||||
| isFunctionType memberTy -> [defineFunctionTypeAlias memberTy]
|
||||
| otherwise -> [])
|
||||
|
||||
-- | The template for setters of a generic deftype.
|
||||
templateGenericSetter :: [String] -> Ty -> Ty -> String -> (String, Binder)
|
||||
templateGenericSetter pathStrings originalStructTy memberTy memberName =
|
||||
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy, memberTy] originalStructTy)
|
||||
where path = SymPath pathStrings ("set-" ++ memberName)
|
||||
t = (FuncTy [VarTy "p", VarTy "t"] (VarTy "p"))
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
Template
|
||||
t
|
||||
(const (toTemplate "$p $NAME($p p, $t newValue)"))
|
||||
(\(FuncTy [_, memberTy] _) ->
|
||||
(let callToDelete = memberDeletion typeEnv env (memberName, memberTy)
|
||||
in (toTemplate (unlines ["$DECL {"
|
||||
,callToDelete
|
||||
," p." ++ memberName ++ " = newValue;"
|
||||
," return p;"
|
||||
,"}\n"]))))
|
||||
(\(FuncTy [_, memberTy] _) ->
|
||||
if isManaged typeEnv memberTy
|
||||
then depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy)
|
||||
else [])
|
||||
|
||||
-- | The template for mutating setters of a deftype.
|
||||
templateMutatingSetter :: TypeEnv -> Env -> String -> Ty -> Template
|
||||
templateMutatingSetter typeEnv env memberName memberTy =
|
||||
Template
|
||||
(FuncTy [RefTy (VarTy "p"), VarTy "t"] UnitTy)
|
||||
(const (toTemplate "void $NAME($p* pRef, $t newValue)"))
|
||||
(const (toTemplate (unlines ["$DECL {"
|
||||
," pRef->" ++ memberName ++ " = newValue;"
|
||||
,"}\n"])))
|
||||
(const [])
|
||||
|
||||
-- | The template for updater functions of a deftype.
|
||||
-- | (allows changing a variable by passing an transformation function).
|
||||
templateUpdater :: String -> Template
|
||||
templateUpdater member =
|
||||
Template
|
||||
(FuncTy [VarTy "p", FuncTy [VarTy "t"] (VarTy "t")] (VarTy "p"))
|
||||
(const (toTemplate "$p $NAME($p p, Lambda updater)")) -- "Lambda" used to be: $(Fn [t] t)
|
||||
(const (toTemplate (unlines ["$DECL {"
|
||||
," p." ++ member ++ " = " ++ (templateCodeForCallingLambda "updater" (FuncTy [VarTy "t"] (VarTy "t")) ["p." ++ member]) ++ ";"
|
||||
," return p;"
|
||||
,"}\n"])))
|
||||
(\(FuncTy [_, t@(FuncTy fArgTys fRetTy)] _) ->
|
||||
if isTypeGeneric fRetTy
|
||||
then []
|
||||
else [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy)])
|
||||
|
||||
-- | Helper function to create the binder for the 'init' template.
|
||||
binderForInit :: [String] -> Ty -> [XObj] -> Either String (String, Binder)
|
||||
binderForInit insidePath structTy@(StructTy typeName _) [XObj (Arr membersXObjs) _ _] =
|
||||
if isTypeGeneric structTy
|
||||
then Right (genericInit StackAlloc insidePath structTy membersXObjs)
|
||||
else Right $ instanceBinder (SymPath insidePath "init")
|
||||
(FuncTy (initArgListTypes membersXObjs) structTy)
|
||||
(concreteInit StackAlloc structTy membersXObjs)
|
||||
|
||||
-- | Generate a list of types from a deftype declaration.
|
||||
initArgListTypes :: [XObj] -> [Ty]
|
||||
initArgListTypes xobjs = map (\(_, x) -> fromJust (xobjToTy x)) (pairwise xobjs)
|
||||
|
||||
-- | The template for the 'init' and 'new' functions for a concrete deftype.
|
||||
concreteInit :: AllocationMode -> Ty -> [XObj] -> Template
|
||||
concreteInit allocationMode originalStructTy@(StructTy typeName typeVariables) membersXObjs =
|
||||
Template
|
||||
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p"))
|
||||
(\(FuncTy _ concreteStructTy) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
memberPairs = memberXObjsToPairs correctedMembers
|
||||
in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg memberPairs) ++ ")"))
|
||||
(const (tokensForInit allocationMode typeName membersXObjs))
|
||||
(\(FuncTy _ _) -> [])
|
||||
|
||||
-- | The template for the 'init' and 'new' functions for a generic deftype.
|
||||
genericInit :: AllocationMode -> [String] -> Ty -> [XObj] -> (String, Binder)
|
||||
genericInit allocationMode pathStrings originalStructTy@(StructTy typeName _) membersXObjs =
|
||||
defineTypeParameterizedTemplate templateCreator path t
|
||||
where path = SymPath pathStrings "init"
|
||||
t = (FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy)
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
Template
|
||||
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p"))
|
||||
(\(FuncTy _ concreteStructTy) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
memberPairs = memberXObjsToPairs correctedMembers
|
||||
in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg memberPairs) ++ ")"))
|
||||
(const (tokensForInit allocationMode typeName membersXObjs))
|
||||
(\(FuncTy _ concreteStructTy) ->
|
||||
case concretizeType typeEnv concreteStructTy of
|
||||
Left err -> error (err ++ ". This error should not crash the compiler - change return type to Either here.")
|
||||
Right ok -> ok
|
||||
)
|
||||
|
||||
tokensForInit :: AllocationMode -> String -> [XObj] -> [Token]
|
||||
tokensForInit allocationMode typeName membersXObjs =
|
||||
toTemplate $ unlines [ "$DECL {"
|
||||
, case allocationMode of
|
||||
StackAlloc -> " $p instance;"
|
||||
HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));"
|
||||
, joinWith "\n" (map (memberAssignment allocationMode) (memberXObjsToPairs membersXObjs))
|
||||
, " return instance;"
|
||||
, "}"]
|
||||
|
||||
-- | Creates the C code for an arg to the init function.
|
||||
-- | i.e. "(deftype A [x Int])" will generate "int x" which
|
||||
-- | will be used in the init function like this: "A_init(int x)"
|
||||
memberArg :: (String, Ty) -> String
|
||||
memberArg (memberName, memberTy) =
|
||||
tyToCLambdaFix (templitizeTy memberTy) ++ " " ++ memberName
|
||||
|
||||
-- | If the type is just a type variable; create a template type variable by appending $ in front of it's name
|
||||
templitizeTy :: Ty -> Ty
|
||||
templitizeTy (VarTy vt) = VarTy ("$" ++ vt)
|
||||
templitizeTy (FuncTy argTys retTy) = FuncTy (map templitizeTy argTys) (templitizeTy retTy)
|
||||
templitizeTy (StructTy name tys) = StructTy name (map templitizeTy tys)
|
||||
templitizeTy (RefTy t) = RefTy (templitizeTy t)
|
||||
templitizeTy (PointerTy t) = PointerTy (templitizeTy t)
|
||||
templitizeTy t = t
|
||||
|
||||
-- | Helper function to create the binder for the 'str' template.
|
||||
binderForStrOrPrn :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> String -> Either String ((String, Binder), [XObj])
|
||||
binderForStrOrPrn typeEnv env insidePath structTy@(StructTy typeName _) [XObj (Arr membersXObjs) _ _] strOrPrn =
|
||||
if isTypeGeneric structTy
|
||||
then Right (genericStr insidePath structTy membersXObjs strOrPrn, [])
|
||||
else Right (instanceBinderWithDeps (SymPath insidePath strOrPrn)
|
||||
(FuncTy [RefTy structTy] StringTy)
|
||||
(concreteStr typeEnv env structTy (memberXObjsToPairs membersXObjs) strOrPrn))
|
||||
|
||||
-- | The template for the 'str' function for a concrete deftype.
|
||||
concreteStr :: TypeEnv -> Env -> Ty -> [(String, Ty)] -> String -> Template
|
||||
concreteStr typeEnv env concreteStructTy@(StructTy typeName _) memberPairs strOrPrn =
|
||||
Template
|
||||
(FuncTy [RefTy concreteStructTy] StringTy)
|
||||
(\(FuncTy [RefTy structTy] StringTy) -> (toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)"))
|
||||
(\(FuncTy [RefTy structTy@(StructTy _ concreteMemberTys)] StringTy) ->
|
||||
(tokensForStr typeEnv env typeName memberPairs concreteStructTy))
|
||||
(\(ft@(FuncTy [RefTy structTy@(StructTy _ concreteMemberTys)] StringTy)) ->
|
||||
concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv)
|
||||
(filter (\t -> (not . isExternalType typeEnv) t && (not . isFullyGenericType) t)
|
||||
(map snd memberPairs)))
|
||||
|
||||
-- | The template for the 'str' function for a generic deftype.
|
||||
genericStr :: [String] -> Ty -> [XObj] -> String -> (String, Binder)
|
||||
genericStr pathStrings originalStructTy@(StructTy typeName varTys) membersXObjs strOrPrn =
|
||||
defineTypeParameterizedTemplate templateCreator path t
|
||||
where path = SymPath pathStrings strOrPrn
|
||||
t = FuncTy [(RefTy originalStructTy)] StringTy
|
||||
members = memberXObjsToPairs membersXObjs
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
Template
|
||||
t
|
||||
(\(FuncTy [RefTy concreteStructTy] StringTy) ->
|
||||
(toTemplate $ "String $NAME(" ++ tyToCLambdaFix concreteStructTy ++ " *p)"))
|
||||
(\(FuncTy [RefTy concreteStructTy@(StructTy _ concreteMemberTys)] StringTy) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
memberPairs = memberXObjsToPairs correctedMembers
|
||||
in (tokensForStr typeEnv env typeName memberPairs concreteStructTy))
|
||||
(\(ft@(FuncTy [RefTy concreteStructTy@(StructTy _ concreteMemberTys)] StringTy)) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
memberPairs = memberXObjsToPairs correctedMembers
|
||||
in concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv)
|
||||
(filter (\t -> (not . isExternalType typeEnv) t && (not . isFullyGenericType) t)
|
||||
(map snd memberPairs))
|
||||
++
|
||||
(if isTypeGeneric concreteStructTy then [] else [defineFunctionTypeAlias ft]))
|
||||
|
||||
tokensForStr :: TypeEnv -> Env -> String -> [(String, Ty)] -> Ty -> [Token]
|
||||
tokensForStr typeEnv env typeName memberPairs concreteStructTy =
|
||||
(toTemplate $ unlines [ "$DECL {"
|
||||
, " // convert members to String here:"
|
||||
, " String temp = NULL;"
|
||||
, " int tempsize = 0;"
|
||||
, " (void)tempsize; // that way we remove the occasional unused warning "
|
||||
, calculateStructStrSize typeEnv env memberPairs concreteStructTy
|
||||
, " String buffer = CARP_MALLOC(size);"
|
||||
, " String bufferPtr = buffer;"
|
||||
, ""
|
||||
, " snprintf(bufferPtr, size, \"(%s \", \"" ++ typeName ++ "\");"
|
||||
, " bufferPtr += strlen(\"" ++ typeName ++ "\") + 2;\n"
|
||||
, joinWith "\n" (map (memberPrn typeEnv env) memberPairs)
|
||||
, " bufferPtr--;"
|
||||
, " snprintf(bufferPtr, size, \")\");"
|
||||
, " return buffer;"
|
||||
, "}"])
|
||||
|
||||
-- | Figure out how big the string needed for the string representation of the struct has to be.
|
||||
calculateStructStrSize :: TypeEnv -> Env -> [(String, Ty)] -> Ty -> String
|
||||
calculateStructStrSize typeEnv env members structTy@(StructTy name _) =
|
||||
" int size = snprintf(NULL, 0, \"(%s )\", \"" ++ name ++ "\");\n" ++
|
||||
unlines (map memberPrnSize members)
|
||||
where memberPrnSize (memberName, memberTy) =
|
||||
let refOrNotRefType = if isManaged typeEnv memberTy then RefTy memberTy else memberTy
|
||||
maybeTakeAddress = if isManaged typeEnv memberTy then "&" else ""
|
||||
strFuncType = FuncTy [refOrNotRefType] StringTy
|
||||
in case nameOfPolymorphicFunction typeEnv env strFuncType "prn" of
|
||||
Just strFunctionPath ->
|
||||
unlines [" temp = " ++ pathToC strFunctionPath ++ "(" ++ maybeTakeAddress ++ "p->" ++ memberName ++ "); "
|
||||
, " size += snprintf(NULL, 0, \"%s \", temp);"
|
||||
, " if(temp) { CARP_FREE(temp); temp = NULL; }"
|
||||
]
|
||||
Nothing ->
|
||||
if isExternalType typeEnv memberTy
|
||||
then unlines [ " size += snprintf(NULL, 0, \"%p \", p->" ++ memberName ++ ");"
|
||||
, " if(temp) { CARP_FREE(temp); temp = NULL; }"
|
||||
]
|
||||
else " // Failed to find str function for " ++ memberName ++ " : " ++ show memberTy ++ "\n"
|
||||
|
||||
-- | Generate C code for converting a member variable to a string and appending it to a buffer.
|
||||
memberPrn :: TypeEnv -> Env -> (String, Ty) -> String
|
||||
memberPrn typeEnv env (memberName, memberTy) =
|
||||
let refOrNotRefType = if isManaged typeEnv memberTy then RefTy memberTy else memberTy
|
||||
maybeTakeAddress = if isManaged typeEnv memberTy then "&" else ""
|
||||
strFuncType = FuncTy [refOrNotRefType] StringTy
|
||||
in case nameOfPolymorphicFunction typeEnv env strFuncType "prn" of
|
||||
Just strFunctionPath ->
|
||||
unlines [" temp = " ++ pathToC strFunctionPath ++ "(" ++ maybeTakeAddress ++ "p->" ++ memberName ++ ");"
|
||||
, " snprintf(bufferPtr, size, \"%s \", temp);"
|
||||
, " bufferPtr += strlen(temp) + 1;"
|
||||
, " if(temp) { CARP_FREE(temp); temp = NULL; }"
|
||||
]
|
||||
Nothing ->
|
||||
if isExternalType typeEnv memberTy
|
||||
then unlines [ " tempsize = snprintf(NULL, 0, \"%p\", p->" ++ memberName ++ ");"
|
||||
, " temp = malloc(tempsize);"
|
||||
, " snprintf(temp, tempsize, \"%p\", p->" ++ memberName ++ ");"
|
||||
, " snprintf(bufferPtr, size, \"%s \", temp);"
|
||||
, " bufferPtr += strlen(temp) + 1;"
|
||||
, " if(temp) { CARP_FREE(temp); temp = NULL; }"
|
||||
]
|
||||
else " // Failed to find str function for " ++ memberName ++ " : " ++ show memberTy ++ "\n"
|
||||
|
||||
-- | Generate C code for assigning to a member variable.
|
||||
-- | Needs to know if the instance is a pointer or stack variable.
|
||||
memberAssignment :: AllocationMode -> (String, Ty) -> String
|
||||
memberAssignment allocationMode (memberName, _) = " instance" ++ sep ++ memberName ++ " = " ++ memberName ++ ";"
|
||||
where sep = case allocationMode of
|
||||
StackAlloc -> "."
|
||||
HeapAlloc -> "->"
|
||||
|
||||
|
||||
|
||||
-- | Helper function to create the binder for the 'delete' template.
|
||||
binderForDelete :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either String ((String, Binder), [XObj])
|
||||
binderForDelete typeEnv env insidePath structTy@(StructTy typeName _) [XObj (Arr membersXObjs) _ _] =
|
||||
if isTypeGeneric structTy
|
||||
then Right (genericDelete insidePath structTy membersXObjs, [])
|
||||
else Right (instanceBinderWithDeps (SymPath insidePath "delete")
|
||||
(FuncTy [structTy] UnitTy)
|
||||
(concreteDelete typeEnv env (memberXObjsToPairs membersXObjs)))
|
||||
|
||||
-- | The template for the 'delete' function of a concrete deftype.
|
||||
concreteDelete :: TypeEnv -> Env -> [(String, Ty)] -> Template
|
||||
concreteDelete typeEnv env members =
|
||||
Template
|
||||
(FuncTy [VarTy "p"] UnitTy)
|
||||
(const (toTemplate "void $NAME($p p)"))
|
||||
(const (toTemplate $ unlines [ "$DECL {"
|
||||
, joinWith "\n" (map (memberDeletion typeEnv env) members)
|
||||
, "}"]))
|
||||
(\_ -> concatMap (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType)
|
||||
(filter (isManaged typeEnv) (map snd members)))
|
||||
|
||||
-- | The template for the 'delete' function of a generic deftype.
|
||||
genericDelete :: [String] -> Ty -> [XObj] -> (String, Binder)
|
||||
genericDelete pathStrings originalStructTy membersXObjs =
|
||||
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy)
|
||||
where path = SymPath pathStrings "delete"
|
||||
t = (FuncTy [VarTy "p"] UnitTy)
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
Template
|
||||
t
|
||||
(const (toTemplate "void $NAME($p p)"))
|
||||
(\(FuncTy [concreteStructTy] UnitTy) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
memberPairs = memberXObjsToPairs correctedMembers
|
||||
in (toTemplate $ unlines [ "$DECL {"
|
||||
, joinWith "\n" (map (memberDeletion typeEnv env) memberPairs)
|
||||
, "}"]))
|
||||
(\(FuncTy [concreteStructTy] UnitTy) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
memberPairs = memberXObjsToPairs correctedMembers
|
||||
in if isTypeGeneric concreteStructTy
|
||||
then []
|
||||
else concatMap (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType)
|
||||
(filter (isManaged typeEnv) (map snd memberPairs)))
|
||||
|
||||
-- | Generate the C code for deleting a single member of the deftype.
|
||||
-- | TODO: Should return an Either since this can fail!
|
||||
memberDeletion :: TypeEnv -> Env -> (String, Ty) -> String
|
||||
memberDeletion typeEnv env (memberName, memberType) =
|
||||
case findFunctionForMember typeEnv env "delete" (typesDeleterFunctionType memberType) (memberName, memberType) of
|
||||
FunctionFound functionFullName -> " " ++ functionFullName ++ "(p." ++ memberName ++ ");"
|
||||
FunctionNotFound msg -> error msg
|
||||
FunctionIgnored -> " /* Ignore non-managed member '" ++ memberName ++ "' */"
|
||||
|
||||
|
||||
|
||||
-- | Helper function to create the binder for the 'copy' template.
|
||||
binderForCopy :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either String ((String, Binder), [XObj])
|
||||
binderForCopy typeEnv env insidePath structTy@(StructTy typeName _) [XObj (Arr membersXObjs) _ _] =
|
||||
if isTypeGeneric structTy
|
||||
then Right (genericCopy insidePath structTy membersXObjs, [])
|
||||
else Right (instanceBinderWithDeps (SymPath insidePath "copy")
|
||||
(FuncTy [RefTy structTy] structTy)
|
||||
(concreteCopy typeEnv env (memberXObjsToPairs membersXObjs)))
|
||||
|
||||
-- | The template for the 'copy' function of a concrete deftype.
|
||||
concreteCopy :: TypeEnv -> Env -> [(String, Ty)] -> Template
|
||||
concreteCopy typeEnv env memberPairs =
|
||||
Template
|
||||
(FuncTy [RefTy (VarTy "p")] (VarTy "p"))
|
||||
(const (toTemplate "$p $NAME($p* pRef)"))
|
||||
(const (tokensForCopy typeEnv env memberPairs))
|
||||
(\_ -> concatMap (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType)
|
||||
(filter (isManaged typeEnv) (map snd memberPairs)))
|
||||
|
||||
-- | The template for the 'copy' function of a generic deftype.
|
||||
genericCopy :: [String] -> Ty -> [XObj] -> (String, Binder)
|
||||
genericCopy pathStrings originalStructTy membersXObjs =
|
||||
defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy] originalStructTy)
|
||||
where path = SymPath pathStrings "copy"
|
||||
t = (FuncTy [RefTy (VarTy "p")] (VarTy "p"))
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
Template
|
||||
t
|
||||
(const (toTemplate "$p $NAME($p* pRef)"))
|
||||
(\(FuncTy [RefTy concreteStructTy] _) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
memberPairs = memberXObjsToPairs correctedMembers
|
||||
in (tokensForCopy typeEnv env memberPairs))
|
||||
(\(FuncTy [RefTy concreteStructTy] _) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
memberPairs = memberXObjsToPairs correctedMembers
|
||||
in if isTypeGeneric concreteStructTy
|
||||
then []
|
||||
else concatMap (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType)
|
||||
(filter (isManaged typeEnv) (map snd memberPairs)))
|
||||
|
||||
tokensForCopy :: TypeEnv -> Env -> [(String, Ty)] -> [Token]
|
||||
tokensForCopy typeEnv env memberPairs=
|
||||
(toTemplate $ unlines [ "$DECL {"
|
||||
, " $p copy = *pRef;"
|
||||
, joinWith "\n" (map (memberCopy typeEnv env) memberPairs)
|
||||
, " return copy;"
|
||||
, "}"])
|
||||
|
||||
-- | Generate the C code for copying the member of a deftype.
|
||||
-- | TODO: Should return an Either since this can fail!
|
||||
memberCopy :: TypeEnv -> Env -> (String, Ty) -> String
|
||||
memberCopy typeEnv env (memberName, memberType) =
|
||||
case findFunctionForMember typeEnv env "copy" (typesCopyFunctionType memberType) (memberName, memberType) of
|
||||
FunctionFound functionFullName ->
|
||||
" copy." ++ memberName ++ " = " ++ functionFullName ++ "(&(pRef->" ++ memberName ++ "));"
|
||||
FunctionNotFound msg -> error msg
|
||||
FunctionIgnored -> " /* Ignore non-managed member '" ++ memberName ++ "' */"
|
||||
-- import Obj
|
||||
-- import Types
|
||||
-- import Util
|
||||
-- import Template
|
||||
-- import Infer
|
||||
-- import Concretize
|
||||
-- import Polymorphism
|
||||
-- import ArrayTemplates
|
||||
-- import Lookup
|
||||
|
||||
13
src/Emit.hs
13
src/Emit.hs
@ -22,6 +22,7 @@ import Util
|
||||
import Template
|
||||
import Scoring
|
||||
import Lookup
|
||||
import Concretize
|
||||
|
||||
addIndent :: Int -> String
|
||||
addIndent n = replicate n ' '
|
||||
@ -198,12 +199,12 @@ toC toCMode root = emitterSrc (execState (visit startingIndent root) (EmitterSta
|
||||
appendToSrc (addIndent indent ++ lambdaEnvName ++ "->" ++
|
||||
pathToC path ++ " = " ++ pathToC path ++ ";\n"))
|
||||
capturedVars
|
||||
appendToSrc (addIndent indent ++ "Lambda " ++ retVar ++
|
||||
" = { .callback = " ++ pathToC (SymPath [] callback) ++
|
||||
", .env = " ++ (if needEnv then lambdaEnvName else "NULL") ++
|
||||
", .delete = NULL" ++
|
||||
", .copy = NULL }" ++
|
||||
";\n")
|
||||
appendToSrc (addIndent indent ++ "Lambda " ++ retVar ++ " = {\n")
|
||||
appendToSrc (addIndent indent ++ " .callback = " ++ pathToC (SymPath [] callback))
|
||||
appendToSrc (addIndent indent ++ " .env = " ++ (if needEnv then lambdaEnvName else "NULL"))
|
||||
appendToSrc (addIndent indent ++ " .delete = " ++ (if needEnv then "" ++ lambdaEnvTypeName ++ "_delete" else "NULL"))
|
||||
appendToSrc (addIndent indent ++ " .copy = " ++ (if needEnv then "" ++ lambdaEnvTypeName ++ "_copy" else "NULL"))
|
||||
appendToSrc (addIndent indent ++ "};\n")
|
||||
return retVar
|
||||
|
||||
-- Def
|
||||
|
||||
@ -33,6 +33,7 @@ import Expand
|
||||
import Lookup
|
||||
import Qualify
|
||||
import TypeError
|
||||
import Concretize
|
||||
|
||||
-- | Dynamic (REPL) evaluation of XObj:s (s-expressions)
|
||||
eval :: Env -> XObj -> StateT Context IO (Either EvalError XObj)
|
||||
|
||||
@ -11,6 +11,7 @@ import ArrayTemplates
|
||||
import Commands
|
||||
import Parsing
|
||||
import Eval
|
||||
import Concretize
|
||||
|
||||
-- | These modules will be loaded in order before any other code is evaluated.
|
||||
coreModules :: String -> [String]
|
||||
@ -143,7 +144,7 @@ generateTemplateFuncCopy funcTy = defineTemplate
|
||||
," f_copy.callback = ref->callback;"
|
||||
," f_copy.delete = ref->delete;"
|
||||
," f_copy.copy = ref->copy;"
|
||||
," f_copy.env = ref->copy(ref->env);"
|
||||
," f_copy.env = ((void*(*)(void*))ref->copy)(ref->env);"
|
||||
," return f_copy;"
|
||||
," } else {"
|
||||
," return *ref;"
|
||||
@ -159,7 +160,7 @@ generateTemplateFuncDelete funcTy = defineTemplate
|
||||
(toTemplate "void $NAME (Lambda f)")
|
||||
(toTemplate $ unlines ["$DECL {"
|
||||
," if(f.delete) {"
|
||||
," f.delete(f.env);"
|
||||
," ((void(*)(void*))f.delete)(f.env);"
|
||||
," }"
|
||||
,"}"])
|
||||
(const [])
|
||||
|
||||
160
src/Template.hs
160
src/Template.hs
@ -11,163 +11,3 @@ import Obj
|
||||
import Parsing
|
||||
import Infer
|
||||
import Concretize
|
||||
|
||||
-- | Templates are instructions for the compiler to generate some C-code
|
||||
-- | based on some template and the names and types to fill into the template.
|
||||
-- | Templates are generic and need to be given an explicit type to generate the
|
||||
-- | correct code.
|
||||
|
||||
-- | Example:
|
||||
-- | template1 : ((Array T) -> Int) = "int length__T(<T> xs) { return xs->len; }"
|
||||
-- | Given the type ((Array Float) -> Int) the following code is produced:
|
||||
-- | "int length__Float(Array__Float xs) { return xs->len; }"
|
||||
|
||||
-- | Create a binding pair used for adding a template definition to an environment.
|
||||
defineTemplate :: SymPath -> Ty -> [Token] -> [Token] -> (Ty -> [XObj]) -> (String, Binder)
|
||||
defineTemplate path t declaration definition depsFunc =
|
||||
let (SymPath _ name) = path
|
||||
template = Template t (const declaration) (const definition) depsFunc
|
||||
i = Info 0 0 (show path ++ ".template") Set.empty 0
|
||||
defLst = [XObj (Deftemplate (TemplateCreator (\_ _ -> template))) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]
|
||||
in (name, Binder emptyMeta (XObj (Lst defLst) (Just i) (Just t)))
|
||||
|
||||
-- | The more advanced version of a template, where the code can vary depending on the type.
|
||||
defineTypeParameterizedTemplate :: TemplateCreator -> SymPath -> Ty -> (String, Binder)
|
||||
defineTypeParameterizedTemplate templateCreator path t =
|
||||
let (SymPath _ name) = path
|
||||
i = Info 0 0 (show path ++ ".parameterizedTemplate") Set.empty 0
|
||||
defLst = [XObj (Deftemplate templateCreator) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]
|
||||
in (name, Binder emptyMeta (XObj (Lst defLst) (Just i) (Just t)))
|
||||
|
||||
-- | Create a binding pair used for adding a template instantiation to an environment.
|
||||
instanceBinder :: SymPath -> Ty -> Template -> (String, Binder)
|
||||
instanceBinder path@(SymPath _ name) actualType template =
|
||||
let (x, _) = instantiateTemplate path actualType template
|
||||
in (name, Binder emptyMeta x)
|
||||
|
||||
-- -- | Create a binding pair and don't discard the dependencies
|
||||
instanceBinderWithDeps :: SymPath -> Ty -> Template -> ((String, Binder), [XObj])
|
||||
instanceBinderWithDeps path@(SymPath _ name) actualType template =
|
||||
let (x, deps) = instantiateTemplate path actualType template
|
||||
in ((name, Binder emptyMeta x), deps)
|
||||
|
||||
-- | Concretizes the types used in @token
|
||||
-- @cName is the name of the definition, i.e. the "foo" in "void foo() { ... }"
|
||||
concretizeTypesInToken :: TypeMappings -> String -> [Token] -> Token -> [Token]
|
||||
concretizeTypesInToken mappings cName decl token =
|
||||
case token of
|
||||
TokDecl -> concatMap (concretizeTypesInToken mappings cName (error "Nope.")) decl
|
||||
TokName -> [TokC cName]
|
||||
TokTy t mode -> [TokTy (replaceTyVars mappings t) mode]
|
||||
_ -> [token]
|
||||
|
||||
-- | High-level helper function for creating templates from strings of C code.
|
||||
toTemplate :: String -> [Token]
|
||||
toTemplate text = case Parsec.runParser templateSyntax 0 "(template)" text of
|
||||
Right ok -> ok
|
||||
Left err -> error (show err)
|
||||
where
|
||||
templateSyntax :: Parsec.Parsec String Int [Token]
|
||||
templateSyntax = Parsec.many parseTok
|
||||
|
||||
parseTok = Parsec.try parseTokDecl <|> --- $DECL
|
||||
Parsec.try parseTokName <|> --- $NAME
|
||||
Parsec.try parseTokTyGrouped <|> --- i.e. $(Fn [Int] t)
|
||||
Parsec.try parseTokTyRawGrouped <|>
|
||||
Parsec.try parseTokTy <|> --- i.e. $t
|
||||
parseTokC --- Anything else...
|
||||
|
||||
parseTokDecl :: Parsec.Parsec String Int Token
|
||||
parseTokDecl = do _ <- Parsec.string "$DECL"
|
||||
return TokDecl
|
||||
|
||||
parseTokName :: Parsec.Parsec String Int Token
|
||||
parseTokName = do _ <- Parsec.string "$NAME"
|
||||
return TokName
|
||||
|
||||
parseTokC :: Parsec.Parsec String Int Token
|
||||
parseTokC = do s <- Parsec.many1 validInSymbol
|
||||
return (TokC s)
|
||||
where validInSymbol = Parsec.choice [Parsec.letter, Parsec.digit, Parsec.oneOf validCharactersInTemplate]
|
||||
validCharactersInTemplate = " ><{}()[]|;:.,_-+*#/'^!?€%&=@\"\n\t"
|
||||
|
||||
parseTokTy :: Parsec.Parsec String Int Token
|
||||
parseTokTy = do _ <- Parsec.char '$'
|
||||
s <- Parsec.many1 Parsec.letter
|
||||
return (toTokTy Normal s)
|
||||
|
||||
parseTokTyGrouped :: Parsec.Parsec String Int Token
|
||||
parseTokTyGrouped = do _ <- Parsec.char '$'
|
||||
_ <- Parsec.char '('
|
||||
Parsec.putState 1 -- One paren to close.
|
||||
s <- fmap ('(' :) (Parsec.many parseCharBalanced)
|
||||
-- Note: The closing paren is read by parseCharBalanced.
|
||||
return (toTokTy Normal s)
|
||||
|
||||
parseTokTyRawGrouped :: Parsec.Parsec String Int Token
|
||||
parseTokTyRawGrouped = do _ <- Parsec.char '§'
|
||||
_ <- Parsec.char '('
|
||||
Parsec.putState 1 -- One paren to close.
|
||||
s <- fmap ('(' :) (Parsec.many parseCharBalanced)
|
||||
-- Note: The closing paren is read by parseCharBalanced.
|
||||
return (toTokTy Raw s)
|
||||
|
||||
parseCharBalanced :: Parsec.Parsec String Int Char
|
||||
parseCharBalanced = do balanceState <- Parsec.getState
|
||||
if balanceState > 0
|
||||
then Parsec.try openParen <|>
|
||||
Parsec.try closeParen <|>
|
||||
Parsec.anyChar
|
||||
else Parsec.char '\0' -- Should always fail which will end the string.
|
||||
|
||||
openParen :: Parsec.Parsec String Int Char
|
||||
openParen = do _ <- Parsec.char '('
|
||||
Parsec.modifyState (+1)
|
||||
return '('
|
||||
|
||||
closeParen :: Parsec.Parsec String Int Char
|
||||
closeParen = do _ <- Parsec.char ')'
|
||||
Parsec.modifyState (\x -> x - 1)
|
||||
return ')'
|
||||
|
||||
-- | Converts a string containing a type to a template token ('TokTy').
|
||||
-- | i.e. the string "(Array Int)" becomes (TokTy (StructTy "Array" IntTy)).
|
||||
toTokTy :: TokTyMode -> String -> Token
|
||||
toTokTy mode s =
|
||||
case parse s "" of
|
||||
Left err -> error (show err)
|
||||
Right [] -> error ("toTokTy got [] when parsing: '" ++ s ++ "'")
|
||||
Right [xobj] -> case xobjToTy xobj of
|
||||
Just ok -> TokTy ok mode
|
||||
Nothing -> error ("toTokTy failed to convert this s-expression to a type: " ++ pretty xobj)
|
||||
Right xobjs -> error ("toTokTy parsed too many s-expressions: " ++ joinWithSpace (map pretty xobjs))
|
||||
|
||||
-- | The code needed to correctly call a lambda from C.
|
||||
templateCodeForCallingLambda :: String -> Ty -> [String] -> String
|
||||
templateCodeForCallingLambda functionName t args =
|
||||
let FuncTy argTys retTy = t
|
||||
castToFnWithEnv = tyToCast (FuncTy (lambdaEnvTy : argTys) retTy)
|
||||
castToFn = tyToCast t
|
||||
in
|
||||
functionName ++ ".env ? " ++
|
||||
"((" ++ castToFnWithEnv ++ ")" ++ functionName ++ ".callback)(" ++ functionName ++ ".env" ++ (if null args then "" else ", ") ++ joinWithComma args ++ ")" ++
|
||||
" : " ++
|
||||
"((" ++ castToFn ++ ")" ++ functionName ++ ".callback)(" ++ joinWithComma args ++ ")"
|
||||
|
||||
-- | Must cast a lambda:s .callback member to the correct type to be able to call it.
|
||||
tyToCast :: Ty -> String
|
||||
tyToCast t =
|
||||
let FuncTy argTys retTy = t
|
||||
in "§(Fn [" ++ joinWithSpace (map show argTys) ++ "] " ++ show retTy ++ ")" -- Note! The '§' means that the emitted type will be "raw" and not converted to 'Lambda'.
|
||||
|
||||
----------------------------------------------------------------------------------------------------------
|
||||
-- ACTUAL TEMPLATES
|
||||
|
||||
-- | This function accepts a pointer and will do nothing with it.
|
||||
templateNoop :: (String, Binder)
|
||||
templateNoop = defineTemplate
|
||||
(SymPath [] "noop")
|
||||
(FuncTy [PointerTy (VarTy "a")] UnitTy)
|
||||
(toTemplate "void $NAME ($a* a)")
|
||||
(toTemplate "$DECL { }")
|
||||
(const [])
|
||||
|
||||
Loading…
Reference in New Issue
Block a user