Most code written, no tests yet

src/Monomorpher/Monomorpher.hs

@@ -1,6 +1,8 @@
 -- | For now, converts polymorphic functions to concrete ones based on usage.
 -- Assumes lambdas are lifted.
+--
 -- This step of compilation is as follows:
+--
 -- Split all function bindings into monomorphic and polymorphic binds. The
 -- monomorphic bindings will be part of this compilation step.
 -- Apply the following monomorphization function on all monomorphic binds, with
@@ -13,9 +15,9 @@
 -- are changed to using the mapped generic types. The expected type provided
 -- in the recursion is changed depending on the different nodes.
 -- 
--- When an external bind is encountered (EId), it is checked whether it is
+-- When an external bind is encountered (with EId), it is checked whether it
--- monomorphic or polymorphic. If monomorphic, nothing further is evaluated.
+-- exists in outputed binds or not. If it does, nothing further is evaluated.
--- If polymorphic, the bind transformer function is called on this with the
+-- If not, the bind transformer function is called on it with the
 -- expected type in this context. The result of this computation (a monomorphic 
 -- bind) is added to the resulting set of binds.
 
@@ -26,17 +28,21 @@ import qualified Monomorpher.MonomorpherIr as M
 
 import           Grammar.Abs   (Ident)
 
-import Control.Monad.State (MonadState (get, put), State, gets, modify)
+import Control.Monad.State (MonadState (get), State, gets, modify, execState)
 import qualified Data.Map as Map
-import Data.Foldable (find)
+import qualified Data.Set as Set
+import Data.Maybe (fromJust)
 
 -- | The environment of computations in this module.
 data Env = Env { -- | All binds in the program.
                  input  :: Map.Map Ident T.Bind,
                  -- | The monomorphized binds.
-                 output :: [M.Bind],
+                 output :: Map.Map Ident M.Bind,
                  -- | Maps polymorphic identifiers with concrete types.
-                 polys  :: Map.Map Ident M.Type
+                 polys  :: Map.Map Ident M.Type,
+                 -- | Local variables, not necessary if id's are annotated based
+                 -- on if they are local or global.
+                 locals :: Set.Set Ident
                }
 
 -- | State Monad wrapper for "Env".
@@ -45,55 +51,144 @@ 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 }
+createEnv binds = Env { input  = Map.fromList kvPairs, 
+                        output = Map.empty,
+                        polys  = Map.empty,
+                        locals = Set.empty }
  where
    kvPairs :: [(Ident, T.Bind)]
    kvPairs = map (\b@(T.Bind (ident, _) _ _) -> (ident, b)) binds
 
+-- | Functions to add, clear and get whether id is a local variable.
+addLocal :: Ident -> EnvM ()
+addLocal ident = modify (\env -> env { locals = Set.insert ident (locals env) })
+
+clearLocal :: EnvM ()
+clearLocal = modify (\env -> env { locals = Set.empty })
+
+localExists :: Ident -> EnvM Bool
+localExists ident = do env <- get
+                       return $ Set.member ident (locals env)
+
 -- | Gets a polymorphic bind from an id.
-getPolymorphic :: T.Id -> EnvM (Maybe T.Bind)
+getPolymorphic :: Ident -> EnvM (Maybe T.Bind)
-getPolymorphic (ident, _) = gets (Map.lookup ident . input)
+getPolymorphic ident = gets (Map.lookup ident . input)
 
 -- | Add monomorphic function derived from a polymorphic one, to env.
 addMonomorphic :: M.Bind -> EnvM ()
-addMonomorphic b = modify (\env -> env { output = b:(output env) })
+addMonomorphic 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)
+
+-- | 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 = undefined
+addPolyMap t1 (T.Bind (_, t2) _ _) = modify modFunc
+ where
+   modFunc env = env { polys = newPolys (polys env) }
+   newPolys oldPolys = Map.union oldPolys (Map.fromList (mapTypes t2 t1))
 
