Begin migration to Mu API backed code generation

anuhc.cabal

@@ -15,19 +15,28 @@ cabal-version:       >=1.10
 
 library
   hs-source-dirs:      src
+  other-extensions:
+    TemplateHaskell,
+    GeneralizedNewtypeDeriving
   ghc-options:         -Wall
   exposed-modules:     Compiler.Mu
+                     , Compiler.Mu.CodeGen
+                     , Compiler.Mu.Monad
                      , Compiler.Mu.Types
+                     , Compiler.Mu.FromSTG
                      , Language.Haskell.GHC.Simple.Extra
   build-depends:       base >= 4.7 && < 5
-                     , mtl
+                     , ansi-wl-pprint
+                     , bytestring
+                     , containers
                      , ghc
                      , ghc-simple
-                     , containers
-                     , bytestring
-                     , ansi-wl-pprint
                      , hoopl
-                     , hs-mu
+                     , microlens-platform
+                     , mtl
+                     , mu
+                     , mu-pure
+                     , transformers
   default-language:    Haskell2010
 
 executable anuhc-exe

src/Compiler/Mu.hs

@@ -13,14 +13,11 @@ module Compiler.Mu
 
 import TyCon (TyCon)
 import StgSyn (StgBinding)
-import Outputable (showSDocForUser, ppr, alwaysQualify)
-import Language.Haskell.GHC.Simple (ModMetadata (..), ms_hspp_opts)
+import Language.Haskell.GHC.Simple (ModMetadata (..))
 
 import Compiler.Mu.FromSTG
 
+import Mu.PrettyPrint
+
 compileMu :: ModMetadata -> ([TyCon], [StgBinding]) -> IO String
-compileMu metadata stg =
-    return . (showSDocForUser dflags qualifier) . ppr $ stgToMu metadata stg
-  where
-    dflags = ms_hspp_opts (mmSummary metadata)
-    qualifier = alwaysQualify
+compileMu metadata stg = return . pp $ stgToMu metadata stg

src/Compiler/Mu/CodeGen.hs

+-- |
+-- Module      :  Compiler.Mu.CodeGen
+-- Copyright   :  nathyong 2016
+-- License     :  BSD3
+--
+-- Maintainer  :  nathyong@gmail.com
+-- Stability   :  experimental
+-- Portability :  unknown
+--
+-- Utility functions for Haskell code generation via Mu.
+--
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Compiler.Mu.CodeGen (
+      -- * Code generation
+      emitClosure
+      -- * Utility functions
+    , stringify
+) where
+
+import Data.Map (Map)
+import qualified Data.Map as M
+import Control.Monad.State (State, MonadState)
+
+import Var (varName)
+import Name (nameOccName, occNameFS)
+import qualified GHC as GHC
+
+import Compiler.Mu.Monad
+import Mu.PrettyPrint (PrettyPrint (..))
+import Mu.Syntax
+
+-------------------------------------------------- * Code generation
+
+emitClosure :: GHC.Id -> String -> Int -> Mu String -> Mu ()
+emitClosure name typeName nargs code = do
+    _func_name <- code
+    return ()
+
+-------------------------------------------------- * Utility functions
+
+stringify :: GHC.Id -> String
+stringify = show . occNameFS . nameOccName . varName

src/Compiler/Mu/FromSTG.hs

@@ -11,10 +11,12 @@
 -- Code generation facilities for the Mu Micro Virtual Machine
 --
 module Compiler.Mu.FromSTG
