mirror of
https://github.com/grin-compiler/grin.git
synced 2024-09-11 15:37:54 +03:00
start work on GHC frontend ; STG (as simlified core) to GRIN conversion
This commit is contained in:
parent
682ee34e9d
commit
8c512bc43a
@ -70,6 +70,7 @@ library
|
|||||||
AbstractInterpretation.IR
|
AbstractInterpretation.IR
|
||||||
AbstractInterpretation.CodeGen
|
AbstractInterpretation.CodeGen
|
||||||
AbstractInterpretation.Reduce
|
AbstractInterpretation.Reduce
|
||||||
|
Frontend.FromSTG
|
||||||
VarGen
|
VarGen
|
||||||
Pipeline
|
Pipeline
|
||||||
Assertions
|
Assertions
|
||||||
@ -109,7 +110,8 @@ library
|
|||||||
hspec,
|
hspec,
|
||||||
extra,
|
extra,
|
||||||
logict,
|
logict,
|
||||||
QuickCheck
|
QuickCheck,
|
||||||
|
ghc
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
executable grin
|
executable grin
|
||||||
|
122
grin/src/Frontend/FromSTG.hs
Normal file
122
grin/src/Frontend/FromSTG.hs
Normal file
@ -0,0 +1,122 @@
|
|||||||
|
{-# LANGUAGE LambdaCase, TupleSections #-}
|
||||||
|
module Frontend.FromSTG where
|
||||||
|
|
||||||
|
import Text.Printf
|
||||||
|
|
||||||
|
-- GHC
|
||||||
|
import StgSyn
|
||||||
|
import Id
|
||||||
|
import Name as GHC
|
||||||
|
import DynFlags
|
||||||
|
import Outputable
|
||||||
|
import Literal
|
||||||
|
import DataCon
|
||||||
|
|
||||||
|
-- Grin
|
||||||
|
import Grin
|
||||||
|
|
||||||
|
import Control.Monad as M
|
||||||
|
import Control.Monad.State
|
||||||
|
|
||||||
|
type CG = State Env
|
||||||
|
|
||||||
|
data Env
|
||||||
|
= Env
|
||||||
|
{ dflags :: DynFlags
|
||||||
|
}
|
||||||
|
|
||||||
|
getDFlags :: CG DynFlags
|
||||||
|
getDFlags = gets dflags
|
||||||
|
|
||||||
|
genName :: Id -> CG String
|
||||||
|
genName = undefined
|
||||||
|
|
||||||
|
pprM :: Outputable a => a -> CG String
|
||||||
|
pprM a = flip showPpr a <$> gets dflags
|
||||||
|
|
||||||
|
emit = undefined
|
||||||
|
|
||||||
|
convertLit :: Literal -> CG Lit
|
||||||
|
convertLit = \case
|
||||||
|
MachInt i -> pure $ LInt64 $ fromIntegral i
|
||||||
|
MachInt64 i -> pure $ LInt64 $ fromIntegral i
|
||||||
|
MachWord w -> pure $ LWord64 $ fromIntegral w
|
||||||
|
MachWord64 w -> pure $ LWord64 $ fromIntegral w
|
||||||
|
MachFloat f -> pure $ LFloat $ realToFrac f
|
||||||
|
MachDouble f -> pure $ LFloat $ realToFrac f
|
||||||
|
lit -> error . printf "unsupported literal %s" <$> pprM lit
|
||||||
|
|
||||||
|
visitArg :: StgArg -> CG Val
|
||||||
|
visitArg = \case
|
||||||
|
StgVarArg id -> Var <$> genName id
|
||||||
|
StgLitArg lit -> Lit <$> convertLit lit
|
||||||
|
|
||||||
|
visitRhs :: Id -> StgRhs -> CG ()
|
||||||
|
visitRhs id rhs = case rhs of
|
||||||
|
StgRhsCon _ dataCon args -> pure () -- TODO
|
||||||
|
StgRhsClosure _ _ freeVars _ _ args body -> do
|
||||||
|
{-
|
||||||
|
TODO:
|
||||||
|
- add def to globals with the right argumentum list
|
||||||
|
- generate the body
|
||||||
|
-}
|
||||||
|
visitExpr body
|
||||||
|
pure ()
|
||||||
|
|
||||||
|
visitBinding :: StgBinding -> CG ()
|
||||||
|
visitBinding = \case
|
||||||
|
StgNonRec id stgRhs -> visitRhs id stgRhs
|
||||||
|
StgRec bindings -> mapM_ (uncurry visitRhs) bindings
|
||||||
|
|
||||||
|
visitExpr :: StgExpr -> CG ()
|
||||||
|
visitExpr = \case
|
||||||
|
StgApp id args -> SApp <$> genName id <*> mapM visitArg args >>= emit
|
||||||
|
StgOpApp op args _ty -> SApp <$> genOpName op <*> mapM visitArg args >>= emit
|
||||||
|
StgConApp dataCon args -> ConstTagNode <$> genTag dataCon <*> mapM visitArg args >>= emit . SReturn
|
||||||
|
StgLit literal -> SReturn . Lit <$> convertLit literal >>= emit
|
||||||
|
StgTick _ expr -> visitExpr expr
|
||||||
|
StgLet binding expr -> visitBinding binding >> visitExpr expr -- TODO: generate local or global bind
|
||||||
|
StgLetNoEscape _ _ binding expr -> visitBinding binding >> visitExpr expr -- TODO: generate local or global bind
|
||||||
|
StgCase expr _ _ result _ _ alts -> undefined -- TODO: construct case expression
|
||||||
|
expr -> error . printf "unsupported expr %s" <$> pprM expr
|
||||||
|
|
||||||
|
genOpName :: StgOp -> CG String
|
||||||
|
genOpName = \case
|
||||||
|
StgPrimOp op -> pprM op -- TODO
|
||||||
|
StgPrimCallOp op -> pprM op -- TODO
|
||||||
|
StgFCallOp op _ -> pprM op -- TODO
|
||||||
|
|
||||||
|
genTag :: DataCon -> CG Tag
|
||||||
|
genTag dataCon = Tag C <$> pprM dataCon
|
||||||
|
|
||||||
|
{-
|
||||||
|
-- If you edit this type, you may need to update the GHC formalism
|
||||||
|
-- See Note [GHC Formalism] in coreSyn/CoreLint.hs
|
||||||
|
data AltCon
|
||||||
|
= DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@.
|
||||||
|
-- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@
|
||||||
|
|
||||||
|
| LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@
|
||||||
|
-- Invariant: always an *unlifted* literal
|
||||||
|
-- See Note [Literal alternatives]
|
||||||
|
|
||||||
|
| DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@
|
||||||
|
deriving (Eq, Ord, Data, Typeable)
|
||||||
|
|
||||||
|
type GenStgAlt bndr occ
|
||||||
|
= (AltCon, -- alts: data constructor,
|
||||||
|
[bndr], -- constructor's parameters,
|
||||||
|
[Bool], -- "use mask", same length as
|
||||||
|
-- parameters; a True in a
|
||||||
|
-- param's position if it is
|
||||||
|
-- used in the ...
|
||||||
|
GenStgExpr bndr occ) -- ...right-hand side.
|
||||||
|
|
||||||
|
data DataCon
|
||||||
|
= MkData {
|
||||||
|
dcName :: Name, -- This is the name of the *source data con*
|
||||||
|
-- (see "Note [Data Constructor Naming]" above)
|
||||||
|
dcUnique :: Unique, -- Cached from Name
|
||||||
|
dcTag :: ConTag, -- ^ Tag, used for ordering 'DataCon's
|
||||||
|
|
||||||
|
-}
|
@ -142,9 +142,10 @@ M: vectorisation as conversion to tagged unions
|
|||||||
T: new approach: optimise high level grin ; implement some optimisations
|
T: new approach: optimise high level grin ; implement some optimisations
|
||||||
W: copy propagation, constant propagation, dead procedure elimination, use hylo to skip operations, dead variable elimination
|
W: copy propagation, constant propagation, dead procedure elimination, use hylo to skip operations, dead variable elimination
|
||||||
T: common sub-expression elimination, inlining
|
T: common sub-expression elimination, inlining
|
||||||
F:
|
F: stg
|
||||||
S:
|
S: weekend
|
||||||
S:
|
S: stg to grin
|
||||||
|
M: add source code links to schema tables, stg to grin
|
||||||
|
|
||||||
- linter that check all possible alternatives are handled by case alternatives
|
- linter that check all possible alternatives are handled by case alternatives
|
||||||
- dead code elimination using HPTResult ; empty type is dead code i.e. {}
|
- dead code elimination using HPTResult ; empty type is dead code i.e. {}
|
||||||
|
Loading…
Reference in New Issue
Block a user