Initial commit (with old MuCodeGen source)

.gitignore

+dist
+dist-*
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+.stack-work/
+cabal.project.local

LICENSE

+Copyright Author name here (c) 2016
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
\ No newline at end of file

Setup.hs

+import Distribution.Simple
+main = defaultMain

anuhc.cabal

+name:                anuhc
+version:             0.1.0.0
+synopsis:            ANU Haskell Compiler
+description:         Please see README.md
+homepage:            https://github.com/githubuser/anuhc#readme
+license:             BSD3
+license-file:        LICENSE
+author:              Author name here
+maintainer:          example@example.com
+copyright:           2016 Author name here
+category:            Web
+build-type:          Simple
+-- extra-source-files:
+cabal-version:       >=1.10
+
+library
+  hs-source-dirs:      src
+  exposed-modules:     Lib
+  build-depends:       base >= 4.7 && < 5
+  default-language:    Haskell2010
+
+executable anuhc-exe
+  hs-source-dirs:      app
+  main-is:             Main.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , ghc
+                     , ghc-paths
+                     , ghc-simple
+                     , anuhc
+  default-language:    Haskell2010
+
+test-suite anuhc-test
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             Spec.hs
+  build-depends:       base
+                     , ghc
+                     , ghc-paths
+                     , ghc-simple
+                     , anuhc
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  default-language:    Haskell2010
+
+source-repository head
+  type:     git
+  location: https://github.com/githubuser/anuhc

app/Main.hs

