Skip to content

Commit

Permalink
simplifications to CoreRun AST
Browse files Browse the repository at this point in the history
  • Loading branch information
@atzedijkstra
atzedijkstra committed Dec 10, 2014
1 parent 2fc3ef5 commit d567a2f
Show file tree
Hide file tree
Showing 12 changed files with 208 additions and 89 deletions.
5 changes: 5 additions & 0 deletions EHC/src/ehc/Base/Common.chs
View file
Expand Up @@ -204,6 +204,11 @@ ppCmt :: PP_Doc -> PP_Doc
ppCmt p = "{-" >#< p >#< "-}"
%%]

%%[8 hs export(ppSemi)
ppSemi :: PP x => x -> PP_Doc
ppSemi = (>|< ";")
%%]

%%[1.PP.Rest export(ppSpaced)

ppSpaced :: PP a => [a] -> PP_Doc
Expand Down
5 changes: 0 additions & 5 deletions EHC/src/ehc/Core/Pretty.cag
View file
Expand Up @@ -134,11 +134,6 @@ ppHole :: UID -> PP_Doc
ppHole i = "<" >|< pp i >|< ">"
%%]

%%[(8 coreout) hs
ppSemi :: PP x => x -> PP_Doc
ppSemi = (>|< ";")
%%]

%%[(9 coreout) hs
ppOptCMetas :: CMetas -> PP_Doc
ppOptCMetas x
Expand Down
38 changes: 20 additions & 18 deletions EHC/src/ehc/Core/ToCoreRun.cag
View file
Expand Up @@ -31,6 +31,8 @@ Offsets start at 0.

%%[(8 corerun) hs import(qualified {%{EH}CoreRun} as CR)
%%]
%%[(8 corerun) hs import(qualified {%{EH}CoreRun.API} as CR)
%%]
%%[(8 corerun) hs import(qualified {%{EH}CoreRun.Prim} as CR)
%%]

Expand Down Expand Up @@ -153,7 +155,7 @@ tailCtxIsTailRec _ = False

-- | Wrap according to tail context
cseCtxWrap :: TailCtx -> CR.Exp -> CR.Exp
cseCtxWrap TailCtx_TailCall = CR.Exp_Tail
cseCtxWrap TailCtx_TailCall = CR.mkTail
cseCtxWrap _ = id
%%]

Expand Down Expand Up @@ -357,17 +359,17 @@ SEM CExpr
%%[(8 corerun) hs
-- | Construct application
mkApp :: CR.Exp -> CR.CRArray CR.SExp -> CR.Exp
mkApp f as = CR.Exp_App ({- CR.Exp_Ret $ -} CR.Exp_Force f) as
mkApp f as = CR.mkApp' (CR.mkEval f) as
%%]
mkApp f as = CR.Exp_App ({- CR.Exp_Ret $ -} CR.Exp_Force f) as
mkApp f as = CR.mkApp' (CR.mkEval f) as

%%[(8 corerun)
ATTR CExpr [ | | creAppArgL: {[CR.SExp]} creAppFun: {TailCtx -> CR.CRArray CR.SExp -> CR.Exp} ]

SEM CExpr
| App loc . creAppArgL = (CR.exp2sexp $ snd $ head @arg.crb) : @func.creAppArgL
. creAppFun = @func.creAppFun
| Tup loc . creAppFun = \_ -> cseCtxWrap TailCtx_Plain . CR.Exp_Tup @tag
| Tup loc . creAppFun = \_ -> cseCtxWrap TailCtx_Plain . CR.mkTup' (ctagTag @tag)
| FFI loc . creAppFun = \_ -> cseCtxWrap TailCtx_Plain . @creMk
| * - App Ann Tup FFI
loc . creAppFun = \tailCtx -> cseCtxWrap tailCtx . tailrec tailCtx . mkApp @cre
Expand Down Expand Up @@ -399,7 +401,7 @@ tailrec tailCtx = if tailCtxIsTailRec tailCtx then id else id -- CR.Exp_Ret -- i

-- | Wrap forcing if at tail recursive position
taileval :: TailCtx -> CR.Exp -> CR.Exp
taileval tailCtx = if tailCtxIsTailRec tailCtx then CR.Exp_Force else id
taileval tailCtx = if tailCtxIsTailRec tailCtx then CR.mkEval else id
%%]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Expand All @@ -412,9 +414,9 @@ ATTR CExpr [ | | crse: {CR.SExp} ]

