lvmlib (empty) → 1.0
raw patch · 38 files changed
+7692/−0 lines, 38 filesdep +arraydep +basedep +containerssetup-changed
Dependencies added: array, base, containers, directory, parsec, wl-pprint
Files
- CREDITS.txt +19/−0
- LICENSE.txt +24/−0
- Lvm/Asm/Data.hs +134/−0
- Lvm/Asm/Inline.hs +177/−0
- Lvm/Asm/Occur.hs +112/−0
- Lvm/Asm/ToLvm.hs +324/−0
- Lvm/Common/Byte.hs +148/−0
- Lvm/Common/Id.hs +310/−0
- Lvm/Common/IdMap.hs +129/−0
- Lvm/Common/IdSet.hs +69/−0
- Lvm/Core/Expr.hs +130/−0
- Lvm/Core/FreeVar.hs +65/−0
- Lvm/Core/LetSort.hs +87/−0
- Lvm/Core/Lift.hs +166/−0
- Lvm/Core/Main.hs +181/−0
- Lvm/Core/Module.hs +429/−0
- Lvm/Core/NoShadow.hs +119/−0
- Lvm/Core/Normalize.hs +150/−0
- Lvm/Core/Parsing/Layout.hs +108/−0
- Lvm/Core/Parsing/Lexer.hs +375/−0
- Lvm/Core/Parsing/Parser.hs +1014/−0
- Lvm/Core/Parsing/Token.hs +109/−0
- Lvm/Core/PrettyId.hs +94/−0
- Lvm/Core/RemoveDead.hs +147/−0
- Lvm/Core/Saturate.hs +110/−0
- Lvm/Core/ToAsm.hs +187/−0
- Lvm/Core/Type.hs +146/−0
- Lvm/Core/Utils.hs +91/−0
- Lvm/Data.hs +28/−0
- Lvm/Import.hs +138/−0
- Lvm/Instr/Data.hs +724/−0
- Lvm/Instr/Resolve.hs +301/−0
- Lvm/Instr/Rewrite.hs +217/−0
- Lvm/Path.hs +79/−0
- Lvm/Read.hs +422/−0
- Lvm/Write.hs +543/−0
- Setup.lhs +4/−0
- lvmlib.cabal +82/−0
+ CREDITS.txt view
@@ -0,0 +1,19 @@+AUTHORS++Daan Leijen, Bastiaan Heeren, Jurriaan Hage++CREDITS++The first version of the Lazy Virtual Machine was developed by Daan Leijen+and released as part of the Helium compiler. This version has been adapted +for the release of the lvmlib cabal package and because of changes in +the Haskell infrastructure. ++The following people have contributed to the development and testing of the+Helium compiler and its components:++Arjan van IJzendoorn, Daan Leijen, Rijk-Jan van Haaften, Arie Middelkoop,+Arjan Oosting, Jurrin Stutterheim, Jeroen Fokker, Andres Loeh,+Arthur Baars, Remco Burema, Atze Dijkstra, Maarten van Gompel,+Doaitse Swierstra, Martijn Lammerts, Martijn Schrage and+Stefan Holdermans.
+ LICENSE.txt view
@@ -0,0 +1,24 @@+Copyright (c) 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Daan Leijen, Bastiaan Heeren, Jurriaan Hage, nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Lvm/Asm/Data.hs view
@@ -0,0 +1,134 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Data.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Asm.Data + ( AsmModule, AsmDecl+ , Top(..), Atom, Expr(..), Note(..), Occur(..)+ , Lit(..), Alt(..), Pat(..), Con(..)+ ) where++import Lvm.Common.Byte+import Lvm.Common.Id+import Lvm.Core.Module+import Text.PrettyPrint.Leijen++{---------------------------------------------------------------+ Asm modules+---------------------------------------------------------------}+type AsmModule = Module Top+type AsmDecl = Decl Top++{---------------------------------------------------------------+ low level "assembly" language+---------------------------------------------------------------}+data Top = Top ![Id] Expr -- arguments expression++type Atom = Expr+data Expr = Eval !Id Expr Expr+ | Match !Id ![Alt]+ | Prim !Id ![Atom]+ -- atomic+ | LetRec ![(Id,Atom)] Expr+ | Let !Id Atom Expr+ | Ap !Id ![Atom]+ | Con !(Con Atom) ![Atom]+ | Lit !Lit+ | Note !Note !Expr++data Note = Occur !Occur+data Occur = Never | Once | Many++data Lit = LitInt !Int+ | LitFloat !Double+ | LitBytes !Bytes++data Alt = Alt !Pat Expr++data Pat = PatVar !Id+ | PatCon !(Con Int) ![Id]+ | PatLit !Lit++data Con tag = ConId !Id+ | ConTag tag !Arity++{---------------------------------------------------------------+ pretty print Asm expressions+---------------------------------------------------------------}++instance Pretty Top where+ pretty (Top args expr) =+ nest 2 (text "\\" <> hsep (map pretty args) <+> text "->" <$> pretty expr)++{---------------------------------------------------------------+ expressions+---------------------------------------------------------------}++instance Pretty Expr where+ pretty = ppExprWith id++ppArg :: Expr -> Doc+ppArg = ppExprWith parens++ppExprWith :: (Doc -> Doc) -> Expr -> Doc+ppExprWith pars expr+ = case expr of+ Let x atom e -> pars $ align $ hang 3 (text "let" <+> ppBind (x,atom)) <$> (text "in" <+> pretty e)+ LetRec binds e -> pars $ align $ hang 7 (text "letrec" <+> vcat (map ppBind binds)) <$> nest 3 (text "in" <+> pretty e)+ Eval x e e' -> pars $ align $ hang 7 (text "let!" <+> pretty x <+> text "=" </> pretty e) + <$> nest 3 (text "in" <+> pretty e')+ Match x alts -> pars $ align $ hang 2 (text "match" <+> pretty x <+> text "with" <$> vcat (map pretty alts))+ Prim x args -> pars $ text "prim" <> char '[' <> pretty x <+> hsep (map ppArg args) <> char ']'+ Ap x [] -> pretty x+ Ap x args -> pars $ pretty x <+> hsep (map ppArg args)+ Con con [] -> pretty con+ Con con args -> pars $ pretty con <+> hsep (map ppArg args)+ Lit lit -> pretty lit+ Note note e -> pars $ align $ pretty note </> pretty e++instance Pretty a => Pretty (Con a) where+ pretty con =+ case con of+ ConId x -> pretty x+ ConTag tag arity -> text "(@" <> pretty tag <> char ',' <> pretty arity <> char ')'++instance Pretty Note where+ pretty (Occur occ) = angles (pretty occ)++instance Pretty Occur where+ pretty Never = text "never"+ pretty Once = text "once"+ pretty Many = text "many"++{---------------------------------------------------------------+ alternatives+---------------------------------------------------------------}++instance Pretty Alt where+ pretty (Alt pat expr) = + hang 2 (pretty pat <+> text "->" </> pretty expr)++instance Pretty Pat where+ pretty pat =+ case pat of+ PatCon con params -> pretty con <+> hsep (map pretty params)+ PatVar x -> pretty x+ PatLit lit -> pretty lit++{---------------------------------------------------------------+ literals and variables+---------------------------------------------------------------}++instance Pretty Lit where + pretty lit = + case lit of+ LitInt i -> pretty i+ LitFloat d -> pretty d+ LitBytes b -> dquotes (string (stringFromBytes b))++ppBind :: Pretty a => (Id, a) -> Doc+ppBind (x, atom) = + pretty x <+> text "=" <+> pretty atom
+ Lvm/Asm/Inline.hs view
@@ -0,0 +1,177 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Inline.hs 291 2012-11-08 11:27:33Z heere112 $+module Lvm.Asm.Inline (asmInline) where++import Data.Maybe+import Lvm.Asm.Data+import Lvm.Asm.Occur ( asmOccur )+import Lvm.Common.Id +import Lvm.Common.IdMap++{---------------------------------------------------------------+ Inline environment maps identifiers to their definition+---------------------------------------------------------------}+type Env = IdMap Expr++removeIds :: [Id] -> IdMap a -> IdMap a+removeIds = flip (foldr deleteMap)++{---------------------------------------------------------------+ asmInline+---------------------------------------------------------------}+asmInline :: AsmModule -> AsmModule+asmInline = fmap inlineTop . asmOccur++inlineTop :: Top -> Top+inlineTop (Top params expr)+ = Top params (inlineExpr emptyMap expr)++inlineExpr :: Env -> Expr -> Expr+inlineExpr env expr+ = case expr of+ -- dead variable+ Let _ (Note (Occur Never) _) e2+ -> inlineExpr env e2+ -- once+ Let x (Note (Occur Once) e1) e2+ -> let e1' = inlineExpr env e1 -- de-annotate+ in inlineExpr (extendMap x e1' env) e2++ -- trivial, inline everywhere+ Let x e1 e2 | trivial e1+ -> let e1' = inlineExpr env (deAnnotate e1)+ in inlineExpr (extendMap x e1' env) e2+ + Eval x e1 e2 | whnfTrivial e1+ -> let e1' = inlineExpr env (deAnnotate e1)+ in inlineExpr (extendMap x e1' env) e2++ -- inline-able let! binding?+ Eval x (Note (Occur Once) e1) e2 + -> let e1' = inlineExpr env e1 -- de-annotate+ in if firstuse x e2+ -- firstuse is true, we can inline immediately+ then let env' = extendMap x (Eval x e1' (Ap x [])) env -- NOTE: should we use a fresh id?+ in inlineExpr env' e2+ else let e2' = inlineExpr env e2+ in if firstuse x e2'+ -- firstuse became true after inlining! re-inline this definition again (is this too expensive?)+ then let env' = extendMap x (Eval x e1' (Ap x [])) emptyMap -- NOTE: should we use a fresh id?+ in inlineExpr env' e2'+ -- otherwise, don't inline this definition+ else Eval x (Note (Occur Once) e1') e2'+ + -- basic cases+ Let x e1 e2 -> let env' = deleteMap x env+ in Let x (inlineExpr env e1) (inlineExpr env' e2)+ + Eval x e1 e2 -> let env' = deleteMap x env + in Eval x (inlineExpr env e1) (inlineExpr env' e2)++ LetRec bs e -> let (bs',env') = inlineBinds env bs + in LetRec bs' (inlineExpr env' e)++ Match x alts -> case lookupMap x env of+ Just e -> -- trivial inlining of a let! binding leads to this configuration.+ -- a case-of-known transformation would actually remove this match.+ Eval x (Note (Occur Once) e) (Match x (inlineAlts env alts))+ Nothing -> Match x (inlineAlts env alts)++ Ap x [] -> fromMaybe (Ap x []) (lookupMap x env)+ Ap x args -> let args0 = inlineExprs env args+ in case lookupMap x env of+ Just e -> case e of+ Ap id1 args1 -> Ap id1 (args1 ++ args0) -- flatten applications+ Eval id1 e1 (Ap id2 []) | id1==id2 -- special case for the strict inliner+ -> Eval id1 e1 (Ap id1 args0) + _ -> Let x e (Ap x args) -- don't inline!+ Nothing -> Ap x args0+ Con con args -> Con (inlineCon env con) (inlineExprs env args)+ Prim x args -> Prim x (inlineExprs env args)+ Lit _ -> expr+ Note note e -> Note note (inlineExpr env e)++inlineCon :: Env -> Con Expr -> Con Expr+inlineCon env con+ = case con of+ ConTag tag arity -> ConTag (inlineExpr env tag) arity+ _ -> con++inlineExprs :: Env -> [Expr] -> [Expr]+inlineExprs env exprs+ = [inlineExpr env expr | expr <- exprs]++inlineBinds :: Env -> [(Id,Expr)] -> ([(Id,Expr)],Env)+inlineBinds env binds + = let env' = removeIds (map fst binds) env+ in ([(x,inlineExpr env' e) | (x,e) <- binds], env')++inlineAlts :: Env -> [Alt] -> [Alt]+inlineAlts env alts+ = [inlineAlt env alt | alt <- alts]++inlineAlt :: IdMap Expr -> Alt -> Alt+inlineAlt env (Alt pat expr)+ = Alt pat (inlineExpr (removeIds (patIds pat) env) expr)+ where+ patIds (PatVar x) = [x]+ patIds (PatCon _ xs) = xs+ patIds (PatLit _) = []+++{---------------------------------------------------------------+ deAnnotate+---------------------------------------------------------------}+deAnnotate :: Expr -> Expr+deAnnotate expr+ = case expr of+ Note _ e -> deAnnotate e+ _ -> expr++{---------------------------------------------------------------+ trivial +---------------------------------------------------------------}+trivial :: Expr -> Bool+trivial expr+ = case expr of+ Note _ e -> trivial e+ Ap _ [] -> True+ Con (ConId _) [] -> True+ Lit _ -> True+ _ -> False++whnfTrivial :: Expr -> Bool+whnfTrivial expr+ = case expr of+ Note _ e -> whnfTrivial e+ Con (ConId _) [] -> True+ Lit _ -> True+ _ -> False++{---------------------------------------------------------------+ firstuse+---------------------------------------------------------------}++firstuse :: Id -> Expr -> Bool+firstuse x = first x False++firsts :: Id -> Bool -> [Expr] -> Bool+firsts = foldl . first++first :: Id -> Bool -> Expr -> Bool+first x c expr+ = case expr of+ LetRec bs e -> firsts x c (map snd bs ++ [e])+ Let _ e1 e2 -> firsts x c [e1,e2]+ Eval _ e1 _ -> first x False e1+ Match _ _ -> False+ Prim _ args -> firsts x False args+ Ap y args | null args && y == x -> True+ | not (null args) -> firsts x c (Ap y [] : args)+ Con _ args -> firsts x c args+ Note _ e -> first x c e+ _ -> c
+ Lvm/Asm/Occur.hs view
@@ -0,0 +1,112 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Occur.hs 291 2012-11-08 11:27:33Z heere112 $+module Lvm.Asm.Occur (asmOccur) where++import Lvm.Asm.Data+import Lvm.Common.Id +import Lvm.Common.IdMap++{---------------------------------------------------------------+ Occ: maps identifiers to the number of syntactic+ occurrences+---------------------------------------------------------------}+type Occ = IdMap Int++addOcc :: Id -> Occ -> Occ+addOcc x = insertMapWith x 1 (+1)++delOcc :: Id -> IdMap Int -> IdMap Int+delOcc = deleteMap++unionOcc :: IdMap Int -> IdMap Int -> IdMap Int+unionOcc = unionMapWith (+)++unionOccs :: [IdMap Int] -> IdMap Int+unionOccs = foldr unionOcc emptyMap++occur :: Id -> Occ -> Occur+occur x occ+ = case lookupMap x occ of+ Just 0 -> Never+ Just 1 -> Once+ Just _ -> Many+ Nothing -> Never++{---------------------------------------------------------------+ asmOccur: annotate every Eval and Let binding with+ the number of syntactic occurrences.+---------------------------------------------------------------}+asmOccur :: AsmModule -> AsmModule+asmOccur = fmap occTop++occTop :: Top -> Top+occTop (Top x expr)+ = let (expr', _) = occExpr expr+ in Top x expr'++occExpr :: Expr -> (Expr,Occ)+occExpr expr+ = case expr of+ -- TODO: if we determine that a let bound variable is never used, + -- we can delete occurrences in its definition *if* an inliner + -- removes all dead let bindings. This would make the occurrence + -- analysis more precise+ Eval x e1 e2 -> let (e1',occ1) = occExpr e1+ (e2',occ2) = occExpr e2+ occ = unionOcc occ1 occ2+ in (Eval x (Note (Occur (occur x occ)) e1') e2', delOcc x occ)+ Let x e1 e2 -> let (e2',occ2) = occExpr e2 + (e1',occ1) = occExpr e1+ occ = unionOcc occ1 occ2+ in (Let x (Note (Occur (occur x occ)) e1') e2', delOcc x occ)+ LetRec bs e -> let (e',occ1) = occExpr e+ (ids,es) = unzip bs+ (es',occ2) = occExprs es+ occ = unionOcc occ1 occ2+ bs' = [(x, Note (Occur (occur x occ)) e2) | (x,e2) <- zip ids es']+ in (LetRec bs' e', foldr delOcc occ ids) ++ Match x alts -> let (alts',occ) = occAlts alts+ in (Match x alts',addOcc x occ)+ Ap x atoms -> let (atoms',occ) = occExprs atoms+ in (Ap x atoms',addOcc x occ)+ Con con atoms -> let (atoms',occ1) = occExprs atoms+ (con',occ2) = occCon con+ in (Con con' atoms',unionOcc occ1 occ2)+ Prim x atoms -> let (atoms',occ) = occExprs atoms+ in (Prim x atoms',occ)+ Lit _ -> (expr,emptyMap)+ Note note e -> let (expr',occ) = occExpr e + in (Note note expr',occ)++occCon :: Con Expr -> (Con Expr, Occ) +occCon con+ = case con of+ ConTag tag arity -> let (tag',occ) = occExpr tag in (ConTag tag' arity,occ)+ _ -> (con,emptyMap)++occExprs :: [Expr] -> ([Expr],Occ)+occExprs exprs+ = let (exprs',occs) = unzip (map occExpr exprs)+ in (exprs',unionOccs occs)++occAlts :: [Alt] -> ([Alt], IdMap Int)+occAlts alts+ = let (alts',occs) = unzip (map occAlt alts)+ in (alts',unionOccs occs)++occAlt :: Alt -> (Alt, IdMap Int)+occAlt (Alt pat expr)+ = let (expr',occ) = occExpr expr+ in (Alt pat expr',foldr delOcc occ (patIds pat))+ where+ patIds (PatVar x) = [x]+ patIds (PatCon _ ids) = ids+ patIds (PatLit _) = []+++
+ Lvm/Asm/ToLvm.hs view
@@ -0,0 +1,324 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: ToLvm.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Asm.ToLvm (asmToLvm) where++import Control.Exception ( assert )+import Data.List +import Lvm.Asm.Data+import Lvm.Common.Id+import Lvm.Common.IdMap +import Lvm.Data+import Lvm.Instr.Data hiding ( Con(..), Alt(..), Pat(..) )+import Lvm.Instr.Resolve (instrResolve)+import Lvm.Instr.Rewrite (instrRewrite)+import qualified Lvm.Asm.Data as Asm+import qualified Lvm.Instr.Data as Instr++{---------------------------------------------------------------+ asmToLvm: generate instructions from Asm expressions+---------------------------------------------------------------}+asmToLvm :: AsmModule -> LvmModule+asmToLvm m = fmap (codegen (initialEnv m)) m++codegen :: Env -> Top -> [Instr]+codegen env = instrRewrite . instrResolve . cgTop env++{---------------------------------------------------------------+ top-level declarations+---------------------------------------------------------------}+cgTop :: Env -> Top -> [Instr]+cgTop env (Top params expr)+ = [ARGCHK (length params)] ++ [ATOM (cgParams env params ++ cgExpr env expr)] ++ [ENTER]++cgParams :: Env -> [Id] -> [Instr]+cgParams _ = map PARAM . reverse++{---------------------------------------------------------------+ expressions+---------------------------------------------------------------}+cgExpr :: Env -> Expr -> [Instr]+cgExpr env expr+ = case expr of+ -- optimized schemes+ Eval id1 (Note (Occur Once) e1) (Match id2 alts) | id1 == id2 && whnf env e1+ -> ATOM (cgExpr env e1) : cgMatch env alts+ Eval id1 (Note (Occur Once) e1) (Match id2 alts) | id1 == id2 + -> EVAL 0 [ATOM (cgExpr env e1),ENTER] : cgMatch env alts+ Eval x e1 e2 | whnf env e1+ -> [ATOM (cgExpr env e1),VAR x] ++ cgExpr env e2+ Eval id1 e1 (Ap id2 []) | id1 == id2+ -> cgExpr env e1++ -- basic cases+ LetRec binds e -> cgLetRec env binds ++ cgExpr env e+ Let x atom e -> cgLet env x atom ++ cgExpr env e+ Eval x e1 e2 -> [EVAL 0 [ATOM (cgExpr env e1),ENTER],VAR x] ++ cgExpr env e2+ Match x alts -> cgVar env x ++ cgMatch env alts+ Prim x args -> cgPrim env x args+ Note _ e -> cgExpr env e+ atom -> cgAtom env atom++{---------------------------------------------------------------+ let bindings+---------------------------------------------------------------}++cgLet :: Env -> Id -> Expr -> [Instr]+cgLet env x atom = cgAtom env atom ++ [VAR x]++cgLetRec :: Env -> [(Id, Atom)] -> [Instr]+cgLetRec env binds = concat (map (cgAlloc env) binds ++ map (cgInit env) binds)++cgAlloc :: Env -> (Id, Atom) -> [Instr]+cgAlloc env (x,atom) = [ATOM (cgAlloc' env atom),VAR x]++cgAlloc' :: Env -> Atom -> [Instr]+cgAlloc' env atom+ = case atom of+ Asm.Ap _ args -> [ALLOCAP (length args + 1)]+ Asm.Let _ _ e2 -> cgAlloc' env e2+ Asm.LetRec _ e2 -> cgAlloc' env e2+ Asm.Note _ e -> cgAlloc' env e+ Asm.Con (ConId x) args + -> [ALLOCCON (conFromId x (length args) env)]+ Asm.Con (ConTag tag arity) args -- TODO: tag may not be recursively bound!+ -> assert (arity == length args) $ -- "AsmToCode.cgAlloc': constructor arity doesn't match arguments"+ [PUSHINT arity] ++ cgAtom env tag ++ [ALLOC]+ Asm.Lit _ -> error "AsmToCode.cgAlloc': literal in recursive binding."+ _ -> error "AsmToCode.cgAlloc': non-atomic expression encountered."++cgInit :: Env -> (Id, Atom) -> [Instr]+cgInit env (x,atom) = [INIT (cgInit' env x atom)]++cgInit' :: Env -> Id -> Atom -> [Instr]+cgInit' env x atom+ = case atom of+ Asm.Ap y args -> cgArgs env args ++ cgVar env y ++ [PACKAP (varFromId x) (length args + 1)]+ Asm.Let y e1 e2 -> cgLet env y e1 ++ cgInit' env y e2+ Asm.LetRec bs e2 -> cgLetRec env bs ++ cgInit' env x e2+ Asm.Note _ e -> cgInit' env x e+ Asm.Con (ConId y) args + -> cgArgs env args ++ [PACKCON (conFromId y (length args) env) (varFromId x)]+ Asm.Con (ConTag _ arity) args+ -> cgArgs env args ++ [PACK arity (varFromId x)]+ Asm.Lit _ -> error "AsmToCode.cgInit: literal in recursive binding."+ _ -> error "AsmToCode.cgInit: non-atomic expression encountered."++++{---------------------------------------------------------------+ alternatives+ result alternatives are 'normalized': the default alternative+ is always there and comes first.+---------------------------------------------------------------}++cgMatch :: Env -> [Alt] -> [Instr]+cgMatch env alts+ = case partition isVarAlt alts of+ ([],as) -> cgAlts env (Instr.Alt Instr.PatDefault []) as+ ([alt],as) -> cgAlts env (cgAlt env alt) as+ _ -> error "AsmToCode.cgMatch: multiple default patterns"+ where+ isVarAlt (Alt (PatVar _) _) = True+ isVarAlt _ = False++cgAlts :: Env -> Instr.Alt -> [Alt] -> [Instr]+cgAlts env def alts+ | all isConIdAlt alts = [MATCHCON (def:map (cgAlt env) alts)]+ | all isConAlt alts = [MATCH (def:map (cgAltTag env) alts)]+ | all isIntAlt alts = [MATCHINT (def:map (cgAlt env) alts)]+ | otherwise = error "AsmToCode.cgMatch: unknown or mixed type patterns"+ where+ isConIdAlt (Alt (PatCon (ConId _) _) _) = True+ isConIdAlt _ = False++ isConAlt (Alt (PatCon _ _) _) = True+ isConAlt _ = False++ isIntAlt (Alt (PatLit (LitInt _)) _) = True+ isIntAlt _ = False++cgAlt :: Env -> Alt -> Instr.Alt+cgAlt env (Alt pat expr)+ = case pat of+ PatCon (ConId x) params + -> Instr.Alt (Instr.PatCon (conFromId x (length params) env))+ [ATOM (map PARAM (reverse params) ++ cgExpr env expr)]+ PatLit (LitInt i) + -> Instr.Alt (Instr.PatInt i) [ATOM (cgExpr env expr)]+ PatVar x + -> Instr.Alt Instr.PatDefault [ATOM (PARAM x : cgExpr env expr)]+ _ + -> error "AsmToCode.cgAlt: unknown pattern"++cgAltTag :: Env -> Alt -> Instr.Alt+cgAltTag env (Alt pat expr)+ = case pat of+ PatCon (ConTag tag arity) params + -> Instr.Alt (Instr.PatTag tag arity)+ [ATOM (map PARAM (reverse params) ++ cgExpr env expr)] + PatCon (ConId x) params + -> let (tag,arity) = tagArityFromId x (length params) env+ in Instr.Alt (Instr.PatTag tag arity)+ [ATOM (map PARAM (reverse params) ++ cgExpr env expr)]+ PatVar x + -> Instr.Alt Instr.PatDefault [ATOM (PARAM x : cgExpr env expr)]+ _ + -> error "AsmToCode.cgAltTag: invalid pattern"++{---------------------------------------------------------------+ primitives+---------------------------------------------------------------}++cgPrim :: Env -> Id -> [Atom] -> [Instr]+cgPrim env x args+ = case lookupInstr x env of+ Nothing -> case lookupGlobal x env of+ Nothing -> error ("AsmToCode.cgPrim: unknown primitive " ++ show x)+ Just arity -> if arity /= length args+ then error ("AsmToCode.cgPrim: unsaturated primitive " ++ show x)+ else result (CALL (Global x 0 arity))+ Just instr+ | isCATCH instr -> case args of+ [handler,atom] -> let y = idFromString "@catch@" in+ cgAtom env handler ++ + [CATCH [EVAL 0 (cgAtom env atom ++[ENTER]),VAR y]]+ _ -> error "AsmToCode.cgPrim: CATCH expects 2 arguments"+ | otherwise -> result instr+ where+ result instr = [ATOM (cgArgs env args ++ [instr])]++{---------------------------------------------------------------+ atomic expressions+---------------------------------------------------------------}++cgAtom :: Env -> Expr -> [Instr]+cgAtom env atom = [ATOM (cgAtom' env atom)]++cgAtom' :: Env -> Expr -> [Instr]+cgAtom' env atom+ = case atom of+ Ap x args -> cgArgs env args ++ cgVar env x +++ (if null args then [] else [NEWAP (length args + 1)])+ Lit lit -> cgLit lit+ Let x e1 e2 -> cgLet env x e1 ++ cgAtom' env e2+ LetRec bs e2 -> cgLetRec env bs ++ cgAtom' env e2+ Note _ e -> cgAtom' env e+ Con (ConId x) args + -> cgArgs env args ++ [NEWCON (conFromId x (length args) env) ]+ Con (ConTag tag arity) args + -> cgArgs env args ++ cgAtom env tag ++ [NEW arity]+ + -- optimizer: inlined strict bindings + Eval x e1 e2 | whnf env e1+ -> [ATOM (cgExpr env e1), VAR x] ++ cgAtom' env e2+ Eval x e1 e2+ -> [EVAL 0 [ATOM (cgExpr env e1), ENTER], VAR x] ++ cgAtom' env e2+++ _ -> error "AsmToCode.cgAtom: non-atomic expression encountered"++cgArgs :: Env -> [Atom] -> [Instr]+cgArgs env args+ = concatMap (cgAtom env) (reverse args)+++{---------------------------------------------------------------+ literals and variables+---------------------------------------------------------------}++cgLit :: Lit -> [Instr]+cgLit lit+ = case lit of+ LitInt i -> [PUSHINT i]+ LitFloat d -> [PUSHFLOAT d]+ LitBytes b -> [PUSHBYTES b 0]++cgVar :: Env -> Id -> [Instr]+cgVar env x+ = case lookupGlobal x env of+ Nothing -> [PUSHVAR (varFromId x)]+ Just arity -> [PUSHCODE (Global x 0 arity)]++{---------------------------------------------------------------+ whnf: returns True when the expression puts a weak head normal form+ value on the stack.+---------------------------------------------------------------}++whnf :: Env -> Expr -> Bool+whnf env expr+ = case expr of+ LetRec _ e -> whnf env e+ Let _ _ e2 -> whnf env e2+ Eval _ _ e2 -> whnf env e2+ Match _ alts -> all (whnfAlt env) alts+ Prim x _ -> whnfPrim env x+ Ap {} -> False+ Con {} -> True+ Lit {} -> True+ Note _ e -> whnf env e++whnfAlt :: Env -> Alt -> Bool+whnfAlt env (Alt _ e) = whnf env e++whnfPrim :: Env -> Id -> Bool+whnfPrim env x+ = case lookupInstr x env of+ Nothing -> False -- TODO: look at the type of a primitive+ Just instr -> strictResult instr+++{---------------------------------------------------------------+ the code generation environment+---------------------------------------------------------------}+data Env = Env { aritiesMap :: IdMap Arity+ , instrsMap :: IdMap Instr+ , consMap :: IdMap (Tag,Arity)+ }++lookupInstr :: Id -> Env -> Maybe Instr+lookupInstr x = lookupMap x . instrsMap++lookupGlobal :: Id -> Env -> Maybe Arity+lookupGlobal x = lookupMap x . aritiesMap++varFromId :: Id -> Var+varFromId x = Var x 0 0++conFromId :: Id -> Arity -> Env -> Instr.Con+conFromId x argcount env+ = let (tag,arity) = tagArityFromId x argcount env+ in Instr.Con x 0 arity tag++tagArityFromId :: Id -> Arity -> Env -> (Tag, Arity)+tagArityFromId x argcount env+ = case lookupMap x (consMap env) of+ Just (tag,arity) -> if arity /= argcount+ then error ("AsmToCode.conFromId: unsaturated constructor " ++ show x)+ else (tag,arity)+ Nothing -> error ("AsmToCode.conFromId: undeclared constructor " ++ show x)++-- create an initial environment from the declarations+initialEnv :: AsmModule -> Env+initialEnv asmMod = Env globals instrs cons+ where+ globals = mapFromList [(declName d,getArity d) | d <- moduleDecls asmMod+ , isDeclValue d || isDeclAbstract d || isDeclExtern d ]++ instrs = mapFromList [(declName d,instrFromEx d) | d <- moduleDecls asmMod+ , isDeclExtern d, externCall d == CallInstr]++ cons = mapFromList [(declName d,(conTag d,declArity d)) | d <- moduleDecls asmMod+ , isDeclCon d]++ getArity (DeclValue{valueValue=Top args _}) = length args + getArity decl = declArity decl++ instrFromEx x = case externName x of+ Plain s -> instrFromName s+ Decorate s -> instrFromName s+ Ordinal i -> instrFromOpcode i
+ Lvm/Common/Byte.hs view
@@ -0,0 +1,148 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Byte.hs 291 2012-11-08 11:27:33Z heere112 $+module Lvm.Common.Byte+ ( Byte, Bytes + , Monoid(..), unit, isEmpty+ , bytesLength, writeBytes, bytesFromList, listFromBytes+ , bytesFromString, stringFromBytes, bytesFromInt32, byteFromInt8+ , readByteList, int32FromByteList, stringFromByteList, bytesFromByteList+ ) where++import qualified Control.Exception as CE (catch, IOException) +import Data.Monoid+import Data.Word+import System.Exit+import System.IO++{----------------------------------------------------------------+ types+----------------------------------------------------------------}+type Byte = Word8++data Bytes = Nil+ | Cons Byte !Bytes -- Byte is not strict since LvmWrite uses it lazily right now.+ | Cat !Bytes !Bytes++instance Show Bytes where+ show bs = show (listFromBytes bs)++instance Eq Bytes where+ bs1 == bs2 = listFromBytes bs1 == listFromBytes bs2++{----------------------------------------------------------------+ conversion to bytes+----------------------------------------------------------------}+byteFromInt8 :: Int -> Byte+byteFromInt8 = toEnum+ +intFromByte :: Byte -> Int+intFromByte = fromEnum++bytesFromString :: String -> Bytes+bytesFromString + = bytesFromList . map (toEnum . fromEnum)++stringFromBytes :: Bytes -> String+stringFromBytes + = map (toEnum . fromEnum) . listFromBytes ++bytesFromInt32 :: Int -> Bytes -- 4 byte big-endian encoding+bytesFromInt32 i+ = let n0 = if i < 0 then max32+i+1 else i+ n1 = div n0 256+ n2 = div n1 256+ n3 = div n2 256+ xs = map (byteFromInt8 . flip mod 256) [n3,n2,n1,n0]+ in bytesFromList xs++max32 :: Int +max32 = 2^(32::Int) -1 -- Bastiaan (Todo: check)++{----------------------------------------------------------------+ Byte lists+----------------------------------------------------------------}++instance Monoid Bytes where+ mempty = Nil+ mappend bs Nil = bs + mappend Nil cs = cs+ mappend bs cs = Cat bs cs ++isEmpty :: Bytes -> Bool+isEmpty Nil = True+isEmpty (Cons _ _) = False+isEmpty (Cat bs cs) = isEmpty bs && isEmpty cs++unit :: Byte -> Bytes+unit = (`Cons` Nil)++listFromBytes :: Bytes -> [Byte]+listFromBytes = loop []+ where+ loop next bs+ = case bs of+ Nil -> next+ Cons b xs -> b:loop next xs+ Cat xs ys -> loop (loop next ys) xs++bytesFromList :: [Byte] -> Bytes+bytesFromList = foldr Cons Nil++bytesLength :: Bytes -> Int+bytesLength = loop 0+ where+ loop n bs+ = case bs of+ Nil -> n+ Cons _ xs -> (loop $! (n+1)) xs+ Cat xs ys -> loop (loop n ys) xs++writeBytes :: FilePath -> Bytes -> IO ()+writeBytes path bs+ = do{ h <- openBinaryFile path WriteMode+ ; writeHandle h bs+ ; hClose h++ }+ +writeHandle :: Handle -> Bytes -> IO ()+writeHandle h bs+ = case bs of+ Nil -> return ()+ Cons b xs -> do{ hPutChar h (toEnum (fromEnum b)); writeHandle h xs }+ Cat xs ys -> do{ writeHandle h xs; writeHandle h ys }+++{----------------------------------------------------------------+ Byte lists+----------------------------------------------------------------}+int32FromByteList :: [Byte] -> (Int,[Byte])+int32FromByteList bs+ = case bs of+ n3:n2:n1:n0:cs -> let i = int32FromByte4 n3 n2 n1 n0 in seq i (i,cs)+ _ -> error "Byte.int32FromBytes: invalid byte stream"+ +int32FromByte4 :: Byte -> Byte -> Byte -> Byte -> Int +int32FromByte4 n0 n1 n2 n3+ = (intFromByte n0*16777216) + (intFromByte n1*65536) + (intFromByte n2*256) + intFromByte n3+++stringFromByteList :: [Byte] -> String+stringFromByteList = map (toEnum . fromEnum)++bytesFromByteList :: [Byte] -> Bytes+bytesFromByteList = bytesFromList++readByteList :: FilePath -> IO [Byte]+readByteList path + = do{ h <- openBinaryFile path ReadMode+ ; xs <- hGetContents h+ ; seq (last xs) (hClose h)+ ; return (map (toEnum . fromEnum) xs)+ } `CE.catch` (\exception ->+ let message = show (exception :: CE.IOException) ++ "\n\nUnable to read from file " ++ show path+ in do { putStrLn message; exitWith (ExitFailure 1) })
+ Lvm/Common/Id.hs view
@@ -0,0 +1,310 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Id.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Common.Id + ( Id+ -- essential used in "asm" and "lvm"+ , stringFromId, idFromString, idFromStringEx, dummyId+ -- exotic: only used in the core compiler+ , freshIdFromId, getNameSpace, setNameSpace, NameSupply, newNameSupply+ , splitNameSupply, splitNameSupplies, freshId, mapWithSupply+ -- very exotic: only used internally for IdMap's that use IntMap+ , intFromId, idFromInt+ ) where++import Data.IORef+import Data.Int (Int32)+import Data.List+import System.IO.Unsafe+import Text.PrettyPrint.Leijen+import qualified Data.IntMap as IntMap++----------------------------------------------------------------+-- Types+----------------------------------------------------------------+newtype Id = Id Int32+ +intFromId :: Id -> Int+intFromId (Id i) = fromIntegral i+idFromInt :: Int -> Id+idFromInt i = Id (fromIntegral i)++----------------------------------------------------------------+-- Names: the symbol table+----------------------------------------------------------------+data Names = Names Int (IntMap.IntMap [String])++namesRef :: IORef Names+namesRef = unsafePerformIO (newIORef emptyNames)++emptyNames :: Names+emptyNames = Names 0 IntMap.empty++idFromString :: String -> Id+idFromString = idFromStringEx (0::Int)++idFromStringEx :: Enum a => a -> String -> Id+idFromStringEx ns name+ = unsafePerformIO $+ do{ names <- readIORef namesRef+ ; let (x, names') = insertName (fromEnum ns) name names+ ; writeIORef namesRef names'+ ; return x+ }++stringFromId :: Id -> String+stringFromId x@(Id i)+ | isUniq i = '.' : show (extractUniq i)+ | otherwise = unsafePerformIO $+ do{ names <- readIORef namesRef+ ; case lookupId x names of+ Nothing -> error "Id.nameFromId: unknown id"+ Just name -> return name+ }+++----------------------------------------------------------------+-- fresh identifiers without a nice name+-- but the advantage of a pure interface+----------------------------------------------------------------+newtype NameSupply = NameSupply (IORef Int32)++newNameSupply :: IO NameSupply+newNameSupply+ = do{ ref <- newIORef 0+ ; return (NameSupply ref)+ }++splitNameSupply :: NameSupply -> (NameSupply,NameSupply)+splitNameSupply supply = (supply,supply)++splitNameSupplies :: NameSupply -> [NameSupply]+splitNameSupplies = repeat++freshIdFromId :: Id -> NameSupply -> (Id,NameSupply)+freshIdFromId x supply@(NameSupply ref)+ = unsafePerformIO (do{ i <- readIORef ref+ ; writeIORef ref (i+1)+ ; let name = stringFromId x ++ "." ++ show i+ x1 = idFromString name+ x2 = setNameSpace (getNameSpace x :: Int) x1+ ; seq name $ seq x2 $ return (x2,supply)+ })++freshId :: NameSupply -> (Id,NameSupply)+freshId supply@(NameSupply ref)+ = unsafePerformIO (do{ i <- readIORef ref+ ; writeIORef ref (i+1)+ ; return (Id (initUniq i), supply)+ })++mapWithSupply :: (NameSupply -> a -> b) -> NameSupply -> [a] -> [b]+mapWithSupply f = zipWith f . splitNameSupplies++----------------------------------------------------------------+-- Bit masks used within an Id+--+-- 0x | 0 0 0 0 | 0 0 0 0 |+-- | | F E | sort (=namespace) of the id (TODO: just 128 entries is too few)+-- | F | F F | hash index in the hash table+-- | 7 F F | | index in the list of id's in the leaves of the hash table+-- | | 1 | unique id (no name available)+-- | 7 F F F | F F | unique number of unique id+----------------------------------------------------------------+dummyId :: Id+dummyId = Id 0x7FFFFFF1++shiftSort, maxSort :: Int32+shiftSort = 0x00000002+maxSort = 0x7F++maxHash, shiftHash :: Int32+maxHash = 0xFFF+shiftHash = 0x00000100++shiftIdx, maxIdx :: Int32+shiftIdx = 0x00100000+maxIdx = 0x7FF++shiftUniq,maxUniq :: Int32+shiftUniq = 0x00000100+maxUniq = 0x007FFFFF+-- flagUniq = 0x00000001++extractBits, clearBits, initBits :: Int32 -> Int32 -> Int32 -> Int32+extractBits shift maxb i+ = (i `div` shift) `mod` (maxb+1)++clearBits shift maxb i+ = i - (extractBits shift maxb i * shift)++initBits shift v i+ = i + (shift * v)++extractSort :: Int32 -> Int32+extractSort = extractBits shiftSort maxSort++clearSort :: Int32 -> Int32+clearSort = clearBits shiftSort maxSort++initSort :: Int32 -> Int32 -> Int32+initSort = initBits shiftSort++extractHash :: Int32 -> Int32+extractHash = extractBits shiftHash maxHash++initHash :: Int32 -> Int32+initHash h = initBits shiftHash h 0++extractIdx :: Int32 -> Int32+extractIdx = extractBits shiftIdx maxIdx++initIdx :: Int32 -> Int32 -> Int32+initIdx = initBits shiftIdx++extractUniq :: Int32 -> Int32+extractUniq = extractBits shiftUniq maxUniq++initUniq :: Int32 -> Int32+initUniq u = initBits shiftUniq u 1++isUniq :: Int32 -> Bool+isUniq = odd++----------------------------------------------------------------+-- The core of the symbol table: lookupId and insertName+----------------------------------------------------------------+instance Eq Id where+ Id i1 == Id i2 = i1 == i2++-- fast, but predictable+instance Ord Id where+ compare x1@(Id i1) x2@(Id i2) =+ case compare (extractHash i1) (extractHash i2) of+ LT -> LT+ EQ | i1 == i2 -> EQ+ | otherwise -> compare (stringFromId x1) (stringFromId x2)+ GT -> GT++instance Show Id where+ show x = "\"" ++ stringFromId x ++ "\""++instance Pretty Id where+ pretty = string . stringFromId++getNameSpace :: Enum a => Id -> a+getNameSpace (Id i)+ = toEnum (fromIntegral (extractSort i))++setNameSpace :: Enum a => a -> Id -> Id+setNameSpace srt (Id i)+ | s > maxSort = error "Id.setIdSort: sort index out of range"+ | otherwise = Id (initSort s (clearSort i))+ where+ s = fromIntegral (fromEnum srt)+++lookupId :: Id -> Names -> Maybe String+lookupId (Id i) (Names _ m)+ = let idx = extractIdx i+ h = extractHash i+ in case IntMap.lookup (fromIntegral h) m of+ Nothing -> Nothing+ Just xs -> Just (index idx xs)+ where+ index 0 (x:_) = x+ index idx (_:xx) = index (idx-1) xx+ index _ [] = error "Id.lookupId: corrupted symbol table"++insertName :: Int -> String -> Names -> (Id, Names)+insertName srt name names+ = let (x, names') = insertName' name names+ in (setNameSpace srt x, names')++insertName' :: String -> Names -> (Id,Names)+insertName' name (Names fresh m) + | idx > maxIdx = error ("Id.insertName: too many names with the same hash value (" ++ show name ++ ")")+ | otherwise = (Id (initIdx idx h), Names fresh m1)+ where+ hname = hash name+ h = initHash hname+ (old, m1) = IntMap.insertLookupWithKey upd (fromIntegral hname) [name] m+ (idx, new) = maybe (0, [name]) (insertIdx name) old+ upd _ _ _ = new++-- [insertIdx] returns the index of an element if it exists already, or+-- appends the element and returns its index.+insertIdx :: Eq a => a -> [a] -> (Int32,[a])+insertIdx y = walk 0+ where+ walk idx [] = (idx,[y])+ walk idx xs@(x:xx) | x == y = (idx,xs)+ | otherwise = let (idx',xx') = walk (idx+1) xx+ in (idx',x:xx')++----------------------------------------------------------------+-- Hashing+----------------------------------------------------------------+hash :: String -> Int32+hash name+ = (hashx name `mod` prime) `mod` maxHash+ where+ prime = 32537 --65599 -- require: prime < maxHash+++-- simple hash function that performs quite good in practice+hashx :: String -> Int32+hashx = foldl' gobble 0+ where+ gobble n c = n*65599 + fromIntegral (fromEnum c)++-----------------------------------------------------------------------------+{-+import Bits+import Word++-- the [hashpjw] algorithm, see dragon book, section 7.6, page 436.+hashpjw :: String -> Int+hashpjw name+ = word32ToInt (foldlStrict gobble (intToWord32 0) name)+ where+ gobble n c = let h = (shiftL n 4) + intToWord32 (fromEnum c)+ high = shiftR h 24+ g = shiftL high 24+ in if (g /= 0)+ then xor (xor h high) g+ else h+-}++{-+primes xs = case xs of+ [] -> []+ (x:xx) -> x:primes (filter ((/=0).(`mod`x)) xx)++-}++{-+,32537,32561,32563,32569,32573,32579,32587,32603,32609,32611,32621,32633,32647,3+2653,32687,32693,32707,32713,32717,32719,32749,32771,32779,32783,32789,32797,328+01,32803,32831,32833,32839,32843,32869,32887,32909,32911,32917,32933,32939,32941+,32957,32969,32971,32983,32987,32993,32999,33013,33023,33029,33037,33049,33053,3+3071,33073,33083,33091,33107,33113,33119,33149,33151,33161,33179,33181,33191,331+99,33203,33211,33223,33247,33287,33289,33301,33311,33317,33329,33331,33343,33347+,33349,33353,33359,33377,33391,33403,33409,33413,33427,33457,33461,33469,33479,3+3487,33493,33503,33521,33529,33533,33547,33563,33569,33577,33581,33587,33589,335+99,33601,33613,33617,33619,33623,33629,33637,33641,33647,33679,33703,33713,33721++,50891,50893,50909,50923,50929,50951,50957,50969,50971,50989,50993,51001,51031,5+1043,51047,51059,51061,51071,51109,51131,51133,51137,51151,51157,51169,51193,511+97,51199,51203,51217,51229,51239,51241,51257,51263,51283,51287,51307,51329,51341+,51343,51347,51349,51361,51383,51407,51413,51419,51421,51427,51431,51437,51439,5+1449,51461,51473,51479,51481,51487,51503,51511,51517,51521,51539,51551,51563,515+77,51581,51593,51599,51607,51613,51631,51637,51647,51659,51673,51679,51683,51691+,51713,51719,51721,51749,51767,51769,51787,51797,51803,51817,51827,51829,51839,5+1853,51859,51869,51871,51893,51899,51907,51913,51929,51941,51949,51971,51973,519+77,51991,52009,52021,52027+-}
+ Lvm/Common/IdMap.hs view
@@ -0,0 +1,129 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: IdMap.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Common.IdMap+ ( IdMap, Id+ -- essential: used by "Asm" and "Lvm"+ , emptyMap, singleMap, elemMap, mapMap, insertMap, extendMap+ , insertMapWith, lookupMap, findMap, filterMap, listFromMap+ , mapMapWithId, unionMap, unionMapWith, updateMap+ -- exotic: used by core compiler+ , foldMap, deleteMap, filterMapWithId, mapFromList+ , unionMaps, diffMap, unionlMap, foldMapWithId+ , isEmptyMap, sizeMap+ ) where++import Data.List+import Data.Maybe+import qualified Data.IntMap as IntMap+import Lvm.Common.Id+import Control.Arrow (first)++----------------------------------------------------------------+-- IdMap+----------------------------------------------------------------+newtype IdMap a = IdMap (IntMap.IntMap a)++emptyMap :: IdMap a+emptyMap = IdMap IntMap.empty++singleMap :: Id -> a -> IdMap a+singleMap x a = insertMap x a emptyMap++isEmptyMap :: IdMap a -> Bool+isEmptyMap (IdMap m) = IntMap.null m+++elemMap :: Id -> IdMap a -> Bool+elemMap x (IdMap m)+ = IntMap.member (intFromId x) m++mapMap :: (a -> b) -> IdMap a -> IdMap b+mapMap f (IdMap m)+ = IdMap (IntMap.map f m)++mapMapWithId :: (Id -> a -> b) -> IdMap a -> IdMap b+mapMapWithId f (IdMap m)+ = IdMap (IntMap.mapWithKey (\i x -> f (idFromInt i) x) m)+++insertMap :: Id -> a -> IdMap a -> IdMap a+insertMap x a (IdMap m)+ = IdMap (IntMap.insertWith err (intFromId x) a m)+ where+ err _ _ = error ("IdMap.insertMap: duplicate id " ++ show x)++insertMapWith :: Id -> a -> (a -> a) -> IdMap a -> IdMap a+insertMapWith x a f (IdMap m)+ = IdMap (IntMap.insertWith (const f) (intFromId x) a m)++updateMap :: Id -> a -> IdMap a -> IdMap a+updateMap x a (IdMap m)+ = IdMap (IntMap.insertWith const (intFromId x) a m)++deleteMap :: Id -> IdMap a -> IdMap a+deleteMap x(IdMap m)+ = IdMap (IntMap.delete (intFromId x) m)++extendMap :: Id -> a -> IdMap a -> IdMap a+extendMap x a (IdMap m)+ = IdMap (IntMap.insertWith const (intFromId x) a m)++lookupMap :: Id -> IdMap a -> Maybe a+lookupMap x (IdMap m)+ = IntMap.lookup (intFromId x) m++filterMap :: (a -> Bool) -> IdMap a -> IdMap a+filterMap p (IdMap m)+ = IdMap (IntMap.filter p m)++filterMapWithId :: (Id -> a -> Bool) -> IdMap a -> IdMap a+filterMapWithId p (IdMap m)+ = IdMap (IntMap.filterWithKey (\i x -> p (idFromInt i) x) m)++findMap :: Id -> IdMap a -> a+findMap x = fromMaybe (error msg) . lookupMap x+ where + msg = "IdMap.findMap: unknown identifier " ++ show x++-- sort is needed to not rely on an id's index+listFromMap :: IdMap a -> [(Id,a)]+listFromMap (IdMap idmap)+ = sortBy (\x y -> fst x `compare` fst y) + $ map (first idFromInt) (IntMap.toList idmap)++mapFromList :: [(Id,a)] -> IdMap a+mapFromList = IdMap . IntMap.fromList . map (first intFromId)++diffMap :: IdMap a -> IdMap a -> IdMap a+diffMap (IdMap map1) (IdMap map2)+ = IdMap (IntMap.difference map1 map2)++unionMap :: IdMap a -> IdMap a -> IdMap a+unionMap (IdMap map1) (IdMap map2)+ = IdMap (IntMap.unionWith err map1 map2)+ where+ err _ _ = error "IdMap.unionMap: duplicate identifiers"++unionMapWith :: (a->a->a) -> IdMap a -> IdMap a -> IdMap a+unionMapWith f (IdMap map1) (IdMap map2)+ = IdMap (IntMap.unionWith f map1 map2)++unionlMap :: IdMap a -> IdMap a -> IdMap a+unionlMap (IdMap map1) (IdMap map2) = IdMap (map1 `IntMap.union` map2)++unionMaps :: [IdMap a] -> IdMap a+unionMaps = foldr unionMap emptyMap++foldMapWithId :: (Id -> a -> b -> b) -> b -> IdMap a -> b+foldMapWithId f z (IdMap m) = IntMap.foldWithKey (f . idFromInt) z m++foldMap :: (a -> b -> b) -> b -> IdMap a -> b+foldMap f z (IdMap m) = IntMap.fold f z m++sizeMap :: IdMap a -> Int+sizeMap (IdMap m) = IntMap.size m
+ Lvm/Common/IdSet.hs view
@@ -0,0 +1,69 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: IdSet.hs 291 2012-11-08 11:27:33Z heere112 $++-- this module is exotic, only used by the core compiler+-- but it works with any IdMap+module Lvm.Common.IdSet+ ( IdSet, Id+ , emptySet, singleSet, elemSet, filterSet, foldSet+ , insertSet, deleteSet, unionSet, unionSets, diffSet+ , listFromSet, setFromList, sizeSet, isEmptySet+ ) where++import Data.IntSet (IntSet)+import Data.List (sort)+import Lvm.Common.Id+import qualified Data.IntSet as IntSet++----------------------------------------------------------------+-- IdSet+----------------------------------------------------------------++newtype IdSet = IdSet IntSet++emptySet :: IdSet+emptySet = IdSet IntSet.empty++singleSet :: Id -> IdSet+singleSet = IdSet . IntSet.singleton . intFromId++elemSet :: Id -> IdSet -> Bool+elemSet x (IdSet s) = IntSet.member (intFromId x) s++filterSet :: (Id -> Bool) -> IdSet -> IdSet+filterSet p (IdSet s) = IdSet (IntSet.filter (p . idFromInt) s)++foldSet :: (Id -> a -> a) -> a -> IdSet -> a+foldSet f a (IdSet s) = IntSet.fold (f . idFromInt) a s++insertSet :: Id -> IdSet -> IdSet+insertSet x (IdSet s) = IdSet (IntSet.insert (intFromId x) s)++deleteSet :: Id -> IdSet -> IdSet+deleteSet x (IdSet s) = IdSet (IntSet.delete (intFromId x) s)++unionSet :: IdSet -> IdSet -> IdSet+unionSet (IdSet s1) (IdSet s2) = IdSet (s1 `IntSet.union` s2)++unionSets :: [IdSet] -> IdSet+unionSets xs = IdSet (IntSet.unions [ s | IdSet s <- xs ])++diffSet :: IdSet -> IdSet -> IdSet+diffSet (IdSet s1) (IdSet s2) = IdSet (IntSet.difference s1 s2)++-- sort is needed to not rely on an id's index+listFromSet :: IdSet -> [Id]+listFromSet (IdSet s) = sort [ idFromInt n | n <- IntSet.elems s ]++setFromList :: [Id] -> IdSet+setFromList = foldr insertSet emptySet++sizeSet :: IdSet -> Int+sizeSet (IdSet s) = IntSet.size s++isEmptySet :: IdSet -> Bool+isEmptySet (IdSet s) = IntSet.null s
+ Lvm/Core/Expr.hs view
@@ -0,0 +1,130 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Expr.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Core.Expr + ( CoreModule, CoreDecl, Expr(..), Binds(..), Bind(..)+ , Alts, Alt(..), Pat(..), Literal(..), Con(..)+ ) where++import Lvm.Common.Byte+import Lvm.Common.Id+import Lvm.Core.Module+import Lvm.Core.PrettyId+import Text.PrettyPrint.Leijen++----------------------------------------------------------------+-- Modules+----------------------------------------------------------------+type CoreModule = Module Expr+type CoreDecl = Decl Expr++----------------------------------------------------------------+-- Core expressions:+----------------------------------------------------------------+data Expr = Let !Binds Expr + | Match !Id Alts+ | Ap Expr Expr+ | Lam !Id Expr+ | Con !(Con Expr)+ | Var !Id+ | Lit !Literal++data Binds = Rec ![Bind]+ | Strict !Bind+ | NonRec !Bind++data Bind = Bind !Id Expr++type Alts = [Alt]+data Alt = Alt !Pat Expr++data Pat = PatCon !(Con Tag) ![Id]+ | PatLit !Literal+ | PatDefault++data Literal = LitInt !Int+ | LitDouble !Double+ | LitBytes !Bytes++data Con tag = ConId !Id+ | ConTag tag !Arity+ +----------------------------------------------------------------+-- Pretty printing+----------------------------------------------------------------++instance Pretty Expr where+ pretty = ppExpr 0++ppExpr :: Int -> Expr -> Doc+ppExpr p expr+ = case expr of+ -- (Let (Strict (Bind id1 expr)) (Match id2 alts)) | id1 == id2+ -- -> prec 0 $ hang 2 (text "case" <+> ppExpr 0 expr <+> text "of" <+> ppId id1 <$> ppAlts alts)+ Match x as -> prec 0 $ align (text "match" <+> ppVarId x <+> text "with" <+> text "{" <$> indent 2 (pretty as)+ <+> text "}")+ Let bs x -> prec 0 $ align (ppLetBinds bs (text "in" <+> ppExpr 0 x))+ Lam x e -> prec 0 $ text "\\" <> ppVarId x <+> ppLams "->" (</>) e+ Ap e1 e2 -> prec 9 $ ppExpr 9 e1 <+> ppExpr 10 e2+ Var x -> ppVarId x+ Con con -> pretty con+ Lit lit -> pretty lit+ where+ prec p' | p' >= p = id+ | otherwise = parens++instance Pretty a => Pretty (Con a) where+ pretty con =+ case con of+ ConId x -> ppConId x+ ConTag tag arity -> parens (char '@' <> pretty tag <> comma <> pretty arity)+ +----------------------------------------------------------------+--+----------------------------------------------------------------++ppLams :: String -> (Doc -> Doc -> Doc) -> Expr -> Doc+ppLams arrow next expr+ = case expr of+ Lam x e -> ppVarId x <+> ppLams arrow next e+ _ -> text arrow `next` ppExpr 0 expr++ppLetBinds :: Binds -> Doc -> Doc+ppLetBinds binds doc+ = case binds of+ NonRec bind -> nest 4 (text "let" <+> pretty bind) <$> doc+ Strict bind -> nest 5 (text "let!" <+> pretty bind) <$> doc+ -- Rec recs -> nest 8 (text "let rec" <+> pretty recs) <$> doc+ Rec recs -> nest 4 (text "let" <+> pretty recs) <$> doc -- let rec not parsable++instance Pretty Bind where+ pretty (Bind x expr) =+ nest 2 (ppId x <+> ppLams "=" (</>) expr <> semi)+ prettyList = vcat . map pretty++instance Pretty Alt where+ pretty (Alt pat expr) =+ nest 4 (pretty pat <+> text "->" </> ppExpr 0 expr <> semi)+ prettyList = vcat . map pretty++----------------------------------------------------------------+--+----------------------------------------------------------------++instance Pretty Pat where + pretty pat = + case pat of+ PatCon con ids -> hsep (pretty con : map ppVarId ids)+ PatLit lit -> pretty lit+ PatDefault -> text "_"++instance Pretty Literal where + pretty lit = + case lit of+ LitInt i -> pretty i+ LitDouble d -> pretty d+ LitBytes s -> text (show (stringFromBytes s))
+ Lvm/Core/FreeVar.hs view
@@ -0,0 +1,65 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: FreeVar.hs 291 2012-11-08 11:27:33Z heere112 $+----------------------------------------------------------------+-- Calculate free variables+----------------------------------------------------------------+module Lvm.Core.FreeVar (FreeVar(..), Binder(..)) where++import Lvm.Common.IdSet+import Lvm.Core.Expr++class FreeVar a where+ freeVar :: a -> IdSet++instance FreeVar a => FreeVar [a] where+ freeVar = unionSets . map freeVar++instance FreeVar Expr where+ freeVar expr = + case expr of+ Let bs e -> freeVar bs `unionSet` (freeVar e `diffSet` binder bs)+ Match x e -> insertSet x (freeVar e)+ Ap e1 e2 -> freeVar e1 `unionSet` freeVar e2+ Lam x e -> deleteSet x (freeVar e)+ Con c -> freeVar c+ Var x -> singleSet x+ Lit _ -> emptySet++instance FreeVar Alt where+ freeVar (Alt p e) = freeVar e `diffSet` binder p++instance FreeVar Binds where+ freeVar binds =+ case binds of+ Rec bs -> freeVar bs `diffSet` binder bs+ NonRec b -> freeVar b+ Strict b -> freeVar b++instance FreeVar Bind where+ freeVar (Bind _ e) = freeVar e -- non-recursive binder!++instance FreeVar a => FreeVar (Con a) where+ freeVar (ConTag a _) = freeVar a+ freeVar (ConId _) = emptySet+ +class Binder a where+ binder :: a -> IdSet++instance Binder a => Binder [a] where+ binder = unionSets . map binder++instance Binder Pat where+ binder (PatCon _ xs) = setFromList xs+ binder _ = emptySet+ +instance Binder Bind where+ binder (Bind x _) = singleSet x+ +instance Binder Binds where+ binder (Rec bs) = binder bs+ binder (NonRec b) = binder b+ binder (Strict b) = binder b
+ Lvm/Core/LetSort.hs view
@@ -0,0 +1,87 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: LetSort.hs 291 2012-11-08 11:27:33Z heere112 $++----------------------------------------------------------------+-- Determine which bindings are really recursive and which are not.+-- maintains free variable information & normalised structure+----------------------------------------------------------------+module Lvm.Core.LetSort (coreLetSort) where++import Data.Graph hiding (topSort)+import Data.Tree+import Lvm.Common.IdSet+import Lvm.Core.Expr+import Lvm.Core.FreeVar+import Lvm.Core.Utils+import Data.Maybe+import Control.Arrow (second)++----------------------------------------------------------------+-- coreLetSort+-- pre: [coreFreeVar] all let bindings are annotated with their free variables+--+-- transform a @Rec@ bindings into the smallest @NonRec@ and @Rec@ bindings.+----------------------------------------------------------------+coreLetSort :: CoreModule -> CoreModule+coreLetSort = fmap lsExpr++lsExpr :: Expr -> Expr+lsExpr expr+ = case expr of+ Let (Strict (Bind x rhs)) e+ -> Let (Strict (Bind x (lsExpr rhs))) (lsExpr e)+ Let binds e+ -> let bindss = sortBinds binds+ in foldr Let (lsExpr e) bindss+ Match x alts+ -> Match x (lsAlts alts)+ Lam x e+ -> Lam x (lsExpr e)+ Ap e1 e2+ -> Ap (lsExpr e1) (lsExpr e2)+ Con (ConTag tag arity)+ -> Con (ConTag (lsExpr tag) arity)+ _+ -> expr++lsAlts :: Alts -> Alts+lsAlts = mapAlts (\pat -> Alt pat . lsExpr)++----------------------------------------------------------------+-- topological sort let bindings+----------------------------------------------------------------+sortBinds :: Binds -> [Binds]+sortBinds (Rec bindsrec)+ = let binds = map (\(Bind x rhs) -> (x,rhs)) bindsrec+ names = zip (map fst binds) [0..]+ es = concatMap (depends names) binds+ sorted = topSort (length names-1) es+ binds' = map (map (binds!!)) sorted+ binds'' = map (map (second lsExpr)) binds'+ in map toBinding binds'' -- foldr sortLets (lsExpr expr) binds''+sortBinds binds+ = [mapBinds (\x expr -> Bind x (lsExpr expr)) binds]++-- topological sort+topSort :: Vertex -> [Edge] -> [[Vertex]]+topSort n = map flatten . scc . buildG (0, n)++toBinding :: [(Id, Expr)] -> Binds+toBinding [(x,rhs)]+ | not (elemSet x (freeVar rhs)) = NonRec (Bind x rhs)+toBinding binds+ = Rec (map (uncurry Bind) binds)++depends :: [(Id,Vertex)] -> (Id,Expr) -> [(Vertex,Vertex)]+depends names (v,expr)+ = foldSet depend [] (freeVar expr)+ where+ index = fromMaybe (error msg) (lookup v names)+ msg = "CoreLetSort.depends: id not in let group??"+ depend x ds = case lookup x names of+ Just i -> (index,i):ds+ Nothing -> ds
+ Lvm/Core/Lift.hs view
@@ -0,0 +1,166 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Lift.hs 291 2012-11-08 11:27:33Z heere112 $++----------------------------------------------------------------+-- Do "johnson" style lambda lifting+-- After this pass, each binding has either no free variables or no arguments.+-- maintains free variable information & normalised structure+----------------------------------------------------------------+module Lvm.Core.Lift (coreLift) where++import Data.List+import Data.Maybe+import Lvm.Common.Id +import Lvm.Common.IdMap +import Lvm.Common.IdSet+import Lvm.Core.Expr+import Lvm.Core.FreeVar+import Lvm.Core.Utils++----------------------------------------------------------------+-- The environment maps variables to variables that should+-- be supplied as arguments at each call site+----------------------------------------------------------------+data Env = Env IdSet (IdMap [Id]) -- primitives && the free variables to be passed as arguments++elemFree :: Env -> Id -> Bool+elemFree (Env _ env) x+ = elemMap x env++lookupFree :: Env -> Id -> [Id]+lookupFree (Env _ env) x+ = fromMaybe [] (lookupMap x env)++isPrimitive :: Env -> Id -> Bool+isPrimitive (Env prim _) = (`elemSet` prim)++extendFree :: Env -> Id -> [Id] -> Env+extendFree (Env prim env) x fv+ = Env prim (extendMap x fv env)++----------------------------------------------------------------+-- coreLift+-- pre: [coreFreeVar] each binding is annotated with free variables+-- [coreNoShadow] there is no shadowing+----------------------------------------------------------------+coreLift :: CoreModule -> CoreModule+coreLift m+ = fmap (liftExpr globals (Env primitives emptyMap)) m+ where+ primitives = externNames m+ globals = globalNames m++liftExpr :: IdSet -> Env -> Expr -> Expr+liftExpr globals env expr+ = case expr of+ Let binds e+ -> let (binds',env') = liftBinds globals env binds+ in Let binds' (liftExpr globals env' e)+ Match x alts+ -> Match x (liftAlts globals env alts)+ Lam x e+ -> Lam x (liftExpr globals env e)+ Ap expr1 expr2+ -> Ap (liftExpr globals env expr1) (liftExpr globals env expr2)+ Var x+ -> foldl' (\e v -> Ap e (Var v)) expr (lookupFree env x)+ Con (ConTag tag arity)+ -> Con (ConTag (liftExpr globals env tag) arity)+ _+ -> expr++liftAlts :: IdSet -> Env -> Alts -> Alts+liftAlts globals env = mapAlts (\pat expr -> Alt pat (liftExpr globals env expr))++----------------------------------------------------------------+-- Lift binding groups+----------------------------------------------------------------++liftBinds :: IdSet -> Env -> Binds -> (Binds, Env)+liftBinds globals env binds+ = case binds of+ NonRec bind -> let ([bind'],env') = liftBindsRec globals env [bind]+ in (NonRec bind',env') + Rec recs -> let (recs',env') = liftBindsRec globals env recs+ in (Rec recs',env')+ Strict (Bind x rhs)+ -> (Strict (Bind x (liftExpr globals env rhs)),env)+ +freeVar2 :: IdSet -> Expr -> IdSet+freeVar2 globals = (`diffSet` globals) . freeVar++liftBindsRec :: IdSet -> Env -> [Bind] -> ([Bind],Env)+liftBindsRec globals env recs+ = let (ids,exprs) = unzipBinds recs+ -- calculate the mutual free variables+ fvmap = fixMutual (zip ids (map (liftedFreeVar env . freeVar2 globals) exprs))+ -- note these recursive equations :-)+ fvs = map (removeLifted env' . listFromSet . snd) fvmap+ env' = foldl insertLifted env (zip recs fvs)++ -- put the computed free variables back into the bindings as lambdas+ recs' = zipWith (addLambdas env) fvs (zipWith Bind ids (map (liftExpr globals env') exprs))+ in (recs', env')++addLambdas :: Env -> [Id] -> Bind -> Bind+addLambdas env fv bind@(Bind x expr)+ | isAtomExpr env expr = bind+ | otherwise = Bind x (foldr Lam expr fv)++insertLifted :: Env -> (Bind, [Id]) -> Env+insertLifted env (Bind x expr,fv)+ = if isAtomExpr env expr -- || isValueExpr expr)+ then env+ else extendFree env x fv++removeLifted :: Env -> [Id] -> [Id]+removeLifted env = filter (not . elemFree env)+++fixMutual :: [(Id,IdSet)] -> [(Id,IdSet)]+fixMutual fvmap+ = let fvmap' = map addMutual fvmap+ in if size fvmap' == size fvmap+ then fvmap+ else fixMutual fvmap'+ where+ addMutual (x,fv)+ = (x, foldSet addLocalFree fv fv)++ addLocalFree x fv0+ = case lookup x fvmap of+ Just fv1 -> unionSet fv0 fv1+ Nothing -> fv0++ size xs+ = sum (map (sizeSet . snd) xs)+++liftedFreeVar :: Env -> IdSet -> IdSet+liftedFreeVar env fv+ = unionSet fv (setFromList (concatMap (lookupFree env) (listFromSet fv)))++----------------------------------------------------------------+-- is an expression atomic: i.e. can we generate code inplace+----------------------------------------------------------------++isAtomExpr :: Env -> Expr -> Bool+isAtomExpr env expr+ = case expr of+ Ap e1 e2 -> isAtomExpr env e1 && isAtomExpr env e2+ Var x -> not (isPrimitive env x)+ Con _ -> True+ Lit _ -> True+ Let binds e -> isAtomBinds env binds && isAtomExpr env e+ _ -> False++isAtomBinds :: Env -> Binds -> Bool+isAtomBinds env binds+ = case binds of+ Strict _ -> False+ NonRec (Bind _ expr) -> isAtomExpr env expr+ Rec bindings -> all (isAtomExpr env) (snd (unzipBinds bindings))
+ Lvm/Core/Main.hs view
@@ -0,0 +1,181 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Main.hs 291 2012-11-08 11:27:33Z heere112 $++module Main (main) where++import Control.Monad+import Lvm.Common.Id+import Lvm.Path+import System.Console.GetOpt+import System.Environment+import System.Exit+import Text.PrettyPrint.Leijen++import Lvm.Asm.Inline (asmInline) -- optimize Asm (ie. local inlining)+import Lvm.Asm.ToLvm (asmToLvm) -- translate Asm to Lvm instructions+import Lvm.Core.Module (modulePublic) -- imports+import Lvm.Core.Parsing.Layout (layout) -- apply layout rule+import Lvm.Core.Parsing.Lexer (lexer) -- lexical tokens+import Lvm.Core.Parsing.Parser (parseModuleExport) -- parse text into Core+import Lvm.Core.RemoveDead (coreRemoveDead) -- remove dead declarations+import Lvm.Core.ToAsm (coreToAsm) -- enriched lambda expressions (Core) to Asm+import Lvm.Import (lvmImport) -- resolve import declarations+import Lvm.Write (lvmWriteFile) -- write a binary Lvm file++----------------------------------------------------------------+--+----------------------------------------------------------------++main :: IO ()+main = do+ args <- getArgs+ case getOpt Permute options args of+ (flags, files, errs)+ | Help `elem` flags -> do+ putStrLn (usageInfo header options)+ exitSuccess+ | Version `elem` flags -> do+ putStrLn ("coreasm, " ++ versionText)+ exitSuccess+ | null errs && not (null files) -> do+ mapM_ (compile flags) files+ exitSuccess+ | otherwise -> do+ putStrLn $ concat errs ++ + "Usage: For basic information, try the --help option."+ exitFailure++versionText :: String+versionText = "version 1.7" -- $Id: Main.hs 291 2012-11-08 11:27:33Z heere112 $"++header :: String+header = + "coreasm: The Core Assembler for the Lazy Virtual Machine\n" +++ "Copyright 2001, Daan Leijen\n" +++ "\nUsage: coreasm [OPTION] <core modules>\n" +++ "\nOptions:"++data Flag = Help | Version | Verbosity Verbosity | Dump Dump (Maybe String)+ deriving Eq++data Verbosity = Silent | Normal | Verbose+ deriving (Eq, Ord)++data Dump = DumpTokens | DumpCore | DumpCoreOpt | DumpAsm+ | DumpAsmOpt | DumpInstr+ deriving Eq++getVerbosity :: [Flag] -> Verbosity+getVerbosity flags = + case [ a | Verbosity a <- flags ] of+ [] -> Normal + xs -> minimum xs++flagVerbose, flagSilent :: Flag+flagVerbose = Verbosity Verbose+flagSilent = Verbosity Silent++options :: [OptDescr Flag]+options =+ [ simple [] "version" Version "show version number"+ , simple "?" "help" Help "show options"+ , simple [] "verbose" flagVerbose "verbose output"+ , simple [] "silent" flagSilent "no output"+ , dump "dump-tokens" DumpTokens "pretty print tokens"+ , dump "dump-core" DumpCore "pretty print core"+ , dump "dump-core-opt" DumpCoreOpt "pretty print core (optimized)"+ , dump "dump-asm" DumpAsm "pretty print assembler"+ , dump "dump-asm-opt" DumpAsmOpt "pretty print assembler (optimized)"+ , dump "dump-instr" DumpInstr "pretty print instructions"+ ]+ where+ simple xs long = Option xs [long] . NoArg+ dump long d = Option [] [long] (OptArg (Dump d) "file")++findModule :: [String] -> Id -> IO String+findModule paths = searchPath paths ".lvm" . stringFromId++findSrc :: [String] -> String -> IO String+findSrc paths = searchPath paths ".core"++compile :: [Flag] -> FilePath -> IO ()+compile flags src = do+ -- searching+ message flags $ "Compiling " ++ showFile src+ lvmPath <- getLvmPath+ let path = "." : lvmPath+ source <- findSrc path src + verbose $ "Source file: " ++ showFile source+ + -- lexing+ verbose "Lexing"+ input <- readFile source+ let tokens = layout (lexer (1,1) input)+ dumpWith DumpTokens flags "Tokens" tokens+ + -- parsing+ verbose "Parsing"+ (m, implExps, es) <- parseModuleExport source tokens+ + -- resolving+ verbose "Resolving imports"+ chasedMod <- lvmImport (findModule path) m+ let publicmod = modulePublic implExps es chasedMod+ dumpWith DumpCore flags "Core" publicmod+ + -- compiling+ verbose "Remove dead declarations"+ let coremod = coreRemoveDead publicmod+ dumpWith DumpCoreOpt flags "Core (dead declarations removed)" coremod++ verbose "Generating code"+ nameSupply <- newNameSupply+ + let asmmod = coreToAsm nameSupply coremod+ dumpWith DumpAsm flags "Assembler" asmmod+ + let asmopt = asmInline asmmod+ dumpWith DumpAsmOpt flags "Assembler (optimized)" asmopt+ + let lvmmod = asmToLvm asmopt+ dumpWith DumpInstr flags "Instructions" lvmmod++ -- writing+ let target = reverse (dropWhile (/='.') (reverse source)) ++ "lvm"+ message flags $ "Writing " ++ showFile target+ lvmWriteFile target lvmmod++ where+ verbose :: Pretty a => a -> IO () + verbose = messageFor Verbose flags++---------------------------------------------------------------------+-- Messages++message :: Pretty a => [Flag] -> a -> IO ()+message = messageFor Normal++messageFor :: Pretty a => Verbosity -> [Flag] -> a -> IO ()+messageFor a flags = + when (getVerbosity flags >= a) . messageDoc++messageDoc :: Pretty a => a -> IO ()+messageDoc = print . pretty++dumpWith :: Pretty a => Dump -> [Flag] -> String -> a -> IO () +dumpWith dump flags s a = + case [ mf | Dump d mf <- flags, d == dump ] of+ Just file:_ -> do message flags ("Writing " ++ file)+ writeFile file (show (pretty a))+ Nothing:_ -> messageDoc nice+ [] -> return ()+ where+ nice = vsep [hline, pretty ("-- " ++ s), empty, pretty a, hline]+ hline = pretty (replicate 40 '-')++showFile :: String -> String+showFile = map (\c -> if c == '\\' then '/' else c)
+ Lvm/Core/Module.hs view
@@ -0,0 +1,429 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Module.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Core.Module+ ( Module(..), Decl(..), Custom(..), DeclKind(..)+ , Arity, Tag, Access(..), ExternName(..), CallConv(..), LinkConv(..)+ , globalNames, externNames, filterPublic, mapDecls+ , customDeclKind, customData, customTypeDecl, modulePublic+ , declKindFromDecl, shallowKindFromDecl, makeDeclKind+ , isDeclValue, isDeclAbstract, isDeclCon, isDeclExtern+ , isDeclImport, isDeclGlobal+ , public, private+ ) where++import Lvm.Common.Byte+import Lvm.Common.Id +import Lvm.Common.IdSet +import Lvm.Core.PrettyId+import Lvm.Instr.Data+import Text.PrettyPrint.Leijen++{---------------------------------------------------------------+ A general LVM module structure parameterised by the+ type of values (Core expression, Asm expression or [Instr])+---------------------------------------------------------------}+data Module v + = Module{ moduleName :: Id+ , moduleMajorVer :: !Int+ , moduleMinorVer :: !Int+ , moduleDecls :: ![Decl v]+ }+++data Decl v + = DeclValue { declName :: Id, declAccess :: !Access, valueEnc :: Maybe Id, valueValue :: v, declCustoms :: ![Custom] }+ | DeclAbstract { declName :: Id, declAccess :: !Access, declArity :: !Arity, declCustoms :: ![Custom] }+ | DeclCon { declName :: Id, declAccess :: !Access, declArity :: !Arity, conTag :: !Tag, declCustoms :: [Custom] }+ | DeclExtern { declName :: Id, declAccess :: !Access, declArity :: !Arity+ , externType :: !String, externLink :: !LinkConv, externCall :: !CallConv+ , externLib :: !String, externName :: !ExternName, declCustoms :: ![Custom] } + | DeclCustom { declName :: Id, declAccess :: !Access, declKind :: !DeclKind, declCustoms :: ![Custom] }++ | DeclImport { declName :: Id, declAccess :: !Access, declCustoms :: ![Custom] }++data Custom+ = CustomInt !Int+ | CustomBytes !Bytes+ | CustomName Id+ | CustomLink Id !DeclKind+ | CustomDecl !DeclKind ![Custom]+ | CustomNothing++data DeclKind + = DeclKindName+ | DeclKindKind+ | DeclKindBytes+ | DeclKindCode+ | DeclKindValue+ | DeclKindCon+ | DeclKindImport+ | DeclKindModule+ | DeclKindExtern+ | DeclKindExternType+ | DeclKindCustom !Id+ deriving (Eq,Show)++data Access+ = Defined { accessPublic :: !Bool }+ | Imported { accessPublic :: !Bool, importModule :: Id, importName :: Id, importKind :: !DeclKind+ , importMajorVer :: !Int, importMinorVer :: !Int }+ +public, private :: Access+public = Defined True+private = Defined False++-- externals+data ExternName = Plain !String+ | Decorate !String+ | Ordinal !Int+ deriving Show++data CallConv = CallC | CallStd | CallInstr+ deriving (Show, Eq, Enum)++data LinkConv = LinkStatic | LinkDynamic | LinkRuntime + deriving (Show, Eq, Enum)+++instance Ord DeclKind where+ compare k1 k2+ = case (k1,k2) of+ (DeclKindCustom id1,DeclKindCustom id2) -> compare id1 id2+ (DeclKindCustom _,_) -> GT+ (_,DeclKindCustom _) -> LT+ _ -> compare (fromEnum k1) (fromEnum k2)++++instance Enum DeclKind where+ toEnum i + = case i of+ 0 -> DeclKindName+ 1 -> DeclKindKind+ 2 -> DeclKindBytes+ 3 -> DeclKindCode+ 4 -> DeclKindValue+ 5 -> DeclKindCon+ 6 -> DeclKindImport+ 7 -> DeclKindModule+ 8 -> DeclKindExtern+ 9 -> DeclKindExternType+ _ -> error ("Module.DeclKind.toEnum: unknown kind (" ++ show i ++ ")")++ fromEnum kind + = case kind of+ DeclKindName -> 0+ DeclKindKind -> 1+ DeclKindBytes -> 2+ DeclKindCode -> 3+ DeclKindValue -> 4+ DeclKindCon -> 5+ DeclKindImport -> 6+ DeclKindModule -> 7+ DeclKindExtern -> 8+ DeclKindExternType-> 9+-- DeclKindCustom i -> i+ _ -> error "Module.DeclKind.fromEnum: unknown kind"++customDeclKind :: String -> DeclKind+customDeclKind = DeclKindCustom . idFromString++customData, customTypeDecl :: DeclKind+customData = customDeclKind "data"+customTypeDecl = customDeclKind "typedecl"++declKindFromDecl :: Decl a -> DeclKind+declKindFromDecl decl+ = case decl of+ DeclValue{} -> DeclKindValue+ DeclAbstract{} -> DeclKindValue+ DeclCon{} -> DeclKindCon+ DeclExtern{} -> DeclKindExtern+ DeclCustom{} -> declKind decl+ DeclImport{} -> importKind (declAccess decl)+ -- _ -> error "Module.kindFromDecl: unknown declaration"++shallowKindFromDecl :: Decl a -> DeclKind+shallowKindFromDecl decl+ = case decl of+ DeclValue{} -> DeclKindValue+ DeclAbstract{} -> DeclKindValue+ DeclCon{} -> DeclKindCon+ DeclExtern{} -> DeclKindExtern+ DeclCustom{} -> declKind decl+ DeclImport{} -> DeclKindImport+ -- _ -> error "Module.shallowKindFromDecl: unknown declaration"++modulePublic :: Bool -> (IdSet,IdSet,IdSet,IdSet,IdSet) -> Module v -> Module v+modulePublic implicit (exports,exportCons,exportData,exportDataCon,exportMods) m+ = m { moduleDecls = map setPublic (moduleDecls m) }+ where+ setPublic decl | declPublic decl = decl{ declAccess = (declAccess decl){ accessPublic = True } }+ | otherwise = decl+ + isExported decl elemIdSet =+ let access = declAccess decl in+ if implicit then+ case decl of+ DeclImport{} -> False+ _ ->+ case access of+ Imported{} -> False+ Defined{} -> accessPublic access+ else+ case access of+ Imported{ importModule = x }+ | elemSet x exportMods -> True+ | otherwise -> elemIdSet+ Defined{}+ | elemSet (moduleName m) exportMods -> True+ | otherwise -> elemIdSet+ + declPublic decl =+ let name = declName decl+ in+ case decl of+ DeclValue{} -> isExported decl (elemSet name exports)+ DeclAbstract{} -> isExported decl (elemSet name exports)+ DeclExtern{} -> isExported decl (elemSet name exports)+ DeclCon{} -> isExported decl+ ( elemSet name exportCons+ || elemSet (conTypeName decl) exportDataCon+ )+ DeclCustom{} -> isExported decl+ ( declKind decl `elem` [customData, customTypeDecl]+ && elemSet name exportData+ )+ DeclImport{} -> not implicit && case importKind (declAccess decl) of+ DeclKindValue -> isExported decl (elemSet name exports)+ DeclKindExtern -> isExported decl (elemSet name exports)+ DeclKindCon -> isExported decl (elemSet name exportCons) + DeclKindModule -> isExported decl (elemSet name exportMods)+ dk@(DeclKindCustom _)+ | dk `elem` [customData, customTypeDecl] ->+ isExported decl (elemSet name exportData)+ _ -> False++ conTypeName (DeclCon{declCustoms=(_:CustomLink x _:_)}) = x+ conTypeName _ = dummyId++----------------------------------------------------------------+-- Functors+----------------------------------------------------------------++instance Functor Module where+ fmap f m = m { moduleDecls = map (fmap f) (moduleDecls m) }++instance Functor Decl where+ fmap f decl = + case decl of+ DeclValue x ac m v cs -> + DeclValue x ac m (f v) cs+ DeclAbstract x ac ar cs -> + DeclAbstract x ac ar cs+ DeclCon x ac ar t cs -> + DeclCon x ac ar t cs+ DeclExtern x ac ar et el ec elib en cs -> + DeclExtern x ac ar et el ec elib en cs+ DeclCustom x ac k cs -> + DeclCustom x ac k cs+ DeclImport x ac cs -> + DeclImport x ac cs++----------------------------------------------------------------+-- Pretty printing+----------------------------------------------------------------++instance Pretty a => Pretty (Module a) where+ pretty (Module name _ _ decls) =+ text "module" <+> ppConId name <+> text "where"+ <$> vcat (map (\decl -> pretty decl <> semi <> line) decls)+ <$> empty++instance Pretty a => Pretty (Decl a) where+ pretty decl = nest 2 $ + case decl of+ DeclValue{} -> ppVarId (declName decl) <+> ppAttrs decl + <$> text "=" <+> pretty (valueValue decl)+ DeclCon{} -> case declAccess decl of+ imp@Imported{} -> + text "abstract" <+> ppConId (declName decl)+ <+> ppAttrs decl+ <$> text "=" <+> ppQualCon (importModule imp) (importName imp)+ <+> parens (char '@' <> pretty (conTag decl) <> + comma <> pretty (declArity decl))+ + _ -> text "con" <+> ppConId (declName decl) <+> ppAttrs decl + <$> text "=" <+> parens (char '@' <> pretty (conTag decl) <> + comma <> pretty (declArity decl))+ DeclCustom{} -> text "custom" <+> pretty (declKind decl) <+> ppId (declName decl) <+> ppAttrs decl+ DeclExtern{} -> text "extern" + <> pretty (externLink decl) <> pretty (externCall decl)+ <+> ppVarId (declName decl) -- <+> ppAttrs decl+ <+> ppExternName (externLib decl) (externName decl) -- <+> pretty (declArity decl)+ <+> ppExternType (externCall decl) (externType decl)+ DeclAbstract{} -> text "abstract" <+> ppVarId (declName decl) <+> ppAttrs decl+ <$> text "=" <+> ppImported (declAccess decl) <+> pretty (declArity decl)+ DeclImport{} -> text "import" <+> pretty (importKind (declAccess decl)) + <+> ppId (declName decl) <+> ppNoImpAttrs decl+ <$> text "=" <+> ppImported (declAccess decl)++instance Pretty LinkConv where+ pretty linkConv =+ case linkConv of+ LinkRuntime -> text " runtime"+ LinkDynamic -> text " dynamic"+ LinkStatic -> empty++instance Pretty CallConv where+ pretty callConv =+ case callConv of+ CallInstr -> text " instrcall"+ CallStd -> text " stdcall"+ CallC -> empty++ppExternName :: String -> ExternName -> Doc+ppExternName libName extName+ = case extName of+ Plain name -> dquotes (ppQual name)+ Decorate name -> text "decorate" <+> ppQual name+ Ordinal i -> ppQual (show i)+ where+ ppQual name+ | null libName = ppVarId (idFromString name)+ | otherwise = ppQualId (idFromString libName) (idFromString name)++ppExternType :: CallConv -> String -> Doc+ppExternType callConv tp+ = text "::" <+> case callConv of+ CallInstr -> pretty tp+ _ -> ppString tp++ppNoImpAttrs :: Decl a -> Doc+ppNoImpAttrs = ppAttrsEx True++ppAttrs :: Decl a -> Doc+ppAttrs = ppAttrsEx False++ppAttrsEx :: Bool -> Decl a -> Doc+ppAttrsEx hideImp decl+ = if null (declCustoms decl) && not (accessPublic (declAccess decl))+ then empty+ else text ":" <+> ppAccess (declAccess decl) + <+> (if not hideImp then ppImportAttr (declAccess decl) else empty) + <> pretty (declCustoms decl)++ppAccess :: Access -> Doc+ppAccess acc + | accessPublic acc = text "public" + | otherwise = text "private"++ppImportAttr :: Access -> Doc+ppImportAttr acc+ = case acc of+ Defined _ -> empty+ Imported _ modid impid impkind _ _+ -> text "import" <+> pretty impkind <+> ppQualId modid impid <> space+ +ppImported :: Access -> Doc+ppImported acc+ = case acc of+ Defined _ -> error "ModulePretty.ppImported: internal error: abstract or import value should always be imported!"+ Imported _ modid impid _ _ _+ -> ppQualId modid impid++instance Pretty Custom where+ pretty custom =+ case custom of+ CustomInt i -> pretty i+ CustomName x -> ppId x+ CustomBytes bs -> dquotes (string (stringFromBytes bs))+ CustomLink x kind -> text "custom" <+> pretty kind <+> ppId x+ CustomDecl kind cs -> text "custom" <+> pretty kind <+> pretty cs+ CustomNothing -> text "nothing"+ + prettyList customs+ | null customs = empty+ | otherwise = list (map pretty customs)++instance Pretty DeclKind where+ pretty kind = + case kind of+ DeclKindCustom x -> ppId x+-- DeclKindName +-- DeclKindKind+-- DeclKindBytes +-- DeclKindCode+ DeclKindValue -> ppId (idFromString "val")+ DeclKindCon -> ppId (idFromString "con")+ DeclKindImport -> ppId (idFromString "import")+ DeclKindModule -> ppId (idFromString "module")+ DeclKindExtern -> ppId (idFromString "extern")+-- DeclKindExternType + _ -> pretty (fromEnum kind)++makeDeclKind :: Id -> DeclKind+makeDeclKind x = + case stringFromId x of+ "val" -> DeclKindValue+ "con" -> DeclKindCon+ "import" -> DeclKindImport+ "module" -> DeclKindModule+ "extern" -> DeclKindExtern+ _ -> DeclKindCustom x++{---------------------------------------------------------------+ Utility functions+---------------------------------------------------------------}++isDeclValue :: Decl a -> Bool+isDeclValue (DeclValue{}) = True+isDeclValue _ = False++isDeclAbstract :: Decl a -> Bool+isDeclAbstract (DeclAbstract{}) = True+isDeclAbstract _ = False++isDeclImport :: Decl a -> Bool+isDeclImport (DeclImport{}) = True+isDeclImport _ = False++isDeclCon :: Decl a -> Bool+isDeclCon (DeclCon{}) = True+isDeclCon _ = False++isDeclExtern :: Decl a -> Bool+isDeclExtern (DeclExtern{}) = True+isDeclExtern _ = False++isDeclGlobal :: Decl a -> Bool+isDeclGlobal (DeclValue{}) = True+isDeclGlobal (DeclAbstract{}) = True+isDeclGlobal (DeclExtern{}) = True+isDeclGlobal _ = False++-- hasDeclKind kind decl = (kind==declKindFromDecl decl)++{---------------------------------------------------------------+ More Utility functions+---------------------------------------------------------------}+filterPublic :: Module v -> Module v+filterPublic m+ = m { moduleDecls = [d | d <- moduleDecls m, accessPublic (declAccess d)] }++globalNames :: Module v -> IdSet+globalNames m+ = setFromList [declName d | d <- moduleDecls m, isDeclValue d || isDeclAbstract d || isDeclExtern d]++externNames :: Module v -> IdSet+externNames m+ = setFromList [declName d | d <- moduleDecls m, isDeclExtern d]++mapDecls :: (Decl v -> Decl w) -> Module v -> Module w+mapDecls f m+ = m { moduleDecls = map f (moduleDecls m) }
+ Lvm/Core/NoShadow.hs view
@@ -0,0 +1,119 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: NoShadow.hs 291 2012-11-08 11:27:33Z heere112 $++----------------------------------------------------------------+-- Make all local bindings locally unique.+-- and all local let-bindings globally unique.+--+-- After this pass, no variables shadow each other and let-bound variables+-- are globally unique.+----------------------------------------------------------------+module Lvm.Core.NoShadow (coreNoShadow, coreRename) where++import Data.Maybe+import Lvm.Common.Id+import Lvm.Common.IdMap+import Lvm.Common.IdSet +import Lvm.Core.Expr+import Lvm.Core.Utils++----------------------------------------------------------------+-- Environment: name supply, id's in scope & renamed identifiers+----------------------------------------------------------------+data Env = Env NameSupply IdSet (IdMap Id)++renameBinders :: Env -> [Id] -> (Env, [Id])+renameBinders env bs+ = let (env',bs') = foldl (\(env1,ids) x1 -> renameBinder env1 x1 $ \env2 x2 -> (env2,x2:ids)) (env,[]) bs+ in (env',reverse bs')++renameLetBinder :: Env -> Id -> (Env -> Id -> a) -> a+renameLetBinder (Env supply inscope renaming) x cont+ = let (x2,supply') = freshIdFromId x supply+ inscope' = insertSet x inscope+ renaming' = extendMap x x2 renaming+ in cont (Env supply' inscope' renaming') x2++renameBinder :: Env -> Id -> (Env -> Id -> a) -> a+renameBinder env@(Env supply set m) x cont+ | elemSet x set+ = renameLetBinder env x cont+ | otherwise+ = cont (Env supply (insertSet x set) m) x++renameVar :: Env -> Id -> Id+renameVar (Env _ _ m) x+ = fromMaybe x (lookupMap x m)++splitEnv :: Env -> (Env,Env)+splitEnv (Env supply set m)+ = let (s0,s1) = splitNameSupply supply+ in (Env s0 set m,Env s1 set m)++splitEnvs :: Env -> [Env]+splitEnvs (Env supply set idmap)+ = map (\s -> Env s set idmap) (splitNameSupplies supply)+++----------------------------------------------------------------+-- coreNoShadow: make all local variables locally unique+-- ie. no local variable shadows another variable+----------------------------------------------------------------+coreNoShadow :: NameSupply -> CoreModule -> CoreModule+coreNoShadow = mapExprWithSupply (nsDeclExpr emptySet)++coreRename :: NameSupply -> CoreModule -> CoreModule+coreRename supply m = mapExprWithSupply (nsDeclExpr (globalNames m)) supply m++nsDeclExpr :: IdSet -> NameSupply -> Expr -> Expr+nsDeclExpr inscope supply = nsExpr (Env supply inscope emptyMap)+++nsExpr :: Env -> Expr -> Expr+nsExpr env expr+ = case expr of+ Let binds e -> nsBinds env binds $ \env' binds' ->+ Let binds' (nsExpr env' e)+ Match x alts -> Match (renameVar env x) (nsAlts env alts)+ Lam x e -> renameBinder env x $ \env2 x2 ->+ Lam x2 (nsExpr env2 e)+ Ap expr1 expr2 -> let (env1,env2) = splitEnv env+ in Ap (nsExpr env1 expr1) (nsExpr env2 expr2)+ Var x -> Var (renameVar env x)+ Con (ConTag e a) -> Con (ConTag (nsExpr env e) a)+ _ -> expr++nsBinds :: Env -> Binds -> (Env -> Binds -> a) -> a+nsBinds env binds cont+ = case binds of+ Strict (Bind x rhs) -> nonrec Strict x rhs+ NonRec (Bind x rhs) -> nonrec NonRec x rhs+ Rec _ -> rec_+ where+ nonrec make x1 rhs+ = renameLetBinder env x1 $ \env' x2 ->+ cont env' (make (Bind x2 (nsExpr env rhs)))+ + rec_ + = let (binds',env') = mapAccumBinds (\env1 x1 rhs -> renameLetBinder env1 x1 $ \env2 x2 -> (Bind x2 rhs,env2))+ env binds+ in cont env' (zipBindsWith (\env1 x1 rhs -> Bind x1 (nsExpr env1 rhs)) (splitEnvs env') binds')++nsAlts :: Env -> Alts -> Alts+nsAlts = zipAltsWith nsAlt . splitEnvs++nsAlt :: Env -> Pat -> Expr -> Alt+nsAlt env pat expr+ = let (pat',env') = nsPat env pat+ in Alt pat' (nsExpr env' expr)++nsPat :: Env -> Pat -> (Pat, Env)+nsPat env pat+ = case pat of+ PatCon con ids -> let (env',ids') = renameBinders env ids+ in (PatCon con ids',env')+ other -> (other,env)
+ Lvm/Core/Normalize.hs view
@@ -0,0 +1,150 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Normalize.hs 291 2012-11-08 11:27:33Z heere112 $++----------------------------------------------------------------+-- Normalises Core:+-- * no lambda's, except directly at let-bindings+-- * each Ap argument is atomic & not a call to an instruction or external function+-- * each Ap target is atomic+--+-- an atomic expression is+-- * a Var+-- * a Lit+-- * a Con+-- * a normalised Ap+-- * a normalised Let(Rec) expression +--+-- pre: [coreNoShadow, coreSaturate]+----------------------------------------------------------------+module Lvm.Core.Normalize (coreNormalize) where++import Lvm.Common.Id+import Lvm.Common.IdSet+import Lvm.Core.Expr+import Lvm.Core.Utils++----------------------------------------------------------------+-- Environment: the name supply+----------------------------------------------------------------+data Env = Env NameSupply !IdSet {- instructions + externs -}++uniqueId :: Env -> Id+uniqueId (Env supply _) = fst (freshId supply)++splitEnv :: Env -> (Env, Env)+splitEnv (Env s d)+ = let (s0,s1) = splitNameSupply s in (Env s0 d, Env s1 d)++splitEnvs :: Env -> [Env]+splitEnvs (Env s d) = map (`Env` d) (splitNameSupplies s)++isDirect :: Env -> Id -> Bool+isDirect (Env _ d) x = elemSet x d++----------------------------------------------------------------+-- coreNormalise+----------------------------------------------------------------+coreNormalize :: NameSupply -> CoreModule -> CoreModule+coreNormalize supply m+ = mapExprWithSupply (normDeclExpr primitives) supply m+ where+ primitives = externNames m++normDeclExpr :: IdSet -> NameSupply -> Expr -> Expr+normDeclExpr directs supply = normBind (Env supply directs)++----------------------------------------------------------------+-- Expression & bindings+----------------------------------------------------------------++normExpr :: Env -> Expr -> Expr+normExpr env expr+ = let (env1,env2) = splitEnv env+ expr' = normBind env1 expr+ in case expr' of+ Lam _ _ -> let x = uniqueId env2+ in (Let (NonRec (Bind x expr')) (Var x))+ _ -> expr'++-- can return lambda's on top+normBind :: Env -> Expr -> Expr+normBind env expr+ = case expr of+ Let binds e -> let (env1,env2) = splitEnv env+ in Let (normBinds env1 binds) (normExpr env2 e)+ Match x alts -> Match x (normAlts env alts)+ Lam x e -> Lam x (normBind env e)+ Ap _ _ -> normAtomExpr env expr+ _ -> expr++normBinds :: Env -> Binds -> Binds+normBinds+ = zipBindsWith (\env x expr -> Bind x (normBind env expr)) . splitEnvs++normAlts :: Env -> Alts -> Alts+normAlts+ = zipAltsWith (\env pat expr -> Alt pat (normExpr env expr)) . splitEnvs++normAtomExpr :: Env -> Expr -> Expr+normAtomExpr env expr+ = let (atom,f) = normAtom env expr+ in (f atom)++-- returns an atomic expression + a function that adds the right bindings+normAtom :: Env -> Expr -> (Expr, Expr -> Expr)+normAtom env expr+ = case expr of+ Match _ _ -> freshBinding+ Lam _ _ -> freshBinding+ Let (Strict _) _ -> freshBinding+ -- we could leave let bindings in place when they are fully+ -- atomic but otherwise the bindings get messed up (shadow7.core).+ -- we lift all bindings out and rely on asmInline to put them+ -- back again if possible.+ Let binds e -> let (env1,env2) = splitEnv env+ (atom,f) = normAtom env1 e+ -- (abinds,g) = normAtomBinds env2 binds+ in (atom, Let (normBinds env2 binds) . f)+ -- (abinds atom, f . g)+ Ap e1 e2 -> let (env1,env2) = splitEnv env+ (atom,f) = normAtom env1 e1+ (arg,g) = normArg env2 e2+ in (Ap atom arg, f . g)+ _ -> (expr,id)+ where+ freshBinding = let (env1,env2) = splitEnv env+ expr' = normBind env1 expr+ x = uniqueId env2+ in (Var x, Let (NonRec (Bind x expr')))++-- normAtomBinds returns two functions: one that adds atomic+-- let bindings and one that adds non-atomic bindings+{- normAtomBinds :: Env -> Binds -> (Expr -> Expr, Expr -> Expr)+normAtomBinds env binds+ = let (binds',(env',f)) = mapAccumBinds norm (env,id) binds + in (Let binds', f)+ where+ norm (env,f) id expr = let (env1,env2) = splitEnv env+ (atom,g) = normAtom env1 expr+ in (Bind id atom, (env2, f . g))+-}+-- just as an atomic expression but binds 'direct' applications (ie. externs & instructions)+normArg :: Env -> Expr -> (Expr, Expr -> Expr)+normArg env expr+ = let (env1,env2) = splitEnv env+ (atom,f) = normAtom env1 expr+ in if isDirectAp env atom+ then let x = uniqueId env2+ in (Var x, f . Let (NonRec (Bind x atom)))+ else (atom,f)++isDirectAp :: Env -> Expr -> Bool+isDirectAp env expr+ = case expr of+ Ap e1 _ -> isDirectAp env e1+ Var x -> isDirect env x+ _ -> False
+ Lvm/Core/Parsing/Layout.hs view
@@ -0,0 +1,108 @@+-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Lexer.hs 269 2012-08-31 15:16:49Z bastiaan $ + +module Lvm.Core.Parsing.Layout (layout) where + +import Lvm.Core.Parsing.Token + +----------------------------------------------------------- +-- The layout rule +----------------------------------------------------------- + +layout :: [Token] -> [Token] +layout = doubleSemi . lay [] . addLayout + + +data Layout = CtxLay Int + | CtxLet Int + | CtxBrace + | Indent Int + deriving (Eq,Show) + +type LayoutToken = Either (Pos, Layout) Token + +getPos :: LayoutToken -> Pos +getPos = either fst fst + +addLayout :: [Token] -> [LayoutToken] +addLayout ts = + case ts of + (pos,LexMODULE):_ -> addLay pos rest + (pos,LexLBRACE):_ -> addLay pos rest + (pos,_):_ -> Left (pos, CtxLay (snd pos)) : addLay pos rest + [] -> [] + where + rest = map Right ts + +addLay :: Pos -> [LayoutToken] -> [LayoutToken] +addLay _ [] = [] +addLay (l, _) (t:ts) = + case t of + Left (pos@(ln, col), _) + | ln > l -> Left (pos, Indent col) : rest + | otherwise -> rest + where + rest = t : addLay pos ts + + Right (pos@(ln, col), lexeme) + | ln > l -> Left (pos,Indent col) : t : rest + | otherwise -> t : rest + where + rest = case lexeme of + LexLET -> newlay CtxLet + LexLETSTRICT -> newlay CtxLet + LexWHERE -> newlay CtxLay + LexOF -> newlay CtxLay + LexDO -> newlay CtxLay + _ -> addLay pos ts + + newlay ctx = + case ts of + [] -> [] + u@(Right (pos',LexLBRACE)):us -> + u : addLay pos' us + u:us -> + let pos' = getPos u + in Left (pos', ctx (snd pos')) : u : addLay pos' us + +lay :: [Layout] -> [LayoutToken] -> [Token] +lay ctx tokens = + case tokens of + [] -> [] + + Left (pos, c):ts -> + case (ctx, c, ts) of + (CtxLet _:cs, Indent _, Right t@(post,LexIN):rest) -> + (post,LexRBRACE) : t : lay cs rest + + (CtxLet n:cs, Indent i, _) + | i == n -> (pos,LexSEMI) : lay ctx ts + | i < n -> (pos,LexRBRACE) : lay cs tokens + | otherwise -> lay ctx ts + + (CtxLay n:cs, Indent i, _) + | i == n -> (pos,LexSEMI) : lay ctx ts + | i < n -> (pos,LexRBRACE) : lay cs tokens + | otherwise -> lay ctx ts + + (CtxBrace:_, Indent _, _) -> lay ctx ts + (_,Indent _, _) -> lay ctx ts + + _ -> (pos,LexLBRACE) : lay (c:ctx) ts + + Right t@(pos, lexeme):ts -> + case (ctx, lexeme) of + (CtxLet _:cs, LexIN) -> (pos,LexRBRACE) : t : lay cs ts + (CtxLay _:cs, LexIN) -> (pos,LexRBRACE) : lay cs tokens + (CtxBrace:cs, LexRBRACE) -> t : lay cs ts + (_, LexLBRACE) -> t : lay (CtxBrace:ctx) ts + _ -> t : lay ctx ts + +doubleSemi :: [Token] -> [Token] +doubleSemi (t@(_, LexSEMI):(_, LexSEMI):rest) = doubleSemi (t:rest) +doubleSemi (t:ts) = t:doubleSemi ts +doubleSemi [] = []
+ Lvm/Core/Parsing/Lexer.hs view
@@ -0,0 +1,375 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Lexer.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Core.Parsing.Lexer (lexer) where++import Control.Monad+import Data.Char hiding (isSymbol, isLetter)+import Data.List+import Data.Maybe+import Lvm.Core.Parsing.Token++type Lexer = Pos -> String -> [Token]+type Lexer5 = Pos -> String -> ([Token] -> [Token], Double, Pos, String)++lexer :: Lexer+lexer (ln,_) [] = [((ln+1,0),LexEOF)]++lexer pos ('-':'-':cs) = nextinc lexeol pos 2 cs+lexer pos ('{':'-':cs) = nextinc (lexComment 0) pos 2 cs++lexer pos ('l':'e':'t':'!':cs) | nonId cs = (pos,LexLETSTRICT) : nextinc lexer pos 4 cs+lexer pos ('l':'e':'t':cs) | nonId cs = (pos,LexLET) : nextinc lexer pos 3 cs+lexer pos ('i':'n':cs) | nonId cs = (pos,LexIN) : nextinc lexer pos 2 cs+lexer pos ('d':'o':cs) | nonId cs = (pos,LexDO) : nextinc lexer pos 2 cs+lexer pos ('w':'h':'e':'r':'e':cs) | nonId cs = (pos,LexWHERE): nextinc lexer pos 5 cs+lexer pos ('c':'a':'s':'e':cs) | nonId cs = (pos,LexCASE) : nextinc lexer pos 4 cs+lexer pos ('o':'f':cs) | nonId cs = (pos,LexOF) : nextinc lexer pos 2 cs+lexer pos ('i':'f':cs) | nonId cs = (pos,LexIF) : nextinc lexer pos 2 cs+lexer pos ('t':'h':'e':'n':cs) | nonId cs = (pos,LexTHEN) : nextinc lexer pos 4 cs+lexer pos ('e':'l':'s':'e':cs) | nonId cs = (pos,LexELSE) : nextinc lexer pos 4 cs+lexer pos ('d':'a':'t':'a':cs) | nonId cs = (pos,LexDATA) : nextinc lexer pos 4 cs+lexer pos ('t':'y':'p':'e':cs) | nonId cs = (pos,LexTYPE) : nextinc lexer pos 4 cs+lexer pos ('m':'o':'d':'u':'l':'e':cs) | nonId cs = (pos,LexMODULE) : nextinc lexer pos 6 cs+lexer pos ('i':'m':'p':'o':'r':'t':cs) | nonId cs = (pos,LexIMPORT) : nextinc lexer pos 6 cs+-- not standard+lexer pos ('c':'o':'n':cs) | nonId cs = (pos,LexCON) : nextinc lexer pos 3 cs+lexer pos ('w':'i':'t':'h':cs) | nonId cs = (pos,LexWITH) : nextinc lexer pos 4 cs+lexer pos ('m':'a':'t':'c':'h':cs) | nonId cs = (pos,LexMATCH) : nextinc lexer pos 5 cs+lexer pos ('c':'c':'a':'l':'l':cs) | nonId cs = (pos,LexCCALL) : nextinc lexer pos 5 cs+lexer pos ('p':'u':'b':'l':'i':'c':cs) | nonId cs = (pos,LexPUBLIC) : nextinc lexer pos 6 cs+lexer pos ('e':'x':'t':'e':'r':'n':cs) | nonId cs = (pos,LexEXTERN) : nextinc lexer pos 6 cs+lexer pos ('s':'t':'a':'t':'i':'c':cs) | nonId cs = (pos,LexSTATIC) : nextinc lexer pos 6 cs+lexer pos ('c':'u':'s':'t':'o':'m':cs) | nonId cs = (pos,LexCUSTOM) : nextinc lexer pos 6 cs+lexer pos ('n':'o':'t':'h':'i':'n':'g':cs) | nonId cs = (pos,LexNOTHING) : nextinc lexer pos 7 cs+lexer pos ('p':'r':'i':'v':'a':'t':'e':cs) | nonId cs = (pos,LexPRIVATE) : nextinc lexer pos 7 cs+lexer pos ('d':'e':'f':'a':'u':'l':'t':cs) | nonId cs = (pos,LexDEFAULT) : nextinc lexer pos 7 cs+lexer pos ('d':'y':'n':'a':'m':'i':'c':cs) | nonId cs = (pos,LexDYNAMIC) : nextinc lexer pos 7 cs+lexer pos ('r':'u':'n':'t':'i':'m':'e':cs) | nonId cs = (pos,LexRUNTIME) : nextinc lexer pos 7 cs+lexer pos ('s':'t':'d':'c':'a':'l':'l':cs) | nonId cs = (pos,LexSTDCALL) : nextinc lexer pos 7 cs+lexer pos ('o':'r':'d':'i':'n':'a':'l':cs) | nonId cs = (pos,LexORDINAL) : nextinc lexer pos 7 cs+lexer pos ('d':'e':'c':'o':'r':'a':'t':'e':cs) | nonId cs = (pos,LexDECORATE) : nextinc lexer pos 8 cs+lexer pos ('a':'b':'s':'t':'r':'a':'c':'t':cs) | nonId cs = (pos,LexABSTRACT) : nextinc lexer pos 8 cs+lexer pos ('i':'n':'s':'t':'r':'c':'a':'l':'l':cs) | nonId cs = (pos,LexINSTRCALL) : nextinc lexer pos 9 cs+lexer pos ('i':'n':'s':'t':'r':'u':'c':'t':'i':'o':'n':cs) | nonId cs = (pos,LexINSTR) : nextinc lexer pos 11 cs+++lexer pos (':':':':cs) | nonSym cs = (pos,LexCOLCOL) : nextinc lexer pos 2 cs+lexer pos ('=':'>':cs) | nonSym cs = (pos,LexARROW) : nextinc lexer pos 2 cs+lexer pos ('-':'>':cs) | nonSym cs = (pos,LexRARROW) : nextinc lexer pos 2 cs+lexer pos ('<':'-':cs) | nonSym cs = (pos,LexLARROW) : nextinc lexer pos 2 cs+lexer pos ('.':'.':cs) | nonSym cs = (pos,LexDOTDOT) : nextinc lexer pos 2 cs+lexer pos ('\'':'\'':cs) = nextinc (lexSpecialId pos) pos 2 cs++lexer pos ('.':cs) | nonSym cs = (pos,LexDOT) : nextinc lexer pos 1 cs+lexer pos (',':cs) | nonSym cs = (pos,LexCOMMA) : nextinc lexer pos 1 cs+lexer pos ('`':cs) | nonSym cs = (pos,LexQUOTE) : nextinc lexer pos 1 cs+lexer pos (';':cs) | nonSym cs = (pos,LexSEMI) : nextinc lexer pos 1 cs+lexer pos ('|':cs) | nonSym cs = (pos,LexBAR) : nextinc lexer pos 1 cs+lexer pos ('~':cs) | nonSym cs = (pos,LexTILDE) : nextinc lexer pos 1 cs+lexer pos ('@':cs) | nonSym cs = (pos,LexAT) : nextinc lexer pos 1 cs+lexer pos ('=':cs) | nonSym cs = (pos,LexASG) : nextinc lexer pos 1 cs+lexer pos ('\\':cs) | nonSym cs = (pos,LexBSLASH) : nextinc lexer pos 1 cs+lexer pos ('!':cs) | nonSym cs = (pos,LexEXCL) : nextinc lexer pos 1 cs+lexer pos (':':cs) | nonSym cs = (pos,LexCOLON) : nextinc lexer pos 1 cs+-- lexer pos ('-':cs) | nonSym cs = (pos,LexDASH) : nextinc lexer pos 1 cs++lexer pos ('(':cs) = (pos,LexLPAREN) : nextinc lexer pos 1 cs+lexer pos (')':cs) = (pos,LexRPAREN) : nextinc lexer pos 1 cs+lexer pos ('[':cs) = (pos,LexLBRACKET):nextinc lexer pos 1 cs+lexer pos (']':cs) = (pos,LexRBRACKET):nextinc lexer pos 1 cs+lexer pos ('{':cs) = (pos,LexLBRACE) : nextinc lexer pos 1 cs+lexer pos ('}':cs) = (pos,LexRBRACE) : nextinc lexer pos 1 cs++lexer pos ('\'':cs) = nextinc lexChar pos 1 cs+lexer pos ('"':cs) = lexString (incpos pos 1) (pos,"") cs++lexer pos ('0':cs) = lexZero pos cs++lexer pos xs@(':':_) = lexWhile isSymbol LexConOp pos pos xs+lexer pos ('$':xs@(c:_)) | isLower c || c == '_' = let np = incpos pos 1 in lexWhile isLetter LexId np np xs+lexer pos xs@(c:cs) | isLower c || c == '_' = lexWhile isLetter LexId pos pos xs+ | isUpper c = lexConOrQual pos xs+ | isSpace c = next lexer pos c cs+ | isSymbol c = lexWhile isSymbol LexOp pos pos xs+ | isDigit c = lexIntFloat pos xs+ | otherwise = (pos,LexUnknown c) : next lexer pos c cs++next :: (Pos -> String -> a) -> Pos -> Char -> String -> a+next f pos c cs = let pos' = newpos pos c in seq pos' (f pos' cs)++nextinc :: (Pos -> String -> a) -> Pos -> Int -> String -> a+nextinc f pos i cs = let pos' = incpos pos i in seq pos' (f pos' cs)++lexConOrQual :: Lexer+lexConOrQual pos cs+ = let (ident,rest) = span isLetter cs+ pos' = foldl' newpos pos ident+ in case rest of+ '.':ds@(d:_) | isLower d || d == '_' + -> lexWhile isLetter (LexQualId ident) pos (incpos pos' 1) ds+ | isUpper d -> lexWhile isLetter (LexQualCon ident) pos (incpos pos' 1) ds+ | isSymbol d -> lexWhile isSymbol (LexQualId ident) pos (incpos pos' 1) ds+ '.':'\'':'\'':ds -> case lexSpecialId pos (incpos pos 3) ds of+ (pos1, LexCon s):xs -> (pos1, LexQualCon ident s):xs+ (pos1, LexId s):xs -> (pos1, LexQualId ident s):xs+ xs -> xs+ _ -> (pos,LexCon ident) : seq pos' (lexer pos' rest)++lexWhile :: (Char -> Bool) -> (String -> Lexeme) -> Pos -> Lexer+lexWhile ctype con pos0 pos cs = let (ident,rest) = span ctype cs+ pos' = foldl' newpos pos ident+ in (pos0,con ident) : seq pos' (lexer pos' rest)++lexSpecialId :: Pos -> Lexer+lexSpecialId originalPos pos cs -- originalPos points to where '' started. it should+ -- be used as the position of the identifier because of the layout rule+ -- y = 4+ -- ''x'' = 3 -- x and y should be in the same context+ = let (ident,rest) = span (\c -> not (isSpace c) && c /= '\'') cs in+ case rest of+ ('\'':'\'':cs')-> let pos' = foldl' newpos pos (ident ++ "''") in+ seq pos' $+ case ident of+ [] -> (originalPos,LexError "empty special identifier") : lexer pos' cs'+ -- ":" -> (originalPos,LexError "empty special con identifier") : lexer pos' cs'+ ":" -> (originalPos,LexId ident) : lexer pos' cs'+ ':':conid -> (originalPos,LexCon conid) : lexer pos' cs'+ _ -> (originalPos,LexId ident) : lexer pos' cs'+ _ -> let pos' = foldl' newpos pos ident in+ (pos',LexError ("expecting '' after special identifier " ++ show ident)):lexer pos' rest++-----------------------------------------------------------+-- Numbers+-----------------------------------------------------------++lexZero :: Lexer+lexZero pos (c:cs) | c == 'o' || c == 'O' = case octal pos' cs of+ Just (i,pos'',cs') -> (pos, LexInt i) : lexer pos'' cs'+ Nothing -> (pos, LexError "illegal octal number")+ : lexer pos' cs+ | c == 'x' || c == 'X' = case hexal pos' cs of+ Just (i,pos'',cs') -> (pos, LexInt i) : lexer pos'' cs'+ Nothing -> (pos, LexError "illegal hexadecimal number")+ : lexer pos' cs+ | c == '.' = lexFloat 0 pos' cs+ | isDigit c = lexIntFloat pos (c:cs)+ | otherwise = (pos,LexInt 0) : lexer pos' (c:cs)+ where+ pos' = newpos (newpos pos '0') c+lexZero pos cs = (pos,LexInt 0) : lexer (newpos pos '0') cs++lexIntFloat :: Lexer+lexIntFloat pos cs = case decimal pos cs of+ Just (i,pos',cs') ->+ case cs' of ('.':cs'') -> lexFloat i (newpos pos' '.') cs''+ _ -> (pos,LexInt i) : lexer pos' cs'+ _ -> error "lexIntFloat"++lexFloat :: Integer -> Lexer+lexFloat i pos cs = let (fracterr,fract,pos',cs') = lexFract pos cs+ (experr,expon,pos'',cs'') = lexExponent pos' cs'+ in fracterr (experr ( (pos,LexFloat ((fromInteger i + fract) * expon)) : lexer pos'' cs''))++lexFract :: Lexer5+lexFract pos cs = let (xs,rest) = span isDigit cs+ in if null xs+ then ( ((pos,LexError "invalid fraction") :), 0.0, pos, cs )+ else ( id, foldr op 0.0 xs, foldl' newpos pos xs, rest )+ where+ c `op` f = (f + fromIntegral (fromEnum c - fromEnum '0'))/10.0++lexExponent :: Lexer5+lexExponent pos (c:cs) | c == 'e' || c == 'E' = case cs of ('-':cs') -> lexExp negate (incpos pos 2) cs'+ ('+':cs') -> lexExp id (incpos pos 2) cs'+ _ -> lexExp id (incpos pos 1) cs+lexExponent pos cs = (id, 1.0, pos, cs)++lexExp :: (Integer -> Integer) -> Lexer5+lexExp f pos cs = case decimal pos cs of+ Just (i,pos',cs') -> (id,power (f i),pos',cs')+ Nothing -> (((pos,LexError "invalid exponent"):), 1.0, pos, cs )+ where+ power e | e < 0 = 1.0/power(-e)+ | otherwise = fromInteger (10^e)++hexal, octal, decimal :: Pos -> String -> Maybe (Integer, Pos, String)+hexal = number 16 isHexal+octal = number 8 isOctal+decimal = number 10 isDigit++number ::Integer-> (Char -> Bool) -> Pos -> String -> Maybe (Integer,Pos,String)+number base test pos cs = let (xs,rest) = span test cs+ in if null xs+ then Nothing+ else Just (foldl' op 0 xs, foldl' newpos pos xs, rest)+ where+ x `op` y = base*x + fromIntegral (fromChar y)+ fromChar c | isDigit c = fromEnum c - fromEnum '0'+ | otherwise = fromEnum (toUpper c) - fromEnum 'A'++isOctal, isHexal :: Char -> Bool+isOctal = isOctDigit +isHexal = isHexDigit ++-----------------------------------------------------------+-- Characters+-----------------------------------------------------------++lexChar :: Lexer+lexChar pos ('\\':cs) = let (pos',lexeme,xs) = escapeChar pos cs+ in lexEndChar lexeme pos' xs+lexChar pos ('\'':cs) = (pos,LexError "empty character") : nextinc lexer pos 1 cs++lexChar pos (c:cs) | isGraphic c || c == '"' || c == ' ' = lexEndChar (pos,LexChar c) (incpos pos 1) cs+ | otherwise = (pos,LexError "invalid character") : next lexer pos c cs++lexChar pos [] = (pos,LexError "unexpected end of input in character") : lexer pos []++lexEndChar :: Token -> Lexer+lexEndChar lexeme pos ('\'':cs) = lexeme : nextinc lexer pos 1 cs+lexEndChar _ pos cs = (pos,LexError "expecting termiInting symbol \"'\"") : lexer pos cs+++lexString :: Pos -> (Pos, String) -> String -> [Token]+lexString pos (p,s) ('"':cs) = (p,LexString (reverse s)) : nextinc lexer pos 1 cs++lexString pos (p,s) ('\n':cs) = (p,LexString (reverse s)) : (pos,LexError "newline in string") : next lexer pos '\n' cs++lexString pos (p,s) ('\\':c:cs) | isSpace c = gap (incpos pos 1) (p,s) cs+ | c == '&' = lexString (incpos pos 2) (p,s) cs+ | otherwise = let (pos',(_,lexeme),cs') = escapeChar pos (c:cs)+ in case lexeme of+ LexChar d -> lexString pos' (p,d:s) cs'+ _ -> (pos,LexError "illegal escape sequence") :+ lexString pos' (p,s) cs'++lexString pos (p,s) [] = (p,LexString (reverse s))+ : (pos,LexError "unexpected end of input in string")+ : lexer pos []+lexString pos (p,s) ['\\'] = lexString (incpos pos 1) (p,s) []++lexString pos (p,s) (c:cs) | isGraphic c || c == '\'' || c == ' '+ = lexString (incpos pos 1) (p,c:s) cs+ | otherwise = (pos,LexError ("illegal character (" ++ [c] ++ ") in string"))+ : lexString (newpos pos c) (p,s) cs++gap :: Pos -> (Pos, String) -> String -> [Token]+gap pos (p,s) cs = let (ws,rest) = span isSpace cs+ pos' = foldl' newpos pos ws+ in case rest of+ ('\\':cs') -> lexString pos' (p,s) cs'+ _ -> (pos',LexError "(\\) expected at end of gap")+ : lexString pos' (p,s) rest++-----------------------------------------------------------+-- Escape sequences+-----------------------------------------------------------+++escapeChar :: Pos -> String -> (Pos,Token,String)+escapeChar pos [] = (pos,(pos,LexError "Unexpected end of input"),[])+escapeChar pos cs = fromMaybe def (msum [ f pos cs | f <- fs ])+ where+ def = (pos,(pos,LexError "invalid escape sequence"),cs)+ fs = [ascii3, ascii2, escape, control, charnum]++charnum :: Pos -> String -> Maybe (Pos,Token,String)+charnum pos ('x':cs) = numToChar pos (hexal (incpos pos 1) cs)+charnum pos ('o':cs) = numToChar pos (octal (incpos pos 1) cs)+charnum pos ('d':cs) = numToChar pos (decimal (incpos pos 1) cs)+charnum pos (c:cs) | isDigit c = numToChar pos (decimal (incpos pos 1) cs)+charnum _ _ = Nothing++numToChar :: Pos -> Maybe (Integer, Pos, String) -> Maybe (Pos, Token, String)+numToChar pos (Just (x,pos',cs')) = Just (pos',(pos,LexChar (toEnum (fromInteger x))), cs')+numToChar _ _ = Nothing++++control :: Pos -> String -> Maybe (Pos,Token,String)+control pos ('^':c:cs) | isUpper c = let x = toEnum (fromEnum c - fromEnum 'A')+ in Just (incpos pos 2, (pos,LexChar x), cs)+control _ _ = Nothing++++escape :: Pos -> String -> Maybe (Pos,Token,String)+escape pos (c:cs) = case lookup c escapemap of+ Just k -> Just (incpos pos 1, (pos,LexChar k), cs)+ Nothing -> Nothing+escape _ _ = Nothing++ascii2 :: Pos -> String -> Maybe (Pos,Token,String)+ascii2 pos (x:y:cs) = case lookup [x,y] ascii2map of+ Just k -> Just (incpos pos 2, (pos,LexChar k), cs)+ Nothing -> Nothing+ascii2 _ _ = Nothing++ascii3 :: Pos -> String -> Maybe (Pos,Token,String)+ascii3 pos (x:y:z:cs)= case lookup [x,y,z] ascii3map of+ Just k -> Just (incpos pos 3, (pos,LexChar k), cs)+ Nothing -> Nothing+ascii3 _ _ = Nothing++++escapemap :: [(Char, Char)]+escapemap = zip "abfnrtv\\\"\'"+ "\a\b\f\n\r\t\v\\\"\'"++ascii2map :: [(String, Char)]+ascii2map = zip ["BS","HT","LF","VT","FF","CR","SO","SI","EM",+ "FS","GS","RS","US","SP"]+ "\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP"++ascii3map :: [(String, Char)]+ascii3map = zip ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL",+ "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB",+ "CAN","SUB","ESC","DEL"]+ "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\SUB\ESC\DEL"+++-----------------------------------------------------------+-- Symbols+-----------------------------------------------------------++isSpecial, isSmall, isLarge, isLetter, isSymbol :: Char -> Bool+isSpecial = (`elem` "(),;[]`{}")+isSmall c = isLower c || c == '_'+isLarge = isUpper+isLetter c = isSmall c || isLarge c || isDigit c || c == '\''+isSymbol = (`elem` "!#$%&*+./<=>?@\\^|-~:")++isGraphic :: Char -> Bool+isGraphic c = isLetter c || isSymbol c || isSpecial c || (c == ':') || (c == '"')++nonId :: String -> Bool+nonId (c:_) = not (isLetter c)+nonId [] = True++nonSym :: String -> Bool+nonSym (c:_) = not (isSymbol c)+nonSym [] = True++-----------------------------------------------------------+-- Comment+-----------------------------------------------------------++lexeol :: Lexer+lexeol pos ('\n':cs) = lexer (newpos pos '\n') cs+lexeol pos (c:cs) = lexeol (newpos pos c) cs+lexeol pos [] = lexer pos []++lexComment :: Int -> Lexer+lexComment level pos s =+ case s of+ '-':'}':cs | level == 0 -> lexer (incpos pos 2) cs+ | otherwise -> lexComment (level - 1) (incpos pos 2) cs+ '{':'-':cs -> lexComment (level+1) (incpos pos 2) cs+ c:cs -> lexComment level (newpos pos c) cs+ [] -> lexer pos []
+ Lvm/Core/Parsing/Parser.hs view
@@ -0,0 +1,1014 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Parser.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Core.Parsing.Parser (parseModuleExport, parseModule) where++import Control.Monad+import Data.List+import Lvm.Common.Byte+import Lvm.Common.Id+import Lvm.Common.IdSet+import Lvm.Core.Expr+import Lvm.Core.Parsing.Token (Token, Lexeme(..))+import Lvm.Core.Type+import Lvm.Core.Utils+import Prelude hiding (lex)+import Text.ParserCombinators.Parsec hiding (satisfy)++parseModuleExport :: FilePath -> [Token] -> IO (CoreModule, Bool, (IdSet,IdSet,IdSet,IdSet,IdSet))+parseModuleExport fname ts =+ case runParser pmodule () fname ts of+ Left err+ -> ioError (userError ("parse error: " ++ show err))+ Right res+ -> return res++parseModule :: FilePath -> [Token] -> IO CoreModule+parseModule fname = liftM (\(m, _, _) -> m) . parseModuleExport fname++----------------------------------------------------------------+-- Basic parsers+----------------------------------------------------------------+type TokenParser a = GenParser Token () a ++----------------------------------------------------------------+-- Program+----------------------------------------------------------------++wrap :: TokenParser a -> TokenParser [a]+wrap p+ = do{ x <- p; return [x] }++pmodule :: TokenParser (CoreModule, Bool, (IdSet,IdSet,IdSet,IdSet,IdSet))+pmodule =+ do{ lexeme LexMODULE+ ; moduleId <- conid <?> "module name"+ ; exports <- pexports+ ; lexeme LexWHERE+ ; lexeme LexLBRACE+ ; declss <- semiList (wrap (ptopDecl <|> pconDecl <|> pabstract <|> pextern <|> pCustomDecl)+ <|> pdata <|> pimport <|> ptypeTopDecl)+ ; lexeme LexRBRACE+ ; lexeme LexEOF++ ; return $+ case exports of+ Nothing ->+ let es = (emptySet,emptySet,emptySet,emptySet,emptySet)+ in+ ( modulePublic+ True+ es+ (Module moduleId 0 0 (concat declss))+ , True+ , es+ )+ Just es ->+ ( modulePublic+ False+ es+ (Module moduleId 0 0 (concat declss))+ , False+ , es+ )+ + }++----------------------------------------------------------------+-- export list+----------------------------------------------------------------+data Export = ExportValue Id+ | ExportCon Id+ | ExportData Id + | ExportDataCon Id+ | ExportModule Id++pexports :: TokenParser (Maybe (IdSet,IdSet,IdSet,IdSet,IdSet))+pexports+ = do{ exports <- commaParens pexport <|> return []+ ; return $+ if null (concat exports) then+ Nothing+ else+ Just (foldl'+ split+ (emptySet,emptySet,emptySet,emptySet,emptySet)+ (concat exports)+ )+ }+ where+ split (values,cons,datas,datacons,ms) export+ = case export of+ ExportValue x -> (insertSet x values,cons,datas,datacons,ms)+ ExportCon x -> (values,insertSet x cons,datas,datacons,ms)+ ExportData x -> (values,cons,insertSet x datas,datacons,ms)+ ExportDataCon x -> (values,cons,datas,insertSet x datacons,ms)+ ExportModule x -> (values,cons,datas,datacons,insertSet x ms)++pexport :: TokenParser [Export]+pexport+ = do{ lexeme LexLPAREN+ ; entity <-+ do { x <- opid ; return (ExportValue x) }+ <|>+ do { x <- conopid; return (ExportCon x) }+ ; lexeme LexRPAREN+ ; return [entity]+ }+ <|>+ do{ x <- varid+ ; return [ExportValue x]+ }+ <|>+ do{ x <- typeid+ ; do{ lexeme LexLPAREN+ ; cons <- pexportCons x+ ; lexeme LexRPAREN+ ; return (ExportData x:cons)+ }+ <|>+ -- no parenthesis: could be either a+ -- constructor or a type constructor+ return [ExportData x, ExportCon x]+ } + <|>+ do{ lexeme LexMODULE+ ; x <- conid+ ; return [ExportModule x]+ }++pexportCons :: Id -> TokenParser [Export]+pexportCons x+ = do{ lexeme LexDOTDOT+ ; return [ExportDataCon x]+ }+ <|>+ do{ xs <- sepBy constructor (lexeme LexCOMMA)+ ; return (map ExportCon xs)+ }+++----------------------------------------------------------------+-- abstract declarations+----------------------------------------------------------------+pabstract :: TokenParser CoreDecl+pabstract+ = do{ lexeme LexABSTRACT+ ; pabstractValue <|> pabstractCon+ }++pabstractValue :: TokenParser (Decl v)+pabstractValue+ = do{ x <- variable+ ; (acc,custom) <- pAttributes private+ ; lexeme LexASG+ ; (mid,impid) <- qualifiedVar+ ; arity <- liftM fromInteger lexInt+ <|> liftM (arityFromType . fst) ptypeDecl+ ; let access | isImported acc = acc+ | otherwise = Imported False mid impid DeclKindValue 0 0+ ; return (DeclAbstract x access arity custom)+ }++pabstractCon :: TokenParser (Decl v)+pabstractCon+ = do{ x <- conid+ ; (acc,custom) <- pAttributes private -- ignore access+ ; lexeme LexASG+ ; (mid,impid) <- qualifiedCon+ ; (tag, arity) <- pConInfo+ ; let access | isImported acc = acc+ | otherwise = Imported False mid impid DeclKindCon 0 0+ ; return (DeclCon x access arity tag custom)+ }++isImported :: Access -> Bool+isImported (Imported {}) = True+isImported _ = False++----------------------------------------------------------------+-- import declarations+----------------------------------------------------------------+pimport :: TokenParser [CoreDecl]+pimport+ = do{ lexeme LexIMPORT+ ; mid <- conid+ ; do{ xss <- commaParens (pImportSpec mid)+ ; return (concat xss)+ }+ <|>+ return [DeclImport mid (Imported False mid dummyId DeclKindModule 0 0) []]+ }++pImportSpec :: Id -> TokenParser [CoreDecl]+pImportSpec mid+ = do{ lexeme LexLPAREN+ ; (kind, x) <-+ do { y <- opid ; return (DeclKindValue, y) }+ <|>+ do { y <- conopid; return (DeclKindCon , y) }+ ; lexeme LexRPAREN+ ; impid <- option x (do{ lexeme LexASG; variable })+ ; return [DeclImport x (Imported False mid impid kind 0 0) []]+ }+ <|>+ do{ x <- varid+ ; impid <- option x (do{ lexeme LexASG; variable })+ ; return [DeclImport x (Imported False mid impid DeclKindValue 0 0) []]+ }+ <|>+ do{ lexeme LexCUSTOM+ ; kind <- lexString+ ; x <- variable <|> constructor+ ; impid <- option x (do { lexeme LexASG; variable <|> constructor })+ ; return [DeclImport x (Imported False mid impid (customDeclKind kind) 0 0) []]+ }+ <|>+ do{ x <- typeid+ ; impid <- option x (do{ lexeme LexASG; variable })+ ; do{ lexeme LexLPAREN+ ; cons <- pImportCons mid+ ; lexeme LexRPAREN+ ; return (DeclImport x (Imported False mid impid customData 0 0) [] : cons)+ }+ <|>+ return+ [DeclImport x (Imported False mid impid DeclKindCon 0 0) []]+ }++pImportCons :: Id -> TokenParser [CoreDecl]+pImportCons mid+ = -- do{ lexeme LexDOTDOT+ -- ; return [ExportDataCon id]+ -- }+ -- <|>+ sepBy (pimportCon mid) (lexeme LexCOMMA)++pimportCon :: Id -> TokenParser CoreDecl+pimportCon mid+ = do{ x <- constructor+ ; impid <- option x (do{ lexeme LexASG; variable })+ ; return (DeclImport x (Imported False mid impid DeclKindCon 0 0) [])+ }++----------------------------------------------------------------+-- constructor declarations+----------------------------------------------------------------++pconDecl :: TokenParser CoreDecl+pconDecl = do+ lexeme LexCON+ x <- constructor+ (access,custom) <- pAttributes public+ lexeme LexASG+ (tag, arity) <- pConInfo+ return $ DeclCon x access arity tag custom++-- constructor info: (@tag, arity)+pConInfo :: TokenParser (Tag, Arity)+pConInfo = (parens $ do+ lexeme LexAT+ tag <- lexInt <?> "tag" + lexeme LexCOMMA+ arity <- lexInt <?> "arity"+ return (fromInteger tag, fromInteger arity))+ <|> do -- :: TypeSig = tag+ (tp, _) <- ptypeDecl+ lexeme LexASG+ tag <- lexInt <?> "tag" + return (fromInteger tag, arityFromType tp)+ ++----------------------------------------------------------------+-- value declarations+----------------------------------------------------------------++ptopDecl :: TokenParser CoreDecl+ptopDecl+ = do{ x <- variable+ ; ptopDeclType x <|> ptopDeclDirect x+ }++ptopDeclType :: Id -> TokenParser (Decl Expr)+ptopDeclType x+ = do{ (tp,_) <- ptypeDecl+ ; lexeme LexSEMI+ ; x2 <- variable+ ; when (x /= x2) $ fail+ ( "identifier for type signature "+ ++ stringFromId x+ ++ " doesn't match the definition"+ ++ stringFromId x2+ )+ ; (access,custom,expr) <- pbindTopRhs+ ; return (DeclValue x access Nothing expr + (customType tp : custom))+ }++ptopDeclDirect :: Id -> TokenParser (Decl Expr)+ptopDeclDirect x+ = do{ (access,custom,expr) <- pbindTopRhs+ ; return (DeclValue x access Nothing expr custom)+ }++pbindTopRhs :: TokenParser (Access, [Custom], Expr)+pbindTopRhs+ = do{ args <- many bindid+ ; (access,custom) <- pAttributes public+ ; lexeme LexASG+ ; body <- pexpr+ ; let expr = foldr Lam body args+ ; return (access,custom,expr)+ }+ <?> "declaration"++++pbind :: TokenParser Bind+pbind+ = do{ x <- variable+ ; expr <- pbindRhs+ ; return (Bind x expr)+ }++pbindRhs :: TokenParser Expr+pbindRhs+ = do{ args <- many bindid+ ; lexeme LexASG+ ; body <- pexpr+ ; let expr = foldr Lam body args+ ; return expr+ }+ <?> "declaration"++----------------------------------------------------------------+-- data declarations+----------------------------------------------------------------++makeCustomBytes :: String -> Bytes -> Custom+makeCustomBytes k bs = CustomDecl (customDeclKind k) [CustomBytes bs]++customType :: Type -> Custom+customType = makeCustomBytes "type" . bytesFromString . show++customKind :: Kind -> Custom+customKind = makeCustomBytes "kind" . bytesFromString . show++pdata :: TokenParser [CoreDecl]+pdata+ = do{ lexeme LexDATA+ ; x <- typeid+ ; args <- many typevarid+ ; let kind = foldr (KFun . const KStar) KStar args+ datadecl = DeclCustom x public customData [customKind kind]+ ; do{ lexeme LexASG+ ; let t1 = foldl TAp (TCon x) (map TVar args)+ ; cons <- sepBy1 (pconstructor t1) (lexeme LexBAR)+ ; let con tag (cid,t2) = DeclCon cid public (arityFromType t2) tag + [customType t2, + CustomLink x customData]+ ; return (datadecl:zipWith con [0..] cons)+ }+ <|> {- empty data types -}+ return [datadecl]+ }++pconstructor :: Type -> TokenParser (Id,Type)+pconstructor tp+ = do{ x <- constructor+ ; args <- many ptypeAtom+ ; return (x,foldr TFun tp args)+ }++----------------------------------------------------------------+-- type declarations+----------------------------------------------------------------++ptypeTopDecl :: TokenParser [CoreDecl]+ptypeTopDecl+ = do{ lexeme LexTYPE+ ; x <- typeid+ ; args <- many typevarid+ ; lexeme LexASG+ ; tp <- ptype+ ; let kind = foldr (KFun . const KStar) KStar args+ tpstr = unwords $ stringFromId x + : map stringFromId args+ ++ ["=", show tp]+ ; return [DeclCustom x private customTypeDecl + [CustomBytes (bytesFromString tpstr)+ ,customKind kind]]+ }++----------------------------------------------------------------+-- Custom+----------------------------------------------------------------+pCustomDecl :: TokenParser CoreDecl+pCustomDecl+ = do{ lexeme LexCUSTOM+ ; kind <- pdeclKind+ ; x <- customid+ ; (access,customs) <- pAttributes private+ ; return (DeclCustom x access kind customs)+ }++pAttributes :: Access -> TokenParser (Access,[Custom])+pAttributes defAccess+ = do{ lexeme LexCOLON+ ; access <- paccess defAccess+ ; customs <- pcustoms+ ; return (access, customs)+ }+ <|> return (private,[])++paccess :: Access -> TokenParser Access+paccess defAccess+ = do{ lexeme LexPRIVATE; pimportaccess False <|> return private }+ <|> do{ lexeme LexPUBLIC; pimportaccess True <|> return public }+ <|> return defAccess++pimportaccess :: Bool -> TokenParser Access+pimportaccess isPublic = do+ lexeme LexIMPORT+ kind <- pdeclKind+ (m, x) <- lexQualifiedId+ return $ Imported isPublic (idFromString m) (idFromString x) kind 0 0++pcustoms :: TokenParser [Custom]+pcustoms+ = do{ lexeme LexLBRACKET+ ; customs <- pcustom `sepBy` lexeme LexCOMMA+ ; lexeme LexRBRACKET+ ; return customs+ }+ <|> return []++pcustom :: TokenParser Custom+pcustom+ = do{ i <- lexInt; return (CustomInt (fromInteger i)) }+ <|> do{ s <- lexString; return (CustomBytes (bytesFromString s)) }+ <|> do{ x <- variable <|> constructor; return (CustomName x) }+ <|> do{ lexeme LexNOTHING; return CustomNothing }+ <|> do{ lexeme LexCUSTOM + ; kind <- pdeclKind+ ; do{ x <- customid+ ; return (CustomLink x kind)+ }+ <|>+ do{ cs <- pcustoms+ ; return (CustomDecl kind cs)+ }+ }+ <?> "custom value"++pdeclKind :: TokenParser DeclKind+pdeclKind+ = do{ x <- varid; return (makeDeclKind x) }+ <|> do{ i <- lexInt; return (toEnum (fromInteger i)) }+ <|> do{ s <- lexString; return (customDeclKind s) }+ <?> "custom kind"++----------------------------------------------------------------+-- Expressions+----------------------------------------------------------------++pexpr :: TokenParser Expr+pexpr+ = do{ lexeme LexBSLASH+ ; args <- many bindid+ ; lexeme LexRARROW+ ; expr <- pexpr+ ; return (foldr Lam expr args)+ }+ <|>+ do{ lexeme LexLET+ ; binds <- semiBraces pbind+ ; lexeme LexIN+ ; expr <- pexpr+ ; return (Let (Rec binds) expr)+ }+ <|>+ do{ lexeme LexCASE+ ; expr <- pexpr+ ; lexeme LexOF+ ; (x,alts) <- palts+ ; case alts of+ [Alt PatDefault rhs] -> return (Let (Strict (Bind x expr)) rhs)+ _ -> return (Let (Strict (Bind x expr)) (Match x alts))+ }+ <|>+ do{ lexeme LexMATCH+ ; x <- variable+ ; lexeme LexWITH+ ; (defid,alts) <- palts+ ; case alts of+ -- better approach is to optize these cases *after* parsing+ [Alt PatDefault rhs] + | x == defid -> return rhs+ | otherwise -> return (Let (NonRec (Bind defid (Var x))) rhs)+ _ | x == defid -> return (Match x alts)+ | defid == wildId -> return (Match x alts)+ | otherwise -> return (Let (NonRec (Bind defid (Var x))) (Match defid alts))+ }+ <|> + do{ lexeme LexLETSTRICT+ ; binds <- semiBraces pbind+ ; lexeme LexIN+ ; expr <- pexpr+ ; return (foldr (Let . Strict) expr binds)+ }+ <|> pexprAp+ <?> "expression"++wildId :: Id+wildId = idFromString "_"++pexprAp :: TokenParser Expr+pexprAp+ = do{ atoms <- many1 patom+ ; return (foldl1 Ap atoms)+ }++patom :: TokenParser Expr+patom+ = do{ x <- varid; return (Var x) }+ <|> do{ x <- conid; return (Con (ConId x)) }+ <|> do{ lit <- pliteral; return (Lit lit) }+ <|> parenExpr+ <|> listExpr+ <?> "atomic expression"+++listExpr :: TokenParser Expr+listExpr+ = do{ lexeme LexLBRACKET+ ; exprs <- sepBy pexpr (lexeme LexCOMMA)+ ; lexeme LexRBRACKET+ ; return (foldr cons nil exprs)+ }+ where+ cons = Ap . Ap (Con (ConId (idFromString ":")))+ nil = Con (ConId (idFromString "[]"))++parenExpr :: TokenParser Expr+parenExpr+ = do{ lexeme LexLPAREN+ ; expr <- do{ x <- opid+ ; return (Var x)+ }+ <|>+ do{ x <- conopid+ ; return (Con (ConId x))+ }+ <|> + do{ lexeme LexAT+ ; tag <- ptagExpr + ; lexeme LexCOMMA+ ; arity <- lexInt <?> "arity"+ ; return (Con (ConTag tag (fromInteger arity)))+ }+ <|>+ do{ exprs <- pexpr `sepBy` lexeme LexCOMMA+ ; case exprs of+ [expr] -> return expr+ _ -> let con = Con (ConTag (Lit (LitInt 0)) (length exprs))+ tup = foldl Ap con exprs+ in return tup+ }+ ; lexeme LexRPAREN+ ; return expr+ }++ptagExpr :: TokenParser Expr+ptagExpr+ = do{ i <- lexInt; return (Lit (LitInt (fromInteger i))) }+ <|> do{ x <- variable; return (Var x) }+ <?> "tag (integer or variable)"++pliteral :: TokenParser Literal+pliteral+ = pnumber id id+ <|> do{ s <- lexString; return (LitBytes (bytesFromString s)) }+ <|> do{ c <- lexChar; return (LitInt (fromEnum c)) }+ <|> do{ lexeme LexDASH+ ; pnumber negate negate+ }+ <?> "literal"++pnumber :: (Int -> Int) -> (Double -> Double) -> TokenParser Literal+pnumber signint signdouble+ = do{ i <- lexInt; return (LitInt (signint (fromInteger i))) }+ <|> do{ d <- lexDouble; return (LitDouble (signdouble d)) }++----------------------------------------------------------------+-- alternatives+----------------------------------------------------------------+palts :: TokenParser (Id,Alts)+palts+ = do{ lexeme LexLBRACE+ ; (x,alts) <- paltSemis+ ; return (x,alts)+ }++paltSemis :: TokenParser (Id,Alts)+paltSemis+ = do{ (x,alt) <- paltDefault+ ; optional (lexeme LexSEMI)+ ; lexeme LexRBRACE+ ; return (x,[alt])+ }+ <|>+ do{ alt <- palt+ ; do{ lexeme LexSEMI+ ; do{ (x,alts) <- paltSemis+ ; return (x,alt:alts)+ }+ <|> do{ lexeme LexRBRACE+ ; x <- wildcard+ ; return (x,[alt])+ }+ }+ <|> do{ lexeme LexRBRACE+ ; x <- wildcard+ ; return (x,[alt])+ }+ }++palt :: TokenParser Alt+palt + = do{ pat <- ppat+ ; lexeme LexRARROW+ ; expr <- pexpr+ ; return (Alt pat expr)+ }++ppat :: TokenParser Pat+ppat + = ppatCon <|> ppatLit <|> ppatParens++ppatParens :: TokenParser Pat+ppatParens+ = do{ lexeme LexLPAREN+ ; do{ lexeme LexAT+ ; tag <- lexInt <?> "tag" + ; lexeme LexCOMMA+ ; arity <- lexInt <?> "arity"+ ; lexeme LexRPAREN+ ; ids <- many bindid+ ; return (PatCon (ConTag (fromInteger tag) (fromInteger arity)) ids)+ }+ <|>+ do{ x <- conopid+ ; lexeme LexRPAREN+ ; ids <- many bindid+ ; return (PatCon (ConId x) ids)+ }+ <|>+ do{ pat <- ppat <|> ppatTuple + ; lexeme LexRPAREN+ ; return pat+ }+ }++ppatCon :: TokenParser Pat+ppatCon+ = do{ x <- conid <|> do{ lexeme LexLBRACKET; lexeme LexRBRACKET; return (idFromString "[]") } + ; args <- many bindid+ ; return (PatCon (ConId x) args)+ }++ppatLit :: TokenParser Pat+ppatLit+ = do{ lit <- pliteral; return (PatLit lit) }++ppatTuple :: TokenParser Pat+ppatTuple+ = do{ ids <- bindid `sepBy` lexeme LexCOMMA+ ; return (PatCon (ConTag 0 (length ids)) ids)+ }++paltDefault :: TokenParser (Id, Alt)+paltDefault+ = do{ x <- bindid <|> do{ lexeme LexDEFAULT; wildcard }+ ; lexeme LexRARROW+ ; expr <- pexpr+ ; return (x,Alt PatDefault expr)+ }++wildcard :: TokenParser Id+wildcard+ = identifier (return "_")++----------------------------------------------------------------+-- externs+----------------------------------------------------------------+pextern :: TokenParser CoreDecl+pextern+ = do{ lexeme LexEXTERN+ ; linkConv <- plinkConv+ ; callConv <- pcallConv+ ; x <- varid+ ; m <- lexString <|> return (stringFromId x)+ ; (mname,name) <- pExternName m+ ; (tp,arity) <- ptypeDecl+ ; return (DeclExtern x private arity (show tp) linkConv callConv mname name [])+ }+ <|>+ do{ lexeme LexINSTR+ ; x <- varid+ ; s <- lexString+ ; (tp,arity) <- ptypeDecl+ ; return (DeclExtern x private arity (show tp) LinkStatic CallInstr "" (Plain s) [])+ }++------------------++plinkConv :: TokenParser LinkConv+plinkConv+ = do{ lexeme LexSTATIC; return LinkStatic }+ <|> do{ lexeme LexDYNAMIC; return LinkDynamic }+ <|> do{ lexeme LexRUNTIME; return LinkRuntime }+ <|> return LinkStatic++pcallConv :: TokenParser CallConv+pcallConv+ = do{ lexeme LexCCALL; return CallC }+ <|> do{ lexeme LexSTDCALL; return CallStd }+ <|> do{ lexeme LexINSTRCALL; return CallInstr }+ <|> return CallC++pExternName :: String -> TokenParser (String, ExternName)+pExternName mname+ = do{ lexeme LexDECORATE+ ; name <- lexString+ ; return (mname,Decorate name)+ }+ <|> do{ lexeme LexORDINAL+ ; ord <- lexInt+ ; return (mname,Ordinal (fromIntegral ord))+ }+ <|> do{ name <- lexString+ ; return (mname,Plain name)+ }+ <|> return ("",Plain mname)+++----------------------------------------------------------------+-- types+----------------------------------------------------------------++ptypeDecl :: TokenParser (Type, Int)+ptypeDecl+ = do{ lexeme LexCOLCOL+ ; ptypeNormal <|> ptypeString+ }++ptypeNormal :: TokenParser (Type, Int)+ptypeNormal+ = do{ tp <- ptype+ ; return (tp,arityFromType tp)+ }+++ptype :: TokenParser Type+ptype+ = ptypeFun++ptypeFun :: TokenParser Type+ptypeFun+ = chainr1 ptypeAp pFun+ where+ pFun = do{ lexeme LexRARROW; return TFun }++ptypeAp :: TokenParser Type+ptypeAp+ = do{ atoms <- many1 ptypeAtom+ ; return (foldl1 TAp atoms)+ }++ptypeAtom :: TokenParser Type+ptypeAtom+ = do{ x <- typeid+ ; ptypeStrict (TCon x) + }+ <|>+ do{ x <- typevarid+ ; ptypeStrict (TVar x)+ }+ <|> listType+ <|> parenType+ <?> "atomic type"++ptypeStrict :: Type -> TokenParser Type+ptypeStrict tp+ = do{ lexeme LexEXCL+ ; return (TStrict tp)+ }+ <|> return tp+ +parenType :: TokenParser Type+parenType+ = do{ lexeme LexLPAREN+ ; tps <- sepBy ptype (lexeme LexCOMMA)+ ; lexeme LexRPAREN+ ; case tps of+ [] -> do{ x <- identifier (return "()"); return (TCon x) } -- (setSortId SortType id))+ [tp] -> return tp+ _ -> return+ (foldl+ TAp+ (TCon (idFromString+ ( "("+ ++ replicate (length tps - 1) ','+ ++ ")"+ )))+ tps+ )+ }++listType :: TokenParser Type+listType+ = do{ lexeme LexLBRACKET+ ; do{ tp <- ptype+ ; lexeme LexRBRACKET+ ; x <- identifier (return "[]")+ ; return (TAp (TCon x {- (setSortId SortType id) -}) tp)+ }+ <|>+ do{ lexeme LexRBRACKET+ ; x <- identifier (return "[]")+ ; return (TCon x {-(setSortId SortType id)-})+ }+ }++ptypeString :: TokenParser (Type, Int)+ptypeString+ = do{ s <- lexString+ ; return (TString s, length s-1)+ }++----------------------------------------------------------------+-- helpers+----------------------------------------------------------------++semiBraces, commaParens :: TokenParser a -> TokenParser [a]+semiBraces p = braces (semiList p)+commaParens p = parens (sepBy p (lexeme LexCOMMA))++braces, parens :: TokenParser a -> TokenParser a+braces = between (lexeme LexLBRACE) (lexeme LexRBRACE)+parens = between (lexeme LexLPAREN) (lexeme LexRPAREN)++-- terminated or separated+semiList1 :: TokenParser a -> TokenParser [a]+semiList1 p+ = do{ x <- p+ ; do{ lexeme LexSEMI+ ; xs <- semiList p+ ; return (x:xs)+ }+ <|> return [x]+ }++semiList :: TokenParser a -> TokenParser [a]+semiList p+ = semiList1 p <|> return []++----------------------------------------------------------------+-- Lexeme parsers+----------------------------------------------------------------++customid :: TokenParser Id+customid+ = varid+ <|> conid+ <|> parens (opid <|> conopid)+ <|> do{ s <- lexString; return (idFromString s) }+ <?> "custom identifier"++variable :: TokenParser Id+variable+ = varid <|> parens opid++opid :: TokenParser Id+opid+ = identifier lexOp+ <?> "operator"++varid :: TokenParser Id+varid+ = identifier lexId+ <?> "variable"++qualifiedVar :: TokenParser (Id, Id)+qualifiedVar + = do{ (m,name) <- lexQualifiedId+ ; return (idFromString m, idFromString name)+ }++bindid :: TokenParser Id+bindid = varid {- + = do{ x <- varid+ ; do{ lexeme LexEXCL+ ; return x {- (setSortId SortStrict id) -}+ }+ <|> return x+ -}++constructor :: TokenParser Id+constructor+ = conid <|> parens conopid++conopid :: TokenParser Id+conopid+ = identifier lexConOp+ <|> do{ lexeme LexCOLON; return (idFromString ":") }+ <?> "constructor operator"++conid :: TokenParser Id+conid+ = identifier lexCon+ <?> "constructor"++qualifiedCon :: TokenParser (Id, Id)+qualifiedCon+ = do{ (m,name) <- lexQualifiedCon+ ; return (idFromString m, idFromString name)+ }++typeid :: TokenParser Id+typeid+ = identifier lexCon -- (setSortId SortType id)+ <?> "type"++typevarid :: TokenParser Id+typevarid+ = identifier lexId -- (setSortId SortType id)++identifier :: TokenParser String -> TokenParser Id+identifier = liftM idFromString++----------------------------------------------------------------+-- Basic parsers+----------------------------------------------------------------++lexeme :: Lexeme -> TokenParser ()+lexeme lex = satisfy f <?> show lex+ where+ f a | a == lex = Just ()+ | otherwise = Nothing+++lexChar :: TokenParser Char+lexChar+ = satisfy (\lex -> case lex of { LexChar c -> Just c; _ -> Nothing })++lexString :: TokenParser String+lexString+ = satisfy (\lex -> case lex of { LexString s -> Just s; _ -> Nothing })++lexDouble :: TokenParser Double+lexDouble+ = satisfy (\lex -> case lex of { LexFloat d -> Just d; _ -> Nothing })++lexInt :: TokenParser Integer+lexInt+ = satisfy (\lex -> case lex of { LexInt i -> Just i; _ -> Nothing })++lexId :: TokenParser String+lexId+ = satisfy (\lex -> case lex of { LexId s -> Just s; _ -> Nothing })++lexQualifiedId :: TokenParser (String, String)+lexQualifiedId+ = satisfy (\lex -> case lex of { LexQualId m x -> Just (m,x); _ -> Nothing })++lexOp :: TokenParser String+lexOp+ = satisfy (\lex -> case lex of { LexOp s -> Just s; _ -> Nothing })++lexCon :: TokenParser String+lexCon+ = satisfy (\lex -> case lex of { LexCon s -> Just s; _ -> Nothing })++lexQualifiedCon :: TokenParser (String, String)+lexQualifiedCon+ = satisfy (\lex -> case lex of { LexQualCon m x -> Just (m,x); _ -> Nothing })++lexConOp :: TokenParser String+lexConOp+ = satisfy (\lex -> case lex of { LexConOp s -> Just s; _ -> Nothing })++satisfy :: (Lexeme -> Maybe a) -> TokenParser a+satisfy p+ = tokenPrim showtok nextpos (\(_,lex) -> p lex)+ where+ showtok (_,lex) = show lex+ nextpos pos _ (((line,col),_):_)+ = setSourceColumn (setSourceLine pos line) col+ nextpos pos _ []+ = pos
+ Lvm/Core/Parsing/Token.hs view
@@ -0,0 +1,109 @@+-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Lexer.hs 269 2012-08-31 15:16:49Z bastiaan $ + +module Lvm.Core.Parsing.Token + ( Token, Lexeme(..), Pos, incpos, newpos + ) where + +import Text.PrettyPrint.Leijen (Pretty(..)) + +----------------------------------------------------------- +-- Tokens and lexems +----------------------------------------------------------- + +type Pos = (Int,Int) +type Token = (Pos,Lexeme) + +data Lexeme = LexUnknown Char + | LexError String + | LexChar Char + | LexString String + | LexInt Integer + | LexFloat Double + | LexId String + | LexQualId String String + | LexOp String + | LexCon String + | LexQualCon String String + | LexConOp String + + | LexCOMMA -- , + | LexQUOTE -- ` + | LexSEMI -- ; + | LexBSLASH -- \ (niet meteen een enter hierachter vanwege -cpp) + | LexASG -- = + | LexCOLON -- : + | LexCOLCOL -- :: + | LexDOT -- . + | LexDOTDOT -- .. + | LexBAR -- | + | LexLARROW -- <- + | LexRARROW -- -> + | LexTILDE -- ~ + | LexARROW -- => + | LexAT -- @ + | LexEXCL -- ! + | LexDASH -- - + + | LexLPAREN -- ( + | LexRPAREN -- ) + | LexLBRACKET -- [ + | LexRBRACKET -- ] + | LexLBRACE -- { + | LexRBRACE -- } + + | LexLET + | LexIN + | LexDO + | LexWHERE + | LexCASE + | LexOF + | LexIF + | LexTHEN + | LexELSE + | LexDATA + | LexTYPE + | LexMODULE + | LexIMPORT + | LexEOF + + -- not standard + | LexLETSTRICT + | LexMATCH + | LexWITH + + | LexPRIVATE + | LexPUBLIC + | LexDEFAULT + | LexCON + + | LexABSTRACT + | LexINSTR + | LexEXTERN + + | LexNOTHING + | LexCUSTOM + + | LexSTATIC | LexDYNAMIC | LexRUNTIME + | LexCCALL | LexSTDCALL | LexINSTRCALL + | LexDECORATE | LexORDINAL + deriving (Eq,Show) + +instance Pretty Lexeme where + pretty = pretty . show + +----------------------------------------------------------- +-- Positions +----------------------------------------------------------- + +incpos :: Pos -> Int -> Pos +incpos (line,col) i = (line,col+i) + +newpos :: Pos -> Char -> Pos +newpos (line,_) '\n' = (line + 1,1) +newpos (line,col) '\t' = (line, ((((col-1) `div` 8)+1)*8)+1) +newpos (line,col) _ = (line, col+1)
+ Lvm/Core/PrettyId.hs view
@@ -0,0 +1,94 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: PrettyId.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Core.PrettyId + ( ppId, ppVarId, ppConId, ppQualId+ , ppQualCon, ppString + ) where++import Data.Char+import Lvm.Common.Id+import Lvm.Common.IdSet+import Text.PrettyPrint.Leijen++ppId :: Id -> Doc+ppId = ppEscapeId isAlpha quoted++ppVarId :: Id -> Doc+ppVarId = ppEscapeId isLower quoted++ppConId :: Id -> Doc+ppConId = ppEscapeId isUpper (quoted . (':' :))++ppQualId :: Id -> Id -> Doc+ppQualId x y = pretty x <> dot <> ppVarId y++ppQualCon :: Id -> Id -> Doc+ppQualCon x y = pretty x <> dot <> ppConId y++quoted :: String -> String+quoted s = "''" ++ s ++ "''"++ppString :: String -> Doc+ppString s+ = dquotes (text (concatMap escape s))++ppEscapeId :: (Char -> Bool) -> (String -> String) -> Id -> Doc+ppEscapeId isValid esc x+ = if not (isReserved x) && firstOk && ordinary+ then text name+ else text (esc (concatMap escapeId name)) <> char ' '+ where+ name = stringFromId x+ firstOk = case name of+ [] -> False+ y:_ -> isValid y+ ordinary = all idchar name+ +idchar :: Char -> Bool+idchar c = isAlphaNum c || c == '_' || c == '\''+ +escapeId :: Char -> String+escapeId ' ' = "\\s"+escapeId c = escape c++escape :: Char -> String+escape c+ = case c of+ -- '.' -> "\\."+ '\a' -> "\\a"+ '\b' -> "\\b"+ '\f' -> "\\f"+ '\n' -> "\\n"+ '\r' -> "\\r"+ '\t' -> "\\t"+ '\v' -> "\\v"+ '\\' -> "\\\\"+ '\"' -> "\\\""+ '\'' -> "\\'"+ _ -> [c]+++isReserved :: Id -> Bool+isReserved = (`elemSet` reserved)+ +reserved :: IdSet+reserved+ = setFromList $ map idFromString+ ["module","where"+ ,"import","abstract","extern"+ ,"custom","val","con"+ ,"match","with"+ ,"let","rec","in"+ ,"static","dynamic","runtime"+ ,"stdcall","ccall","instruction"+ ,"decorate"+ ,"private","public","nothing"+ ,"type","data","forall","exist"+ ,"case","of"+ ,"if","then","else"+ ]
+ Lvm/Core/RemoveDead.hs view
@@ -0,0 +1,147 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: RemoveDead.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Core.RemoveDead (coreRemoveDead) where++import qualified Data.Set as Set+import Data.Set (Set)+import Lvm.Common.Id+import Lvm.Common.IdSet+import Lvm.Core.Expr+import Lvm.Core.FreeVar+import Lvm.Core.Utils+import Data.List++----------------------------------------------------------------+-- The identity of a declaration is it's name *and* the kind.+-- i.e. we can have a kind Type and a type Type. Extern declarations+-- are identified as Value declarations since they are not+-- distinguished from normal values inside core expressions.+----------------------------------------------------------------+type Identity = (DeclKind,Id)+type Used = Set Identity++declIdentity :: CoreDecl -> Identity+declIdentity decl@(DeclExtern {})+ = (DeclKindValue, declName decl)+declIdentity decl+ = (declKindFromDecl decl, declName decl)++++----------------------------------------------------------------+-- Remove all dead declarations+-- TODO: at the moment, the analysis is too conservative and+-- only removes private declarations that are nowhere used.+-- A proper analysis would find all reachable declaratins.+----------------------------------------------------------------+coreRemoveDead :: CoreModule -> CoreModule+coreRemoveDead m+ = m { moduleDecls = filter (isUsed used) (moduleDecls m) }+ where+ -- Retain main$ even though it is private and not used+ -- It cannot be public because it would be imported and clash+ -- in other modules+ used = foldl' usageDecl alwaysUsed (moduleDecls m)++ alwaysUsed = Set.fromList+ [ (DeclKindValue, idFromString "main$")+ , (DeclKindValue, idFromString "main")+ ]+ +----------------------------------------------------------------+-- Is a declaration used?+----------------------------------------------------------------+isUsed :: Used -> CoreDecl -> Bool+isUsed used decl+ = accessPublic (declAccess decl) || Set.member (declIdentity decl) used+++----------------------------------------------------------------+-- Find used declarations+----------------------------------------------------------------+usageDecl :: Used -> CoreDecl -> Used+usageDecl used decl+ = let usedCustoms = usageCustoms used (declCustoms decl)+ in case decl of+ DeclValue{} -> let usedExpr = usageValue usedCustoms (valueValue decl)+ usedEnc = case valueEnc decl of+ Just x -> Set.insert (DeclKindValue,x) usedExpr+ Nothing -> usedExpr+ in usedEnc+ _ -> usedCustoms++usageCustoms :: Used -> [Custom] -> Used+usageCustoms = foldl' usageCustom++usageCustom :: Set (DeclKind, Id) -> Custom -> Set (DeclKind, Id)+usageCustom used custom+ = case custom of+ CustomLink x kind -> Set.insert (kind,x) used+ CustomDecl _ customs -> usageCustoms used customs+ _ -> used++----------------------------------------------------------------+-- Find used declarations in expressions+----------------------------------------------------------------++usageValue :: Used -> Expr -> Used+usageValue = usageExpr emptySet++usageExprs :: IdSet -> Used -> [Expr] -> Used+usageExprs = foldl' . usageExpr++usageExpr :: IdSet -> Used -> Expr -> Used+usageExpr locals used expr+ = case expr of+ Let binds e -> let used' = usageBinds locals used binds + locals' = unionSet locals (binder binds)+ in usageExpr locals' used' e+ Lam x e -> usageExpr (insertSet x locals) used e+ Match x alts -> usageAlts locals (usageVar locals used x) alts+ Ap e1 e2 -> usageExpr locals (usageExpr locals used e1) e2+ Var x -> usageVar locals used x+ Con con -> usageCon locals used con+ Lit _ -> used++usageVar :: IdSet -> Set (DeclKind, Id) -> Id -> Set (DeclKind, Id)+usageVar locals used x+ | elemSet x locals = used+ | otherwise = Set.insert (DeclKindValue,x) used++usageCon :: IdSet -> Set (DeclKind, Id) -> Con Expr -> Set (DeclKind, Id)+usageCon locals used con+ = case con of+ ConId x -> Set.insert (DeclKindCon,x) used+ ConTag tag _ -> usageExpr locals used tag++usageBinds :: IdSet -> Used -> Binds -> Used+usageBinds locals used binds + = case binds of+ NonRec (Bind _ rhs) -> usageExpr locals used rhs+ Strict (Bind _ rhs) -> usageExpr locals used rhs+ Rec bs -> let (ids,rhss) = unzipBinds bs+ locals' = unionSet locals (setFromList ids)+ in usageExprs locals' used rhss+ ++usageAlts :: IdSet -> Set (DeclKind, Id) -> [Alt] -> Set (DeclKind, Id)+usageAlts = foldl' . usageAlt++usageAlt :: IdSet -> Set (DeclKind, Id) -> Alt -> Used+usageAlt locals used (Alt pat expr)+ = case pat of+ PatCon con ids -> let locals' = unionSet locals (setFromList ids)+ used' = usageConPat used con+ in usageExpr locals' used' expr+ _ -> usageExpr locals used expr+ +usageConPat :: Set (DeclKind, Id) -> Con t -> Set (DeclKind, Id)+usageConPat used con+ = case con of+ ConId x -> Set.insert (DeclKindCon,x) used+ ConTag _ _ -> used
+ Lvm/Core/Saturate.hs view
@@ -0,0 +1,110 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Saturate.hs 291 2012-11-08 11:27:33Z heere112 $++----------------------------------------------------------------+-- saturate all calls to externals, instructions and constructors.+-- pre: [coreNoShadow]+----------------------------------------------------------------+module Lvm.Core.Saturate (coreSaturate) where++import Data.List+import Data.Maybe+import Lvm.Common.Id +import Lvm.Common.IdMap+import Lvm.Core.Expr+import Lvm.Core.Utils++----------------------------------------------------------------+-- Environment: a name supply and a map from id to its arity+----------------------------------------------------------------+data Env = Env NameSupply (IdMap Int)++uniqueId :: Env -> (Id, Env)+uniqueId (Env supply arities)+ = let (x,supply') = freshId supply+ in (x,Env supply' arities)++findArity :: Id -> Env -> Int+findArity x (Env _ arities)+ = fromMaybe 0 (lookupMap x arities)++splitEnv :: Env -> (Env, Env)+splitEnv (Env supply arities)+ = let (s0,s1) = splitNameSupply supply+ in (Env s0 arities, Env s1 arities)++splitEnvs :: Env -> [Env]+splitEnvs (Env supply arities)+ = map (`Env` arities) (splitNameSupplies supply)++----------------------------------------------------------------+-- coreSaturate+----------------------------------------------------------------+coreSaturate :: NameSupply -> CoreModule -> CoreModule+coreSaturate supply m+ = mapExprWithSupply (satDeclExpr arities) supply m+ where+ arities = mapFromList [(declName d,declArity d) | d <- moduleDecls m, isDeclCon d || isDeclExtern d]+++satDeclExpr :: IdMap Int -> NameSupply -> Expr -> Expr+satDeclExpr arities supply = satExpr (Env supply arities)++----------------------------------------------------------------+-- saturate expressions+----------------------------------------------------------------+satExpr :: Env -> Expr -> Expr+satExpr env expr+ = case expr of+ Let binds e+ -> let (env0,env1) = splitEnv env+ in Let (satBinds env0 binds) (satExpr env1 e)+ Match x alts+ -> Match x (satAlts env alts)+ Lam x e+ -> Lam x (satExpr env e)+ _+ -> let expr' = satExprSimple env expr+ in addLam env (requiredArgs env expr') expr'++satBinds :: Env -> Binds -> Binds+satBinds = zipBindsWith (\env x expr -> Bind x (satExpr env expr)) . splitEnvs++satAlts :: Env -> Alts -> Alts+satAlts = zipAltsWith (\env pat expr -> Alt pat (satExpr env expr)) . splitEnvs++-- don't saturate Ap, Var and Con here+satExprSimple :: Env -> Expr -> Expr+satExprSimple env expr+ = case expr of+ Let _ _ -> satExpr env expr+ Match _ _ -> satExpr env expr+ Lam _ _ -> satExpr env expr+ Ap e1 e2 -> let (env1,env2) = splitEnv env+ in Ap (satExprSimple env1 e1) (satExpr env2 e2)+ _ -> expr++----------------------------------------------------------------+-- Add lambda's+----------------------------------------------------------------++addLam :: (Num a, Enum a) => Env -> a -> Expr -> Expr+addLam env n expr+ = let (_,ids) = mapAccumR (\env2 _ -> let (x,env') = uniqueId env2 in (env',x)) env [1..n]+ in foldr Lam (foldl Ap expr (map Var ids)) ids++requiredArgs :: Env -> Expr -> Int+requiredArgs env expr+ = case expr of+ Let _ _ -> 0+ Match _ _ -> 0+ Lam _ _ -> 0+ Ap e1 _ -> requiredArgs env e1 - 1+ Var x -> findArity x env+ Con (ConId x) -> findArity x env+ Con (ConTag _ arity) -> arity+ _ -> 0
+ Lvm/Core/ToAsm.hs view
@@ -0,0 +1,187 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: ToAsm.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Core.ToAsm (coreToAsm) where++import Control.Exception (assert)+import Lvm.Common.Id+import Lvm.Common.IdSet+import Lvm.Core.Expr+import Lvm.Core.Utils+import qualified Lvm.Asm.Data as Asm++import Lvm.Core.NoShadow (coreRename) -- rename local variables+import Lvm.Core.Saturate (coreSaturate) -- saturate constructors, instructions and externs+import Lvm.Core.Normalize (coreNormalize) -- normalize core, ie. atomic arguments and lambda's at let bindings+import Lvm.Core.LetSort (coreLetSort) -- find smallest recursive let binding groups+import Lvm.Core.Lift (coreLift) -- lambda-lift, ie. make free variables arguments++{---------------------------------------------------------------+ coreToAsm: translate Core expressions into Asm expressions+---------------------------------------------------------------}+coreToAsm :: NameSupply -> CoreModule -> Asm.AsmModule+coreToAsm supply+ = exprToTop + . coreLift+ . coreLetSort+ . coreNormalize supply2+ . coreSaturate supply1+ . coreRename supply0+ where + (supply0:supply1:supply2:_) = splitNameSupplies supply++exprToTop :: CoreModule -> Asm.AsmModule+exprToTop m+ = m{ moduleDecls = concatMap (asmDecl (externNames m)) (moduleDecls m) }++{---------------------------------------------------------------+ top-level bindings+---------------------------------------------------------------}++asmDecl :: IdSet -> Decl Expr -> [Decl Asm.Top]+asmDecl prim decl =+ case decl of + DeclValue x acc enc expr custom -> + let (pars,(lifted,asmexpr)) = asmTop prim expr+ in DeclValue x acc enc (Asm.Top pars asmexpr) custom : concatMap (asmLifted prim (declName decl)) lifted+ _ -> [fmap (error "asmDecl") decl]++asmLifted :: IdSet -> Id -> Bind -> [Decl Asm.Top]+asmLifted prim enc (Bind x expr)+ = let (pars,(lifted,asmexpr)) = asmTop prim expr+ in DeclValue x (Defined False) (Just enc) (Asm.Top pars asmexpr) []+ : concatMap (asmLifted prim x) lifted++asmTop :: IdSet -> Expr -> ([Id], ([Bind], Asm.Expr))+asmTop prim expr+ = let (pars,expr') = splitParams expr+ in (pars,asmExpr prim expr')++splitParams :: Expr -> ([Id],Expr)+splitParams expr+ = case expr of+ Lam x e -> let (pars,e') = splitParams e in (x:pars,e')+ _ -> ([],expr)++{---------------------------------------------------------------+ expressions+---------------------------------------------------------------}+asmExpr :: IdSet -> Expr -> ([Bind],Asm.Expr)+asmExpr prim expr+ = case expr of+ Let binds e -> asmLet prim binds (asmExpr prim e)+ Match x alts -> let (lifted,asmalts) = asmAlts prim alts+ in (concat lifted, Asm.Match x asmalts)+ atom -> let asmatom = asmAtom atom [] -- handles prim ap's too+ in case asmatom of+ Asm.Ap x args | elemSet x prim+ -> ([],Asm.Prim x args)+ _ -> ([],asmatom)++asmAlts :: IdSet -> [Alt] -> ([[Bind]], [Asm.Alt])+asmAlts prim alts+ = unzip (map (asmAlt prim) alts)++asmAlt :: IdSet -> Alt -> ([Bind], Asm.Alt)+asmAlt prim (Alt pat expr)+ = let (lifted,asmexpr) = asmExpr prim expr+ in (lifted, Asm.Alt (asmPat pat) asmexpr)++asmPat :: Pat -> Asm.Pat+asmPat pat+ = case pat of+ PatCon con params -> Asm.PatCon (asmPatCon con) params+ PatLit lit -> Asm.PatLit (asmLit lit)+ PatDefault -> Asm.PatVar (idFromString ".def")++asmPatCon :: Con a -> Asm.Con a+asmPatCon con+ = case con of+ ConId x -> Asm.ConId x+ ConTag tag arity -> Asm.ConTag tag arity++asmLet :: IdSet -> Binds -> ([Bind], Asm.Expr) -> ([Bind], Asm.Expr)+asmLet prim binds (lifted,asmexpr)+ = case binds of+ NonRec (Bind x expr)+ -> if isAtomic prim expr+ then (lifted, Asm.Let x (asmAtom expr []) asmexpr)+ else (Bind x expr:lifted,asmexpr)+ Strict (Bind x rhs)+ -> let (liftedrhs,asmrhs) = asmExpr prim rhs+ in (lifted ++ liftedrhs,Asm.Eval x asmrhs asmexpr)+ Rec bs -> let (lifted',binds') = foldr asmRec (lifted,[]) bs+ in if null binds'+ then (lifted',asmexpr)+ else (lifted',Asm.LetRec binds' asmexpr)+ where+ asmRec bind@(Bind x expr) (lft,bs)+ | isAtomic prim expr = (lft,(x,asmAtom expr []):bs)+ | otherwise = (bind:lft,bs)+++{---------------------------------------------------------------+ atomic expressions & primitive applications+---------------------------------------------------------------}++asmAtom :: Expr -> [Asm.Expr] -> Asm.Expr+asmAtom atom args+ = case atom of+ Ap e1 e2 -> asmAtom e1 (asmAtom e2 []:args)+ Var x -> Asm.Ap x args+ Con con -> Asm.Con (asmCon con) args+ Lit lit | null args -> Asm.Lit (asmLit lit)+ Let binds expr+ -> asmAtomBinds binds (asmAtom expr args)+ _ -> error "CoreToAsm.asmAtom: non atomic expression (do 'coreNormalise' first?)"++asmCon :: Con Expr -> Asm.Con Asm.Atom+asmCon con + = case con of+ ConId x -> Asm.ConId x + ConTag tag arity -> assert (simpleTag tag) $ -- "CoreToAsm.asmCon: tag expression too complex (should be integer or (strict) variable"+ Asm.ConTag (asmAtom tag []) arity+ where+ simpleTag (Lit (LitInt _)) = True+ simpleTag (Var _) = True+ simpleTag _ = False++asmAtomBinds :: Binds -> Asm.Expr -> Asm.Expr+asmAtomBinds binds+ = case binds of+ NonRec (Bind x expr) -> Asm.Let x (asmAtom expr [])+ Rec bs -> Asm.LetRec [(x,asmAtom expr []) | Bind x expr <- bs]+ _ -> error "CoreToAsm.asmAtomBinds: strict binding as atomic expression (do 'coreNormalise first?)"++asmLit :: Literal -> Asm.Lit+asmLit lit+ = case lit of+ LitInt i -> Asm.LitInt i+ LitDouble d -> Asm.LitFloat d+ LitBytes s -> Asm.LitBytes s++{---------------------------------------------------------------+ is an expression atomic ?+---------------------------------------------------------------}++isAtomic :: IdSet -> Expr -> Bool+isAtomic prim expr+ = case expr of+ Ap e1 e2 -> isAtomic prim e1 && isAtomic prim e2+ Var x -> not (elemSet x prim)+ Con (ConId _) -> True+ Con (ConTag t _) -> isAtomic prim t+ Lit _ -> True+ Let binds e+ -> isAtomicBinds prim binds && isAtomic prim e+ _ -> False++isAtomicBinds :: IdSet -> Binds -> Bool+isAtomicBinds prim binds+ = case binds of+ Strict _ -> False+ _ -> all (isAtomic prim) (snd (unzipBinds (listFromBinds binds)))
+ Lvm/Core/Type.hs view
@@ -0,0 +1,146 @@+-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Data.hs 250 2012-08-22 10:59:40Z bastiaan $ + +module Lvm.Core.Type + ( Type(..), Kind(..) + , addForall, arityFromType + ) where + +import Lvm.Common.Id +import Lvm.Common.IdSet +import Text.PrettyPrint.Leijen + +---------------------------------------------------------------- +-- Types +---------------------------------------------------------------- +data Type = TFun Type Type + | TAp Type Type + | TForall Id Type + | TExist Id Type + | TStrict Type + | TVar Id + | TCon Id + | TAny + | TString String + +data Kind = KFun {kind1::Kind, kind2::Kind} + | KStar + | KString {kindString::String} + +-- data SuperKind = Box + +arityFromType :: Type -> Int +arityFromType tp + = case tp of + TFun _ t2 -> arityFromType t2 + 1 + TAp _ _ -> 0 -- assumes saturated constructors! + TForall _ t -> arityFromType t + TExist _ t -> arityFromType t + TStrict t -> arityFromType t + TVar _ -> 0 + TCon _ -> 0 + TAny -> 0 + TString _ -> error "Core.arityFromType: string type" + +{- +arityFromKind :: Kind -> Int +arityFromKind kind + = case kind of + KFun k1 _ -> arityFromKind k1 + 1 + KStar -> 0 + KString _ -> error "Core.arityFromKind: string kind" -} + +addForall :: Type -> Type +addForall tp + = foldr TForall tp (listFromSet (varsInType tp)) + +varsInType :: Type -> IdSet +varsInType tp + = case tp of + TForall a t -> deleteSet a (varsInType t) + TExist a t -> deleteSet a (varsInType t) + TString _ -> emptySet + TFun t1 t2 -> unionSet (varsInType t1) (varsInType t2) + TAp t1 t2 -> unionSet (varsInType t1) (varsInType t2) + TStrict t -> varsInType t + TVar a -> singleSet a + TCon _ -> emptySet + TAny -> emptySet + +---------------------------------------------------------------- +-- Pretty printing +---------------------------------------------------------------- + +instance Show Type where + show = show . pretty + +instance Show Kind where + show = show . pretty + +instance Pretty Type where + pretty = ppType 0 + +instance Pretty Kind where + pretty = ppKind 0 + +ppType :: Int -> Type -> Doc +ppType level tp + = parenthesized $ + case tp of + TAp (TCon a) t2 | a == idFromString "[]" -> text "[" <> pretty t2 <> text "]" + TFun t1 t2 -> ppHi t1 <+> text "->" <+> ppEq t2 + TAp t1 t2 -> ppEq t1 <+> ppHi t2 + TForall a t -> text "forall" <+> pretty a <> text "." <+> ppEq t + TExist a t -> text "exist" <+> pretty a <> text "." <+> ppEq t + TStrict t -> ppHi t <> text "!" + TVar a -> pretty a + TCon a -> pretty a + TAny -> text "any" + TString s -> string s + where + tplevel = levelFromType tp + parenthesized doc | level <= tplevel = doc + | otherwise = parens doc + ppHi t | level <= tplevel = ppType (tplevel+1) t + | otherwise = ppType 0 t + ppEq t | level <= tplevel = ppType tplevel t + | otherwise = ppType 0 t + +ppKind :: Int -> Kind -> Doc +ppKind level kind + = parenthesized $ + case kind of + KFun k1 k2 -> ppHi k1 <+> text "->" <+> ppEq k2 + KStar -> text "*" + KString s -> string s + where + (klevel,parenthesized) + | level <= levelFromKind kind = (levelFromKind kind,id) + | otherwise = (0,parens) + + ppHi = ppKind (if klevel<=0 then 0 else klevel+1) + ppEq = ppKind klevel + +levelFromType :: Type -> Int +levelFromType tp + = case tp of + TString{} -> 1 + TForall{} -> 2 + TExist{} -> 2 + TFun{} -> 3 + TAp{} -> 4 + TStrict{} -> 5 + TVar{} -> 6 + TCon{} -> 6 + TAny -> 7 + +levelFromKind :: Kind -> Int +levelFromKind kind + = case kind of + KString{} -> 1 + KFun{} -> 2 + KStar{} -> 3
+ Lvm/Core/Utils.hs view
@@ -0,0 +1,91 @@+-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Data.hs 250 2012-08-22 10:59:40Z bastiaan $ + +module Lvm.Core.Utils + ( module Lvm.Core.Module + , listFromBinds, unzipBinds, mapBinds, mapAccumBinds, zipBindsWith + , mapAlts, zipAltsWith, mapExprWithSupply, mapAccum + ) where + +import Lvm.Core.Expr +import Lvm.Common.Id +import Lvm.Core.Module + +---------------------------------------------------------------- +-- Binders functions +---------------------------------------------------------------- + +listFromBinds :: Binds -> [Bind] +listFromBinds binds + = case binds of + NonRec bind -> [bind] + Strict bind -> [bind] + Rec recs -> recs + +unzipBinds :: [Bind] -> ([Id],[Expr]) +unzipBinds = unzip . map (\(Bind x rhs) -> (x,rhs)) + +mapBinds :: (Id -> Expr -> Bind) -> Binds -> Binds +mapBinds f binds + = case binds of + NonRec (Bind x rhs) + -> NonRec (f x rhs) + Strict (Bind x rhs) + -> Strict (f x rhs) + Rec recs + -> Rec (map (\(Bind x rhs) -> f x rhs) recs) + +mapAccumBinds :: (a -> Id -> Expr -> (Bind,a)) -> a -> Binds -> (Binds,a) +mapAccumBinds f x binds + = case binds of + NonRec (Bind y rhs) + -> let (bind,z) = f x y rhs + in (NonRec bind, z) + Strict (Bind y rhs) + -> let (bind,z) = f x y rhs + in (Strict bind, z) + Rec recs + -> let (recs',z) = mapAccum (\a (Bind y rhs) -> f a y rhs) x recs + in (Rec recs',z) + +mapAccum :: (a -> b -> (c,a)) -> a -> [b] -> ([c],a) +mapAccum _ s [] = ([],s) +mapAccum f s (x:xs) = (y:ys,s'') + where (y,s' ) = f s x + (ys,s'') = mapAccum f s' xs + + +zipBindsWith :: (a -> Id -> Expr -> Bind) -> [a] -> Binds -> Binds +zipBindsWith f (x:_) (Strict (Bind y rhs)) + = Strict (f x y rhs) +zipBindsWith f (x:_) (NonRec (Bind y rhs)) + = NonRec (f x y rhs) +zipBindsWith f xs (Rec recs) + = Rec (zipWith (\x (Bind y rhs) -> f x y rhs) xs recs) +zipBindsWith _ _ _ + = error "zipBindsWith" + +---------------------------------------------------------------- +-- Alternatives functions +---------------------------------------------------------------- + +mapAlts :: (Pat -> Expr -> Alt) -> Alts -> Alts +mapAlts f = map (\(Alt pat expr) -> f pat expr) + +zipAltsWith :: (a -> Pat -> Expr -> Alt) -> [a] -> Alts -> Alts +zipAltsWith f = zipWith (\x (Alt pat expr) -> f x pat expr) + +---------------------------------------------------------------- +-- +---------------------------------------------------------------- + +mapExprWithSupply :: (NameSupply -> Expr -> Expr) -> NameSupply -> CoreModule -> CoreModule +mapExprWithSupply f supply m + = m { moduleDecls = mapWithSupply fvalue supply (moduleDecls m) } + where + fvalue sup decl@(DeclValue{}) = decl{ valueValue = f sup (valueValue decl)} + fvalue _ decl = decl
+ Lvm/Data.hs view
@@ -0,0 +1,28 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Data.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Data+ ( module Lvm.Core.Module, LvmModule, LvmDecl+ -- constants+ , recHeader,recFooter + ) where++import Lvm.Core.Module+import Lvm.Instr.Data ( Instr )++{--------------------------------------------------------------+ An LVM module+---------------------------------------------------------------}+type LvmModule = Module [Instr]+type LvmDecl = Decl [Instr]++{---------------------------------------------------------------+ Constants+---------------------------------------------------------------}+recHeader,recFooter :: Int+recHeader = 0x1F4C564D+recFooter = 0x1E4C564D
+ Lvm/Import.hs view
@@ -0,0 +1,138 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Import.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Import (lvmImport, lvmImportDecls) where++import Control.Monad+import Data.List +import Lvm.Common.Id+import Lvm.Common.IdMap+import Lvm.Data+import Lvm.Read (lvmReadFile)+import qualified Lvm.Core.Module as Module++{--------------------------------------------------------------+ lvmImport: replace all import declarations with+ abstract declarations or constructors/externs/customs+--------------------------------------------------------------}+lvmImport :: (Id -> IO FilePath) -> Module v -> IO (Module v)+lvmImport findModule m+ = do{ mods <- lvmImportModules findModule m+ ; let mods0 = lvmExpandModule mods (moduleName m) + mods1 = lvmResolveImports mods0+ mod1 = findMap (moduleName m) mods1+ ; return mod1{ moduleDecls = filter (not . isDeclImport) (moduleDecls mod1) }+ }++lvmImportDecls :: (Id -> IO FilePath) -> [Decl v] -> IO [[Decl v]]+lvmImportDecls findModule = mapM $ \importDecl -> do+ m <- lvmImport findModule+ Module.Module+ { Module.moduleName = idFromString "Main"+ , Module.moduleMajorVer = 0+ , Module.moduleMinorVer = 0+ , Module.moduleDecls = [importDecl]+ }+ return (moduleDecls m)++{--------------------------------------------------------------+ lvmImportModules: + recursively read all imported modules+--------------------------------------------------------------}+lvmImportModules :: (Id -> IO FilePath) -> Module v -> IO (IdMap (Module v))+lvmImportModules findModule m+ = readModuleImports findModule emptyMap (moduleName m) m+ +readModuleImports :: (Id -> IO FilePath) -> IdMap (Module v) -> Id -> Module v -> IO (IdMap (Module v))+readModuleImports findModule loaded x m+ = foldM (readModule findModule) (insertMap x m loaded) (imported m)++readModule :: (Id -> IO FilePath) -> IdMap (Module v) -> Id -> IO (IdMap (Module v))+readModule findModule loaded x+ | elemMap x loaded = return loaded+ | otherwise = do{ fname <- findModule x + ; m <- lvmReadFile fname+ ; readModuleImports findModule loaded x (filterPublic m)+ }++imported :: Module v -> [Id]+imported m = [importModule (declAccess d) | d <- moduleDecls m, isDeclImport d]++{--------------------------------------------------------------+ lvmExpandModule loaded modname: + expand Module import declarations of [modname] + into declarations for all items exported from that module.+--------------------------------------------------------------}+lvmExpandModule :: IdMap (Module v) -> Id -> IdMap (Module v)+lvmExpandModule loaded modname+ = mapMap expand loaded+ where+ expand m | moduleName m == modname = expandModule loaded m+ | otherwise = m++expandModule :: IdMap (Module v) -> Module v -> Module v+expandModule loaded m+ = m{ moduleDecls = concatMap (expandDecl loaded (moduleName m)) (moduleDecls m) }++expandDecl :: IdMap (Module a) -> Id -> Decl a -> [Decl a]+expandDecl loaded modname DeclImport{declAccess = access@(Imported{importModule = imodname,importKind = DeclKindModule})}+ = case lookupMap imodname loaded of+ Nothing -> error ("LvmImport.expandDecl: import module is not loaded: " ++ stringFromId modname)+ Just imod | moduleName imod == modname + -> error ("LvmImport.expandDecl: module imports itself: " ++ stringFromId modname)+ Just imod -> map importDecl (moduleDecls imod)+ where+ importDecl decl+ = decl{ declAccess = access{importName = declName decl, importKind = declKindFromDecl decl} }++expandDecl _ _ decl = [decl]++{---------------------------------------------------------------+lvmResolveImports:+ replaces all "DImport" declarations with the real+ declaration (except the access is Import). This is always+ needed for all modules.+---------------------------------------------------------------}+lvmResolveImports :: IdMap (Module v) -> IdMap (Module v)+lvmResolveImports mods = foldl' resolveImports mods (listFromMap mods)++resolveImports :: IdMap (Module v) -> (Id,Module v) -> IdMap (Module v)+resolveImports loaded (modid, m)+ = foldl' (resolveImport [] modid) loaded (filter isDeclImport (moduleDecls m))++resolveImport :: [Id] -> Id -> IdMap (Module v) -> Decl v -> IdMap (Module v)+resolveImport visited modid loaded imp@(DeclImport x access@(Imported _ imodid impid kind _ _) _)+ | modid `elem` visited = error ("LvmImport.resolveImport: circular import chain: " ++ stringFromId imodid ++ "." ++ stringFromId impid)+ | otherwise = + let m = findMap modid loaded in + case lookupMap imodid loaded of+ Nothing -> error ("LvmImport.resolveImport: import module is not loaded: " ++ stringFromId imodid)+ Just imod -> case lookupDecl impid kind (moduleDecls imod) of+ [] -> notfound imodid impid+ ds -> case filter (not . isDeclImport) ds of+ [] -> case filter isDeclImport ds of+ [] -> notfound imodid impid+ [d] -> let loaded' = resolveImport (modid:visited) imodid loaded d+ in resolveImport (imodid:visited) modid loaded' imp+ _ -> ambigious imodid impid+ [d] -> update m { moduleDecls = d{declName=x,declAccess = access} : moduleDecls m}+ _ -> ambigious imodid impid+ where+ update m = updateMap modid m loaded+resolveImport _ _ _ _ = error "resolveImport: not DeclImport"++lookupDecl :: Id -> DeclKind -> [Decl a] -> [Decl a]+lookupDecl impid kind decls =+ [d | d <- decls, declName d==impid && declKindFromDecl d == kind]+ +notfound :: Id -> Id -> a+notfound imodid impid = + error ("LvmImport.resolveImport: unresolved identifier: " ++ stringFromId imodid ++ "." ++ stringFromId impid)++ambigious :: Id -> Id -> a+ambigious imodid impid = + error ("LvmImport.resolveImport: ambigious import record: " ++ stringFromId imodid ++ "." ++ stringFromId impid)
+ Lvm/Instr/Data.hs view
@@ -0,0 +1,724 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Data.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Instr.Data + ( Instr(..), Var(..), Con(..), Global(..), Alt(..), Pat(..)+ , Offset, Depth, Index, Tag, Arity+ , opcodeFromInstr, instrFromOpcode, instrFromName, nameFromInstr+ , isCATCH, strictResult+ ) where++import Data.Char+import Data.Maybe+import Lvm.Common.Byte+import Lvm.Common.Id+import Text.PrettyPrint.Leijen++----------------------------------------------------------------+-- Types+----------------------------------------------------------------++type Offset = Int+type Depth = Int+type Index = Int+type Tag = Int+type Arity = Int++data Global = Global + { idFromGlobal :: !Id+ , indexFromGlobal :: Index+ , arityFromGlobal :: !Arity + }+ deriving Show++data Con = Con+ { idFromCon :: !Id + , indexFromCon :: Index + , arityFromCon :: !Arity + , tagFromCon :: !Tag+ }+ deriving Show++data Var = Var+ { idFromVar :: !Id + , offsetFromVar :: !Offset + , depthFromVar :: !Depth+ } + deriving Show++----------------------------------------------------------------+-- The instructions+----------------------------------------------------------------+data Pat = PatCon !Con+ | PatInt !Int+ | PatTag !Tag !Arity+ | PatDefault+ deriving Show++data Alt = Alt !Pat ![Instr]+ deriving Show++data Instr =+ -- pseudo instructions+ VAR !Id+ | PARAM !Id+ | USE !Id+ | NOP+ | ATOM ![Instr]+ | INIT ![Instr]+++ -- structured instructions+ | CATCH ![Instr] -- for generating PUSHCATCH+ | EVAL !Depth ![Instr] -- for generating PUSHCONT+ | RESULT ![Instr] -- for generating SLIDE++ | MATCH ![Alt]+ | MATCHCON ![Alt]+ | SWITCHCON ![Alt]+ | MATCHINT ![Alt]++ -- push instructions+ | PUSHVAR !Var+ | PUSHINT !Int+ | PUSHBYTES !Bytes !Index+ | PUSHFLOAT !Double+ | PUSHCODE !Global+ | PUSHCONT !Offset+ | PUSHCATCH++ -- stack instructions+ | ARGCHK !Arity+ | SLIDE !Int !Int !Depth+ | STUB !Var++ -- control+ | ENTER+ | RAISE+ | CALL !Global++ | ENTERCODE !Global+ | EVALVAR !Var++ | RETURN+ | RETURNCON !Con+ | RETURNINT !Int++ -- applications+ | ALLOCAP !Arity+ | PACKAP !Var !Arity+ | PACKNAP !Var !Arity+ | NEWAP !Arity+ | NEWNAP !Arity++ -- constructors+ | ALLOCCON !Con+ | PACKCON !Con !Var+ | NEWCON !Con++ | ALLOC+ | NEW !Arity+ | PACK !Arity !Var+ | UNPACK !Arity+ | GETFIELD+ | SETFIELD+ | GETTAG+ | GETSIZE+ | UPDFIELD++ -- INT operations+ | ADDINT+ | SUBINT+ | MULINT+ | DIVINT+ | MODINT+ | QUOTINT+ | REMINT+ | ANDINT+ | XORINT+ | ORINT+ | SHRINT+ | SHLINT+ | SHRNAT+ | NEGINT++ | EQINT+ | NEINT+ | LTINT+ | GTINT+ | LEINT+ | GEINT+ + -- FLOAT operations+ | ADDFLOAT+ | SUBFLOAT+ | MULFLOAT+ | DIVFLOAT+ | NEGFLOAT++ | EQFLOAT+ | NEFLOAT+ | LTFLOAT+ | GTFLOAT+ | LEFLOAT+ | GEFLOAT++ -- optimized VAR+ | PUSHVAR0+ | PUSHVAR1+ | PUSHVAR2+ | PUSHVAR3+ | PUSHVAR4++ | PUSHVARS2 !Var !Var++ -- optimized AP+ | NEWAP2+ | NEWAP3+ | NEWAP4++ | NEWNAP2+ | NEWNAP3+ | NEWNAP4++ -- optimized NEWCON+ | NEWCON0 !Con+ | NEWCON1 !Con+ | NEWCON2 !Con+ | NEWCON3 !Con++ | RETURNCON0 !Con+ deriving Show++----------------------------------------------------------------+-- Pretty printing+----------------------------------------------------------------++instance Pretty Instr where+ prettyList = align . vcat . map pretty+ pretty instr = + case instr of+ -- pseudo instructions+ VAR x -> text name <+> pretty x+ PARAM x -> text name <+> pretty x+ USE x -> text name <+> pretty x+ NOP -> text name+ + ATOM is -> nest 2 (text name <$> pretty is)+ INIT is -> nest 2 (text name <$> pretty is)++ -- structured instructions+ CATCH instrs -> nest 2 (text name <$> pretty instrs)+ EVAL d instrs -> nest 2 (text name <+> pretty d <$> pretty instrs)+ RESULT instrs -> nest 2 (text name <$> pretty instrs)++ SWITCHCON alts -> nest 2 (text name <$> pretty alts)+ MATCHCON alts -> nest 2 (text name <$> pretty alts)+ MATCHINT alts -> nest 2 (text name <$> pretty alts)+ MATCH alts -> nest 2 (text name <$> pretty alts)+++ -- push instructions+ PUSHVAR var -> text name <+> pretty var+ PUSHINT n -> text name <+> pretty n+ PUSHBYTES bs _ -> text name <+> ppBytes bs+ PUSHFLOAT d -> text name <+> pretty d+ PUSHCODE global -> text name <+> pretty global+ PUSHCONT ofs -> text name <+> pretty ofs++ -- stack instructions+ ARGCHK n -> text name <+> pretty n+ SLIDE n m depth -> text name <+> pretty n <+> pretty m <+> pretty depth+ STUB var -> text name <+> pretty var++ -- control+ ENTER -> text name+ RAISE -> text name+ CALL global -> text name <+> pretty global++ ENTERCODE global -> text name <+> pretty global+ EVALVAR var -> text name <+> pretty var++ RETURN -> text name+ RETURNCON con -> text name <+> pretty con+ RETURNINT n -> text name <+> pretty n++ -- applications+ ALLOCAP arity -> text name <+> pretty arity+ PACKAP var arity -> text name <+> pretty var <+> pretty arity+ PACKNAP var arity -> text name <+> pretty var <+> pretty arity+ NEWAP arity -> text name <+> pretty arity+ NEWNAP arity -> text name <+> pretty arity++ -- constructors+ ALLOCCON con -> text name <+> pretty con+ PACKCON con var -> text name <+> pretty var <+> pretty con+ NEWCON con -> text name <+> pretty con+ + NEW arity -> text name <+> pretty arity+ PACK arity var -> text name <+> pretty arity <+> pretty var+ UNPACK arity -> text name <+> pretty arity++ -- optimized instructions+ PUSHVARS2 v w -> text name <+> pretty v <+> pretty w++ NEWCON0 con -> text name <+> pretty con+ NEWCON1 con -> text name <+> pretty con+ NEWCON2 con -> text name <+> pretty con+ NEWCON3 con -> text name <+> pretty con++ RETURNCON0 con -> text name <+> pretty con++ -- others+ _ -> text name+ where + name = nameFromInstr instr+ +instance Pretty Alt where + pretty (Alt pat is) = nest 2 (pretty pat <> text ":" <$> pretty is)+ prettyList = vcat . map pretty++instance Pretty Pat where+ pretty pat =+ case pat of+ PatCon con -> pretty con+ PatInt i -> pretty i+ PatTag t a -> text "(@" <> pretty t <> char ',' <> pretty a <> text ")"+ PatDefault -> text "<default>"++instance Pretty Con where+ pretty (Con x _ arity _) =+ pretty x <+> pretty arity++instance Pretty Global where+ pretty (Global x _ arity) =+ pretty x <+> pretty arity++instance Pretty Var where+ pretty (Var x ofs depth) =+ pretty x <+> parens( pretty ofs <> comma <+> pretty depth )++ppBytes :: Bytes -> Doc+ppBytes = dquotes . string . stringFromBytes++----------------------------------------------------------------+-- Instruction instances+----------------------------------------------------------------+instance Enum Instr where+ fromEnum = enumFromInstr+ toEnum _ = error "Code.toEnum: undefined for instructions"++instance Eq Instr where+ instr1 == instr2 = fromEnum instr1 == fromEnum instr2++instance Ord Instr where+ compare instr1 instr2 = compare (fromEnum instr1) (fromEnum instr2)++----------------------------------------------------------------+-- Instruction names+----------------------------------------------------------------+instrFromName :: String -> Instr+instrFromName name+ = fromMaybe (error msg) (lookup (map toUpper name) instrNames)+ where+ msg = "Code.instrFromName: unknown instruction name: " ++ name+ instrNames+ = [ ("CATCH", CATCH [])+ , ("RAISE", RAISE)++ , ("ADDINT", ADDINT)+ , ("SUBINT", SUBINT)+ , ("MULINT", MULINT)+ , ("DIVINT", DIVINT)+ , ("MODINT", MODINT)+ , ("QUOTINT",QUOTINT)+ , ("REMINT", REMINT)+ , ("ANDINT", ANDINT)+ , ("XORINT", XORINT)+ , ("ORINT", ORINT)+ , ("SHRINT", SHRINT)+ , ("SHLINT", SHLINT)+ , ("SHRNAT", SHRNAT)+ , ("NEGINT", NEGINT)++ , ("EQINT", EQINT)+ , ("NEINT", NEINT)+ , ("LTINT", LTINT)+ , ("GTINT", GTINT)+ , ("LEINT", LEINT)+ , ("GEINT", GEINT)++ , ("ADDFLOAT", ADDFLOAT)+ , ("SUBFLOAT", SUBFLOAT)+ , ("MULFLOAT", MULFLOAT)+ , ("DIVFLOAT", DIVFLOAT)+ , ("NEGFLOAT", NEGFLOAT)++ , ("EQFLOAT", EQFLOAT)+ , ("NEFLOAT", NEFLOAT)+ , ("LTFLOAT", LTFLOAT)+ , ("GTFLOAT", GTFLOAT)+ , ("LEFLOAT", LEFLOAT)+ , ("GEFLOAT", GEFLOAT)++ , ("ALLOC", ALLOC)+ , ("GETFIELD",GETFIELD)+ , ("SETFIELD",SETFIELD)+ , ("GETTAG", GETTAG)+ , ("GETSIZE", GETSIZE)+ , ("UPDFIELD",UPDFIELD)+ ]+++{---------------------------------------------------------------+ instrHasStrictResult: returns [True] if an instruction returns+ a strict result, ie. a value that can be [match]ed or [RETURN]'ed.+---------------------------------------------------------------}++strictResult :: Instr -> Bool+strictResult (NEW _) = True+strictResult instr = instr `elem` strictList+ where+ strictList = + [ ALLOC, ADDINT, SUBINT, MULINT, DIVINT, MODINT, QUOTINT+ , REMINT, ANDINT, XORINT, ORINT, SHRINT, SHLINT, SHRNAT + , NEGINT, EQINT, NEINT, LTINT, GTINT, LEINT, GEINT + , ADDFLOAT, SUBFLOAT, MULFLOAT, DIVFLOAT, NEGFLOAT+ , EQFLOAT, NEFLOAT, LTFLOAT, GTFLOAT, LEFLOAT, GEFLOAT + ]++----------------------------------------------------------------+-- Instruction opcodes+----------------------------------------------------------------+instrFromOpcode :: Int -> Instr+instrFromOpcode i+ | i >= length instrTable = error "Instr.instrFromOpcode: illegal opcode"+ | otherwise = instrTable !! i++opcodeFromInstr :: Instr -> Int+opcodeFromInstr instr+ = walk 0 instrTable+ where+ walk _ [] = error "Instr.opcodeFromInstr: no opcode defined for this instruction"+ walk opc (i:is) | instr == i = opc+ | otherwise = (walk $! (opc+1)) is++instrTable :: [Instr]+instrTable =+ [ ARGCHK 0, PUSHCODE global, PUSHCONT 0, PUSHVAR var+ , PUSHINT 0, PUSHFLOAT 0, PUSHBYTES mempty 0, SLIDE 0 0 0, STUB var+ , ALLOCAP 0, PACKAP var 0, PACKNAP var 0, NEWAP 0, NEWNAP 0+ , ENTER, RETURN, PUSHCATCH, RAISE, CALL global+ , ALLOCCON con, PACKCON con var, NEWCON con+ --, UNPACKCON 0 , TESTCON id [], TESTINT 0 []+ , NOP, NOP, NOP+ , ADDINT, SUBINT, MULINT, DIVINT, MODINT, QUOTINT, REMINT+ , ANDINT, XORINT, ORINT, SHRINT, SHLINT, SHRNAT, NEGINT+ , EQINT, NEINT, LTINT, GTINT, LEINT, GEINT+ , ALLOC, NEW 0, GETFIELD, SETFIELD, GETTAG, GETSIZE, PACK 0 var, UNPACK 0+ , PUSHVAR0, PUSHVAR1, PUSHVAR2, PUSHVAR3, PUSHVAR4+ -- , PUSHVARS2 id 0 id 0, PUSHVARS3 id 0 id 0 id 0, PUSHVARS4 id 0 id 0 id 0 id 0+ , PUSHVARS2 var var, NOP, NOP+ , NOP, NEWAP2, NEWAP3, NEWAP4+ , NOP, NEWNAP2, NEWNAP3, NEWNAP4+ , NEWCON0 con, NEWCON1 con, NEWCON2 con, NEWCON3 con+ , ENTERCODE global, EVALVAR var, RETURNCON con, RETURNINT 0, RETURNCON0 con + , MATCHCON [], SWITCHCON [], MATCHINT [], NOP {- MATCHFLOAT -}, MATCH []+ , NOP {- ENTERFLOAT -}, ADDFLOAT, SUBFLOAT, MULFLOAT, DIVFLOAT, NEGFLOAT+ , EQFLOAT, NEFLOAT, LTFLOAT, GTFLOAT, LEFLOAT, GEFLOAT+ -- Additional experimental instructions (AD, 20040108)+ , UPDFIELD + ]+ where+ dum = dummyId+ var = Var dum 0 0+ global = Global dum 0 0+ con = Con dum 0 0 0+++----------------------------------------------------------------+-- Instruction enumeration+----------------------------------------------------------------++isCATCH :: Instr -> Bool+isCATCH (CATCH _) = True+isCATCH _ = False+ +enumFromInstr :: Instr -> Int+enumFromInstr instr+ = case instr of+ -- pseudo instructions+ VAR {} -> -1+ PARAM {} -> -2+ USE {} -> -3+ NOP -> -4+ ATOM {} -> -5+ INIT {} -> -6+++ -- structured instructions+ CATCH {} -> 0+ EVAL {} -> 1+ RESULT {} -> 2++ MATCHCON {} -> 3+ SWITCHCON {} -> 4+ MATCHINT {} -> 5+ MATCH {} -> 6++ -- push instructions+ PUSHVAR {} -> 10+ PUSHINT {} -> 11+ PUSHBYTES {} -> 12+ PUSHFLOAT {} -> 13+ PUSHCODE {} -> 14+ PUSHCONT {} -> 15+ PUSHCATCH -> 16++ -- stack instructions+ ARGCHK {} -> 20+ SLIDE {} -> 21+ STUB {} -> 22++ -- control+ ENTER -> 30+ RAISE -> 31+ CALL {} -> 32++ ENTERCODE {} -> 33+ EVALVAR {} -> 34++ RETURN -> 35+ RETURNCON {} -> 36+ RETURNINT {} -> 37++ -- applications+ ALLOCAP {} -> 40+ PACKAP {} -> 41+ PACKNAP {} -> 42+ NEWAP {} -> 43+ NEWNAP {} -> 44++ -- constructors+ ALLOCCON {} -> 47+ PACKCON {} -> 48+ NEWCON {} -> 49++ ALLOC -> 50+ NEW {} -> 51+ PACK {} -> 52+ UNPACK {} -> 53+ GETFIELD -> 54 + SETFIELD -> 55+ GETTAG -> 56+ GETSIZE -> 57+ UPDFIELD -> 58++ -- INT operations+ ADDINT -> 60+ SUBINT -> 61+ MULINT -> 62+ DIVINT -> 63+ MODINT -> 64+ QUOTINT -> 65+ REMINT -> 66+ ANDINT -> 67+ XORINT -> 68+ ORINT -> 69+ SHRINT -> 70+ SHLINT -> 71+ SHRNAT -> 72+ NEGINT -> 73++ -- relative INT ops+ EQINT -> 80+ NEINT -> 81+ LTINT -> 82+ GTINT -> 83+ LEINT -> 84+ GEINT -> 85++ -- optimized instructions+ PUSHVAR0 -> 100+ PUSHVAR1 -> 101+ PUSHVAR2 -> 102+ PUSHVAR3 -> 103+ PUSHVAR4 -> 104+ PUSHVARS2 {} -> 105++ -- optimizes AP+ NEWAP2 -> 111+ NEWAP3 -> 112+ NEWAP4 -> 113++ NEWNAP2 -> 114+ NEWNAP3 -> 115+ NEWNAP4 -> 116++ -- optimized NEWCON+ NEWCON0 {} -> 120+ NEWCON1 {} -> 121+ NEWCON2 {} -> 122+ NEWCON3 {} -> 123++ RETURNCON0 {} -> 124++ -- FLOAT operations+ ADDFLOAT -> 160+ SUBFLOAT -> 161+ MULFLOAT -> 162+ DIVFLOAT -> 163+ NEGFLOAT -> 164++ -- relative FLOAT ops+ EQFLOAT -> 180+ NEFLOAT -> 181+ LTFLOAT -> 182+ GTFLOAT -> 183+ LEFLOAT -> 184+ GEFLOAT -> 185+++----------------------------------------------------------------+-- Instruction names+----------------------------------------------------------------++nameFromInstr :: Instr -> String+nameFromInstr instr+ = case instr of+ -- pseudo instructions+ VAR {} -> "VAR"+ PARAM {} -> "PARAM"+ USE {} -> "USE"+ NOP -> "NOP"+ ATOM {} -> "ATOM"+ INIT {} -> "INIT"+++ -- structured instructions+ CATCH {} -> "CATCH"+ EVAL {} -> "EVAL"+ RESULT {} -> "RESULT"++ MATCHCON {} -> "MATCHCON"+ SWITCHCON {} -> "SWITCHCON"+ MATCHINT {} -> "MATCHINT"+ MATCH {} -> "MATCH"++ -- push instructions+ PUSHVAR {} -> "PUSHVAR"+ PUSHINT {} -> "PUSHINT"+ PUSHBYTES {} -> "PUSHBYTES"+ PUSHFLOAT {} -> "PUSHFLOAT"+ PUSHCODE {} -> "PUSHCODE"+ PUSHCONT {} -> "PUSHCONT"+ PUSHCATCH -> "PUSHCATCH"++ -- stack instructions+ ARGCHK {} -> "ARGCHK"+ SLIDE {} -> "SLIDE"+ STUB {} -> "STUB"++ -- control+ ENTER -> "ENTER"+ RAISE -> "RAISE"+ CALL {} -> "CALL"++ ENTERCODE {} -> "ENTERCODE"+ EVALVAR {} -> "EVALVAR"++ RETURN -> "RETURN"+ RETURNCON {} -> "RETURNCON"+ RETURNINT {} -> "RETURNINT"++ -- applications+ ALLOCAP {} -> "ALLOCAP"+ PACKAP {} -> "PACKAP"+ PACKNAP {} -> "PACKNAP"+ NEWAP {} -> "NEWAP"+ NEWNAP {} -> "NEWNAP"++ -- constructors+ ALLOCCON {} -> "ALLOCCON"+ PACKCON {} -> "PACKCON"+ NEWCON {} -> "NEWCON"++ ALLOC -> "ALLOC"+ NEW {} -> "NEW"+ PACK {} -> "PACK"+ UNPACK {} -> "UNPACK"+ GETFIELD -> "GETFIELD" + SETFIELD -> "SETFIELD"+ GETTAG -> "GETTAG"+ GETSIZE -> "GETSIZE"+ UPDFIELD -> "UPDFIELD"++ -- INT operations+ ADDINT -> "ADDINT"+ SUBINT -> "SUBINT"+ MULINT -> "MULINT"+ DIVINT -> "DIVINT"+ MODINT -> "MODINT"+ QUOTINT -> "QUOTINT"+ REMINT -> "REMINT"+ ANDINT -> "ANDINT"+ XORINT -> "XORINT"+ ORINT -> "ORINT"+ SHRINT -> "SHRINT"+ SHLINT -> "SHLINT"+ SHRNAT -> "SHRNAT"+ NEGINT -> "NEGINT"++ -- relative INT ops+ EQINT -> "EQINT"+ NEINT -> "NEINT"+ LTINT -> "LTINT"+ GTINT -> "GTINT"+ LEINT -> "LEINT"+ GEINT -> "GEINT"++ -- optimized instructions+ PUSHVAR0 -> "PUSHVAR0"+ PUSHVAR1 -> "PUSHVAR1"+ PUSHVAR2 -> "PUSHVAR2"+ PUSHVAR3 -> "PUSHVAR3"+ PUSHVAR4 -> "PUSHVAR4"++ PUSHVARS2 {} -> "PUSHVARS2"+++ -- optimizes AP+ NEWAP2 -> "NEWAP2"+ NEWAP3 -> "NEWAP3"+ NEWAP4 -> "NEWAP4"++ NEWNAP2 -> "NEWNAP2"+ NEWNAP3 -> "NEWNAP3"+ NEWNAP4 -> "NEWNAP4"++ -- optimized NEWCON+ NEWCON0 {} -> "NEWCON0"+ NEWCON1 {} -> "NEWCON1"+ NEWCON2 {} -> "NEWCON2"+ NEWCON3 {} -> "NEWCON3"++ RETURNCON0 {} -> "RETURNCON0"++ -- FLOAT operations+ ADDFLOAT -> "ADDFLOAT"+ SUBFLOAT -> "SUBFLOAT"+ MULFLOAT -> "MULFLOAT"+ DIVFLOAT -> "DIVFLOAT"+ NEGFLOAT -> "NEGFLOAT"++ -- relative FLOAT ops+ EQFLOAT -> "EQFLOAT"+ NEFLOAT -> "NEFLOAT"+ LTFLOAT -> "LTFLOAT"+ GTFLOAT -> "GTFLOAT"+ LEFLOAT -> "LEFLOAT"+ GEFLOAT -> "GEFLOAT"
+ Lvm/Instr/Resolve.hs view
@@ -0,0 +1,301 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Resolve.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Instr.Resolve (instrResolve) where++import Control.Exception (assert)+import Data.Maybe+import Lvm.Common.Id+import Lvm.Common.IdMap+import Lvm.Instr.Data++{---------------------------------------------------------------+ resolve monad+---------------------------------------------------------------}+newtype Resolve a = R ((Base,Env,Depth) -> (a,Depth))++type Env = IdMap Depth+type Base = Depth++find :: Id -> IdMap a -> a+find x env+ = fromMaybe (error msg) (lookupMap x env)+ where+ msg = "InstrResolve.find: unknown identifier " ++ show x++instance Functor Resolve where+ fmap f (R r) = R (\ctx -> case r ctx of (x,d) -> (f x,d))++instance Monad Resolve where+ return x = R (\(_,_,d) -> (x,d))+ (R r) >>= f = R (\ctx@(base,env,_) ->+ case r ctx of+ (x,depth') -> case f x of+ R fr -> fr (base,env,depth'))++{---------------------------------------------------------------+ non-proper morphisms+---------------------------------------------------------------}+pop :: Depth -> Resolve ()+pop n+ = push (-n)++push :: Depth -> Resolve ()+push n+ = R (\(_,_,d) -> ((),d+n))++-- base :: Resolve Base+-- base = R (\(bas,_,d) -> (bas,d))++depth :: Resolve Depth+depth+ = R (\(_,_,d) -> (d,d))++bind :: Id -> Resolve a -> Resolve a+bind x (R r)+ = R (\(bas,env,d) -> r (bas,extendMap x d env,d))++based :: Resolve a -> Resolve a+based (R r)+ = R (\(_,env,d) -> r (d,env,d))++resolveVar :: Var -> Resolve Var+resolveVar (Var x _ _)+ = R (\(_,env,d) -> let xd = find x env in (Var x (d - xd) xd,d))++alternative :: Depth -> Resolve a -> Resolve a+alternative d (R r)+ = R (\(bas,env,_) -> let (x,d1) = r (bas,env,d)+ in assert (d1==d+1) (x,d1))+ -- "InstrResolve.alternative: invalid elements on the stack " ++ show depth' ++ ", " ++ show depth)+ +runResolve :: Resolve a -> a+runResolve (R r)+ = let (x,d) = r (0,emptyMap,0)+ in assert (d==0) x -- "InstrResolve.runResolve: still elements on the stack (" ++ show depth ++ ")"++{---------------------------------------------------------------+ codeResolver+---------------------------------------------------------------}+instrResolve :: [Instr] -> [Instr]+instrResolve instrs+ = runResolve (resolves instrs)++resolves :: [Instr] -> Resolve [Instr]+resolves instrs+ = case instrs of+ (PARAM x : rest) -> do{ push 1; bind x (resolves rest) }+ (VAR x : rest) -> bind x (resolves rest)+ (instr : rest) -> do{ is <- resolve instr+ ; iss <- resolves rest+ ; return (is ++ iss)+ }+ [] -> return []++resolve :: Instr -> Resolve [Instr]+resolve (PUSHVAR v)+ = do{ var <- resolveVar v+ ; push 1+ ; return [PUSHVAR var]+ }++resolve (STUB v)+ = do{ var <- resolveVar v+ ; return [STUB var]+ }++resolve (PACKAP v n)+ = do{ var <- resolveVar v+ ; pop n+ ; return [PACKAP var n]+ }++resolve (PACKNAP v n)+ = do{ var <- resolveVar v+ ; pop n+ ; return [PACKNAP var n]+ }++resolve (PACKCON con v)+ = do{ var <- resolveVar v+ ; pop (arityFromCon con)+ ; return [PACKCON con var]+ }++resolve (PACK arity v)+ = do{ var <- resolveVar v+ ; pop arity+ ; return [PACK arity var]+ }++resolve (EVAL _ is)+ = do{ push 3+ ; d <- depth+ ; is' <- based (resolves is)+ ; pop 3+ ; push 1+ ; return [EVAL d is']+ }++resolve (CATCH is)+ = do{ pop 1+ ; push 3+ ; is' <- resolves is+ ; return (PUSHCATCH : is')+ }+{-++ = do{ b <- base+ ; pop 1+ ; push 3+ ; is' <- based (resolves is)+ ; d <- depth+ ; pop (d-b)+ ; return (PUSHCATCH : is')+ }+-}+{-+resolve (RESULT is)+ = do{ b <- base+ ; d <- depth+ ; is' <- resolves is+ ; d' <- depth+ ; pop (d' - b)+ ; if (d' <= d)+ then return (is' ++ [SLIDE 1 (d'-b-1) (d'-1), ENTER])+ else return (is' ++ [SLIDE (d'-d) (d-b) d,ENTER])+ }+-}+resolve (ATOM is)+ = resolveSlide 1 is++resolve (INIT is)+ = resolveSlide 0 is++resolve (MATCH alts)+ = resolveAlts MATCH alts++resolve (MATCHCON alts)+ = resolveAlts MATCHCON alts++resolve (SWITCHCON alts)+ = resolveAlts SWITCHCON alts++resolve (MATCHINT alts)+ = resolveAlts MATCHINT alts++resolve instr+ = do{ effect instr; return [instr] }++resolveSlide :: Depth -> [Instr] -> Resolve [Instr]+resolveSlide n is+ = do{ d0 <- depth+ ; is' <- resolves is+ ; d1 <- depth+ ; let m = d1-d0-n+ ; pop m+ ; return (is' ++ [SLIDE n m d1])+ }++resolveAlts :: ([Alt] -> a) -> [Alt] -> Resolve [a]+resolveAlts match alts+ = do{ pop 1+ ; d <- depth+ ; alts' <- mapM (alternative d . resolveAlt) alts+ ; return [match alts']+ }++{-+resolveAlt (Alt pat [])+ = do{ b <- base+ ; d <- depth+ ; pop (d-b)+ ; return (Alt pat [])+ }+-}+resolveAlt :: Alt -> Resolve Alt+resolveAlt (Alt pat [])+ = do{ push 1+ ; return (Alt pat [])+ }+++resolveAlt (Alt pat is)+ = do{ is' <- resolves is+ ; return (Alt pat is')+ }++effect :: Instr -> Resolve ()+effect instr+ = case instr of+ ENTER -> pop 1+ RAISE -> pop 1++ CALL global -> do{ pop (arityFromGlobal global); push 1 }++ ALLOCAP {} -> push 1+ NEWAP n -> do{ pop n; push 1 }+ NEWNAP n -> do{ pop n; push 1 }++ ALLOCCON {} -> push 1+ NEWCON con -> do{ pop (arityFromCon con); push 1 }++ NEW arity -> do{ pop 1; pop arity; push 1 }+ UNPACK arity -> do{ pop 1; push arity }++ ALLOC -> do{ pop 2; push 1 }+ GETFIELD -> do{ pop 2; push 1 }+ SETFIELD -> pop 3+ GETTAG -> do{ pop 1; push 1 }+ GETSIZE -> do{ pop 1; push 1 }+ UPDFIELD -> do{ pop 3; push 1 }++ RETURNCON con -> pop (arityFromCon con) -- it is the last instruction!++ PUSHCODE _ -> push 1+ PUSHINT _ -> push 1+ PUSHFLOAT _ -> push 1+ PUSHBYTES _ _ -> push 1++ PUSHCONT _ -> push 3+ PUSHCATCH -> do{ pop 1; push 3 }++ ADDINT -> pop 1+ SUBINT -> pop 1+ MULINT -> pop 1+ DIVINT -> pop 1+ MODINT -> pop 1+ QUOTINT -> pop 1+ REMINT -> pop 1++ ANDINT -> pop 1+ XORINT -> pop 1+ ORINT -> pop 1+ SHRINT -> pop 1+ SHLINT -> pop 1+ SHRNAT -> pop 1++ EQINT -> pop 1+ NEINT -> pop 1+ LTINT -> pop 1+ GTINT -> pop 1+ LEINT -> pop 1+ GEINT -> pop 1++ ADDFLOAT -> pop 1+ SUBFLOAT -> pop 1+ MULFLOAT -> pop 1+ DIVFLOAT -> pop 1++ EQFLOAT -> pop 1+ NEFLOAT -> pop 1+ LTFLOAT -> pop 1+ GTFLOAT -> pop 1+ LEFLOAT -> pop 1+ GEFLOAT -> pop 1++ _ -> return ()
+ Lvm/Instr/Rewrite.hs view
@@ -0,0 +1,217 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Rewrite.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Instr.Rewrite (instrRewrite) where++import Lvm.Instr.Data++{---------------------------------------------------------------+ debugging+---------------------------------------------------------------}++{-+showInstr instr+ = showInstrs [instr]++showInstrs instrs+ = show (instrPretty instrs)+++traceInstrs instrs + = trace ("trace:\n" ++ showInstrs instrs ++ "\n\n") instrs + -}++{---------------------------------------------------------------+ rewrite rules+---------------------------------------------------------------}+instrRewrite :: [Instr] -> [Instr]+instrRewrite instrs+ = peephole (rewrites (dummies (rewrites (rewrites instrs))))++rewrites :: [Instr] -> [Instr]+rewrites instrs+ = case instrs of + -- TODO: the following three rules optimize things like (id x = x) but+ -- this can probably be better done on the code generation level+ PUSHVAR (Var _ 0 _) : SLIDE 1 m d : is+ | m >= 1+ -> rewrites (SLIDE 1 (m-1) (d-1) : is)++ PUSHVAR (Var _ 1 _) : PUSHVAR (Var _ 1 _) : SLIDE 2 m d : is+ | m >= 2+ -> rewrites (SLIDE 2 (m-2) (d-2) : is)++ PUSHVAR (Var _ 2 _) : PUSHVAR (Var _ 2 _) : PUSHVAR (Var _ 2 _) : SLIDE 3 m d : is+ | m >= 3+ -> rewrites (SLIDE 3 (m-3) (d-3) : is)+ + -- applications+ NEWAP i : SLIDE n m d: ENTER : is+ -> SLIDE (n+i-1) m (d+i-1): ENTER : rewrites is++ NEWNAP i : SLIDE n m d: ENTER : is+ -> SLIDE (n+i-1) m (d+i-1): ENTER : rewrites is++ CALL global : SLIDE 1 m d: ENTER : is+ -> SLIDE arity m (d+arity-1): CALL global : ENTER : rewrites is+ where+ arity = arityFromGlobal global++ -- returns+ NEWCON con : SLIDE 1 m d: ENTER : is+ -> SLIDE n m (d+n-1): RETURNCON con : rewrites is+ where n = arityFromCon con++ PUSHINT i : SLIDE 1 m d: ENTER : is+ -> SLIDE 0 m (d-1): RETURNINT i : rewrites is++ instr : SLIDE 1 m d: ENTER : is+ | strictResult instr+ -> instr : SLIDE 1 m d: RETURN : is++ -- eval and pushcode+ PUSHCODE f : is+ -> rewritePushCode f (rewrites is)++ EVAL d is' : is+ -> rewriteEval d (rewrites is') is++ -- merge slides+ SLIDE n0 m0 d0 : SLIDE n1 m1 _ : is+ | n1 <= n0 -> rewrites (SLIDE n1 (m0+m1-(n0-n1)) d0 : is)++ -- essential rewrites+ MATCH alts : is+ -> [rewriteMatch MATCH alts is]++ MATCHCON alts : is+ -> [rewriteMatch MATCHCON alts is]++ SWITCHCON alts : is+ -> [rewriteMatch SWITCHCON alts is]++ MATCHINT alts : is+ -> [rewriteMatch MATCHINT alts is]++ -- default+ instr:rest -> instr:rewrites rest+ [] -> []+++rewriteMatch :: ([Alt] -> a) -> [Alt] -> [Instr] -> a+rewriteMatch match alts is = match (map (rewriteAlt is) alts)++rewriteAlt :: [Instr] -> Alt -> Alt+rewriteAlt instrs (Alt pat is)+ | null is = Alt pat []+ | otherwise = Alt pat (rewrites (is ++ instrs))++-- rewrite PUSHCODE+rewritePushCode :: Global -> [Instr] -> [Instr]+rewritePushCode f instrs+ = case instrs of+ NEWAP n : is+ | arity >= n -> PUSHCODE f : NEWNAP n : is+ PACKAP var n : is+ | arity >= n -> PUSHCODE f : PACKNAP var n : is+ SLIDE n m d: ENTER : is+ | arity == (n-1) && arity /= 0 -> SLIDE (n-1) m (d-1): ENTERCODE f : is+ _+ -> PUSHCODE f : instrs+ where+ arity = arityFromGlobal f++-- rewrite EVAL+rewriteEval :: Depth -> [Instr] -> [Instr] -> [Instr]+rewriteEval d evalis is+ = case evalis of+ [PUSHVAR (Var x ofs d1),SLIDE 1 0 _,ENTER]+ -> rewrites (EVALVAR (Var x (ofs-3) d1) : is)+ [PUSHVAR (Var x ofs dv),ENTER]+ -> rewrites (EVALVAR (Var x (ofs-3) dv) : is)+ _ -> EVAL d evalis : rewrites is++{---------------------------------------------------------------+ peephole optimization+---------------------------------------------------------------}++peephole :: [Instr] -> [Instr]+peephole = simplify shorten++dummies :: [Instr] -> [Instr]+dummies = simplify id++simplify :: (Instr -> Instr) -> [Instr] -> [Instr]+simplify single = walk+ where+ walk instrs + = case instrs of+ -- structured+ EVAL d is' : is -> EVAL d (walk is') : walk is+ MATCH alts : is -> MATCH (map walkAlt alts) : walk is+ MATCHCON alts : is -> MATCHCON (map walkAlt alts) : walk is+ SWITCHCON alts : is -> SWITCHCON (map walkAlt alts) : walk is+ MATCHINT alts : is -> MATCHINT (map walkAlt alts) : walk is++ -- dummy+ NEWAP 1 : is -> walk is+ NEWNAP 1 : is -> walk is++ -- slide+ SLIDE _ 0 _ : is -> walk is+ SLIDE 1 _ _ : RETURN : is -> walk (RETURN : is)+ SLIDE n _ _ : RETURNCON con : is+ | arityFromCon con == n -> walk (RETURNCON con : is)+ SLIDE 0 _ _ : RETURNINT i : is+ -> walk (RETURNINT i : is)++ -- shorten sequences+ PUSHVAR v : PUSHVAR w : is+ -> PUSHVARS2 v w : walk is++ -- default+ instr:is -> single instr : walk is+ [] -> []++ walkAlt (Alt pat is)+ = Alt pat (walk is)++shorten :: Instr -> Instr+shorten instr+ = case instr of+ PUSHVAR var -> case offsetFromVar var of+ 0 -> PUSHVAR0+ 1 -> PUSHVAR1+ 2 -> PUSHVAR2+ 3 -> PUSHVAR3+ 4 -> PUSHVAR4+ _ -> instr++ NEWAP n -> case n of+ 2 -> NEWAP2+ 3 -> NEWAP3+ 4 -> NEWAP4+ _ -> instr++ NEWNAP n -> case n of+ 2 -> NEWNAP2+ 3 -> NEWNAP3+ 4 -> NEWNAP4+ _ -> instr++ NEWCON con -> case arityFromCon con of+ 0 -> NEWCON0 con+ 1 -> NEWCON1 con+ 2 -> NEWCON2 con+ 3 -> NEWCON3 con+ _ -> instr++ RETURNCON con -> case arityFromCon con of+ 0 -> RETURNCON0 con+ _ -> instr++ _ -> instr
+ Lvm/Path.hs view
@@ -0,0 +1,79 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Path.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Path + ( getLvmPath, searchPath+ , searchPathMaybe, splitPath+ ) where++import qualified Control.Exception as CE (catch, IOException)+import Data.List+import System.Directory+import System.Environment+import System.Exit++----------------------------------------------------------------+-- file searching+----------------------------------------------------------------++searchPath :: [String] -> String -> String -> IO String+searchPath path ext name = do+ ms <- searchPathMaybe path ext name+ case ms of + Just s -> return s+ Nothing -> do + putStrLn ("Error: could not find " ++ show nameext)+ putStrLn (" with search path " ++ show path)+ exitFailure+ where+ nameext+ | ext `isSuffixOf` name = name+ | otherwise = name ++ ext+ +searchPathMaybe :: [String] -> String -> String -> IO (Maybe String)+searchPathMaybe path ext name+ = walk (map makeFName path) -- was ("":path), but we don't want to look in the current directory by default+ where+ walk [] = return Nothing+ walk (fname:xs) = do{ exist <- doesFileExist fname+ ; if exist+ then return (Just fname)+ else walk xs+ }++ makeFName dir+ | null dir = nameext+ | last dir == '/' ||+ last dir == '\\' = dir ++ nameext+ | otherwise = dir ++ "/" ++ nameext++ nameext+ | ext `isSuffixOf` name = name+ | otherwise = name ++ ext++getLvmPath :: IO [String]+getLvmPath+ = do{ xs <- getEnv "LVMPATH"+ ; return (splitPath xs)+ }+ `CE.catch` handler+ where+ handler :: CE.IOException -> IO [String] + handler _ = return []++splitPath :: String -> [String]+splitPath = walk [] ""+ where+ walk ps p xs+ = case xs of+ [] -> if null p+ then reverse ps+ else reverse (reverse p:ps)+ (';':cs) -> walk (reverse p:ps) "" cs+ (':':'\\':cs) -> walk ps ("\\:" ++ p) cs+ (':':cs) -> walk (reverse p:ps) "" cs+ (c:cs) -> walk ps (c:p) cs
+ Lvm/Read.hs view
@@ -0,0 +1,422 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Read.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Read (lvmReadFile, lvmRead) where++import Control.Monad+import Data.Array+import Lvm.Common.Byte hiding (readByteList)+import Lvm.Common.Id+import Lvm.Data+import Lvm.Instr.Data+import Prelude hiding (Read)+import qualified Lvm.Common.Byte as Byte++{--------------------------------------------------------------+ Magic numbers+--------------------------------------------------------------}+lvmMajor, lvmMinor :: Int+lvmMajor = 15+lvmMinor = 0++data Record v = RecDecl (Decl v)+ + | RecName Id+ | RecKind Id+ | RecBytes !Bytes+ | RecCode ![Int]+ | RecModule Id !Int !Int [Custom]+ | RecExternType !String+ | RecAnon !DeclKind [Custom]+ +{--------------------------------------------------------------+ read an LVM file+--------------------------------------------------------------}++{-+test src+ = do{ path <- getLvmPath+ ; source <- searchPath path ".lvm" src+ ; mod <- lvmReadFile source+ ; putDoc (modulePretty instrPretty mod)+ } -}++lvmReadFile :: FilePath -> IO (Module v)+lvmReadFile fname+ = do{ bs <- Byte.readByteList fname+ ; ns <- newNameSupply+ ; return (lvmRead ns fname bs)+ }++lvmRead :: NameSupply -> FilePath -> [Byte] -> Module v+lvmRead = runRead readModule ++readModule :: Read v (Module v,[Record v])+readModule+ = do{ tag <- readRaw+ ; readGuard (tag == recHeader) "readHeader" "magic number is incorrect"+ ; _len <- readint+ ; total <- readint+ ; lvmmajor <- readint+ ; lvmminor <- readint+ ; readGuard (lvmmajor == lvmMajor && lvmminor >= lvmMinor) "readHeader" ("incompatible lvm version " ++ show lvmmajor ++ "." ++ show lvmminor)+ ; count <- readint+ ; _bcount <- readint+ ; ~(x,major,minor) <- readModuleIdx + ; recs <- readRecords total [] + ; readGuard (count == length recs) "readModule" "incorrect record count"+ ; return (Module x major minor [d | RecDecl d <- filter isRecDecl recs],recs)+ }+ where+ isRecDecl (RecDecl _) = True+ isRecDecl _ = False++readRecords :: Int -> [Record v] -> Read v [Record v]+readRecords total acc+ = do{ x <- readRaw+ ; len <- readint+ ; if x == recFooter+ then do{ total' <- readint+ ; readGuard (total==total') "readRecords" "footer doesn't match with header"+ ; return (reverse acc)+ }+ else if isInt x+ then do{ let tag = decodeInt x + ; rec_ <- case tag of+ 0 -> readName len+ 1 -> readKind len+ 2 -> readBytes len+ 3 -> readCode len+ 4 -> readValue len+ 5 -> readCon len+ 6 -> readImport len+ 7 -> readModuleRec len+ 8 -> readExtern len+ 9 -> readExternType len+ _ -> readError "readRecords" ("unknown standard record kind (" ++ show tag ++ ")")+ ; readRecords total (rec_:acc)+ }+ else do{ let idx = decodeIdx x+ ; rec_ <- readDeclCustom idx len + ; readRecords total (rec_:acc)+ }+ }+++{--------------------------------------------------------------+ declarations+--------------------------------------------------------------}+readValue :: Int -> Read v (Record v)+readValue len+ = do{ x <- readNameIdx "value"+ ; acc <- readAccess+ ; arity <- readint+ ; _ <- readEnclosing+ ; _ <- readIdx "code"+ ; customs<- readCustoms (len - 20)+ ; return (RecDecl (DeclAbstract x acc arity customs))+ }++readCon :: Int -> Read v (Record a)+readCon len+ = do{ x <- readNameIdx "constructor"+ ; acc <- readAccess+ ; arity <- readint+ ; tag <- readint+ ; customs <- readCustoms (len - 16)+ ; return (RecDecl (DeclCon x acc arity tag customs))+ }++readImport :: Int -> Read v (Record v1)+readImport len+ = do{ x <- readNameIdx "import"+ ; flags <- readint+ ; ~(modid,major,minor) <- readModuleIdx+ ; impid <- readNameIdx "imported"+ ; kind <- readKindIdx+ ; customs <- readCustoms (len - 20)+ ; return (RecDecl (DeclImport x (Imported (odd flags) modid impid kind major minor) customs))+ }++readKindIdx :: Read v DeclKind+readKindIdx+ = do{ xkind <- readRaw+ ; if isInt xkind+ then return (toEnum (decodeInt xkind))+ else do{ kindid <- resolveKindIdx (decodeIdx xkind)+ ; return (DeclKindCustom kindid)+ }+ }+readModuleRec :: Int -> Read v (Record a)+readModuleRec len+ = do{ x <- readNameIdx "module"+ ; major <- readint+ ; minor <- readint+ ; customs <- readCustoms (len - 12)+ ; return (RecModule x major minor customs)+ }++readDeclCustom :: Index -> Int -> Read v (Record v)+readDeclCustom kindIdx len+ = do{ kindid <- resolveKindIdx kindIdx+ ; mbId <- readCustomNameIdx+ ; case mbId of+ Just x -> do{ acc <- readAccess+ ; customs <- readCustoms (len-8)+ ; return (RecDecl (DeclCustom x acc (DeclKindCustom kindid) customs))+ }+ Nothing -> do{ customs <- readCustoms (len-4)+ ; return (RecAnon (DeclKindCustom kindid) customs)+ }+ }++readExtern :: Int -> Read v (Record v)+readExtern len+ = do{ x <- readNameIdx "extern"+ ; acc <- readAccess+ ; arity <- readint+ ; tp <- readExternTypeIdx+ ; libname <- readNameStringIdx+ ; xname <- readRaw + ; mode <- readint+ ; link <- readint+ ; call <- readint+ ; customs <- readCustoms (len - 9*4)+ ; name <- case mode of+ 1 -> fmap Decorate (readNameString (decodeIdx xname))+ 2 -> return (Ordinal (decodeInt xname))+ _ -> fmap Plain (readNameString (decodeIdx xname))+ ; let linkMode = case link of+ 1 -> LinkDynamic+ 2 -> LinkRuntime+ _ -> LinkStatic+ callMode = case call of+ 1 -> CallStd+ 2 -> CallInstr+ _ -> CallC+ ; return (RecDecl (DeclExtern x acc arity tp linkMode callMode libname name customs))+ }+ +{--------------------------------------------------------------+ constants+--------------------------------------------------------------}+readCode :: Int -> Read v (Record v)+readCode len+ = do{ ints <- mapM (const readRaw) [1..div len 4]+ ; return (RecCode ints)+ }++readName :: Int -> Read v (Record v)+readName len+ = do{ bs <- readByteSeq len+ ; return (RecName (idFromString (stringFromByteList bs)))+ }++readKind :: Int -> Read v (Record v)+readKind len+ = do{ bs <- readByteSeq len+ ; return (RecKind (idFromString (stringFromByteList bs)))+ }++readBytes :: Int -> Read v (Record v)+readBytes len+ = do{ bs <- readByteSeq len+ ; return (RecBytes (bytesFromByteList bs))+ }++readExternType :: Int -> Read v (Record a)+readExternType len+ = do{ bs <- readByteSeq len+ ; return (RecExternType (stringFromByteList bs))+ }++readByteSeq :: Int -> Read v [Byte]+readByteSeq len+ = do{ blen <- readint+ ; bs <- readByteList blen+ ; skip (len - 4 - blen) + ; return bs+ }++readCustoms :: Int -> Read v [Custom]+readCustoms len+ = mapM (const readCustom) [1..div len 4]+ +readAccess :: Read v Access+readAccess+ = do{ flags <- readint+ ; return (Defined (odd flags))+ }++readCustom :: Read v Custom+readCustom+ = do{ x <- readRaw+ ; if isInt x+ then return (CustomInt (decodeInt x))+ else if decodeIdx x == 0+ then return CustomNothing+ else resolve (decodeIdx x) recToCustom+ }+ where+ recToCustom rec_+ = case rec_ of+ RecName x -> CustomName x+ RecBytes bs -> CustomBytes bs+ RecDecl d -> CustomLink (declName d) (declKindFromDecl d)+ RecAnon kind cs -> CustomDecl kind cs+ _ -> error "LvmRead.readCustom: invalid link"+++{--------------------------------------------------------------+ indices+--------------------------------------------------------------}+readNameIdx :: String -> Read v Id+readNameIdx parent+ = do{ idx <- readIdx (parent ++ ".name")+ ; if idx == 0+ then readFreshId+ else resolve idx (\rec_ -> case rec_ of + RecName x -> x+ _ -> error "LvmRead.readName: invalid name index")+ }++readCustomNameIdx :: Read v (Maybe Id)+readCustomNameIdx+ = do{ idx <- readIdx "custom name"+ ; if idx==0+ then return Nothing+ else do{ x1 <- resolve idx (\rec_ -> case rec_ of + RecName x2 -> x2+ _ -> error "LvmRead.readCustomNameIdx: invalid name index")+ ; return (Just x1)+ }+ }++resolveKindIdx :: Index -> Read v Id+resolveKindIdx idx+ = resolve idx (\rec_ -> case rec_ of + RecKind x -> x+ _ -> error "LvmRead.resolveKindIdx: invalid kind index")++readModuleIdx :: Read v (Id, Int, Int)+readModuleIdx + = do{ idx <- readIdx "module descriptor"+ ; resolve idx (\rec_ -> case rec_ of+ RecModule modid major minor _ -> (modid,major,minor)+ _ -> error "LvmRead.readModule: invalid module index")+ }++readExternTypeIdx :: Read v String+readExternTypeIdx+ = do{ idx <- readIdx "extern type"+ ; resolve idx (\rec_ -> case rec_ of+ RecExternType tp -> tp+ _ -> error "LvmRead.readExternType: invalid extern type index")+ }++readNameStringIdx :: Read v String+readNameStringIdx+ = do{ idx <- readIdx "name string"+ ; readNameString idx+ }++readNameString :: Int -> Read v String+readNameString idx + = resolve idx (\rec_ -> case rec_ of+ RecName x -> stringFromId x+ RecBytes bs -> stringFromBytes bs+ _ -> error "LvmRead.readNameString: invalid name index")++readEnclosing :: Read a (Maybe Id)+readEnclosing+ = do{ idx <- readIdx "enclosing"+ ; if idx == 0+ then return Nothing+ else resolve idx (\rec_ -> case rec_ of+ RecDecl d | isDeclValue d || isDeclAbstract d -> Just (declName d)+ _ -> error "readEnclosing" "invalid enclosing index"+ )+ }++++readint :: Read v Int+readint + = do{ i <- readRaw+ ; readGuard (isInt i) "readint" "expecting integer but found index"+ ; return (decodeInt i)+ }+readIdx :: String -> Read v Int+readIdx name+ = do{ i <- readRaw+ ; readGuard (isIdx i) "readIdx" ("expecting index but found integer (" ++ name ++ ")")+ ; return (decodeIdx i)+ }++isInt, isIdx :: Int -> Bool+isInt = odd+isIdx = even++decodeInt, decodeIdx :: Int -> Int+decodeInt i = (i-1) `div` 2+decodeIdx i = i `div` 2++{--------------------------------------------------------------+ Reader monad.+ Note the lazy recursive definition, where resolving+ and reading is done in a single pass (using delayed + computations).+--------------------------------------------------------------}+newtype Read v a = Read (Env v -> State -> Result a)+type Records v = Array Int (Record v)+data Result a = Result a !State+data Env v = Env !FilePath (Records v)+data State = State ![Byte] !NameSupply++unRead :: Read a b -> Env a -> State -> Result b+unRead (Read r) = r++runRead :: Read v (a,[Record v]) -> NameSupply -> FilePath -> [Byte]-> a+runRead (Read r) ns fname bs+ = let (Result (x,rs) _) = r (Env fname (listArray (1,length rs) rs)) (State bs ns)+ in x++instance Functor (Read v) where+ fmap f (Read r) = Read (\env st1 -> case r env st1 of+ Result x st2 -> Result (f x) st2)+instance Monad (Read v) where+ return x = Read (\_ bs -> Result x bs)+ (Read r) >>= f = Read (\rs bs -> case r rs bs of+ Result x bsx -> unRead (f x) rs bsx) +++readRaw :: Read v Int+readRaw + = Read (\_ (State bs ns) -> case int32FromByteList bs of (i,cs) -> Result i (State cs ns))++readByteList :: Int -> Read v [Byte]+readByteList n+ = Read (\_ (State bs ns) -> case splitAt n bs of (xs,cs) -> Result xs (State cs ns))++skip :: Int -> Read v ()+skip n+ = Read (\_ (State bs ns) -> Result () (State (drop n bs) ns))++readFreshId :: Read v Id+readFreshId+ = Read (\_ (State bs ns) -> let (x,ns') = freshId ns in Result x (State bs ns'))+ +readGuard :: Bool -> String -> String -> Read v ()+readGuard test fun = unless test . readError fun++readError :: String -> String -> Read v a+readError fun msg+ = Read (\(Env fname _) _ -> error ("LvmRead." ++ fun ++ ": \"" ++ fname ++ "\"\n " ++ msg))++resolve :: Int -> (Record v -> a) -> Read v a+resolve idx f+ = Read (\(Env _ rs) st -> Result (f (rs ! idx)) st)
+ Lvm/Write.hs view
@@ -0,0 +1,543 @@+--------------------------------------------------------------------------------+-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+--------------------------------------------------------------------------------+-- $Id: Write.hs 291 2012-11-08 11:27:33Z heere112 $++module Lvm.Write (lvmWriteFile, lvmToBytes) where++import qualified Control.Exception as CE (assert, catch, IOException) +import Control.Monad+import Data.Maybe+import Lvm.Common.Byte+import Lvm.Common.Id +import Lvm.Common.IdMap+import Lvm.Data+import Lvm.Instr.Data+import System.Exit ++{--------------------------------------------------------------+ Magic numbers+--------------------------------------------------------------}+lvmMajorVersion,lvmMinorVersion :: Int+lvmMajorVersion = 15+lvmMinorVersion = 0++{--------------------------------------------------------------+ Emit an LVM file+--------------------------------------------------------------}+lvmWriteFile :: FilePath -> LvmModule -> IO ()+lvmWriteFile path lvm+ = let bytes = lvmToBytes lvm+ in seq bytes $+ writeBytes path bytes `CE.catch` (\exception ->+ let message = show (exception :: CE.IOException) ++ "\n\nUnable to write to file " ++ show path+ in do { putStrLn message; exitWith (ExitFailure 1) })++lvmToBytes :: LvmModule -> Bytes+lvmToBytes m+ = let (idxInfo,recs) = bytesFromModule m+ headerlen = 24+ header = block+ [ recHeader+ , encodeInt headerlen+ , encodeInt totallen+ , encodeInt lvmMajorVersion+ , encodeInt lvmMinorVersion+ , encodeInt (length recs)+ , encodeInt (bytesLength brecs)+ , encodeIdx idxInfo+ ]++ footerlen = 4+ footer = block [ recFooter, encodeInt footerlen, encodeInt totallen ]++ brecs = mconcat recs + totallen = bytesLength brecs + headerlen + 8 + footerlen + 8+ total = mconcat [header,brecs,footer]+ in seq totallen total++bytesFromModule :: LvmModule -> (Index,[Bytes])+bytesFromModule = runEmit . emitLvmModule+++emitLvmModule :: LvmModule -> Emit Index+emitLvmModule m+ = do{ idxInfo <- emitModule (moduleName m) (moduleMajorVer m) (moduleMinorVer m)+ ; mapM_ emitDecl (moduleDecls m)+ ; return idxInfo+ }++{--------------------------------------------------------------+ emit declarations+ TODO: emit assumes some canonical order: We should do+ allocation of named blocks first and than emit to fix this.+--------------------------------------------------------------}+flags :: Access -> Int+flags access = if accessPublic access then 1 else 0++isImported :: Decl v -> Bool+isImported decl+ = case declAccess decl of+ Imported{} -> True+ _ -> False++emitDecl :: Decl [Instr] -> Emit Index+emitDecl DeclExtern{ externCall = CallInstr } + = return 0+emitDecl decl+ | isImported decl = emitImport (declName decl) (declKindFromDecl decl) (declAccess decl) []+emitDecl decl+ = case decl of+ DeclValue{} -> emitDValue decl+ DeclAbstract{} -> emitDAbstract decl+ DeclCon{} -> emitDCon decl+ DeclExtern{} -> emitDExtern decl+ DeclCustom{} -> emitDCustom decl+ _ -> error "LvmWrite.emitDecl: invalid declaration at this phase"++emitDValue :: Decl [Instr] -> Emit Index+emitDValue (DeclValue x access mbEnc instrs custom)+ = do{ idxEnc <- maybe (return 0) (findIndex DeclKindValue) mbEnc+ ; idxCode <- emitInstrs instrs+ ; emitNamedBlock x DeclKindValue [encodeInt (flags access), encodeInt arity+ ,encodeIdx idxEnc, encodeIdx idxCode] custom+ }+ where+ arity = case instrs of+ (ARGCHK n:_ ) -> n+ _ -> error ("LvmWrite.emitDecl: instructions do not start with an argument check: " ++ show x)+emitDValue _ = error "Lvm.Write"++emitDCon :: Decl a -> Emit Index+emitDCon (DeclCon x access arity tag custom)+ = emitNamedBlock x DeclKindCon [encodeInt (flags access),encodeInt arity,encodeInt tag] custom+emitDCon _ = error "Lvm.Write"++emitDCustom :: Decl a -> Emit Index+emitDCustom (DeclCustom x access kind custom)+ = emitNamedBlock x kind [encodeInt (flags access)] custom+emitDCustom _ = error "Lvm.Write"++emitDExtern :: Decl a -> Emit Index+emitDExtern (DeclExtern x access arity tp linkconv callconv libname externname custom)+ = do{ idxType <- emitExternType tp+ ; idxLibName <- emitNameString libname+ ; (nameFlag,idxName) <- emitNameExtern+ ; idxId <- emitName x+ ; emitBlockEx (Just x) DeclKindValue DeclKindExtern + (block [encodeIdx idxId, encodeInt (flags access), encodeInt arity+ ,encodeIdx idxType+ ,encodeIdx idxLibName+ ,idxName -- already encoded+ ,encodeInt nameFlag+ ,encodeInt (fromEnum linkconv)+ ,encodeInt (fromEnum callconv)+ ]) custom+ }+ where+ emitNameExtern = case externname of+ Plain s -> do{ idx <- emitNameString s; return (0,encodeIdx idx) }+ Decorate s -> do{ idx <- emitNameString s; return (1,encodeIdx idx) }+ Ordinal i -> return (2,encodeInt i)+emitDExtern _ = error "Lvm.Write"++emitDAbstract :: Decl a -> b+emitDAbstract _ = error "LvmWrite.emitDAbstract: abstract values should be imported"++emitImport :: Id -> DeclKind -> Access -> [Custom] -> Emit Index+emitImport x declkind access@(Imported _ modName impName kind majorVer minorVer) customs+ = CE.assert (declkind==kind) $ -- LvmWrite.emitImport: kinds don't match+ do{ idxModule <- emitModule modName majorVer minorVer+ ; idxName <- emitName impName+ ; idxId <- emitName x+ ; kindenc <- encodeKind declkind+ ; emitBlockEx (Just x) declkind DeclKindImport + (block [encodeIdx idxId, encodeInt (flags access), encodeIdx idxModule+ , encodeIdx idxName, kindenc]) customs+ }+emitImport _ _ _ _ = error "LvmWrite.emitImport: unknown case"++emitModule :: Id -> Int -> Int -> Emit Index+emitModule name major minor+ = do{ idxName <- emitName name+ ; emitBlock Nothing DeclKindModule (block [encodeIdx idxName,encodeInt major,encodeInt minor]) []+ }++{--------------------------------------------------------------+ emit instructions+--------------------------------------------------------------}+emitInstrs :: [Instr] -> Emit Index+emitInstrs instrs+ = do{ rinstrs <- mapM resolve instrs+ ; let codes = concatMap emit rinstrs+ ; emitBlock Nothing DeclKindCode (block codes) []+ }+{-+emitCode :: (Id,LvmValue) -> Emit Index+emitCode (id,DValue access mbEnc instrs custom)+ = do{ idx <- findIndex id+ ; rinstrs <- mapM resolve instrs+ ; let codes = concatMap emit rinstrs+ ; emitBlock Nothing recCode (block (idx:codes)) []+ }++emitCode other+ = return 0+-}++{--------------------------------------------------------------+ emit an instruction+--------------------------------------------------------------}++emits :: [Instr] -> [Int]+emits = concatMap emit++emit :: Instr -> [Int]+emit instr+ = let opcode = opcodeFromInstr instr+ illegal = error ("LvmWrite.emit: illegal instruction at this phase: " ++ show (nameFromInstr instr))+ todo = error ("LvmWrite.emit: todo: " ++ show (nameFromInstr instr))+ in case instr of+ -- pseudo instructions+ VAR _ -> []+ PARAM _ -> []+ USE _ -> []+ NOP -> illegal+ RESULT _ -> illegal++ -- structured instructions+ MATCH alts -> opcode : emitMatch 3 alts+ MATCHCON alts -> opcode : emitMatch 2 alts+ MATCHINT alts -> opcode : emitMatch 2 alts+ SWITCHCON _ -> todo++ EVAL _ is -> let scrut = emits is+ in emit (PUSHCONT (length scrut)) ++ scrut++ -- push instructions+ PUSHVAR var -> [opcode, offsetFromVar var]+ PUSHINT n -> [opcode, n]+ PUSHBYTES _ c -> [opcode, c]+ PUSHFLOAT _ -> todo+ PUSHCODE global -> [opcode, indexFromGlobal global]+ PUSHCONT ofs -> [opcode, ofs]++ -- stack instructions+ ARGCHK n -> [opcode, n]+ SLIDE n m _ -> [opcode, n, m]+ STUB var -> [opcode, offsetFromVar var]++ -- control+ ENTER -> [opcode]+ PUSHCATCH -> [opcode]+ RAISE -> [opcode]+ CALL global -> [opcode, indexFromGlobal global, arityFromGlobal global]++ ENTERCODE global -> [opcode, indexFromGlobal global]+ EVALVAR var -> [opcode, offsetFromVar var]++ RETURN -> [opcode]+ RETURNCON con -> [opcode, indexFromCon con, arityFromCon con]+ RETURNINT i -> [opcode, i]++ -- applications+ ALLOCAP arity -> [opcode, arity]+ PACKAP var arity -> [opcode, offsetFromVar var, arity]+ PACKNAP var arity -> [opcode, offsetFromVar var, arity]+ NEWAP arity -> [opcode, arity]+ NEWNAP arity -> [opcode, arity]++ -- constructors+ ALLOCCON con -> [opcode, indexFromCon con, arityFromCon con]+ PACKCON con var -> [opcode, offsetFromVar var, arityFromCon con] --TODO: constant instead of arity++ NEWCON con -> [opcode, indexFromCon con, arityFromCon con] ++ NEW arity -> [opcode, arity]+ PACK arity v -> [opcode, arity, offsetFromVar v]+ UNPACK arity -> [opcode, arity]++ -- optimized instructions+ PUSHVARS2 v w -> [opcode, offsetFromVar v, offsetFromVar w]++ NEWCON0 con -> [opcode, indexFromCon con]+ NEWCON1 con -> [opcode, indexFromCon con]+ NEWCON2 con -> [opcode, indexFromCon con]+ NEWCON3 con -> [opcode, indexFromCon con]++ RETURNCON0 con -> [opcode, indexFromCon con]++ -- single opcode instructions+ _ -> [opcode]++emitMatch :: Int -> [Alt] -> [Int]+emitMatch entrySize alts+ = CE.assert (normalizedAlts alts) $ -- "LvmWrite.emitMatch: unnormalized alternatives"+ let (pats,iss) = unzipAlts alts+ altis = map emits iss+ start = 2 + entrySize*(length alts -1)+ in [length alts-1]+ ++ matches start (zip pats (map length altis))+ ++ concat altis + where+ matches _ [] = []+ matches top ((pat,n):xs)+ = (case pat of+ PatCon con -> [indexFromCon con]+ PatInt i -> [i]+ PatTag t a -> [t,a]+ PatDefault -> [])+ ++ [if n==0 then 0 else top] ++ matches (top+n) xs+++normalizedAlts :: [Alt] -> Bool+normalizedAlts alts+ = case alts of+ Alt PatDefault _:_ -> True+ _ -> False++unzipAlts :: [Alt] -> ([Pat], [[Instr]])+unzipAlts alts+ = unzip (map (\(Alt pat expr) -> (pat,expr)) alts)+++{--------------------------------------------------------------+ resolve instructions+--------------------------------------------------------------}++resolves :: ([Instr] -> a) -> [Instr] -> Emit a+resolves f is+ = do{ ris <- mapM resolve is+ ; return (f ris)+ }++resolve :: Instr -> Emit Instr+resolve instr+ = case instr of+ EVAL d is -> resolves (EVAL d) is+ RESULT is -> resolves RESULT is+ MATCH alts -> resolveAlts MATCH alts+ MATCHCON alts -> resolveAlts MATCHCON alts+ MATCHINT alts -> resolveAlts MATCHINT alts+ SWITCHCON alts -> resolveAlts SWITCHCON alts++ PUSHCODE global -> resolveGlobal PUSHCODE global+ ENTERCODE global-> resolveGlobal ENTERCODE global+ CALL global -> resolveGlobal CALL global++ RETURNCON con -> resolveCon RETURNCON con+ ALLOCCON con -> resolveCon ALLOCCON con+ NEWCON con -> resolveCon NEWCON con+ PACKCON con var -> resolveCon (`PACKCON` var) con++ PUSHBYTES bs _ -> resolveBytes (PUSHBYTES bs) bs++ -- optimized instructions+ RETURNCON0 con -> resolveCon RETURNCON0 con+ NEWCON0 con -> resolveCon NEWCON0 con+ NEWCON1 con -> resolveCon NEWCON1 con+ NEWCON2 con -> resolveCon NEWCON2 con+ NEWCON3 con -> resolveCon NEWCON3 con++ _ -> return instr++resolveAlts :: ([Alt] -> a) -> [Alt] -> Emit a+resolveAlts f = liftM f . mapM resolveAlt++resolveAlt :: Alt -> Emit Alt+resolveAlt (Alt pat is)+ = do{ pat' <- resolvePat pat+ ; resolves (Alt pat') is+ }++resolvePat :: Pat -> Emit Pat+resolvePat pat+ = case pat of+ PatCon con -> resolveCon PatCon con+ _ -> return pat++resolveGlobal :: (Global -> a) -> Global -> Emit a+resolveGlobal f (Global x _ arity)+ = do{ idx <- findIndex DeclKindValue x+ ; return (f (Global x idx arity))+ }++resolveCon :: (Con -> a) -> Con -> Emit a+resolveCon f (Con x _ arity tag)+ = do{ idx <- findIndex DeclKindCon x+ ; return (f (Con x idx arity tag))+ }++resolveBytes :: (Index -> a) -> Bytes -> Emit a+resolveBytes f bs+ = do{ idx <- emitBytes bs+ ; return (f idx)+ }+ +{--------------------------------------------------------------+ basic entities+--------------------------------------------------------------}+emitNamedBlock :: Id -> DeclKind -> [Int] -> [Custom] -> Emit Index+emitNamedBlock x kind is custom+ = do{ idxName <- emitName x+ ; emitBlock (Just x) kind (block (encodeIdx idxName:is)) custom+ }++emitName :: Id -> Emit Index+emitName x+ = emitNameString (stringFromId x)++emitNameString :: String -> Emit Index+emitNameString s+ = emitBlock Nothing DeclKindName (blockString s) []++emitExternType :: String -> Emit Index+emitExternType tp+ = emitBlock Nothing DeclKindExternType (blockString tp) []++emitKind :: Id -> Emit Index+emitKind x+ = emitBlock Nothing DeclKindKind (blockString (stringFromId x)) []++emitBytes :: Bytes -> Emit Index+emitBytes bs+ = emitBlock Nothing DeclKindBytes (blockBytes bs) []++emitBlock :: Maybe Id -> DeclKind -> Bytes -> [Custom] -> Emit Index+emitBlock mbId kind = emitBlockEx mbId kind kind++emitBlockEx :: Maybe Id -> DeclKind -> DeclKind -> Bytes -> [Custom] -> Emit Index+emitBlockEx mbId kindId kind bs custom+ = do{ bcustom <- emitCustoms custom+ ; kindenc <- encodeKind kind+ ; let bytes = mappend bs bcustom+ total = mappend (block [kindenc,encodeInt (bytesLength bytes)]) bytes+ ; CE.assert ((bytesLength bytes `mod` 4) == 0) $ -- "LvmWrite.emitBlock: unaligned size"+ emitPrimBlock (maybe Nothing (\x -> Just (x,kindId)) mbId) kind total+ }++encodeKind :: DeclKind -> Emit Int+encodeKind (DeclKindCustom x)+ = do{ idx <- emitKind x+ ; return (encodeIdx idx)+ }++encodeKind kind+ = return (encodeInt (fromEnum kind))+++{--------------------------------------------------------------+ custom fields+--------------------------------------------------------------}+emitCustoms :: [Custom] -> Emit Bytes+emitCustoms decls+ = do{ is <- mapM emitCustom decls+ ; return (block is)+ }++emitCustom :: Custom -> Emit Int+emitCustom custom+ = case custom of+ CustomInt i -> return (encodeInt i)+ CustomNothing -> return (encodeIdx 0)+ CustomBytes bs -> do{ idx <- emitBytes bs; return (encodeIdx idx) }+ CustomName x -> do{ idx <- emitName x; return (encodeIdx idx) }+ CustomLink x kind -> do{ idx <- findIndex kind x; return (encodeIdx idx) }+ CustomDecl kind cs -> do{ idx <- emitAnonymousCustom kind cs; return (encodeIdx idx) }++emitAnonymousCustom :: DeclKind -> [Custom] -> Emit Index+emitAnonymousCustom kind+ = emitBlock Nothing kind (block [encodeIdx 0])+++{--------------------------------------------------------------+ Emit Monad+--------------------------------------------------------------}+newtype Emit a = Emit (Env -> State -> (a,State))+data State = State !Int Env [Bytes]+type Env = IdMap [(DeclKind,Index)]++instance Functor Emit where+ fmap f (Emit e) = Emit (\env st -> case e env st of+ (x,stx) -> (f x,stx))++instance Monad Emit where+ return x = Emit (\_ st -> (x,st))+ (Emit e) >>= f = Emit (\env st -> case e env st of+ (x,stx) -> case f x of+ Emit ef -> ef env stx)++runEmit :: Emit a -> (a,[Bytes])+runEmit (Emit e)+ = let (x,State _ env bbs) = e env (State 0 emptyMap []) -- yes, a recursive, lazy, env :-)+ in (x,reverse bbs)++emitPrimBlock :: Maybe (Id,DeclKind) -> DeclKind -> Bytes -> Emit Index+emitPrimBlock mpair kind bs+ = Emit (\_ (State count m1 bbs) ->+ let (index,count2,bbs2) | sharable kind = case find count bs bbs of --try to share records+ Nothing -> (count+1,count+1,bs:bbs)+ Just idx -> (idx,count,bbs)+ | otherwise = (count+1,count+1,bs:bbs)+ m2 = case mpair of+ Just (x,kindid) -> insertMapWith x [(kindid,index)] ((kindid,index):) m1+ Nothing -> m1+ in (index, State count2 m2 bbs2)+ )++sharable :: DeclKind -> Bool+sharable _ = False+{-+ = case kind of+ DeclKindBytes -> True+ DeclKindName -> True+ DeclKindKind -> True+ DeclKindExternType -> True+ DeclKindModule -> True -- dubious when custom values are present!+ other -> False+-}++find :: Eq a => Int -> a -> [a] -> Maybe Int+find n _ [] = CE.assert (n==0) Nothing -- "LvmWrite.find: count too large"+find n x (y:ys) | x==y = Just n+ | otherwise = (find $! (n-1)) x ys++-- a nice lazy formulation, we can calculate all indices before writing the bytes.+findIndex :: DeclKind -> Id -> Emit Index+findIndex kind x + = Emit (\env st ->+ (case lookupMap x env of+ Nothing -> error ("LvmWrite.findIndex: undeclared identifier: " ++ show (stringFromId x))+ Just xs -> fromMaybe (error msg) (lookup kind xs)+ , st))+ where+ msg = "LvmWrite.findIndex: undeclared identifier (with the right declaration kind): " ++ show (stringFromId x)++++{--------------------------------------------------------------+ block+--------------------------------------------------------------}+block :: [Int] -> Bytes+block is+ = mconcat (map bytesFromInt32 is)++blockString :: String -> Bytes+blockString s+ = blockBytes (bytesFromString s)++blockBytes :: Bytes -> Bytes+blockBytes bs+ = let len = bytesLength bs+ in mconcat [bytesFromInt32 (encodeInt len), bs, padding len]++padding :: Int -> Bytes+padding n+ = let m = div (n + 3) 4 * 4+ in bytesFromList (replicate (m - n) (byteFromInt8 0))++encodeInt, encodeIdx :: Int -> Int+encodeInt i = (2*i)+1+encodeIdx i = 2*i
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ lvmlib.cabal view
@@ -0,0 +1,82 @@+name: lvmlib+version: 1.0+synopsis: The Lazy Virtual Machine (LVM).+homepage: http://www.cs.uu.nl/wiki/bin/view/Helium/WebHome+description:++ The Lazy Virtual Machine (LVM) defines a portable instruction set and file+ format. It is specifically designed to execute languages with non-strict (or+ lazy) semantics. This cabal package defines the core assembler (coreasm) for + compiling core programs into LVM instructions and a library. The LVM is used + as a backend for the Helium compiler. At the moment, one LVM runtime + implementation is available (written in C). More information about LVM can be + found in Chapter 6 of Daan Leijen's PhD Thesis, The Lambda Abroad.++category: Compilers/Interpreters+copyright: (c) 2012+license: BSD3+license-file: LICENSE.txt+author: Daan Leijen, Bastiaan Heeren, Jurriaan Hage+maintainer: helium@cs.uu.nl+stability: provisional+extra-source-files: CREDITS.txt+build-type: Simple+cabal-version: >= 1.10.1.0+tested-with: GHC == 7.0.2, GHC == 7.0.3, GHC == 7.4.1++source-repository head+ type: svn+ location: https://svn.science.uu.nl/repos/sci.hage0101.lvm/trunk/src/lib++--------------------------------------------------------------------------------++Executable coreasm+ Build-Depends: base >= 3 && < 5, array, containers, directory, parsec, wl-pprint+ ghc-options: -Wall+ default-language: Haskell98+ hs-source-dirs: .+ Main-is: Lvm/Core/Main.hs++Library+ Build-Depends: base >= 3 && < 5, array, containers, directory, parsec, wl-pprint+ ghc-options: -Wall+ default-language: Haskell98+ hs-source-dirs: .+ Exposed-modules:+ Lvm.Asm.Data+ Lvm.Asm.Inline+ Lvm.Asm.Occur+ Lvm.Asm.ToLvm+ Lvm.Common.Byte+ Lvm.Common.Id+ Lvm.Common.IdMap+ Lvm.Common.IdSet+ Lvm.Core.Expr+ Lvm.Core.FreeVar+ Lvm.Core.LetSort+ Lvm.Core.Lift+ Lvm.Core.Module+ Lvm.Core.NoShadow+ Lvm.Core.Normalize+ Lvm.Core.Parsing.Layout+ Lvm.Core.Parsing.Lexer+ Lvm.Core.Parsing.Parser+ Lvm.Core.Parsing.Token+ Lvm.Core.PrettyId+ Lvm.Core.RemoveDead+ Lvm.Core.Saturate+ Lvm.Core.ToAsm+ Lvm.Core.Type+ Lvm.Core.Utils+ Lvm.Data+ Lvm.Import+ Lvm.Instr.Data+ Lvm.Instr.Resolve+ Lvm.Instr.Rewrite+ Lvm.Path+ Lvm.Read+ Lvm.Write+++--------------------------------------------------------------------------------+