-  ( stgToMu
+  (
+  -- * Main entry points
+  stgToMu
   ) where
 
--- * Main entry points
+
 import Data.Char (ord)
 import Control.Monad (void)
 import Control.Monad.Writer.Lazy (Writer, execWriter, tell)
@@ -30,38 +32,62 @@ import TyCon (TyCon)
 import StgSyn
        (StgBinding, GenStgBinding(..), StgRhs, GenStgRhs(..), StgArg,
         GenStgArg(..), StgExpr, GenStgExpr(..), UpdateFlag(..))
+import qualified GHC as GHC
 
-import Id (Id)
+import Compiler.Mu.CodeGen
+import Compiler.Mu.Monad
+import Mu.Syntax
+import Mu.Builder
 
-import Compiler.Mu.Types
-import qualified Mu.Syntax as Mu
 
 -- | Compile the information inside an STG module into a MuBundle.
-stgToMu :: ModMetadata -> ([TyCon], [StgBinding]) -> Mu.Program
-stgToMu modData (tyCons, bindings) = runMu emptyBundle $ do mapM_ codegenTop bindings
+stgToMu :: ModMetadata -> ([TyCon], [StgBinding]) -> Either MuException Program
+stgToMu modData (tyCons, bindings) =
+    buildMu $ do
+        loadTypes
+        mapM_ codegenTop bindings
+
+
+loadTypes :: Mu ()
+loadTypes = do
+    _ <- putTypedef "i3" $ MuInt 3
+    i64 <- putTypedef "i64" $ MuInt 64
+    _mu_tagref <- putTypedef "_mu_tagref" TagRef64
+    _ <- putTypedef "_mu_hybrid" $ Hybrid [i64, _mu_tagref] i64
+    return ()
 
 
 -- mapM_ codegenTopTypes tyCons
 codegenTop :: StgBinding -> Mu ()
-codegenTop binding = undefined
---     case binding of
---         StgNonRec bindId rhs -> cgTop (nameOf bindId) rhs
---         StgRec pairs -> unzipWith (cgTop . nameOf) pairs
---             where unzipWith f = mapM_ (uncurry f)
+codegenTop binding =
+    case binding of
+        StgNonRec bindId rhs -> cgTop bindId rhs
+        StgRec pairs -> unzipWith cgTop pairs
+            where unzipWith f = mapM_ (uncurry f)
+
+
+-------------------------------------------------- Utilities
+
+cgTop :: GHC.Id -> StgRhs -> Mu ()
+cgTop name rhs =
+    case rhs of
+        -- make the top-level constructor, need to output code for it?
+        -- emitTop name (TypeTop name (length args) con)
+        StgRhsCon _cc con args -> do
+            i64 <- getTypedef "i64"
+            _ <- putConstant (stringify name) i64 "some_value"
+            return ()
+        StgRhsClosure _cc _bindinfo _nonfrees _updateFlag _srt vars body ->
+            emitClosure name "some_type_name" (length vars) $
+            cgClosureBody vars body
+
+cgClosureBody :: [GHC.Id] -> StgExpr -> Mu String
+cgClosureBody vars body = do
+    return "FunctionName"
+
+
 
 
--- cgTop :: Name -> StgRhs -> Mu ()
--- cgTop name rhs =
---     case rhs of
---         StgRhsCon _cc con args
---         -- make the top-level constructor, need to output code for it?
---         -- emitTop name (TypeTop name (length args) con)
---          -> return ()
---         StgRhsClosure _cc _bindinfo _nonfrees _updateFlag _srt vars body ->
---             emitClosureTop name (Name "some_type_name") (length vars) $
---             cgClosureBody (fmap nameOf vars) body
---
---
 -- -- | Convert an StgBinding to Mu Code.
 -- cgBindings :: StgBinding -> MuCode ()
 -- cgBindings stgBinding =

src/Compiler/Mu/Kappa/FromSTG.hs

--- |
--- Module      :  Compiler.Mu.Kappa.FromSTG
--- Copyright   :  nathyong 2016
---
--- Maintainer  :  nathan.yong@anu.edu.au
--- Stability   :  experimental
--- Portability :  unknown
---
--- Functions for translating STG code to Kappa form.
---
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Compiler.Mu.Kappa.FromSTG
-    ( -- * Main entry points
-      stgToKappa
-    ) where
-
-import Data.Char (ord)
-import Control.Monad (void)
-import Control.Monad.Writer.Lazy (Writer, execWriter, tell)
-
-import Literal (Literal (..))
-import DataCon (DataCon , dataConWrapId)
-import BasicTypes (RecFlag (..))
-import Outputable (Outputable, pprTraceIt)
-import Language.Haskell.GHC.Simple (ModMetadata (..))
-import GHC (ModSummary (..))
-import DynFlags (DynFlags)
-import TyCon (TyCon)
-import StgSyn (StgBinding, GenStgBinding (..), StgRhs, GenStgRhs (..),
-               StgArg, GenStgArg (..),
-               StgAlt, GenStgAlt (..),
-               StgExpr, GenStgExpr (..),
-               UpdateFlag (..))
-import qualified Language.Haskell.GHC.Simple as GHC
-
-import Compiler.Mu.Kappa
-
-
--------------------------------------------------- * Main entry points
-
--- | The top-level transformation that transforms STG intermediate results to
--- Kappa representation.
---
-stgToKappa :: ModMetadata -> ([TyCon], [StgBinding]) -> Bundle
-stgToKappa modData (tyCons, bindings)
-    = runKappa emptyBundle $ do
-        mapM_ codegenTop bindings
-        -- mapM_ codegenTopTypes tyCons
-        -- codegenModInfo modData
-
-
--- | Transform a top-level STG binding to Kappa code
-codegenTop :: StgBinding -> Kappa ()
-codegenTop binding = case binding of
-    StgNonRec bindId rhs -> cgTop (nameOf bindId) rhs
-    StgRec pairs -> unzipWith (cgTop . nameOf) pairs
-      where
-        unzipWith f = mapM_ (uncurry f)
-
-
--- | Generate code for an STG top-level binding
-cgTop :: Name -> StgRhs -> Kappa ()
-cgTop name rhs = case rhs of
-    StgRhsCon _cc con args ->
-        emitTop name (TypeTop name (length args) con)
-    StgRhsClosure _cc _bindinfo _nonfrees _updateFlag _srt vars body ->
-        emitClosureTop name (Name "some_type_name") (length vars)
-            $ cgClosureBody (fmap nameOf vars) body
-
-
-cgClosureBody :: [Name] -> StgExpr -> ProcM Procedure
-cgClosureBody args body = cgExpr body >>= entryProc args
-
-
-entryProc :: [Name] -> Expression -> ProcM Procedure
-entryProc args code = return $ Procedure (Name "entry") args code
-
-
--- | Generate code for an StgExpr, the top-level of the STG syntax tree.
-cgExpr :: StgExpr -> ProcM Expression
-cgExpr expr = case expr of
-
-    StgCase scrut _live _live2 bndr _srt altType alts ->
-        cgCase scrut bndr altType alts
-
-    StgApp fn args -> cgApp fn args
-
-    StgLetNoEscape _live _live2 binds subExpr -> do
-        otherFunction <- cgExpr subExpr
-        return $ seq otherFunction $ Literal (KByteString "let nothing escape")
-        -- _pprError "cgExpr" binds
-
-    StgLet binds subExpr -> cgExpr subExpr
-
-    StgLit lit -> return $ Literal (normalise lit)
-
-    StgConApp {} -> return $ MkClosure (Name "ConApp") (Literal $ KInt 3)
-    StgOpApp {}  -> _pprError "cgExpr.StgOpApp" expr
-    StgLam {}    -> _pprError "cgExpr.StgLam" expr
-    StgTick {}   -> _pprError "cgExpr.StgTick" expr
-
-
--- | Generate code for an `StgApp`, a function application.
-cgApp :: GHC.Id -> [StgArg] -> ProcM Expression
-cgApp fn args = do args' <- mapM argName args
-                   return $ Call (nameOf fn) args'
-  where
-    -- maybe we need to generate upvalues for the literal arguments
-    argName arg = case arg of
-                      StgVarArg argId -> return $ nameOf argId
-                      StgLitArg lit -> allocate lit
-
-
--- | Generate code for an `StgCase`, a case/pattern matching expression.
-cgCase :: StgExpr -> GHC.Id -> GHC.AltType -> [StgAlt] -> ProcM Expression
-cgCase scrut bndr altType alts = do
-    scrutCode <- cgExpr scrut
-    (defaultCode, otherCodes) <- cgAlts (nameOf bndr) altType alts
-    return $ Switch scrutCode (nameOf bndr) defaultCode otherCodes
-
-
--- | Generate code for `StgAlt` branches (following the `StgCase` expression.
-cgAlts :: Name -> GHC.AltType -> [StgAlt] -> ProcM (Maybe Expression, [(Const, Expression)])
-cgAlts bndr altType alts = case (altType, alts) of
-
-    -- polymorphic data types come with only one RHS
-    (GHC.PolyAlt, [(_, _, _, rhs)]) -> do
-        altCode <- cgExpr rhs
-        return (Just altCode, [])
-
-    -- same with unboxed tuple alts
-    (GHC.UbxTupAlt _, [(_, _, _, rhs)]) -> do
-        altCode <- cgExpr rhs
-        return (Just altCode, [])
-
-    -- for an algebraic data type, generate the code for each of the alts and
-    -- then the jump code for the constructor, if it is tagged
-    --
-    -- TODO: the way this works is by jumping on the value (tag) of the data
-    -- constructor that is being used
-    (GHC.AlgAlt con, alts)
-        | GHC.isEnumerationTyCon con -> do
-            _pprError "Enumerated TyCon?" con
-
-        | otherwise -> do
-            altCodes <- mapM genAltCode alts
-
-            let familySize = GHC.tyConFamilySize con
-
-            let defaultCode = case altCodes of
-                    (GHC.DEFAULT, rhs):_ -> Just rhs
-                    _                    -> Nothing
-
-                realAlts = [(KInt 3, altCode) {- TODO: fix -} | (GHC.DataAlt _, altCode) <- altCodes]
-
-            
-
-            return (defaultCode, realAlts)
-
-    -- Primitive cases are easier, and they always have a default case too
-    (GHC.PrimAlt con, alts) -> do
-        altCodes <- mapM genAltCode alts
-
-        let defaultCode = case altCodes of
-                -- just to be careful
-                (GHC.DEFAULT, rhs):_ -> Just rhs
-                _                    -> Nothing
-
-            realAlts = [ (normalise lit, altCode)
-                       | (GHC.LitAlt lit, altCode) <- altCodes]
-
-        return (defaultCode, realAlts)
-
-    _ -> undefined
-
-  where
-
-    genAltCode :: StgAlt -> ProcM (GHC.AltCon, Expression)
-    genAltCode (con, bndrs, _, rhs) = seq (pprTraceIt "params" (con, bndrs)) $ do
-        expr <- cgExpr rhs >>= bindConArgs con bndrs
-        return (con, expr)
-
-    bindConArgs :: GHC.AltCon -> [GHC.Id] -> Expression -> ProcM Expression
-    bindConArgs con bndrs subExpr = return $ Bind (Name "binding") 13371337 bndr subExpr
-
-
-_pprError :: Outputable a => String -> a -> b
-_pprError msg val = seq (pprTraceIt msg val) undefined

src/Compiler/Mu/Monad.hs

+-- |
+-- Module      :  Compiler.Mu.Monad
+-- Copyright   :  nathyong 2016
+-- License     :  BSD3
+--
+-- Maintainer  :  nathyong@gmail.com
+-- Stability   :  experimental
+-- Portability :  unknown
+--
+-- Monad for interfacing with Mu
+--
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Compiler.Mu.Monad (
+      -- * Monad
+      Mu
+    , buildMu
+    , runMu
+      -- * Interface
+    , flatten
+) where
+
+import Control.Monad.Except (MonadError, ExceptT, runExceptT)
+import Control.Monad.State (State, MonadState, evalState, get)
+
+import Lens.Micro.Platform (assign, modifying, makeLenses)
+
+import Mu.PrettyPrint (PrettyPrint (..))
+import Mu.Syntax
+import Mu.Builder hiding (flatten)
+import qualified Mu.Builder
+
+
+-------------------------------------------------- * Data structures
+
+data MuState = MuState
+    { _builderState :: BuilderState
+    , _currentBlock :: ()
+    }
+
+makeLenses ''MuState
+
+emptyMuState :: MuState
+emptyMuState = MuState emptyBuilderState ()
+
+-------------------------------------------------- * Monad
+
+newtype Mu a = Mu (ExceptT MuException (State MuState) a)
+    deriving (Functor, Applicative, Monad, MonadState MuState, MonadError MuException)
+
+instance PrettyPrint MuState where
+    ppFormat = ppFormat . flatten
+
+instance MuBuilder Mu where
+    getBuilderState = get >>= return . _builderState
+    putBuilderState = assign builderState
+    getsBuilderState f = get >>= return . f . _builderState
+    modifyBuilderState = modifying builderState
+
+buildMu :: Mu a -> Either MuException Program
+buildMu mu = case runMu (mu >> get) of
+    Left x -> Left x
+    Right ms -> Right (flatten ms)
+
+runMu :: Mu a -> Either MuException a
+runMu (Mu code) = evalState (runExceptT code) emptyMuState
+
+-------------------------------------------------- * Utility functions
+
+-- | Transform a BuilderState into a Program
+flatten :: MuState -> Program
+flatten (MuState bs _) = Mu.Builder.flatten bs

src/Compiler/Mu/PprMu.hs

-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE GADTs #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Compiler.Mu.PprMu
-  ( showMu
-  ) where
-
-import Data.Foldable (foldl')
-
-import Compiler.Mu.Types
-import Numeric (fromRat)
-import OrdList
-import Outputable
-
-showMu :: MuBundle -> String
-showMu = showSDocUnsafe . ppr
-
-instance Outputable MuBundle where
-    ppr (MuBundle groups) = vcat2 groups
-
-instance Outputable MuGroup where
-    ppr = pprMuGroup
-
-instance Outputable MuClosure where
-    ppr = pprMuClosure
-
-instance Outputable MuBlock where
-    ppr = pprMuBlock
-
-instance Outputable (MuNode e x) where
-    ppr = pprMuNode
-
-instance Outputable MuLit where
-    ppr = pprMuLit
-
-pprMuGroup :: MuGroup -> SDoc
-pprMuClosure :: MuClosure -> SDoc
-pprMuBlock :: MuBlock -> SDoc
-pprMuNode :: MuNode e x -> SDoc
-pprMuLit :: MuLit -> SDoc
-pprMuGroup group = hang' header 4 (decls $+$ codes) $+$ empty
-  where
-    header = ppr (mgLabel group) <> "_closure:"
-    decls = name $+$ args
-    name = "entry:" <+> ppr (entryFunction group)
-    args
-        | null (entryArgs group) = empty
-        | otherwise = hang' "args:" 4 $ vcat2 (entryArgs group)
-    codes
-        | null (mgClosures group) = empty
-        | otherwise = hang' "codes:" 4 $ vcat2 (mgClosures group)
-
-pprMuClosure closure = hang' header 4 body
-  where
-    header = ppr (closureName closure) <> ":"
-    body = vcat2 (closureFunction closure)
-
-pprMuBlock block = hang' header 4 body
-  where
-    header = ppr (blockId block) <> ":"
-    body = vcat2 (blockCode block) $+$ ppr (blockTerminator block)
-
-pprMuNode node =
-    case node of
-        MuComment fs -> "//" <+> ppr fs
-
-pprMuLit lit =
-    case lit of
-        MuInt i w ->
-            (if i < 0
-                 then parens
-                 else id) $
-            integer i <> dcolon <> "W" <> int w
-        MuFloat r -> double $ fromRat r
-        MuDouble r -> double $ fromRat r
-        MuLabel l -> ppr l
-        MuLabelOff l off -> ppr l <> pprOffset off
-        MuVector lits -> brackets (hsep . fmap ppr $ lits)
-        MuByteString bs -> pprHsBytes bs
-
-pprOffset :: Int -> SDoc
-pprOffset i
-    | i == 0 = empty
-    | i >= 0 = char '+' <> int i
-    | otherwise = char '-' <> int (-i)
-
--- | Convenience function as vcat for 'OrdList's
-vcatOL :: Outputable a => OrdList a -> SDoc
-vcatOL list
-    | isNilOL list = "[]"
-    | otherwise = showIt list
-  where
-    showIt = foldl' ($+$) empty . fromOL . fmap (("-" <+>) . ppr)
-
-vcat2 :: Outputable a => [a] -> SDoc
-vcat2 list
-    | null list = "[]"
-    | otherwise = showIt list
-  where
-    showIt = foldl' ($+$) empty . fmap (("-" <+>) . ppr)
-
-hang' :: SDoc -> Int -> SDoc -> SDoc
-hang' d1 n d2 = d1 $+$ nest n d2

src/Compiler/Mu/Util.hs

-
--- Miscellaneous functions for transformation of Mu code.

stack.yaml

 # This file was automatically generated by 'stack init'
 # 
-# Some commonly used options have been documented as comments in this file.
-# For advanced use and comprehensive documentation of the format, please see:
-# http://docs.haskellstack.org/en/stable/yaml_configuration/
-
-# Resolver to choose a 'specific' stackage snapshot or a compiler version.
-# A snapshot resolver dictates the compiler version and the set of packages
-# to be used for project dependencies. For example:
-# 
-# resolver: lts-3.5
-# resolver: nightly-2015-09-21
-# resolver: ghc-7.10.2
-# resolver: ghcjs-0.1.0_ghc-7.10.2
-# resolver:
-#  name: custom-snapshot
-#  location: "./custom-snapshot.yaml"
 resolver: nightly-2016-08-05
 
-# User packages to be built.
-# Various formats can be used as shown in the example below.
-# 
-# packages:
-# - some-directory
-# - https://example.com/foo/bar/baz-0.0.2.tar.gz
-# - location:
-#    git: https://github.com/commercialhaskell/stack.git
-#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-#   extra-dep: true
-#  subdirs:
-#  - auto-update
-#  - wai
-# 
-# A package marked 'extra-dep: true' will only be built if demanded by a
-# non-dependency (i.e. a user package), and its test suites and benchmarks
-# will not be run. This is useful for tweaking upstream packages.
 packages:
   - '.'
-  - '../hs-mu'
+  - '../haskell_libraries/mu'
+  - '../haskell_libraries/mu-pure'
 
-# Dependency packages to be pulled from upstream that are not in the resolver
-# (e.g., acme-missiles-0.3)
-extra-deps: ["ghc-simple-0.4"]
+extra-deps:
+  - 'ghc-simple-0.4'
+  - 'c-storable-deriving-0.1.3'
 
-# Override default flag values for local packages and extra-deps
 flags: {}
 
-# Extra package databases containing global packages
 extra-package-dbs: []
 
-# Control whether we use the GHC we find on the path
-# system-ghc: true
-# 
-# Require a specific version of stack, using version ranges
 # require-stack-version: -any # Default
-# require-stack-version: ">=1.1"
-# 
-# Override the architecture used by stack, especially useful on Windows
+
 # arch: i386
 # arch: x86_64
-# 
-# Extra directories used by stack for building
+#
 # extra-include-dirs: [/path/to/dir]
-# extra-lib-dirs: [/path/to/dir]
-# 
-# Allow a newer minor version of GHC than the snapshot specifies
+#
+extra-lib-dirs:
+  - '/Users/nathan/projects/microvm/haskell_libraries/mu-impl-ref2/cbinding/'
+
 # compiler-check: newer-minor