-
Notifications
You must be signed in to change notification settings - Fork 1
/
ILLift.lhs
134 lines (120 loc) · 4.3 KB
/
ILLift.lhs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
% -*- LaTeX -*-
% $Id: ILLift.lhs 3048 2011-10-02 14:14:03Z wlux $
%
% Copyright (c) 2000-2011, Wolfgang Lux
% See LICENSE for the full license.
%
\nwfilename{ILLift.lhs}
\section{Normalization}
Before the intermediate language code is translated into abstract
machine code, all (f)case and choice expressions occurring in argument
positions are lifted into global functions.
\begin{verbatim}
> module ILLift(liftProg) where
> import Combined
> import IL
> import List
> import Monad
> import Utils
> type LiftState a = St [QualIdent] a
> liftProg :: Module -> Module
> liftProg (Module m es is ds) = Module m es is (concatMap liftDecl ds)
> liftDecl :: Decl -> [Decl]
> liftDecl (DataDecl tc n cs) = [DataDecl tc n cs]
> liftDecl (TypeDecl tc n ty) = [TypeDecl tc n ty]
> liftDecl (FunctionDecl f vs ty e) = FunctionDecl f vs ty e' : ds'
> where (e',ds') = runSt (liftExpr True e) nameSupply
> nameSupply = map (qual m . appIdent (name f') (uniqueId f')) [1..]
> where (m,f') = splitQualIdent f
> qual m = maybe qualify qualifyWith m
> appIdent f n i = renameIdent (mkIdent (f ++ "._#app" ++ show i)) n
> liftDecl (ForeignDecl f cc ie ty) = [ForeignDecl f cc ie ty]
> liftExpr :: Bool -> Expression -> LiftState (Expression,[Decl])
> liftExpr _ (Literal l) = return (Literal l,[])
> liftExpr _ (Variable v) = return (Variable v,[])
> liftExpr _ (Function f n) = return (Function f n,[])
> liftExpr _ (Constructor c n) = return (Constructor c n,[])
> liftExpr root (Apply f e) =
> do
> (f',ds) <- liftExpr root f
> (e',ds') <- liftExpr False e
> return (Apply f' e',ds ++ ds')
> liftExpr root (Case ev e as)
> | root =
> do
> (e',ds) <- liftExpr root e
> (as',ds') <- mapLift (liftAlt root) as
> return (Case ev e' as',ds ++ ds')
> | otherwise = lift (Case ev e as)
> liftExpr root (Choice es)
> | root =
> do
> (es',ds) <- mapLift (liftExpr root) es
> return (Choice es',ds)
> | otherwise = lift (Choice es)
> liftExpr root (Exist vs e) =
> do
> (e',ds) <- liftExpr root e
> return (Exist vs e',ds)
> liftExpr root (Let rec bs e) =
> do
> (bs',ds) <- mapLift liftBinding bs
> (e',ds') <- liftExpr root e
> return (Let rec bs' e',ds ++ ds')
> liftExpr root (SrcLoc p e) =
> do
> (e',ds) <- liftExpr root e
> return (SrcLoc p e',ds)
> lift :: Expression -> LiftState (Expression,[Decl])
> lift e =
> do
> f <- uniqueName
> (e',ds') <- liftExpr True e
> return (foldl Apply (Function f n) (map Variable fvs),
> FunctionDecl f fvs ty e' : ds')
> where fvs = nub (fv e)
> n = length fvs
> ty = foldr1 TypeArrow (map TypeVariable [0..n])
\end{verbatim}
\ToDo{The type of lifted functions is too general ($\forall
\alpha_1\dots\alpha_{n+1} . \alpha_1 \rightarrow \dots \rightarrow
\alpha_n \rightarrow \alpha_{n+1}$, where $n$ is the arity of the
function). In order to fix this bug we need more type information in
the intermediate language so that we can compute the type of any
expression in the module.}
\begin{verbatim}
> liftAlt :: Bool -> Alt -> LiftState (Alt,[Decl])
> liftAlt root (Alt t e) =
> do
> (e',ds) <- liftExpr root e
> return (Alt t e',ds)
> liftBinding :: Binding -> LiftState (Binding,[Decl])
> liftBinding (Binding v e) =
> do
> (e',ds) <- liftExpr False e
> return (Binding v e',ds)
> mapLift :: (a -> LiftState (a,[Decl])) -> [a] -> LiftState ([a],[Decl])
> mapLift f xs = liftM (apSnd concat . unzip) (mapM f xs)
> uniqueName :: LiftState QualIdent
> uniqueName = liftM head (updateSt tail)
> fv :: Expression -> [Ident]
> fv (Literal _) = []
> fv (Variable v) = [v]
> fv (Function _ _) = []
> fv (Constructor _ _) = []
> fv (Apply f e) = fv f ++ fv e
> fv (Case _ e as) = fv e ++ concatMap fvAlt as
> fv (Choice es) = concatMap fv es
> fv (Exist vs e) = filter (`notElem` vs) (fv e)
> fv (Let rec bs e) =
> fvBinds rec vs (concatMap fv es) ++ filter (`notElem` vs) (fv e)
> where (vs,es) = unzip [(v,e) | Binding v e <- bs]
> fvBinds NonRec _ = id
> fvBinds Rec vs = filter (`notElem` vs)
> fv (SrcLoc _ e) = fv e
> fvAlt :: Alt -> [Ident]
> fvAlt (Alt t e) = filter (`notElem` bv t) (fv e)
> where bv (LiteralPattern _) = []
> bv (ConstructorPattern _ vs) = vs
> bv (VariablePattern v) = [v]
\end{verbatim}