Monomorphizer cleanup
This commit is contained in:
Rakarake
parent
e2db863c3e
commit
ec95e0d9ef
1 changed files with 42 additions and 42 deletions
|
|
@ -44,13 +44,13 @@ data Env = Env { -- | All binds in the program.
|
|||
-- | Local variables, not necessary if id's are annotated based
|
||||
-- on if they are local or global.
|
||||
locals :: Set.Set Ident,
|
||||
-- | The identifier of the current function.
|
||||
currentFunc :: Ident
|
||||
} deriving (Show)
|
||||
|
||||
-- | State Monad wrapper for "Env".
|
||||
type EnvM a = State Env a
|
||||
|
||||
-- TODO: use fromList
|
||||
-- | Creates the environment based on the input binds.
|
||||
createEnv :: [T.Bind] -> Env
|
||||
createEnv binds = Env { input = Map.fromList kvPairs,
|
||||
|
|
@ -70,8 +70,8 @@ addLocals :: [Ident] -> EnvM ()
|
|||
addLocals idents = modify (\env ->
|
||||
env { locals = Set.fromList idents `Set.union` locals env })
|
||||
|
||||
clearLocal :: EnvM ()
|
||||
clearLocal = modify (\env -> env { locals = Set.empty })
|
||||
clearLocals :: EnvM ()
|
||||
clearLocals = modify (\env -> env { locals = Set.empty })
|
||||
|
||||
localExists :: Ident -> EnvM Bool
|
||||
localExists ident = do env <- get
|
||||
|
|
@ -83,47 +83,33 @@ isCurrentFunc ident = do env <- get
|
|||
return $ ident == currentFunc env
|
||||
|
||||
-- | Gets a polymorphic bind from an id.
|
||||
getPolymorphic :: Ident -> EnvM (Maybe T.Bind)
|
||||
getPolymorphic ident = gets (Map.lookup ident . input)
|
||||
getInputBind :: Ident -> EnvM (Maybe T.Bind)
|
||||
getInputBind ident = gets (Map.lookup ident . input)
|
||||
|
||||
-- | Add monomorphic function derived from a polymorphic one, to env.
|
||||
addMonomorphic :: M.Bind -> EnvM ()
|
||||
addMonomorphic b@(M.Bind (ident, _) _ _) = modify
|
||||
addOutputBind :: M.Bind -> EnvM ()
|
||||
addOutputBind b@(M.Bind (ident, _) _ _) = modify
|
||||
(\env -> env { output = Map.insert ident b (output env) })
|
||||
|
||||
-- | Checks whether or not an ident is added to output binds.
|
||||
isOutputted :: Ident -> EnvM Bool
|
||||
isOutputted ident = do env <- get
|
||||
return $ Map.member ident (output env)
|
||||
isBindOutputted :: Ident -> EnvM Bool
|
||||
isBindOutputted ident = do env <- get
|
||||
return $ Map.member ident (output env)
|
||||
|
||||
-- | Finds main bind
|
||||
getMain :: EnvM T.Bind
|
||||
getMain = gets (\env -> fromJust $ Map.lookup (T.Ident "main") (input env))
|
||||
|
||||
-- | Add polymorphic -> monomorphic type bindings regardless of bind.
|
||||
-- The structue of the types should be the same, map them.
|
||||
addPolyMap :: M.Type -> T.Bind -> EnvM ()
|
||||
addPolyMap t1 (T.Bind (_, t2) _ _) = modify modFunc
|
||||
-- The structue of the types should be the same.
|
||||
mapTypesInBind :: M.Type -> T.Bind -> EnvM ()
|
||||
mapTypesInBind t1 (T.Bind (_, t2) _ _) = modify modFunc
|
||||
where
|
||||
modFunc env = env { polys = newPolys (polys env) }
|
||||
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
|
||||
-- | 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.
|
||||
mapTypes :: T.Type -> M.Type -> [(Ident, M.Type)]
|
||||
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 _ _ = 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
|
||||
getExpType :: T.Exp -> T.Type
|
||||
getExpType (T.EId (_, t)) = t
|
||||
|
|
@ -145,29 +146,29 @@ getExpType (T.ELet _ _) = error "Lets not allowed🛑👮"
|
|||
-- (and all referenced binds within this bind).
|
||||
morphBind :: M.Type -> T.Bind -> EnvM ()
|
||||
morphBind expectedType b@(T.Bind (Ident name, _) args exp) = do
|
||||
outputted <- isOutputted (Ident name)
|
||||
outputted <- isBindOutputted (Ident name)
|
||||
if outputted then
|
||||
-- Don't add anything!
|
||||
return ()
|
||||
else do
|
||||
-- Add processed bind!
|
||||
addLocals $ map fst args -- Add all the local variables
|
||||
addPolyMap expectedType b
|
||||
mapTypesInBind expectedType b
|
||||
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 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
|
||||
T.EApp _ e1 e2 -> do t2 <- getMono $ getExpType e2
|
||||
T.EApp _ e1 e2 -> do t2 <- getMonoFromPoly $ getExpType e2
|
||||
e2' <- morphExp t2 e2
|
||||
t1 <- getMono $ getExpType e1
|
||||
t1 <- getMonoFromPoly $ getExpType e1
|
||||
e1' <- morphExp t1 e1
|
||||
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
|
||||
t1 <- getMono $ getExpType e1
|
||||
t1 <- getMonoFromPoly $ getExpType e1
|
||||
e1' <- morphExp t1 e1
|
||||
return $ M.EAdd expectedType e1' e2'
|
||||
-- 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
|
||||
|
||||
T.EId (ident, t) -> do maybeLocal <- localExists ident
|
||||
trace ("Ident: " ++ show ident ++": " ++ show maybeLocal) (return ())
|
||||
if maybeLocal then do
|
||||
t' <- getMono t
|
||||
t' <- getMonoFromPoly t
|
||||
return $ M.EId (ident, t')
|
||||
else do
|
||||
clearLocal
|
||||
bind <- getPolymorphic ident
|
||||
clearLocals
|
||||
bind <- getInputBind ident
|
||||
case bind of
|
||||
Nothing -> error "Wowzers!"
|
||||
Just bind' -> do
|
||||
maybeCurrentFunc <- isCurrentFunc ident
|
||||
t' <- getMono t
|
||||
t' <- getMonoFromPoly t
|
||||
if maybeCurrentFunc then -- Recursive call?
|
||||
return ()
|
||||
else
|
||||
|
|
@ -211,7 +211,7 @@ monomorphize :: T.Program -> M.Program
|
|||
monomorphize (T.Program binds) = M.Program $ (map snd . Map.toList) outputMap
|
||||
where
|
||||
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' = do
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue