git.iko.soy/Idris-dev
on master help sign in
Simplify generating the simplified language
199c45dThomas Scholtes
src/IRTS/Simplified.hs+47−52
compare with master
unifiedsplit
@@ -42,15 +42,15 @@ data SAlt = SConCase Int Int Name [Name] SExp
42data SDecl = SFun Name [Name] Int SExp
42data SDecl = SFun Name [Name] Int SExp
43 deriving Show
43 deriving Show
44
44
45−hvar :: State (DDefs, Int) Int
46−hvar = do (l, h) <- get
47− put (l, h + 1)
48− return h
49
45
50ldefs :: State (DDefs, Int) DDefs
46ldefs :: State (DDefs, Int) DDefs
51ldefs = do (l, h) <- get
47ldefs = do (l, h) <- get
52 return l
48 return l
53
49
50+-- | Simplify an expression by let-binding argument expressions that
51+-- are not variables
52+-- The boolean parameter indicates whether the expression is at tail
53+-- call position.
54simplify :: Bool -> DExp -> State (DDefs, Int) SExp
54simplify :: Bool -> DExp -> State (DDefs, Int) SExp
55simplify tl (DV (Loc i)) = return (SV (Loc i))
55simplify tl (DV (Loc i)) = return (SV (Loc i))
56simplify tl (DV (Glob x))
56simplify tl (DV (Glob x))
@@ -58,67 +58,62 @@ simplify tl (DV (Glob x))
58 case lookupCtxtExact x ctxt of
58 case lookupCtxtExact x ctxt of
59 Just (DConstructor _ t 0) -> return $ SCon Nothing t x []
59 Just (DConstructor _ t 0) -> return $ SCon Nothing t x []
60 _ -> return $ SV (Glob x)
60 _ -> return $ SV (Glob x)
61−simplify tl (DApp tc n args) = do args' <- mapM sVar args
61+simplify tl (DApp tc n args) = bindExprs args (SApp (tl || tc) n)
62− mkapp (SApp (tl || tc) n) args'
63simplify tl (DForeign ty fn args)
62simplify tl (DForeign ty fn args)
64− = do args' <- mapM sVar (map snd args)
63+ = let (fdescs, exprs) = unzip args
65− let fargs = zip (map fst args) args'
64+ in bindExprs exprs (\vars -> SForeign ty fn (zip fdescs vars))
66− mkfapp (SForeign ty fn) fargs
67simplify tl (DLet n v e) = do v' <- simplify False v
65simplify tl (DLet n v e) = do v' <- simplify False v
68 e' <- simplify tl e
66 e' <- simplify tl e
69 return (SLet (Glob n) v' e')
67 return (SLet (Glob n) v' e')
70simplify tl (DUpdate n e) = do e' <- simplify False e
68simplify tl (DUpdate n e) = do e' <- simplify False e
71 return (SUpdate (Glob n) e')
69 return (SUpdate (Glob n) e')
72−simplify tl (DC loc i n args) = do args' <- mapM sVar args
70+simplify tl (DC loc i n args) = bindExprs args (SCon loc i n)
73− mkapp (SCon loc i n) args'
74−simplify tl (DProj t i) = do v <- sVar t
71+simplify tl (DProj t i) = bindExpr t (\var -> SProj var i)
75− case v of
76− (x, Nothing) -> return (SProj x i)
77− (Glob x, Just e) ->
78− return (SLet (Glob x) e (SProj (Glob x) i))
79−simplify tl (DCase up e alts) = do v <- sVar e
72+simplify tl (DCase up e alts)
80− alts' <- mapM (sAlt tl) alts
73+ = do alts' <- mapM (sAlt tl) alts
81− case v of
74+ bindExpr e (\var -> SCase up var alts')
82− (x, Nothing) -> return (SCase up x alts')
83− (Glob x, Just e) ->
84− return (SLet (Glob x) e (SCase up (Glob x) alts'))
85simplify tl (DChkCase e alts)
75simplify tl (DChkCase e alts)
86− = do v <- sVar e
87− alts' <- mapM (sAlt tl) alts
76+ = do alts' <- mapM (sAlt tl) alts
88− case v of
89− (x, Nothing) -> return (SChkCase x alts')
90− (Glob x, Just e) ->
91− return (SLet (Glob x) e (SChkCase (Glob x) alts'))
77+ bindExpr e (\var -> SChkCase var alts')
92simplify tl (DConst c) = return (SConst c)
78simplify tl (DConst c) = return (SConst c)
93−simplify tl (DOp p args) = do args' <- mapM sVar args
79+simplify tl (DOp p args) = bindExprs args (SOp p)
94− mkapp (SOp p) args'
95simplify tl DNothing = return SNothing
80simplify tl DNothing = return SNothing
96simplify tl (DError str) = return $ SError str
81simplify tl (DError str) = return $ SError str
97
82
83+
84+-- | Let-bind a list of expressions to variables and construct the
85+-- inner expression with the bound variables.
86+-- If an expression in the list is already a variable we don’t bind it
87+-- again.
88+bindExprs :: [DExp] -> ([LVar] -> SExp) -> State (DDefs, Int) SExp
89+bindExprs es f = bindExprs' es f [] where
90+ bindExprs' [] f vars = return $ f (reverse vars)
91+ bindExprs' (e:es) f vars =
92+ bindExprM e (\var -> bindExprs' es f (var:vars))
93+
94+-- | Special case of 'bindExprs' for just one expression
95+bindExpr :: DExp -> (LVar -> SExp) -> State (DDefs, Int) SExp
96+bindExpr e f = bindExprM e (return . f)
97+
98+bindExprM :: DExp -> (LVar -> State (DDefs, Int) SExp) -> State (DDefs, Int) SExp
98−sVar (DV (Glob x))
99+bindExprM (DV (Glob x)) f
99 = do ctxt <- ldefs
100 = do ctxt <- ldefs
100 case lookupCtxtExact x ctxt of
101 case lookupCtxtExact x ctxt of
101− Just (DConstructor _ t 0) -> sVar (DC Nothing t x [])
102+ Just (DConstructor _ t 0) -> bindExprM (DC Nothing t x []) f
102− _ -> return (Glob x, Nothing)
103+ _ -> f (Glob x)
103−sVar (DV x) = return (x, Nothing)
104+bindExprM (DV var) f = f var
105+bindExprM e f =
104−sVar e = do e' <- simplify False e
106+ do e' <- simplify False e
105− i <- hvar
107+ var <- freshVar
108+ f' <- f var
109+ return $ SLet var e' f'
110+ where
111+ freshVar = do (defs, i) <- get
112+ put (defs, i + 1)
106− return (Glob (sMN i "R"), Just e')
113+ return (Glob (sMN i "R"))
107−
114+
108−mkapp f args = mkapp' f args [] where
115+
109− mkapp' f [] args = return $ f (reverse args)
116+sAlt :: Bool -> DAlt -> State (DDefs, Int) SAlt
110− mkapp' f ((x, Nothing) : xs) args = mkapp' f xs (x : args)
111− mkapp' f ((x, Just e) : xs) args
112− = do sc <- mkapp' f xs (x : args)
113− return (SLet x e sc)
114−
115−mkfapp f args = mkapp' f args [] where
116− mkapp' f [] args = return $ f (reverse args)
117− mkapp' f ((ty, (x, Nothing)) : xs) args = mkapp' f xs ((ty, x) : args)
118− mkapp' f ((ty, (x, Just e)) : xs) args
119− = do sc <- mkapp' f xs ((ty, x) : args)
120− return (SLet x e sc)
121−
122sAlt tl (DConCase i n args e) = do e' <- simplify tl e
117sAlt tl (DConCase i n args e) = do e' <- simplify tl e
123 return (SConCase (-1) i n args e')
118 return (SConCase (-1) i n args e')
124sAlt tl (DConstCase c e) = do e' <- simplify tl e
119sAlt tl (DConstCase c e) = do e' <- simplify tl e