+module Main where
+
+import Control.Monad.IO.Class (liftIO)
+
+import Language.Haskell.GHC.Simple
+
+targetFile = "B.hs"
+
+main :: IO ()
+main = do getDynFlagsForConfig defaultConfig
+          mod <- compile stgToMu [targetFile]
+          case mod of
+              Success results _ _ -> let printModule (CompiledModule txt _ _) = putStrLn txt
+                                      in mapM_ printModule results
+              Failure _ _ -> putStrLn "Noooo"
+
+
+stgToMu :: ModMetadata -> [StgBinding] -> IO String
+stgToMu _ _ = return "Hello, world!"
+
+
+-- example = defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
+--     runGhc (Just libdir) $ do
+--         dflags <- getSessionDynFlags
+--         -- let dflags' = foldl xopt_set dflags
+--         --                     [Opt_Cpp, Opt_ImplicitPrelude, Opt_MagicHash]
+--         setSessionDynFlags dflags
+--         target <- guessTarget targetFile Nothing
+--         setTargets [target]
+--         load LoadAllTargets
+--         modSum <- getModSummary $ mkModuleName "B"
+--         p <- parseModule modSum
+--         t <- typecheckModule p
+--         d <- desugarModule t
+--         l <- loadModule d
+--         n <- getNamesInScope
+--         let core_modguts = coreModule d
+--         stg <- liftIO $ myCoreToStg dflags modSum core_modguts
+--         return stg
+-- --  
+-- --         g <- getModuleGraph
+-- --         mapM showModule g     
+-- --         return $ (parsedSource d,"/n-----/n",  typecheckedSource d)
+-- 
+-- 
+-- myCoreToStg :: DynFlags -> ModSummary -> ModGuts -> IO ([StgBinding], CollectedCCs)
+-- myCoreToStg dflags guts summary = do
+--     env <- gg
+--     liftIO $ do
+--         stg_binds <- coreToStg dflags this_mod prepd_binds
+--         return $ stg2stg dflags this_mod stg_binds
+-- 
+-- -- myCoreToStg :: DynFlags -> Module -> CoreProgram
+-- --             -> IO ( [StgBinding] -- output program
+-- --                   , CollectedCCs) -- cost centre info (declared and used)
+-- -- myCoreToStg dflags this_mod prepd_binds = do
+-- --     stg_binds
+-- --          <- {-# SCC "Core2Stg" #-}
+-- --            coreToStg dflags this_mod prepd_binds
+-- -- 
+-- --     (stg_binds2, cost_centre_info)
+-- --         <- {-# SCC "Stg2Stg" #-}
+-- --            stg2stg dflags this_mod stg_binds
+-- -- 
+-- --     return (stg_binds2, cost_centre_info)

src/Lib.hs

+module Lib
+    ( someFunc
+    ) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"

src/MuCodeGen.hs

+-- |
+-- Module      :  MuCodeGen
+-- Copyright   :  nathyong 2016
+--
+-- Maintainer  :  nathan.yong@anu.edu.au
+-- Stability   :  experimental
+-- Portability :  unknown
+--
+-- Code generation facilities for the Mu Micro Virtual Machine
+--
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+
+module MuCodeGen (
+    muCodeGen
+) where
+
+import StgSyn
+
+import Util (unzipWith)
+import BasicTypes (RecFlag (..))
+import DynFlags
+import OrdList
+import OccName
+import FastString
+import Literal
+import Outputable (pprTraceIt)
+
+import CmmExpr
+import HscTypes
+import CostCentre
+import Id
+import IdInfo
+import Type
+import DataCon
+import Name
+import TyCon
+import Module
+import PrelInfo (maybeIntLikeCon, maybeCharLikeCon)
+
+import MuCodeGen.Types
+
+import Data.Char (ord)
+import Control.Monad (when, void, ap)
+import Control.Monad.Trans.Writer.Strict
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+
+
+--------------------------------------------------------------------------------
+
+muCodeGen :: HscEnv
+          -> Module
+          -> [TyCon]
+          -> CollectedCCs
+          -> [StgBinding]
+          -> HpcInfo
+          -> IO MuBundle
+muCodeGen hsc_env this_mod type_constructors _cost_centre_info stg_binds _hpc_info
+    = return $ execWriter output
+  where
+    output = muCodeGen' dflags this_mod type_constructors stg_binds
+    dflags = hsc_dflags hsc_env
+
+
+muCodeGen' :: DynFlags -> Module -> [TyCon] -> [StgBinding] -> Writer MuBundle ()
+muCodeGen' dflags _this_mod _type_constructors stg_binds = do
+    let cg :: MuCode () -> Writer MuBundle ()
+        cg muCode = tell $ evalMuCode (muCode >> extractBundle) (initialMuState dflags)
+
+    seq (pprTraceIt "MuCodeGen STG" stg_binds) (return ())
+    mapM_ (cg . muBindings) stg_binds
+
+    -- let do_tycon tycon = do
+    --         mapM_ (cg . genDataConstructor) (tyConDataCons tycon)
+    -- mapM_ do_tycon type_constructors
+    -- add information about the module
+    -- cg $ genModuleInfo this_mod
+
+
+muBindings :: StgBinding -> MuCode ()
+muBindings stg = case stg of
+    StgNonRec id rhs -> do
+        let (binder, code) = muTopBinding NonRecursive id rhs
+        muBind binder
+        code
+    StgRec pairs -> do
+        let (binders, codes) = unzip $ unzipWith (muTopBinding Recursive) pairs
+        mapM_ muBind binders
+        sequence_ codes
+
+
+muTopBinding :: RecFlag -> Id -> StgRhs -> (MuBindInfo, MuCode ())
+muTopBinding rec bndr rhs = case rhs of
+    StgRhsCon _cc con arg -> muCgTopRhsCon con bndr arg
+    StgRhsClosure _cc _bindinfo _nonfrees updateflag vars body ->
+        (MuBindInfo bndr, return ())
+
+
+-- genBinding :: RecFlag -> Id -> StgRhs -> MuCode ()
+-- genBinding rec bndr rhs = do
+--     muBind bndr
+--     case rhs of
+--         StgRhsCon _cc con arg ->
+--             genConstructor con arg
+--         StgRhsClosure _cc _bindinfo _nonfrees updateflag vars body ->
+--             genClosure rec updateflag vars body
+--     muBlockToFunction bndr
+
+
+muCgTopRhsCon :: DataCon -> Id -> [StgArg] -> (MuBindInfo, MuCode ())
+muCgTopRhsCon con bndr args = (info, code)
+  where
+    info = MuBindInfo bndr
+    get_lit arg = seq (pprTraceIt "muCgTopRhsCon" bndr) $ case arg of
+                    StgVarArg var -> MuLabel var
+                    StgLitArg lit -> muCgLit lit
+    code = do let payload = map get_lit args
+              emitGroup bndr [] (dataConWrapId con) payload
+
+
+muCgLit :: Literal -> MuLit
+muCgLit lit = case lit of
+                MachInt i    -> MuInt i 64
+                MachInt64 i  -> MuInt i 64
+                MachWord i   -> MuInt i 64
+                MachWord64 i -> MuInt i 64
+                MachFloat r  -> MuFloat r
+                MachDouble r -> MuDouble r
+                -- MachStr s    -> MuVector 
+                _            -> seq (pprTraceIt "muCgLit" lit) $ error "Not implemented"
+
+
+
+-- muCgTopRhsCon :: DataCon -> [StgArg] -> (MuBindInfo, MuCode ())
+-- muCgTopRhsCon con args = case args of
+--     [] -> return ()  -- generate no code at all!
+--     [StgLitArg (MachInt val)]
+--         | maybeIntLikeCon con -> do
+--             -- TODO: add more checks
+--             muEmitTop $ ConstructorHeader (dataConName con)
+--             muEmitTop $ LiteralInt (fromIntegral val)
+--     [StgLitArg (MachChar val)]
+--         | maybeCharLikeCon con -> do
+--             -- TODO: add more checks
+--             muEmitTop $ ConstructorHeader (dataConName con)
+--             muEmitTop $ LiteralChar (fromIntegral (ord val))
+--     _ -> void $ muEmitBlock $ toOL [MuStmt $ MuComment "StgRhsCon binding"]
+
+
+-- -- | Generate the function body for a closure
+-- genClosure :: RecFlag -> UpdateFlag -> [Id] -> StgExpr -> MuCode ()
+-- genClosure _rec _updateflag vars body = do
+--     -- need to emit a closure header somewhere
+--     mucgExpr body
+
+
+-- mucgExpr :: StgExpr -> MuCode ()
+-- mucgExpr body = void $ case body of
+--     StgApp fun args -> do
+--         _ <- muEmitBlock $ toOL [MuStmt (MuComment "StgApp")]
+--         _ <- muEmitBlock $ toOL [MuStmt (MuFunCall fun args)]
+--         return ""
+--     StgLit {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgLit")]
+--     StgConApp con args -> muEmitBlock $ toOL [MuStmt (MuComment "StgConApp")]
+--     StgOpApp {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgOpApp")]
+--     StgLam {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgLam")]
+--     StgCase scrut bndr alt_type alts -> do
+--         mucgCase scrut bndr alt_type alts
+--         return ""
+--     StgLet {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgLet")]
+--     StgLetNoEscape {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgLetNoEscape")]
+--     StgTick {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgTick")]
+-- 
+-- 
+-- mucgCase :: StgExpr -> Id -> AltType -> [StgAlt] -> MuCode ()
+-- mucgCase scrut bndr alt_type alts = do
+--     muEmitBlock' [scrut] $ toOL [MuStmt (MuComment "StgCase")]
+--     seq (pprTraceIt "some case" scrut) $ return ()
+--     seq (pprTraceIt "bind it to" bndr) $ return ()
+--     seq (pprTraceIt "some results" alts) $ return ()
+-- 
+--     -- force scrut
+--     -- bind it to bndr
+--     -- generate alts
+-- 
+--     -- scrutinise: evaluate @scrut@ and bind it to @bndr@
+--     -- case-jump: branch on the value of the @bndr@
+-- 
+--     -- evaluate scrut and bind it sowhere
+--     _ <- muEvalAndBind scrut bndr
+--     mucgAlts bndr alt_type alts
+--     return ()
+--   where
+--     muEvalAndBind scrut bndr = do
+--         mucgExpr scrut
+--         muEmitBlock $ toOL [MuStmt (MuComment "bind the thing somewhere")]
+-- 
+--     mucgAlts bndr alt_type alts = void $ case alt_type of
+--         PolyAlt -> muEmitBlock $ toOL [MuStmt (MuComment "PolyAlt")]
+--         UbxTupAlt _ -> muEmitBlock $ toOL [MuStmt (MuComment "UbxAlt")]
+--         PrimAlt _ -> muEmitBlock $ toOL [MuStmt (MuComment "PrimAlt")]
+--         AlgAlt tycon -> muEmitBlock $ toOL [MuStmt (MuComment "AlgAlt")]
+-- 
+-- 
+-- -- Generate the entry code, info tables, and (for niladic constructor)
+-- -- the static closure, for a constructor.
+-- genDataConstructor :: DataCon -> MuCode ()
+-- genDataConstructor _datacon = void $ muEmitBlock $ toOL [MuStmt (MuComment "Inside the data constructor now")]
+-- 
+-- 
+-- genTypeConstructors :: TyCon -> MuCode ()
+-- genTypeConstructors _tycon = do
+--     void $ muEmitBlock $ toOL [MuStmt $ MuComment "Type constructor"]
+-- 
+-- 
+-- genModuleInfo :: Module -> MuCode ()
+-- genModuleInfo mod = do
+--     muEmitTop (ModuleDecl name)
+--   where
+--     name = moduleNameFS $ moduleName mod

src/MuCodeGen/CodeGenerator.hs

+-- |
+-- Module      :  MuCode.CodeGenerator
+-- Copyright   :  nathyong 2016
+--
+-- Maintainer  :  nathyong@gmail.com
+-- Stability   :  experimental
+-- Portability :  unknown
+--
+-- Code generator monad from Mu Intermediate Representation.
+--
+-- Uses a "final tagless" DSL for code generation that maps to either a testing
+-- semantics built on top of some pure monad, or the real code generation
+-- semantics that is used for the compilation process.
+--
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module MuCodeGen.CodeGenerator (
+) where

src/MuCodeGen/PprMu.hs

+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+module MuCodeGen.PprMu () where
+
+import Data.Foldable (foldl')
+
+import Compiler.Hoopl
+import DynFlags
+import FastString
+import Id
+import MuCodeGen.Types
+import Name
+import Numeric ( fromRat )
+import OrdList
+import Outputable
+import StgSyn
+import UniqSupply
+
+
+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 = hang' "declarations:" 4 $ (ppr $ entryFunction group) $+$ (vcat2 $ entryArgs group)
+    codes = 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 (blockName 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 <> int w
+                 MuFloat r -> double $ fromRat r
+                 MuDouble r -> double $ fromRat r
+                 MuLabel l -> ppr l
+                 MuLabelOff l off -> ppr l <> ppr_offset off
+
+ppr_offset :: Int -> SDoc
+ppr_offset 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/MuCodeGen/Types.hs

+-- |
+-- Module      :  MuCodeGen.Types
+-- Copyright   :  nathyong 2016
+-- License     :  BSD3
+--
+-- Maintainer  :  nathyong@gmail.com
+-- Stability   :  experimental
+-- Portability :  unknown
+--
+-- Type structure for an intermediate representation of Mu Code
+--
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+
+module MuCodeGen.Types where
+
+import Control.Monad (ap, liftM)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.ByteString (ByteString)
+import Data.Foldable (foldl')
+import Data.Word
+import Data.Int
+
+import Compiler.Hoopl
+import DynFlags
+import FastString
+import Id
+import Name
+import OrdList
+import PprCmmExpr ()
+import StgSyn
+import UniqSupply
+
+-- Mu data structures ------------------------------------------------------ {{{
+
+-- | The Mu Program itself, which is expressed as a list of 'MuGroup's.
+newtype MuBundle = MuBundle [MuGroup] deriving Monoid
+
+
+-- | The MuCode monad, for constructing a single MuGroup (analogous to
+-- 'Cmm.CmmGroup').  This could be a function, or a literal.
+newtype MuCode a = MuCode (MuState -> (# a, MuState #))
+
+-- | State for the 'MuCode' monad.
+data MuState = MuState
+    { -- used for generating the current function
+      msBlocks            :: [MuBlock]
+    , msBindings          :: MuBindings
+
+      -- used for storing the rest of the module
+    , msGroups            :: [MuGroup]
+    , msDynFlags          :: DynFlags
+    }
+
+instance Functor MuCode where
+    fmap f (MuCode code) = MuCode $ \s -> case code s of
+        (# a, s' #) -> (# f a, s' #)
+
+instance Applicative MuCode where
+    pure a = MuCode $ \s -> (# a, s #)
+    (<*>) = ap
+
+instance Monad MuCode where
+    return = pure
+    (MuCode code) >>= f = MuCode $ \s -> case code s of
+        (# a, s' #) -> case f a of
+            MuCode code' -> code' s'
+
+instance HasDynFlags MuCode where
+    getDynFlags = getMuState >>= return . msDynFlags
+
+
+type MuBindings = Map Id MuBindInfo
+
+-- | Information of bindings
+data MuBindInfo = MuBindInfo
+    { bindingId :: Id
+    }
+
+
+-- | A single MuGroup (analogous to 'Cmm.CmmGroup').
+data MuGroup = MuGroup
+    { mgLabel :: Id
+    , mgClosures :: [MuClosure]
+    , entryFunction :: Id
+    , entryArgs :: [MuLit]
+    }
+
+
+-- | A closure of data and function
+data MuClosure = MuClosure
+    { closureName :: Id
+    , closureFunction :: [MuBlock]
+    }
+
+
+-- | A Mu Basic Block
+data MuBlock = MuBlock
+    { blockArgs :: ()
+    , blockName :: Id
+    , blockCode :: [MuStmt]
+    , blockTerminator :: MuLastStmt
+    }
+
+-- | Possible Mu node entries
+data MuNode e x where
+    MuComment :: FastString -> MuNode O O
+
+type MuStmt = MuNode O O
+type MuLastStmt = MuNode O C
+
+
+data MuLit = MuInt !Integer Int
+           | MuFloat !Rational