Commit fe72024a authored by Vincent Zweije's avatar Vincent Zweije
Browse files

First implementation of input expression conversion (case lifting)

parent e38c6254
......@@ -34,19 +34,23 @@ convert_fundef
, [(SuclSymbol,SuclSymbolKind)] // Kind of symbol
)
convert_fundef fundef (typerulemap,strictsmap,rulesmap,kindmap)
convert_fundef fundef (typerulemap,strictsmap,fundefs0,kindmap)
= ( [(funsym,typerule):typerulemap]
, [(funsym,stricts):strictsmap]
, [(funsym,rules):rulesmap]
, fundefs1
, [(funsym,kind):kindmap]
)
where {fun_symb,fun_body,fun_type,fun_kind} = fundef
funsym = SuclUser fun_symb
funsym = SuclUser fun_symb.id_info
(typerule,stricts) = foldoptional notyperule convert_symboltype fun_type
notyperule = abort "convert: convert_fundef: fun_type is absent"
rules = convert_functionbody fun_body
fundefs1 = convert_functionbody funsym fun_body fundefs0
kind = convert_kind fun_kind
/******************************************************************************
* TYPE CONVERSION *
******************************************************************************/
/* Convert the SymbolType data structure
This type describes the types of (function) symbols
We use the principal type
......@@ -132,10 +136,165 @@ convert_btype BT_Bool = SuclBOOL
convert_btype BT_Dynamic = SuclDYNAMIC
convert_btype BT_File = SuclFILE
convert_btype BT_World = SuclWORLD
convert_btype _ = abort "convert: convert_btype: unhandled basic type"
convert_btype _ = abort "convert: convert_btype: unhandledRule basic type"
/******************************************************************************
* EXPRESSION CONVERSION *
******************************************************************************/
convert_functionbody :: SuclSymbol FunctionBody [FunBinding SuclSymbol SuclVariable] -> [FunBinding SuclSymbol SuclVariable]
convert_functionbody funsym (TransformedBody t) fundefs0 = convert_transformedbody funsym t fundefs0
convert_functionbody funsym _ fundefs0
= [(funsym,norule):fundefs0]
where norule = abort "convert: convert_functionbody: unexpected FunctionBody constructor"
convert_transformedbody :: SuclSymbol TransformedBody [FunBinding SuclSymbol SuclVariable] -> [FunBinding SuclSymbol SuclVariable]
convert_transformedbody funsym {tb_args=args,tb_rhs=expression} fundefs0
| not (isEmpty globals0) // Sanity check, since we have it in our fingers anyway
= abort "convert: convert_transformedbody: function rhs contains free variables!"
= [(funsym,[mkrule (map snd seen0) (hd rest) (compilegraph nodes0)]):fundefs1]
where (_,(nodes0,fundefs1,globals0,rest))
= convert_expression [] expression ((heap0,seen0),([],fundefs0,[],[]))
heap0 = heap
seen0 = map mkseen args
mkseen fv = (fv.fv_info_ptr,SuclNamed fv.fv_info_ptr)
heap = map SuclAnonymous [0..]
:: NodeBinding sym var :== (var,Node sym var)
:: FunBinding sym var :== (sym,[Rule sym var])
:: Econv_state
:== ( ( [SuclVariable] // Heap of node-ids
, [(VarInfoPtr,SuclVariable)] // Already seen CoreClean Variables for cycle breaking
)
, ( [NodeBinding SuclSymbol SuclVariable]// Nodes of Sucl expression being built
, [FunBinding SuclSymbol SuclVariable] // Lifted functions for case/lambda expressions
, [SuclVariable] // Free Sucl variables in expression being built
, [SuclVariable] // List of variables to which root of expression is prepended (accumulator)
)
)
convert_expressions bounds exprs (heapseen0,(nodes0,fundefs0,globals0))
= foldlr (convert_expression bounds) (heapseen0,(nodes0,fundefs0,globals0,[])) exprs
convert_expression
:: [(VarInfoPtr,Econv_state->Econv_state)] // Locally bound variables, with the expressions they're bound to, for resolving locally bound variables
Expression // Expression to convert
Econv_state // Input expression conversion state
-> Econv_state // Resulting expression conversion state
convert_expression bounds (App appinfo) ((heap0,seen0),(nodes0,fundefs0,globals0,rest))
= ((heap2,seen1),(nodes2,fundefs1,globals1,[root:rest]))
where [root:heap1] = heap0
((heap2,seen1),(nodes1,fundefs1,globals1,args0))
= convert_expressions bounds appinfo.app_args ((heap1,seen0),(nodes0,fundefs0,globals0))
nodes2 = [(root,(SuclUser appinfo.app_symb.symb_name.id_info,args0)):nodes1]
convert_expression bounds (Var varinfo) ((heap0,seen0),(nodes0,fundefs0,globals0,rest))
= foldmap oldvip newvip seen0 vip
where // oldvip: We've already seen this Var, reuse it and don't do anything else
oldvip root = ((heap0,seen0),(nodes0,fundefs0,globals0,[root:rest]))
// newvip: We haven't seen this Var yet, figure out what to do
newvip = foldmap local newglobal bounds vip
// local: this Var is bound locally to an expression, use the associated expression evaluator
local convert_local
= ((heap1,seen2),(nodes1,fundefs1,globals1,[root:rest]))
where seen1 = [(vip,root):seen0]
((heap1,seen2),(nodes1,fundefs1,globals1,[root:_]))
= convert_local ((heap0,seen1),(nodes0,fundefs0,globals0,[]))
// newglobal: this Var wasn't seen before and it's not bound locally, it must be a global reference
newglobal
= ((heap1,seen1),(nodes0,fundefs0,globals1,[root:rest]))
where [root:heap1] = heap0
seen1 = [(vip,root):seen0]
globals1 = [root:globals0]
vip = varinfo.var_info_ptr
convert_expression bounds0 (Let letinfo) ((heap0,seen0),(nodes0,fundefs0,globals0,rest))
= convert_expression bounds1 letinfo.let_expr ((heap0,seen0),(nodes0,fundefs0,globals0,rest))
where newbounds = [(lb.lb_dst.fv_info_ptr,convert_bound_expr bounds1 lb.lb_src) \\ lb<-letinfo.let_lazy_binds]
bounds1 = newbounds++bounds0
convert_expression bounds (Case caseinfo) ((heap0,seen0),(nodes6,fundefs5,globals6,rest))
= ((heap4,seen3),(nodes9,fundefs9,globals9,[root:rest]))
where // Plan: (0.5) convert selector
// (1) convert branches
// (1.5) convert default if present
// (2) build rules/fundef from branches
// (4) build closure node
// (4) Build closure node
nodes9 = [(root,(SuclCase caseinfo.case_info_ptr,innerglobals++defaultroots++selectorroots)):nodes8]
// (2) build rules/fundef from branches
fundefs9 = [(SuclCase caseinfo.case_info_ptr,map mkalt alternatives++map mkdefaultalt defaultroots):fundefs8]
where mkalt (patroot,reproot,nodes)
= mkrule (innerglobals++defaultroots++[patroot]) reproot (compilegraph nodes)
mkdefaultalt defaultroot
= mkrule (innerglobals++defaultroots++selectorroots) defaultroot emptygraph
// (1.5) convert default if necessary
((heap4,seen3),(nodes7,fundefs6,globals7,defaultroots))
= case caseinfo.case_default
of Yes expr
-> convert_expression bounds expr ((heap3,seen2),(nodes6,fundefs5,globals6,[]))
No
-> ((heap3,seen2),(nodes6,fundefs5,globals6,[]))
// (1) convert branches
((heap3,seen2),(innerglobals,fundefs7,alternatives))
= case caseinfo.case_guards
of AlgebraicPatterns _ branches
-> foldlr convert_algebraic_branch ((heap2,seen1),([],fundefs6,[])) branches
BasicPatterns _ branches
-> foldlr convert_basic_branch ((heap2,seen1),([],fundefs6,[])) branches
_
-> ((heap2,seen1),([],fundefs6,abort "convert: convert_expression: cannot handle case guard constructor"))
globals8 = removeDup (innerglobals++globals7)
// (0.5) Convert selector
((heap2,seen1),(nodes8,fundefs8,globals9,selectorroots))
= convert_expression bounds caseinfo.case_expr ((heap1,seen0),(nodes7,fundefs7,globals8,[]))
// (0) Claim root node
[root:heap1] = heap0
convert_algebraic_branch branch ((heap0,seen0),(globals0,fundefs0,alternatives0))
= ((heap2,seen2),(globals1,fundefs1,alternatives1))
where ((heap1,seen1),(nodes0,patrest))
= convert_algebraic_pattern branch ((heap0,seen0),([],[]))
((heap2,seen2),(nodes1,fundefs1,globals1,rest))
= convert_expression [] branch.ap_expr ((heap1,seen1),(nodes0,fundefs0,globals0,[]))
alternatives1 = [(hd patrest,hd rest,nodes1):alternatives0]
convert_algebraic_pattern ap ((heap0,seen0),(nodes0,rest))
= ((heap1,seen1),(nodes1,[root:rest]))
where [root:heap1] = heap0
argmap = [(fv.fv_info_ptr,SuclNamed fv.fv_info_ptr) \\ fv <- ap.ap_vars]
seen1 = argmap++seen0
args0 = map snd argmap
nodes1 = [(root,(SuclUser ap.ap_symbol.glob_object.ds_ident.id_info,args0)):nodes0]
convert_basic_branch branch ((heap0,seen0),(globals0,fundefs0,alternatives0))
= ((heap2,seen2),(globals1,fundefs1,alternatives1))
where ((heap1,seen1),(nodes0,patrest))
= convert_basic_pattern branch ((heap0,seen0),([],[]))
((heap2,seen2),(nodes1,fundefs1,globals1,rest))
= convert_expression [] branch.bp_expr ((heap1,seen1),(nodes0,fundefs0,globals0,[]))
alternatives1 = [(hd patrest,hd rest,nodes1):alternatives0]
convert_basic_pattern bp ((heap0,seen0),(nodes0,rest))
= ((heap1,seen0),(nodes1,[root:rest]))
where [root:heap1] = heap0
nodes1 = [(root,(convert_bvalue bp.bp_value,[])):nodes0]
convert_bound_expr bounds expr ((heap0,seen0),(nodes0,fundefs0,globals0,rest))
= ((heap1,seen1),(nodes1,fundefs1,globals1,rest`))
where ((heap1,seen1),(nodes1,fundefs1,globals1,rest`))
= convert_expression bounds expr ((heap0,seen0),(nodes0,fundefs0,globals0,rest))
convert_functionbody :: FunctionBody -> [Rule SuclSymbol SuclVariable]
convert_functionbody _ = abort "convert: convert_functionbody: not implemented"
convert_bvalue :: BasicValue -> SuclSymbol
convert_bvalue (BVI intrepr) = SuclInt (toInt intrepr)
//convert_bvalue (BVC charrepr) = SuclChar (fromString charrepr)
convert_bvalue (BVB bool) = SuclBool bool
//convert_bvalue (BVR realrepr) = SuclReal (fromString realrepr)
//convert_bvalue (BVS stringrepr) = SuclString (fromString stringrepr)
convert_bvalue _ = abort "convert: convert_bvalue: unhandled BasicValue constructor"
convert_kind :: DefOrImpFunKind -> SuclSymbolKind
convert_kind _ = abort "convert: convert_kind: not implemented"
......@@ -2,12 +2,13 @@ definition module coreclean
// $Id$
from syntax import TypeSymbIdent,Ident,TypeVar
from syntax import TypeSymbIdent,Ident,TypeVar,ExprInfoPtr,VarInfoPtr
// Transitive necessities
from syntax import SymbolPtr,SymbolTableEntry,STE_Kind,Index,Level,Global,TypeSymbProperties,SignClassification,PropClassification,TypeVarInfoPtr,TypeVarInfo
from syntax import SymbolPtr,SymbolTableEntry,STE_Kind,Index,Level,Global,TypeSymbProperties,SignClassification,PropClassification,TypeVarInfoPtr,TypeVarInfo,ExprInfo,VarInfo
from general import BITVECT
from Heap import Ptr,PtrN,HeapN
from StdOverloaded import ==
from StdString import String
:: SuclTypeSymbol
......@@ -28,8 +29,19 @@ from StdString import String
sucltypeheap :: [SuclTypeVariable]
:: SuclSymbol
= SuclUser Ident
= SuclUser SymbolPtr
| SuclCase ExprInfoPtr
| SuclInt Int
| SuclChar Char
| SuclBool Bool
:: SuclSymbolKind
= SuclFunction
| SuclConstructor
| SuclPrimitive
:: SuclVariable
= SuclAnonymous Int
| SuclNamed VarInfoPtr
instance == SuclVariable
......@@ -23,7 +23,11 @@ sucltypeheap :: [SuclTypeVariable]
sucltypeheap =: map SuclANONYMOUS [0..]
:: SuclSymbol
= SuclUser Ident
= SuclUser SymbolPtr
| SuclCase ExprInfoPtr
| SuclInt Int
| SuclChar Char
| SuclBool Bool
:: SuclSymbolKind
= SuclFunction
......@@ -32,3 +36,9 @@ sucltypeheap =: map SuclANONYMOUS [0..]
:: SuclVariable
= SuclAnonymous Int
| SuclNamed VarInfoPtr
instance == SuclVariable
where (==) (SuclAnonymous i1) (SuclAnonymous i2) = i1 == i2
(==) (SuclNamed p1) (SuclNamed p2) = p1 == p2
(==) _ _ = False
......@@ -158,6 +158,11 @@ isinstance
/*
> compilegraph :: [(**,(*,[**]))] -> graph * **
> compilegraph = foldr (uncurry updategraph) emptygraph
*/
compilegraph :: ![(var,Node sym var)] -> Graph sym var
/*
------------------------------------------------------------------------
......
......@@ -196,6 +196,12 @@ Uses in Miranda:
> compilegraph :: [(**,(*,[**]))] -> graph * **
> compilegraph = foldr (uncurry updategraph) emptygraph
*/
compilegraph :: ![(var,Node sym var)] -> Graph sym var
compilegraph nds = foldr (uncurry updategraph) emptygraph nds
/*
`Instance g1 g2' determines whether g2 is an instance of g1.
Uses in Miranda:
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment