Rakarake/churf
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Monomorphizer cleanup

Browse source
This commit is contained in:
Rakarake 2023-03-12 17:53:46 +01:00
parent e2db863c3e
commit ec95e0d9ef
1 changed files with 42 additions and 42 deletions
Download patch file Download diff file Expand all files Collapse all files

84
src/Monomorpher/Monomorpher.hs
View file

@ -44,13 +44,13 @@ data Env = Env { -- | All binds in the program.
-- | Local variables, not necessary if id's are annotated based -- | Local variables, not necessary if id's are annotated based
-- on if they are local or global. -- on if they are local or global.
locals :: Set.Set Ident, locals :: Set.Set Ident,
-- | The identifier of the current function.
currentFunc :: Ident currentFunc :: Ident
} deriving (Show) } deriving (Show)
-- | State Monad wrapper for "Env". -- | State Monad wrapper for "Env".
type EnvM a = State Env a type EnvM a = State Env a
-- TODO: use fromList
-- | Creates the environment based on the input binds. -- | Creates the environment based on the input binds.
createEnv :: [T.Bind] -> Env createEnv :: [T.Bind] -> Env
createEnv binds = Env { input = Map.fromList kvPairs, createEnv binds = Env { input = Map.fromList kvPairs,
@ -70,8 +70,8 @@ addLocals :: [Ident] -> EnvM ()
addLocals idents = modify (\env -> addLocals idents = modify (\env ->
env { locals = Set.fromList idents `Set.union` locals env }) env { locals = Set.fromList idents `Set.union` locals env })
clearLocal :: EnvM () clearLocals :: EnvM ()
clearLocal = modify (\env -> env { locals = Set.empty }) clearLocals = modify (\env -> env { locals = Set.empty })
localExists :: Ident -> EnvM Bool localExists :: Ident -> EnvM Bool
localExists ident = do env <- get localExists ident = do env <- get
@ -83,47 +83,33 @@ isCurrentFunc ident = do env <- get
return $ ident == currentFunc env return $ ident == currentFunc env
-- | Gets a polymorphic bind from an id. -- | Gets a polymorphic bind from an id.
getPolymorphic :: Ident -> EnvM (Maybe T.Bind) getInputBind :: Ident -> EnvM (Maybe T.Bind)
getPolymorphic ident = gets (Map.lookup ident . input) getInputBind ident = gets (Map.lookup ident . input)
-- | Add monomorphic function derived from a polymorphic one, to env. -- | Add monomorphic function derived from a polymorphic one, to env.
addMonomorphic :: M.Bind -> EnvM () addOutputBind :: M.Bind -> EnvM ()
addMonomorphic b@(M.Bind (ident, _) _ _) = modify addOutputBind b@(M.Bind (ident, _) _ _) = modify
(\env -> env { output = Map.insert ident b (output env) }) (\env -> env { output = Map.insert ident b (output env) })
-- | Checks whether or not an ident is added to output binds. -- | Checks whether or not an ident is added to output binds.
isOutputted :: Ident -> EnvM Bool isBindOutputted :: Ident -> EnvM Bool
isOutputted ident = do env <- get isBindOutputted ident = do env <- get
return $ Map.member ident (output env) return $ Map.member ident (output env)
-- | Finds main bind -- | Finds main bind
getMain :: EnvM T.Bind getMain :: EnvM T.Bind
getMain = gets (\env -> fromJust $ Map.lookup (T.Ident "main") (input env)) getMain = gets (\env -> fromJust $ Map.lookup (T.Ident "main") (input env))
-- | Add polymorphic -> monomorphic type bindings regardless of bind. -- | Add polymorphic -> monomorphic type bindings regardless of bind.
-- The structue of the types should be the same, map them. -- The structue of the types should be the same.
addPolyMap :: M.Type -> T.Bind -> EnvM () mapTypesInBind :: M.Type -> T.Bind -> EnvM ()
addPolyMap t1 (T.Bind (_, t2) _ _) = modify modFunc mapTypesInBind t1 (T.Bind (_, t2) _ _) = modify modFunc
where where
modFunc env = env { polys = newPolys (polys env) } modFunc env = env { polys = newPolys (polys env) }
newPolys oldPolys = Map.union oldPolys (Map.fromList (mapTypes t2 t1)) newPolys oldPolys = Map.union oldPolys (Map.fromList (mapTypes t2 t1))
-- | Gets the monomorphic type of a polymorphic type in the current context.
getMono :: T.Type -> EnvM M.Type
getMono t = do env <- get
return $ getMono' (polys env) t
where
getMono' :: Map.Map Ident M.Type -> T.Type -> M.Type
getMono' polys t = case t of
(T.TMono ident) -> M.TMono ident
(T.TArr t1 t2) -> M.TArr
(getMono' polys t1) (getMono' polys t2)
(T.TPol ident) -> case Map.lookup ident polys of
Just concrete -> concrete
Nothing -> error $ "type not found! type: " ++ show ident
-- NOTE: could make this function more optimized -- NOTE: could make this function more optimized
-- | Makes a kv pair list of poly to concrete mappings, throws runtime -- | Makes a kv pair list of polymorphic to monomorphic mappings, throws runtime
-- error when encountering different structures between the two arguments. -- error when encountering different structures between the two arguments.
mapTypes :: T.Type -> M.Type -> [(Ident, M.Type)] mapTypes :: T.Type -> M.Type -> [(Ident, M.Type)]
mapTypes (T.TMono _) (M.TMono _) = [] mapTypes (T.TMono _) (M.TMono _) = []
@ -132,6 +118,21 @@ mapTypes (T.TArr pt1 pt2) (M.TArr mt1 mt2) = mapTypes pt1 mt1 ++
mapTypes pt2 mt2 mapTypes pt2 mt2
mapTypes _ _ = error "structure of types not the same!" mapTypes _ _ = error "structure of types not the same!"
-- | Gets the mapped monomorphic type of a polymorphic type in the current context.
getMonoFromPoly :: T.Type -> EnvM M.Type
getMonoFromPoly t = do env <- get
return $ getMono (polys env) t
where
getMono :: Map.Map Ident M.Type -> T.Type -> M.Type
getMono polys t = case t of
(T.TMono ident) -> M.TMono ident
(T.TArr t1 t2) -> M.TArr
(getMono polys t1) (getMono polys t2)
(T.TPol ident) -> case Map.lookup ident polys of
Just concrete -> concrete
Nothing -> error $
"type not found! type: " ++ show ident
-- Get type of expression -- Get type of expression
getExpType :: T.Exp -> T.Type getExpType :: T.Exp -> T.Type
getExpType (T.EId (_, t)) = t getExpType (T.EId (_, t)) = t
@ -145,29 +146,29 @@ getExpType (T.ELet _ _) = error "Lets not allowed🛑👮"
-- (and all referenced binds within this bind). -- (and all referenced binds within this bind).
morphBind :: M.Type -> T.Bind -> EnvM () morphBind :: M.Type -> T.Bind -> EnvM ()
morphBind expectedType b@(T.Bind (Ident name, _) args exp) = do morphBind expectedType b@(T.Bind (Ident name, _) args exp) = do
outputted <- isOutputted (Ident name) outputted <- isBindOutputted (Ident name)
if outputted then if outputted then
-- Don't add anything! -- Don't add anything!
return () return ()
else do else do
-- Add processed bind! -- Add processed bind!
addLocals $ map fst args -- Add all the local variables addLocals $ map fst args -- Add all the local variables
addPolyMap expectedType b mapTypesInBind expectedType b
exp' <- morphExp expectedType exp exp' <- morphExp expectedType exp
addMonomorphic $ M.Bind (newName expectedType b, expectedType) [] exp' addOutputBind $ M.Bind (newName expectedType b, expectedType) [] exp'
morphExp :: M.Type -> T.Exp -> EnvM M.Exp morphExp :: M.Type -> T.Exp -> EnvM M.Exp
morphExp expectedType exp = case exp of morphExp expectedType exp = case exp of
T.ELit t lit -> do t' <- getMono t -- These steps are abundant T.ELit t lit -> do t' <- getMonoFromPoly t -- These steps are abundant
return $ M.ELit t' lit return $ M.ELit t' lit
T.EApp _ e1 e2 -> do t2 <- getMono $ getExpType e2 T.EApp _ e1 e2 -> do t2 <- getMonoFromPoly $ getExpType e2
e2' <- morphExp t2 e2 e2' <- morphExp t2 e2
t1 <- getMono $ getExpType e1 t1 <- getMonoFromPoly $ getExpType e1
e1' <- morphExp t1 e1 e1' <- morphExp t1 e1
return $ M.EApp expectedType e1' e2' return $ M.EApp expectedType e1' e2'
T.EAdd _ e1 e2 -> do t2 <- getMono $ getExpType e2 T.EAdd _ e1 e2 -> do t2 <- getMonoFromPoly $ getExpType e2
e2' <- morphExp t2 e2 e2' <- morphExp t2 e2
t1 <- getMono $ getExpType e1 t1 <- getMonoFromPoly $ getExpType e1
e1' <- morphExp t1 e1 e1' <- morphExp t1 e1
return $ M.EAdd expectedType e1' e2' return $ M.EAdd expectedType e1' e2'
-- Add local vars to locals, this will never be called after the lambda lifter -- Add local vars to locals, this will never be called after the lambda lifter
@ -177,18 +178,17 @@ morphExp expectedType exp = case exp of
morphExp t e morphExp t e
T.EId (ident, t) -> do maybeLocal <- localExists ident T.EId (ident, t) -> do maybeLocal <- localExists ident
trace ("Ident: " ++ show ident ++": " ++ show maybeLocal) (return ())
if maybeLocal then do if maybeLocal then do
t' <- getMono t t' <- getMonoFromPoly t
return $ M.EId (ident, t') return $ M.EId (ident, t')
else do else do
clearLocal clearLocals
bind <- getPolymorphic ident bind <- getInputBind ident
case bind of case bind of
Nothing -> error "Wowzers!" Nothing -> error "Wowzers!"
Just bind' -> do Just bind' -> do
maybeCurrentFunc <- isCurrentFunc ident maybeCurrentFunc <- isCurrentFunc ident
t' <- getMono t t' <- getMonoFromPoly t
if maybeCurrentFunc then -- Recursive call? if maybeCurrentFunc then -- Recursive call?
return () return ()
else else
@ -211,7 +211,7 @@ monomorphize :: T.Program -> M.Program
monomorphize (T.Program binds) = M.Program $ (map snd . Map.toList) outputMap monomorphize (T.Program binds) = M.Program $ (map snd . Map.toList) outputMap
where where
outputMap :: Map.Map Ident M.Bind outputMap :: Map.Map Ident M.Bind
outputMap = output $ execState monomorphize' (trace ("Inital Env: " ++ show (createEnv binds)) $ createEnv binds) outputMap = output $ execState monomorphize' (createEnv binds)
monomorphize' :: EnvM () monomorphize' :: EnvM ()
monomorphize' = do monomorphize' = do