%%[(8 corerun)
SEM CExpr
| Int loc . crse = CR.SExp_Int @int
| Char loc . crse = CR.SExp_Char @char
| String loc . crse = CR.SExp_String @str
| Int loc . crse = CR.mkInt' @int
| Char loc . crse = CR.mkChar' @char
| String loc . crse = CR.mkString' @str
| Var loc . crse = CR.SExp_Var $ maybe (CR.RRef_Dbg @nm) (CR.rrefToDis @lhs.lev) $ Map.lookup @nm @lhs.nm2ref
%%[[97
| Integer loc . crse = CR.SExp_Integer @integer
Expand Down Expand Up @@ -444,15 +446,15 @@ SEM CExpr
%%[[97
Integer
%%]]
loc . creBase = CR.Exp_SExp @crse
| Var loc . creBase = taileval @lhs.tailCtx $ CR.Exp_SExp @crse
loc . creBase = CR.mkExp @crse
| Var loc . creBase = taileval @lhs.tailCtx $ CR.mkExp @crse
| Lam loc . creBase = if @isTopLam
then CR.Exp_Lam (whatExprMbBind @lhs.whatAbove) @lev (length @creLamArgL) (@refOffsetMax) (@stackDepthMax) (CR.nm2RefMpInverse @nm2refNew) @body.creLamBody
then CR.Exp_Lam (whatExprMbBind @lhs.whatAbove) {- @lev -} (length @creLamArgL) {- @refOffsetMax -} (@stackDepthMax) (CR.nm2RefMpInverse @nm2refNew) @body.creLamBody
else CR.dbg "Core.ToCoreRun.CExpr.Lam.cre" -- TBD
| App loc . creBase = if @isTopApp'
then @creAppFun @lhs.tailCtx $ CR.mkCRArray $ reverse @creAppArgL
else CR.dbg "Core.ToCoreRun.CExpr.App.cre" -- TBD
| Tup loc . creBase = CR.Exp_Tup @tag CR.emptyCRArray
| Tup loc . creBase = CR.mkTup (ctagTag @tag) []
| Let loc . creBase = if @isGlobal
then @body.cre
else CR.Exp_Let @lhs.lev @lhs.refOffset (CR.nm2RefMpInverse @nm2refNew) (CR.mkCRArray $ map snd @binds.crb) @body.cre
Expand Down Expand Up @@ -484,8 +486,8 @@ ATTR AllBind CExpr [ | | crb USE {++} {[]} : {[(HsName, CR.Bind)]} ]

SEM CBound
| Bind Val loc . creMkForce = case @toBe of
ToBe_Forced -> tailrec @tailCtx . CR.Exp_Force
ToBe_Thunked -> CR.Exp_Lam (Just @lhs.nm) @lev 0 (@expr.refOffsetMax) (@stackDepthMaxThunked) (CR.nm2RefMpInverse @nm2refNew)
ToBe_Forced -> tailrec @tailCtx . CR.mkEval
ToBe_Thunked -> CR.Exp_Lam (Just @lhs.nm) {- @lev -} 0 {- @expr.refOffsetMax -} (@stackDepthMaxThunked) (CR.nm2RefMpInverse @nm2refNew)
ToBe_LeftAsIs -> id
-- . creMkReturned = if @isToBeReturned then CR.Exp_Ret else id
. creBind = {- @creMkReturned $ -} @creMkForce @expr.cre
Expand All @@ -505,22 +507,22 @@ SEM CExpr
ATTR AllAlt [ | | cra USE {++} {[]} : {[CR.Alt]} ]

SEM CAlt
| Alt lhs . cra = [CR.Alt_Alt (CR.nm2RefMpInverse @nm2refNew) @pat.crp @expr.cre]
| Alt lhs . cra = [CR.Alt_Alt (CR.nm2RefMpInverse @nm2refNew) {- @pat.crp -} @expr.cre]
%%]

%%[(8 corerun)
ATTR CPat [ | | crp: {CR.Pat} ]

SEM CPat
| Con lhs . crp = CR.Pat_Con @tag
| Con lhs . crp = CR.Pat_Con (ctagTag @tag)
%%[[97
-- | BoolExpr lhs . crp = CR.Pat_BoolExpr @cexpr.cre
%%]]
| * - Con
%%[[97
-- BoolExpr
%%]]
lhs . crp = CR.Pat_Con CTagRec -- TBD
lhs . crp = CR.Pat_Con 0 -- TBD
%%]

%%[(8 corerun)
Expand All @@ -530,7 +532,7 @@ SEM CModule
| Mod loc . crmBinds = CR.mkCRArray $ map snd @expr.crb
lhs . crm = CR.Mod_Mod (CR.nm2RefMpInverse @nm2refNew)
@moduleNm @lhs.modNr (@expr.stackDepthMax + 2 {- - CR.craLength @crmBinds -})
@crmBinds (CR.Exp_Force @creMod)
@crmBinds (CR.mkEval @creMod)
%%]


Expand Down
6 changes: 3 additions & 3 deletions EHC/src/ehc/CoreRun.cag
View file
Expand Up @@ -108,17 +108,17 @@ type Bind = Exp
%%% Construction
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%[(8 corerun) hs export(unit)
%%[(8 corerun) hs
-- | Equivalent of '()'
unit :: Exp
unit = Exp_Tup CTagRec emptyCRArray
unit = Exp_Tup 0 emptyCRArray
%%]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Debugging
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%[(8 corerun) hs export(dbg)
%%[(8 corerun) hs export(dbgs, dbg)
-- | Debug info is embedded in SExp
dbgs = SExp_Dbg
dbg = Exp_SExp . dbgs
Expand Down
123 changes: 117 additions & 6 deletions EHC/src/ehc/CoreRun/API.chs
View file
Expand Up @@ -5,23 +5,134 @@
-- Intended for constructing basic CoreRun Programs.
--
-- CoreRun is a simplified Core intended to be used for direct interpretation/execution.
-- See TBD for semantics.
--

module %%@{%{EH}%%}CoreRun.API
(
-- * Core AST
-- | The datatypes making up a CoreRun program.
CR.Mod
, CR.Exp
, CR.SExp
, CR.Alt
, CR.Pat
Mod
, Exp
, SExp
, Alt
-- , Pat

-- * Utilities
, CRArray
, mkCRArray

-- * Construction functions
, mkExp

, mkInt, mkInt'
, mkChar, mkChar'
%%[[97
, mkInteger, mkInteger'
%%]]
, mkString, mkString'
, mkDbg, mkDbg'

, mkApp, mkApp'
, mkTup, mkTup'
, mkEval
, mkTail
, mkCase
, mkLam

)
where

import qualified %%@{%{EH}%%}CoreRun as CR
import %%@{%{EH}%%}CoreRun as CR

-- **************************************
-- Construction: constants as SExp or Exp
-- **************************************

-- | Lift 'SExp' into 'Exp'
mkExp :: SExp -> Exp
mkExp = Exp_SExp

-- | Int constant as 'SExp'
mkInt' :: Int -> SExp
mkInt' = SExp_Int

-- | Int constant as 'Exp'
mkInt :: Int -> Exp
mkInt = mkExp . mkInt'

-- | Char constant as 'SExp'
mkChar' :: Char -> SExp
mkChar' = SExp_Char

-- | Char constant as 'Exp'
mkChar :: Char -> Exp
mkChar = mkExp . mkChar'

%%[[97
-- | Integer constant as 'SExp'
mkInteger' :: Integer -> SExp
mkInteger' = SExp_Integer

-- | Integer constant as 'Exp'
mkInteger :: Integer -> Exp
mkInteger = mkExp . mkInteger'
%%]]

-- | String constant as 'SExp'
mkString' :: String -> SExp
mkString' = SExp_String

-- | String constant as 'Exp'
mkString :: String -> Exp
mkString = mkExp . mkString'

-- | Debug info as 'SExp', will make an interpreter stop with displaying the message
mkDbg' :: String -> SExp
mkDbg' = dbgs

-- | Debug info as 'Exp'
mkDbg :: String -> Exp
mkDbg = dbg

-- **************************************
-- Construction: Exp
-- **************************************

-- | Application
mkApp' :: Exp -> CRArray SExp -> Exp
mkApp' = Exp_App

-- | Application
mkApp :: Exp -> [SExp] -> Exp
mkApp f as = mkApp' f (mkCRArray as)

-- | Tuple, Node
mkTup' :: Int -> CRArray SExp -> Exp
mkTup' = Exp_Tup

-- | Tuple, Node
mkTup :: Int -> [SExp] -> Exp
mkTup t as = mkTup' t (mkCRArray as)

-- | Force evaluation
mkEval :: Exp -> Exp
mkEval = Exp_Force

-- | Set tail call context
mkTail :: Exp -> Exp
mkTail = Exp_Tail

-- | Case
mkCase :: SExp -> [Exp] -> Exp
mkCase scrut alts = Exp_Case scrut $ mkCRArray $ map (Alt_Alt ref2nmEmpty) alts

-- | Lambda
mkLam
:: Int -- ^ nr of arguments, 0 encodes a thunk/CAF
-> Int -- ^ total stack size, including arguments, locals, expression calculation
-> Exp -- ^ body
-> Exp
mkLam nrArgs stackDepth body = Exp_Lam Nothing nrArgs stackDepth ref2nmEmpty body

%%]
16 changes: 9 additions & 7 deletions EHC/src/ehc/CoreRun/AbsSyn.cag
View file
Expand Up @@ -54,7 +54,7 @@ DATA Exp
| SExp sexpr : SExp

-- node constructor, tuple or data constructor, determined by tag
| Tup tag : {CTag}
| Tup tag : {Int}
args : {CRArray SExp}

-- let bindings, recursiveness allowed, yes/no eval made explicit in rhs of binding
Expand All @@ -69,9 +69,9 @@ DATA Exp
func : Exp
args : {CRArray SExp}
| Lam mbNm : {Maybe HsName} -- possibly bound to name
lev : {Int} -- lexical level
-- lev : {Int} -- lexical level
nrArgs : {Int} -- nr of arguments, 0 means it is a thunk
nrBinds : {Int} -- nr stack frame locations to be allocated (excluding arguments) for locals
-- nrBinds : {Int} -- nr stack frame locations to be allocated (excluding arguments) for locals
stkDepth : {Int} -- max depth of stack
ref2nm : {Ref2Nm} -- inverse lookup of locally introduced binding RRef's
body : Exp
Expand All @@ -82,9 +82,11 @@ DATA Exp

-- expr in a context to which must be returned (i.e. no tail rec)
-- | Ret expr : Exp

-- expr in a case alternative result context (with local bindings to be removed)
| RetCase nrBinds : {Int}
expr : Exp
-- | RetCase nrBinds : {Int}
-- expr : Exp

-- Tail context
| Tail expr : Exp

Expand Down Expand Up @@ -126,13 +128,13 @@ DATA Exp
%%[(8 corerun)
DATA Alt
| Alt ref2nm : {Ref2Nm} -- inverse lookup of locally introduced binding RRef's
pat : Pat
-- pat : Pat
expr : Exp
%%]

%%[(8 corerun)
DATA Pat
| Con tag : {CTag}
| Con tag : {Int}
%%[[97
| BoolExpr expr : Exp
%%]]
Expand Down

0 comments on commit d567a2f

Please sign in to comment.