packages feed

alpha 1.0.12 → 1.0.13

raw patch · 4 files changed

+47/−41 lines, 4 files

Files

alpha.cabal view
@@ -1,5 +1,5 @@ name:           alpha-version:        1.0.12+version:        1.0.13 synopsis:       A compiler for the Alpha language description:    Alpha is a programming language that aims at being very simple and                  low-level, so as to be efficient, while at the same time
src/Alpha.hs view
@@ -75,9 +75,10 @@   mapM_ (\e -> compileExpr e >> putStr "> " >> hFlush stdout) (parseAlpha "/dev/stdin" str)   putStrLn "\rGoodbye !" compileProgram (language,entryName) = withInitialContext $ do-  importLanguage (const $ return ()) language-  entrySym <- viewState language_ $ internSym entryName-  tagIO ("Linking program "++entryName) $ do+  langTime <- importLanguage (const $ return ()) language+  progTime <- modTime entryName+  when (progTime < langTime) $ tagIO ("Linking program "++entryName) $ do+    entrySym <- viewState language_ $ internSym entryName     _ <- getAddressComp (outputArch ?settings) entrySym     (addrs,ptrs) <- unzip $< sortBy (comparing fst) $< M.elems $< gets compAddresses     top <- gets compTop
src/Serialize.hs view
@@ -13,33 +13,32 @@ import My.Control.Monad import PCode -deriving instance Generic Code-deriving instance Generic BindVar deriving instance Generic Builtin deriving instance Generic C.Value deriving instance Generic Axiom deriving instance Generic (Range a)-+instance Serialize Builtin+instance Serialize C.Value+instance Serialize Axiom instance Serialize a => Serialize (Range a)-instance (Ord a,Ord b,Serialize a,Serialize b) => Serialize (BM.Bimap a b) where-  get = BM.fromList $< get -  put = put . BM.toList -newtype Squashed = Squash { unSquash :: Int }+newtype SquashedI = SqI { unSqI :: Int }+newtype SquashedL a = SqL { unSqL :: [a] }+newtype SquashedM a = SqM { unSqM :: BM.Bimap String a } -instance Serialize Squashed where-  put (Squash n) = do-    let bytes = map fromIntegral $ takeWhile (>0) $ iterate (`shiftR`8) n-    putWord8 (fromIntegral $ length bytes)-    mapM_ putWord8 bytes-  get = do-    n <- getWord8+instance Serialize SquashedI where+  put (SqI n) = putWord8 (fromIntegral $ length bytes) >> mapM_ putWord8 bytes+    where bytes = map fromIntegral $ takeWhile (>0) $ iterate (`shiftR`8) n+  get = getWord8 >>= \n -> do     bytes <- mapM (const getWord8) [1..n]-    return $ Squash $ sum (zipWith shiftL (map fromIntegral bytes) [0,8..])+    return $ SqI $ sum (zipWith shiftL (map fromIntegral bytes) [0,8..])+instance Serialize a => Serialize (SquashedL a) where+  put (SqL l) = put (SqI $ length l) >> mapM_ put l+  get = get >>= \(SqI n) -> SqL $< mapM (const get) [1..n]+instance (Ord a,Serialize a) => Serialize (SquashedM a) where+  put (SqM m) = put $ SqL [(SqL n,v) | (n,v) <- BM.toList m]+  get = get >§ \(SqL l) -> SqM (BM.fromList [(n,v) | (SqL n,v) <- l]) -instance Serialize Builtin-instance Serialize C.Value-instance Serialize Axiom typeCodes = [(Value,0),(GValue,1),(Address,2),(Size,3),(SymID,4)] instance Serialize PCode.Value where   put (SymVal t n) = putWord8 (fromJust (lookup t typeCodes)) >> put n@@ -52,45 +51,45 @@       6 -> return NullVal instance Serialize Code where   put (Code [] [Branch _ []] Nothing) = putWord8 0-  put (Code [] instrs ret)            = putWord8 1 >> put (instrs,ret)-  put (Code args instrs ret)          = putWord8 2 >> put (args,instrs,ret)+  put (Code [] instrs ret)            = putWord8 1 >> put (SqL instrs,ret)+  put (Code args instrs ret)          = putWord8 2 >> put (SqL args,SqL instrs,ret)   get = getWord8 >>= \n -> case n of     0 -> return $ Code [] [Branch NullVal []] Nothing-    1 -> get >§ \(instrs,ret) -> Code [] instrs ret-    2 -> get >§ \(args,instrs,ret) -> Code args instrs ret+    1 -> get >§ \(SqL instrs,ret) -> Code [] instrs ret+    2 -> get >§ \(SqL args,SqL instrs,ret) -> Code args instrs ret  instance Serialize Instruction where   put (Op b d [x])     = putWord8 0 >> put (b,d,x)   put (Op b d [x,y])   = putWord8 1 >> put (b,d,x,y)-  put (Op b d l)       = putWord8 2 >> put (b,d,l)+  put (Op b d l)       = putWord8 2 >> put (b,d,SqL l)   put (Branch _ [])    = putWord8 3   put (Branch _ [x])   = putWord8 4 >> put x   put (Branch v [x,y]) = putWord8 5 >> put (v,x,y)-  put (Branch v l)     = putWord8 6 >> put (v,l)+  put (Branch v l)     = putWord8 6 >> put (v,SqL (map SqI l))   put (Bind bv x)      = putWord8 7 >> put (bv,x)   put Noop             = putWord8 8   get = getWord8 >>= \x -> case x of     0 -> get >§ \(b,d,x) -> Op b d [x]     1 -> get >§ \(b,d,x,y) -> Op b d [x,y]-    2 -> get >§ \(b,d,l) -> Op b d l+    2 -> get >§ \(b,d,SqL l) -> Op b d l     3 -> return $ Branch NullVal []     4 -> get >§ \x -> Branch NullVal [x]     5 -> get >§ \(v,x,y) -> Branch v [x,y]-    6 -> get >§ \(v,l) -> Branch v l+    6 -> get >§ \(v,SqL l) -> Branch v (map unSqI l)     7 -> get >§ \(bv,x) -> Bind bv x     8 -> return Noop instance Serialize BindVar where   put (BindVar sym (0,1) 0 []) = putWord8 0 >> put sym-  put (BindVar sym (n,nr) pad []) = putWord8 1 >> put (sym,Squash n,Squash nr,Squash pad)-  put (BindVar sym (n,nr) pad subs) = putWord8 2 >> put (sym,Squash n,Squash nr,Squash pad,subs)+  put (BindVar sym (n,nr) pad []) = putWord8 1 >> put (sym,SqI n,SqI nr,SqI pad)+  put (BindVar sym (n,nr) pad subs) = putWord8 2 >> put (sym,SqI n,SqI nr,SqI pad,SqL subs)   get = getWord8 >>= \n -> case n of     0 -> get >§ \sym -> BindVar sym (0,1) 0 []-    1 -> get >§ \(sym,Squash n,Squash nr,Squash pad) -> BindVar sym (n,nr) pad []-    2 -> get >§ \(sym,Squash n,Squash nr,Squash pad,subs) -> BindVar sym (n,nr) pad subs+    1 -> get >§ \(sym,SqI n,SqI nr,SqI pad) -> BindVar sym (n,nr) pad []+    2 -> get >§ \(sym,SqI n,SqI nr,SqI pad,SqL subs) -> BindVar sym (n,nr) pad subs instance Serialize ID where-  put (ID n) = put (Squash n)-  get = ID . unSquash $< get-  +  put (ID n) = put (SqI n)+  get = ID . unSqI $< get+ instance Serialize Language where-  put l = put (maxIDL l,symbolsL l,valuesL l,languagesL l)-  get = get >§ \(mi,syms,vals,langs) -> mempty{ maxIDL = mi, symbolsL = syms, valuesL = vals, languagesL = langs }+  put l = put (maxIDL l,SqM (symbolsL l),valuesL l,SqM (languagesL l))+  get = get >§ \(mi,SqM syms,vals,SqM langs) -> mempty{ maxIDL = mi, symbolsL = syms, valuesL = vals, languagesL = langs }
src/Specialize/X86_64/Binary.hs view
@@ -119,7 +119,7 @@  withSpecial spe f d r (Left n) = fromMaybe (f d r (Left n)) $ spe d r n withSpecial _ f d r v = f d r v-ignoreZero = const $ const $ flip lookup [(0,return ())]+ignoreZero _ _ = flip lookup [(0,return ())]  shli = withSpecial ignoreZero $ opi (codeFun [(8,(0xC1,1,4))]) undefined shri = withSpecial ignoreZero $ opi (codeFun [(8,(0xC1,1,5))]) undefined@@ -164,7 +164,13 @@ (addrr,addri',addir)      = commOp [0x03]      [(8,(0x83,1,0)),(32,(0x81,4,0))] mulri = withSpecial spe mulri'   where spe d r n = liftM (shli d r . Left . fi) $ log2n n-(mulrr,mulri',mulir)       = commOp [0x0F,0xAF] [(8,(0x6B,1,0)),(64,(0x69,8,0))]+mulir = flip . mulri+mulrr = op [0x0F,0xAF]+mulri' d a i = case codeFun [(8,(0x6B,1,undefined)),(32,(0x69,4,undefined))] i of+  Just (code,_,sz,imm) -> tell (fromBytesN (length pref+sz) (liftM (pref++) imm))+    where (pre,suf) = argBytes d a Nothing+          pref = pre++[code]++suf+  Nothing -> movi rsi i >> mulrr d a rsi (bwandrr,bwandri,bwandir) = commOp [0x23]      [(7,(0x83,1,4)),(31,(0x81,4,4))] (bworrr,bworri,bworir)    = commOp [0x0b]      [(7,(0x83,1,1)),(31,(0x81,4,1))] (bwxorrr,bwxorri,bwxorir) = commOp [0x33]      [(7,(0x83,1,6)),(31,(0x81,4,6))]