diff --git a/src/Monomorpher/Monomorpher.hs b/src/Monomorpher/Monomorpher.hs index 63a5b33..4c8cebf 100644 --- a/src/Monomorpher/Monomorpher.hs +++ b/src/Monomorpher/Monomorpher.hs @@ -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