Intercepted STG code from GHC's pipeline

.gitignore

@@ -0,0 +1 @@
+TAGS

LICENSE

@@ -0,0 +1,30 @@
+Copyright Rahul Muttineni (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 Rahul Muttineni 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.

README.md

@@ -0,0 +1,43 @@
+# GHCVM - A JVM backend for GHC
+
+This project aims to compile Haskell to the JVM, with the primary goal of seamless compatibility with GHC's Haskell.
+
+# Goals 
+
+We aim to meet the following goals:
+
+- Easy interop with Java libraries
+- High performance lazy functional language implementation
+- Seamless integration with Java IDEs
+  - IntelliJ
+  - Eclipse
+  - Android Studio
+- Optimize for specific JVM implementations
+  - OpenJDK HotSpot
+  - Dalvik VM (for Android compatibility, a lightweight runtime)
+- Support hot code reloading 
+- Re-use GHC's infrastructure
+  - Keep up with their release cycle
+  - CLI should match that of ghc's to mak
+
+# Progress
+
+## Completed Items
+- Came up with an efficient design for a JVM Runtime System for Haskell that:
+  - Has full support of Tail Call Optimization (TCO)
+  - Has a memory-efficient solution to overriding a thunk with its value
+  - Can interoperate with Java seamlessly
+- Intercepted the STG Code in GHC pipeline
+
+## Pending Items
+1. Write the minimum code generator and run time system implementing the design. 
+2. Compile a single source file to run on the JVM.
+3. ...
+
+# Contributing
+
+As you can see, this project is a large undertaking. If you would love to run your Haskell programs on the JVM, get in touch and we'll see how we can fit you in.
+
+# Gratitude
+
+We are grateful that the folks at GHC HQ have graciously open-sourced their state-of-the-art Haskell compiler allowing us to hack on it to implement Haskell on a wide variety of platforms. Thank you guys!

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

compiler/GHCVM/DriverPipeline.hs

@@ -0,0 +1,149 @@
+module GHCVM.DriverPipeline (runGhcVMPhase) where
+
+import Module
+import DynFlags
+import DriverPipeline
+import DriverPhases
+import HscTypes
+import CoreSyn (CoreProgram)
+import StgSyn (StgBinding, pprStgBindings)
+import CostCentre (CollectedCCs)
+import SimplStg         ( stg2stg )
+import CoreToStg        ( coreToStg )
+import CorePrep         ( corePrepPgm )
+import Maybes (expectJust)
+import Panic
+import MonadUtils ( liftIO )
+import SysTools
+import ErrUtils
+import Outputable
+
+import System.Directory
+import System.FilePath
+import TyCon ( isDataTyCon )
+
+runGhcVMPhase :: PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)
+runGhcVMPhase realphase@(RealPhase (Unlit _)) = runPhase realphase
+runGhcVMPhase realphase@(RealPhase (Cpp _)) = runPhase realphase
+runGhcVMPhase realphase@(RealPhase (HsPp _)) = runPhase realphase
+runGhcVMPhase realphase@(RealPhase (DriverPhases.Hsc _)) = \fn dflags -> do
+  liftIO $ putStrLn "In Hsc phase"
+  runPhase realphase fn dflags
+runGhcVMPhase realphase@(HscOut src_flavour mod_name result) = \_ dflags -> do
+  location <- getLocation src_flavour mod_name
+  setModLocation location
+
+  let o_file = ml_obj_file location -- The real object file
+      hsc_lang = hscTarget dflags
+      next_phase = StopLn
+
+  liftIO $ print location
+  liftIO $ print o_file
+  liftIO . putStrLn $ "next_phase: " ++ show next_phase
+
+  case result of
+    HscNotGeneratingCode -> do
+      liftIO . putStrLn $ "HscNotGeneratingCode"
+      return (RealPhase next_phase,
+              panic "No output filename from Hsc when no-code")
+    HscUpToDate -> do
+          liftIO . putStrLn $ "HscUpToDate"
+          liftIO $ touchObjectFile dflags o_file
+          -- The .o file must have a later modification date
+          -- than the source file (else we wouldn't get Nothing)
+          -- but we touch it anyway, to keep 'make' happy (we think).
+          return (RealPhase StopLn, o_file)
+    HscUpdateBoot ->
+      do -- In the case of hs-boot files, generate a dummy .o-boot
+          -- stamp file for the benefit of Make
+          liftIO . putStrLn $ "HscUpdateBoot"
+          liftIO $ touchObjectFile dflags o_file
+          return (RealPhase next_phase, o_file)
+    HscUpdateSig ->
+      do -- We need to create a REAL but empty .o file
+          -- because we are going to attempt to put it in a library
+          liftIO . putStrLn $ "HscUpdateSig"
+          PipeState{hsc_env=hsc_env'} <- getPipeState
+          let input_fn = expectJust "runPhase" (ml_hs_file location)
+              basename = dropExtension input_fn
+          liftIO $ compileEmptyStub dflags hsc_env' basename location
+          return (RealPhase next_phase, o_file)
+    HscRecomp cgguts mod_summary ->
+      do output_fn <- phaseOutputFilename next_phase
+         liftIO . putStrLn $ "HscRecomp"
+
+         PipeState{hsc_env=hsc_env'} <- getPipeState
+
+         outputFilename <- liftIO $ genStg hsc_env' cgguts mod_summary output_fn
+         liftIO $ putStrLn $ "Finished in pipeline STG"
+
+         return (RealPhase next_phase, outputFilename)
+
+runGhcVMPhase realphase@(RealPhase other) = \_ dflags -> panic $ "runGhcVMPhase: invalid phase " ++ show other
+
+
+genStg :: HscEnv -> CgGuts -> ModSummary -> FilePath -> IO FilePath
+genStg hsc_env cgguts mod_summary output_filename = do
+  let CgGuts{ -- This is the last use of the ModGuts in a compilation.
+              -- From now on, we just use the bits we need.
+              cg_module   = this_mod,
+              cg_binds    = core_binds,
+              cg_tycons   = tycons,
+              cg_foreign  = foreign_stubs0,
+              cg_dep_pkgs = dependencies,
+              cg_hpc_info = hpc_info } = cgguts
+      dflags = hsc_dflags hsc_env
+      location = ms_location mod_summary
+      data_tycons = filter isDataTyCon tycons
+      -- cg_tycons includes newtypes, for the benefit of External Core,
+      -- but we don't generate any code for newtypes
+
+  -------------------
+  -- PREPARE FOR CODE GENERATION
+  -- Do saturation and convert to A-normal form
+  prepd_binds <- {-# SCC "CorePrep" #-}
+                  corePrepPgm hsc_env location core_binds data_tycons ;
+  -----------------  Convert to STG ------------------
+  (stg_binds, cost_centre_info)
+      <- {-# SCC "CoreToStg" #-}
+          myCoreToStg dflags this_mod prepd_binds
+  dumpStg dflags $ pprStgBindings stg_binds
+  -- This is the point in which we need to plug in the new runtime system
+  return "Test.dump-stg"
+
+dumpStg :: DynFlags -> SDoc -> IO ()
+dumpStg dflags = dumpSDoc dflags alwaysQualify Opt_D_dump_stg "STG Syntax:"
+
+touchObjectFile :: DynFlags -> FilePath -> IO ()
+touchObjectFile dflags path = do
+  createDirectoryIfMissing True $ takeDirectory path
+  SysTools.touch dflags "Touching object file" path
+
+compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> IO ()
+compileEmptyStub dflags hsc_env basename location = do
+  -- To maintain the invariant that every Haskell file
+  -- compiles to object code, we make an empty (but
+  -- valid) stub object file for signatures
+  empty_stub <- newTempName dflags "c"
+  writeFile empty_stub ""
+  {- _ <- runPipeline StopLn hsc_env
+                  (empty_stub, Nothing)
+                  (Just basename)
+                  Persistent
+                  (Just location)
+                  Nothing -}
+  return ()
+
+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)
+

ghcvm.cabal

@@ -0,0 +1,44 @@
+name:                ghcvm
+version:             0.0.0.1
+description:         Haskell to JVM compiler
+license:             BSD3
+license-file:        LICENSE
+author:              Rahul Muttineni
+maintainer:          Rahul Muttineni <rahulmutt@gmail.com>
+copyright:           Rahul Muttineni 2016
+stability:           Experimental
+build-type:          Simple
+cabal-version:       >=1.10
+
+source-repository head
+    type: git
+    location: https://github.com/rahulmutt/ghcvm.git
+
+library
+    default-language:    Haskell2010
+    exposed-modules:     GHCVM.DriverPipeline
+    build-depends:       base >= 4.7 && < 5
+                       , ghc >= 7.10.3 && < 7.11.0
+                       , directory >= 1.2
+                       , filepath
+    hs-source-dirs:      compiler
+    exposed:             True
+    buildable:           True
+
+executable ghcvm
+  hs-source-dirs:      ghcvm
+  main-is:             Main.hs
+  default-language:    Haskell2010
+  build-depends:       array
+                     , base >= 4.7 && < 5
+                     , bytestring
+                     , deepseq
+                     , directory
+                     , filepath
+                     , ghc >= 7.10.3 && < 7.11.0
+                     , ghc-paths == 0.1.0.9
+                     , haskeline
+                     , process
+                     , transformers
+                     , unix
+                     , ghcvm

ghcvm/GhcVM.h

@@ -0,0 +1,11 @@
+#ifndef GHCVM_H
+#define GHCVM_H
+
+#define GLOBAL_VAR(name,value,ty)               \
+  {-# NOINLINE name #-};                        \
+  name :: IORef (ty);                           \
+  name = Util.global (value);
+
+#define ASSERT(e)      if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else
+
+#endif /* GhcVM.h */