---morphBind :: M.Type -> T.Bind -> EnvM M.Bind
+-- | Gets the monomorphic type of a polymorphic type in the current context.
---morphBind expectedType (T.Bind (ident, t) _ exp) = do
+getMono :: T.Type -> EnvM M.Type
---  exp' <- morphExp expectedType exp
+getMono t = do env <- get
---  return $ M.Bind (ident, expectedType) [] exp'
+               return $ getMono' (polys env) t
---
+ where
----- | Monomorphize an expression.
+  getMono' :: Map.Map Ident M.Type -> T.Type -> M.Type
---morphExp :: M.Type -> T.Exp -> EnvM M.Exp
+  getMono' polys t = case t of
---morphExp expectedType exp = case exp of
+    (T.TMono ident) -> M.TMono ident
---  T.EApp t e1 e2 -> do  
+    (T.TArr t1 t2)  -> M.TArr
---    e1' <- morphExp expectedType e1
+        (getMono' polys t1) (getMono' polys t2)
---    e2' <- morphExp t1 e2
+    (T.TPol ident) -> case Map.lookup ident polys of
---    return $ M.EApp expectedType e1' e2'
+                         Just concrete -> concrete
---  T.EAdd t e1 e2 -> do e1' <- morphExp e1
+                         Nothing       -> error "type not found!"
---                       e2' <- morphExp e2
---                       return $ M.EAdd t e1' e2'
---  T.EId  id ->undefined
---  T.ELit t lit ->undefined
---  T.ELet bind e ->undefined
---  -- Special case at bind level
---  T.EAbs t id e -> error "Passing lambda lifter, this is not possible."
 
+-- NOTE: could make this function more optimized
+-- | Makes a kv pair list of poly to concrete 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 _)       = []
+mapTypes (T.TPol i1)      tm               = [(i1, tm)]
+mapTypes (T.TArr pt1 pt2) (M.TArr mt1 mt2) = mapTypes pt1 mt1 ++ 
+                                             mapTypes pt2 mt2
+mapTypes _ _ = error "structure of types not the same!"
+
+-- | If ident not already in env's output, morphed bind to output
+-- (and all referenced binds within this bind).
+morphBind :: M.Type -> T.Bind -> EnvM ()
+morphBind expectedType b@(T.Bind (ident, _) _ exp) = do
+  outputted <- isOutputted ident
+  if outputted then
+    -- Don't add anything!
+    return ()
+  else do
+    -- Add processed bind!
+    addPolyMap expectedType b
+    exp' <- morphExp expectedType exp
+    addMonomorphic $ M.Bind (ident, expectedType) [] exp'
+
+-- Get type of expression
+getExpType :: T.Exp -> T.Type
+getExpType (T.EId  (_, t)) = t
+getExpType (T.ELit t _)    = t
+getExpType (T.EApp t _ _)  = t
+getExpType (T.EAdd t _ _)  = t
+getExpType (T.EAbs t _ _)  = t
+getExpType (T.ELet _ _)    = error "Lets not allowed🛑👮"
+
+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
+                       return $ M.ELit t' lit
+  T.EApp _ e1 e2 -> do t2  <- getMono $ getExpType e2
+                       e2' <- morphExp t2 e2
+                       t1  <- getMono $ getExpType e1
+                       e1' <- morphExp t1 e1
+                       return $ M.EApp expectedType e1' e2'
+  T.EAdd _ e1 e2 -> do t2  <- getMono $ getExpType e2
+                       e2' <- morphExp t2 e2
+                       t1  <- getMono $ getExpType e1
+                       e1' <- morphExp t1 e1
+                       return $ M.EApp expectedType e1' e2'
+  -- Add local vars to locals
+  T.EAbs _ (ident, _) e -> do let (M.TArr _ t) = expectedType
+                              addLocal ident
+                              morphExp t e
+
+  T.EId (ident, t) ->      do maybeLocal <- localExists ident
+                              if maybeLocal then do
+                                t' <- getMono t
+                                return $ M.EId (ident, t')
+                              else do
+                                clearLocal
+                                bind <- getPolymorphic ident
+                                case bind of
+                                  Nothing    -> error "Wowzers!"
+                                  Just bind' -> do
+                                    t' <- getMono t
+                                    morphBind t' bind'
+                                    return $ M.EId (ident, t')
+
+  T.ELet (T.Bind {}) _ -> error "Lets not possible yet."
+
+-- TODO: make sure that monomorphic binds are not processed again
 -- | Does the monomorphization.
 monomorphize :: T.Program -> M.Program
-monomorphize (T.Program binds) = undefined
+monomorphize (T.Program binds) = M.Program $ (map snd . Map.toList) outputMap
  where
-  monomorphize' :: EnvM M.Program
+  outputMap :: Map.Map Ident M.Bind
+  outputMap = output $ execState monomorphize' (createEnv binds)
+
+  monomorphize' :: EnvM ()
   monomorphize' = do
-    put $ createEnv binds
+    main <- getMain
-    -- TODO: complete
+    morphBind (M.TMono $ M.Ident "Int") main
-    return $ M.Program []
 
----- | Add functions (including polymorphic ones) to global environment.
---addBind :: Env -> Def -> Err Env
---addBind env (DDef ident identArgs closure) = envAdd env ident (foldl (flip EAbs) closure identArgs)